{-# 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
  { ErrInfo -> Doc AnsiStyle
_errDoc    :: Doc AnsiStyle
  , ErrInfo -> [Delta]
_errDeltas :: [Delta]
  } deriving (Int -> ErrInfo -> ShowS
[ErrInfo] -> ShowS
ErrInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrInfo] -> ShowS
$cshowList :: [ErrInfo] -> ShowS
show :: ErrInfo -> String
$cshow :: ErrInfo -> String
showsPrec :: Int -> ErrInfo -> ShowS
$cshowsPrec :: Int -> ErrInfo -> ShowS
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
  { Err -> Maybe (Doc AnsiStyle)
_reason      :: Maybe (Doc AnsiStyle)
  , Err -> [Doc AnsiStyle]
_footnotes   :: [Doc AnsiStyle]
  , Err -> Set String
_expected    :: Set String
  , Err -> [Delta]
_finalDeltas :: [Delta]
  }

makeClassy ''Err

instance Semigroup Err where
  Err Maybe (Doc AnsiStyle)
md [Doc AnsiStyle]
mds Set String
mes [Delta]
delta1 <> :: Err -> Err -> Err
<> Err Maybe (Doc AnsiStyle)
nd [Doc AnsiStyle]
nds Set String
nes [Delta]
delta2
    = Maybe (Doc AnsiStyle)
-> [Doc AnsiStyle] -> Set String -> [Delta] -> Err
Err (Maybe (Doc AnsiStyle)
nd forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Doc AnsiStyle)
md) (if forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
nd then [Doc AnsiStyle]
nds else if forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
md then [Doc AnsiStyle]
mds else [Doc AnsiStyle]
nds forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle]
mds) (Set String
mes forall a. Semigroup a => a -> a -> a
<> Set String
nes) ([Delta]
delta1 forall a. Semigroup a => a -> a -> a
<> [Delta]
delta2)
  {-# inlinable (<>) #-}

instance Monoid Err where
  mempty :: Err
mempty = Maybe (Doc AnsiStyle)
-> [Doc AnsiStyle] -> Set String -> [Delta] -> Err
Err forall a. Maybe a
Nothing [] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  {-# inlinable mempty #-}
  mappend :: Err -> Err -> Err
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  {-# inlinable mappend #-}

-- | Generate a simple 'Err' word-wrapping the supplied message.
failed :: String -> Err
failed :: String -> Err
failed String
m = Maybe (Doc AnsiStyle)
-> [Doc AnsiStyle] -> Set String -> [Delta] -> Err
Err (forall a. a -> Maybe a
Just (forall ann. [Doc ann] -> Doc ann
fillSep (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
words String
m))) [] forall a. Monoid a => a
mempty forall a. Monoid a => a
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 :: Rendering -> Err -> Doc AnsiStyle
explain Rendering
r (Err Maybe (Doc AnsiStyle)
mm [Doc AnsiStyle]
as Set String
es [Delta]
_)
  | forall a. Set a -> Bool
Set.null Set String
es = Doc AnsiStyle -> Doc AnsiStyle
report (Doc AnsiStyle -> Doc AnsiStyle
withEx forall a. Monoid a => a
mempty)
  | forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
mm   = Doc AnsiStyle -> Doc AnsiStyle
report forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
withEx forall a b. (a -> b) -> a -> b
$ forall a. Char -> Doc a
Pretty.char Char
',' forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann}. Doc ann
expecting
  | Bool
otherwise   = Doc AnsiStyle -> Doc AnsiStyle
report forall {ann}. Doc ann
expecting
  where
    now :: [String]
now = [String] -> [String]
spaceHack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set String
es
    spaceHack :: [String] -> [String]
spaceHack [String
""] = [String
"space"]
    spaceHack [String]
xs = forall a. (a -> Bool) -> [a] -> [a]
List.filter (forall a. Eq a => a -> a -> Bool
/= String
"") [String]
xs
    withEx :: Doc AnsiStyle -> Doc AnsiStyle
withEx Doc AnsiStyle
x = forall a. a -> Maybe a -> a
fromMaybe (forall ann. [Doc ann] -> Doc ann
fillSep forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
words String
"unspecified error") Maybe (Doc AnsiStyle)
mm forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
x
    expecting :: Doc ann
expecting = forall a ann. Pretty a => a -> Doc ann
pretty String
"expected:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
fillSep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (forall a. Char -> Doc a
Pretty.char Char
',') (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
now))
    report :: Doc AnsiStyle -> Doc AnsiStyle
report Doc AnsiStyle
txt = forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [Delta -> Doc AnsiStyle
prettyDelta (forall t. HasDelta t => t -> Delta
delta Rendering
r) forall a. Semigroup a => a -> a -> a
<> forall a. Char -> Doc a
Pretty.char Char
':' forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
Pretty.color Color
Pretty.Red) (forall a ann. Pretty a => a -> Doc ann
pretty String
"error") forall a. Semigroup a => a -> a -> a
<> forall a. Char -> Doc a
Pretty.char Char
':' forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
nest Int
4 Doc AnsiStyle
txt]
             forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Rendering -> Doc AnsiStyle
