content: {-# language CPP                    #-}
  {-# language DeriveFoldable         #-}
  {-# language DeriveFunctor          #-}
  {-# language DeriveTraversable      #-}
  {-# language FlexibleContexts       #-}
  {-# language FlexibleInstances      #-}
  {-# language FunctionalDependencies #-}
  {-# language MultiParamTypeClasses  #-}
  {-# language Rank2Types             #-}
  {-# language TemplateHaskell        #-}
  {-# language UndecidableInstances   #-}
  -----------------------------------------------------------------------------
  -- |
  -- Copyright   :  (c) Edward Kmett 2011-2019
  -- License     :  BSD3
  --
  -- Maintainer  :  ekmett@gmail.com
  -- Stability   :  experimental
  -- Portability :  non-portable
  --
  -- Results and Parse Errors
  -----------------------------------------------------------------------------
  module Text.Trifecta.Result
    (
    -- * Parse Results
      Result(..)
    , AsResult(..)
    , foldResult
    , _Success
    , _Failure
    -- * Parsing Errors
    , Err(..), HasErr(..), Errable(..)
    , ErrInfo(..)
    , explain
    , failed
    ) where
  
  import           Control.Applicative                          as Alternative
  import           Control.Lens                                 hiding (cons, snoc)
  import           Control.Monad                                (guard)
  import           Data.Foldable
  import qualified Data.List                                    as List
  import           Data.Maybe                                   (fromMaybe, isJust)
  #if !(MIN_VERSION_base(4,11,0))
  import           Data.Semigroup
  #endif
  import           Data.Set                                     as Set hiding (empty, toList)
  import           Prettyprinter                                as Pretty
  import           Prettyprinter.Render.Terminal                as Pretty
  
  import Text.Trifecta.Delta       as Delta
  import Text.Trifecta.Rendering
  import Text.Trifecta.Util.Pretty as Pretty
  
  data ErrInfo = ErrInfo
    { _errDoc    :: Doc AnsiStyle
    , _errDeltas :: [Delta]
    } deriving (Show)
  
  -- | This is used to report an error. What went wrong, some supplemental docs
  -- and a set of things expected at the current location. This does not, however,
  -- include the actual location.
  data Err = Err
    { _reason      :: Maybe (Doc AnsiStyle)
    , _footnotes   :: [Doc AnsiStyle]
    , _expected    :: Set String
    , _finalDeltas :: [Delta]
    }
  
  makeClassy ''Err
  
  instance Semigroup Err where
    Err md mds mes delta1 <> Err nd nds nes delta2
      = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) (delta1 <> delta2)
    {-# inlinable (<>) #-}
  
  instance Monoid Err where
    mempty = Err Nothing [] mempty mempty
    {-# inlinable mempty #-}
    mappend = (<>)
    {-# inlinable mappend #-}
  
  -- | Generate a simple 'Err' word-wrapping the supplied message.
  failed :: String -> Err
  failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty mempty
  {-# inlinable failed #-}
  
  -- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc AnsiStyle',
  -- ready to be prettyprinted to the user.
  explain :: Rendering -> Err -> Doc AnsiStyle
  explain r (Err mm as es _)
    | Set.null es = report (withEx mempty)
    | isJust mm   = report $ withEx $ Pretty.char ',' <+> expecting
    | otherwise   = report expecting
    where
      now = spaceHack $ toList es
      spaceHack [""] = ["space"]
      spaceHack xs = List.filter (/= "") xs
      withEx x = fromMaybe (fillSep $ pretty <$> words "unspecified error") mm <> x
      expecting = pretty "expected:" <+> fillSep (punctuate (Pretty.char ',') (pretty <$> now))
      report txt = vsep $ [prettyDelta (delta r) <> Pretty.char ':' <+> annotate (Pretty.color Pretty.Red) (pretty "error") <> Pretty.char ':' <+> nest 4 txt]
               <|> prettyRendering r <$ guard (not (nullRendering r))
               <|> as
  
  class Errable m where
    raiseErr :: Err -> m a
  
  instance Monoid ErrInfo where
    mempty = ErrInfo mempty mempty
    mappend = (<>)
  
  instance Semigroup ErrInfo where
    ErrInfo xs d1 <> ErrInfo ys d2 = ErrInfo (vsep [xs, ys]) (max d1 d2)
  
  -- | The result of parsing. Either we succeeded or something went wrong.
  data Result a
    = Success a
    | Failure ErrInfo
    deriving (Show,Functor,Foldable,Traversable)
  
  -- | Fold over a 'Result'
  foldResult :: (ErrInfo -> b) -> (a -> b) -> Result a -> b
  foldResult f g r = case r of
    Failure e -> f e
    Success a -> g a
  
  -- | A 'Prism' that lets you embed or retrieve a 'Result' in a potentially larger type.
  class AsResult s t a b | s -> a, t -> b, s b -> t, t a -> s where
    _Result :: Prism s t (Result a) (Result b)
  
  instance AsResult (Result a) (Result b) a b where
    _Result = id
    {-# inlinable _Result #-}
  
  -- | The 'Prism' for the 'Success' constructor of 'Result'
  _Success :: AsResult s t a b => Prism s t a b
  _Success = _Result . dimap seta (either id id) . right' . rmap (fmap Success) where
    seta (Success a) = Right a
    seta (Failure e) = Left (pure (Failure e))
  {-# inlinable _Success #-}
  
  -- | The 'Prism' for the 'Failure' constructor of 'Result'
  _Failure :: AsResult s s a a => Prism' s ErrInfo
  _Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where
    seta (Failure e) = Right e
    seta (Success a) = Left (pure (Success a))
  {-# inlinable _Failure #-}
  
  instance Applicative Result where
    pure = Success
    {-# inlinable pure #-}
    Success f <*> Success a = Success (f a)
    Success _ <*> Failure y = Failure y
    Failure x <*> Success _ = Failure x
    Failure x <*> Failure y =
      Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y)
    {-# inlinable (<*>) #-}
  
  instance Alternative Result where
    Failure x <|> Failure y =
      Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y)
    Success a <|> Success _ = Success a
    Success a <|> Failure _ = Success a
    Failure _ <|> Success a = Success a
    {-# inlinable (<|>) #-}
    empty = Failure mempty
    {-# inlinable empty #-}
  
  instance Monad Result where
    return = pure
    Success a >>= m = m a
    Failure e >>= _ = Failure e
  