prettyRendering Rendering
r forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Rendering -> Bool
nullRendering Rendering
r))
             forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Doc AnsiStyle]
as

class Errable m where
  raiseErr :: Err -> m a

instance Monoid ErrInfo where
  mempty :: ErrInfo
mempty = Doc AnsiStyle -> [Delta] -> ErrInfo
ErrInfo forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  mappend :: ErrInfo -> ErrInfo -> ErrInfo
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup ErrInfo where
  ErrInfo Doc AnsiStyle
xs [Delta]
d1 <> :: ErrInfo -> ErrInfo -> ErrInfo
<> ErrInfo Doc AnsiStyle
ys [Delta]
d2 = Doc AnsiStyle -> [Delta] -> ErrInfo
ErrInfo (forall ann. [Doc ann] -> Doc ann
vsep [Doc AnsiStyle
xs, Doc AnsiStyle
ys]) (forall a. Ord a => a -> a -> a
max [Delta]
d1 [Delta]
d2)

-- | The result of parsing. Either we succeeded or something went wrong.
data Result a
  = Success a
  | Failure ErrInfo
  deriving (Int -> Result a -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show,forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: forall a b. (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor,forall a. Eq a => a -> Result a -> Bool
forall a. Num a => Result a -> a
forall a. Ord a => Result a -> a
forall m. Monoid m => Result m -> m
forall a. Result a -> Bool
forall a. Result a -> Int
forall a. Result a -> [a]
forall a. (a -> a -> a) -> Result a -> a
forall m a. Monoid m => (a -> m) -> Result a -> m
forall b a. (b -> a -> b) -> b -> Result a -> b
forall a b. (a -> b -> b) -> b -> Result a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Result a -> a
$cproduct :: forall a. Num a => Result a -> a
sum :: forall a. Num a => Result a -> a
$csum :: forall a. Num a => Result a -> a
minimum :: forall a. Ord a => Result a -> a
$cminimum :: forall a. Ord a => Result a -> a
maximum :: forall a. Ord a => Result a -> a
$cmaximum :: forall a. Ord a => Result a -> a
elem :: forall a. Eq a => a -> Result a -> Bool
$celem :: forall a. Eq a => a -> Result a -> Bool
length :: forall a. Result a -> Int
$clength :: forall a. Result a -> Int
null :: forall a. Result a -> Bool
$cnull :: forall a. Result a -> Bool
toList :: forall a. Result a -> [a]
$ctoList :: forall a. Result a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Result a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Result a -> a
foldr1 :: forall a. (a -> a -> a) -> Result a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Result a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Result a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Result a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Result a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Result a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Result a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Result a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Result a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Result a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Result a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Result a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Result a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Result a -> m
fold :: forall m. Monoid m => Result m -> m
$cfold :: forall m. Monoid m => Result m -> m
Foldable,Functor Result
Foldable Result
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Result (m a) -> m (Result a)
forall (f :: * -> *) a.
Applicative f =>
Result (f a) -> f (Result a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Result a -> m (Result b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Result a -> f (Result b)
sequence :: forall (m :: * -> *) a. Monad m => Result (m a) -> m (Result a)
$csequence :: forall (m :: * -> *) a. Monad m => Result (m a) -> m (Result a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Result a -> m (Result b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Result a -> m (Result b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Result (f a) -> f (Result a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Result (f a) -> f (Result a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Result a -> f (Result b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Result a -> f (Result b)
Traversable)

-- | Fold over a 'Result'
foldResult :: (ErrInfo -> b) -> (a -> b) -> Result a -> b
foldResult :: forall b a. (ErrInfo -> b) -> (a -> b) -> Result a -> b
foldResult ErrInfo -> b
f a -> b
g Result a
r = case Result a
r of
  Failure ErrInfo
e -> ErrInfo -> b
f ErrInfo
e
  Success a
a -> a -> b
g a
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 :: Prism (Result a) (Result b) (Result a) (Result b)
_Result = forall a. a -> a
id
  {-# inlinable _Result #-}

-- | The 'Prism' for the 'Success' constructor of 'Result'
_Success :: AsResult s t a b => Prism s t a b
_Success :: forall s t a b. AsResult s t a b => Prism s t a b
_Success = forall s t a b. AsResult s t a b => Prism s t (Result a) (Result b)
_Result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {f :: * -> *} {b} {a}.
Applicative f =>
Result b -> Either (f (Result a)) b
seta (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Result a
Success) where
  seta :: Result b -> Either (f (Result a)) b
seta (Success b
a) = forall a b. b -> Either a b
Right b
a
  seta (Failure ErrInfo
e) = forall a b. a -> Either a b
Left (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ErrInfo -> Result a
Failure ErrInfo
e))
{-# inlinable _Success #-}

-- | The 'Prism' for the 'Failure' constructor of 'Result'
_Failure :: AsResult s s a a => Prism' s ErrInfo
_Failure :: forall s a. AsResult s s a a => Prism' s ErrInfo
_Failure = forall s t a b. AsResult s t a b => Prism s t (Result a) (Result b)
_Result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {f :: * -> *} {a}.
Applicative f =>
Result a -> Either (f (Result a)) ErrInfo
seta (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ErrInfo -> Result a
Failure) where
  seta :: Result a -> Either (f (Result a)) ErrInfo
seta (Failure ErrInfo
e) = forall a b. b -> Either a b
Right ErrInfo
e
  seta (Success a
a) = forall a b. a -> Either a b
Left (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Result a
Success a
a))
{-# inlinable _Failure #-}

instance Applicative Result where
  pure :: forall a. a -> Result a
pure = forall a. a -> Result a
Success
  {-# inlinable pure #-}
  Success a -> b
f <*> :: forall a b. Result (a -> b) -> Result a -> Result b
<*> Success a
a = forall a. a -> Result a
Success (a -> b
f a
a)
  Success a -> b
_ <*> Failure ErrInfo
y = forall a. ErrInfo -> Result a
Failure ErrInfo
y
  Failure ErrInfo
x <*> Success a
_ = forall a. ErrInfo -> Result a
Failure ErrInfo
x
  Failure ErrInfo
x <*> Failure ErrInfo
y =
    forall a. ErrInfo -> Result a
Failure forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> [Delta] -> ErrInfo
ErrInfo (forall ann. [Doc ann] -> Doc ann
vsep [ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
x, ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
y]) (ErrInfo -> [Delta]
_errDeltas ErrInfo
x forall a. Semigroup a => a -> a -> a
<> ErrInfo -> [Delta]
_errDeltas ErrInfo
y)
  {-# inlinable (<*>) #-}

instance Alternative Result where
  Failure ErrInfo
x <|> :: forall a. Result a -> Result a -> Result a
<|> Failure ErrInfo
y =
    forall a. ErrInfo -> Result a
Failure forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> [Delta] -> ErrInfo
ErrInfo (forall ann. [Doc ann] -> Doc ann
vsep [ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
x, ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
y]) (ErrInfo -> [Delta]
_errDeltas ErrInfo
x forall a. Semigroup a => a -> a -> a
<> ErrInfo -> [Delta]
_errDeltas ErrInfo
y)
  Success a
a <|> Success a
_ = forall a. a -> Result a
Success a
a
  Success a
a <|> Failure ErrInfo
_ = forall a. a -> Result a
Success a
a
  Failure ErrInfo
_ <|> Success a
a = forall a. a -> Result a
Success a
a
  {-# inlinable (<|>) #-}
  empty :: forall a. Result a
empty = forall a. ErrInfo -> Result a
Failure forall a. Monoid a => a
mempty
  {-# inlinable empty #-}

instance Monad Result where
  return :: forall a. a -> Result a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Success a
a >>= :: forall a b. Result a -> (a -> Result b) -> Result b
>>= a -> Result b
m = a -> Result b
m a
a
  Failure ErrInfo
e >>= a -> Result b
_ = forall a. ErrInfo -> Result a
Failure ErrInfo
e