{-# 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           Data.Text.Prettyprint.Doc                    as Pretty
import           Data.Text.Prettyprint.Doc.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
(Int -> ErrInfo -> ShowS)
-> (ErrInfo -> String) -> ([ErrInfo] -> ShowS) -> Show ErrInfo
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 Maybe (Doc AnsiStyle)
-> Maybe (Doc AnsiStyle) -> Maybe (Doc AnsiStyle)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Doc AnsiStyle)
md) (if Maybe (Doc AnsiStyle) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
nd then [Doc AnsiStyle]
nds else if Maybe (Doc AnsiStyle) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
md then [Doc AnsiStyle]
mds else [Doc AnsiStyle]
nds [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle]
mds) (Set String
mes Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> Set String
nes) ([Delta]
delta1 [Delta] -> [Delta] -> [Delta]
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 Maybe (Doc AnsiStyle)
forall a. Maybe a
Nothing [] Set String
forall a. Monoid a => a
mempty [Delta]
forall a. Monoid a => a
mempty
  {-# inlinable mempty #-}
  mappend :: Err -> Err -> Err
mappend = Err -> Err -> Err
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 (Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just ([Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
fillSep (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc AnsiStyle) -> [String] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
words String
m))) [] Set String
forall a. Monoid a => a
mempty [Delta]
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]
_)
  | Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
es = Doc AnsiStyle -> Doc AnsiStyle
report (Doc AnsiStyle -> Doc AnsiStyle
withEx Doc AnsiStyle
forall a. Monoid a => a
mempty)
  | Maybe (Doc AnsiStyle) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Doc AnsiStyle)
mm   = Doc AnsiStyle -> Doc AnsiStyle
report (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
withEx (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Char -> Doc AnsiStyle
forall a. Char -> Doc a
Pretty.char Char
',' Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
expecting
  | Bool
otherwise   = Doc AnsiStyle -> Doc AnsiStyle
report Doc AnsiStyle
forall ann. Doc ann
expecting
  where
    now :: [String]
now = [String] -> [String]
spaceHack ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set String
es
    spaceHack :: [String] -> [String]
spaceHack [String
""] = [String
"space"]
    spaceHack [String]
xs = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
List.filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") [String]
xs
    withEx :: Doc AnsiStyle -> Doc AnsiStyle
withEx Doc AnsiStyle
x = Doc AnsiStyle -> Maybe (Doc AnsiStyle) -> Doc AnsiStyle
forall a. a -> Maybe a -> a
fromMaybe ([Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
fillSep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc AnsiStyle) -> [String] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
words String
"unspecified error") Maybe (Doc AnsiStyle)
mm Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
x
    expecting :: Doc ann
expecting = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"expected:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Char -> Doc ann
forall a. Char -> Doc a
Pretty.char Char
',') (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> [String] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
now))
    report :: Doc AnsiStyle -> Doc AnsiStyle
report Doc AnsiStyle
txt = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Delta -> Doc AnsiStyle
prettyDelta (Rendering -> Delta
forall t. HasDelta t => t -> Delta
delta Rendering
r) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Char -> Doc AnsiStyle
forall a. Char -> Doc a
Pretty.char Char
':' Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
Pretty.color Color
Pretty.Red) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
"error") Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Char -> Doc AnsiStyle
forall a. Char -> Doc a
Pretty.char Char
':' Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
nest Int
4 Doc AnsiStyle
txt]
             [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Rendering -> Doc AnsiStyle
prettyRendering Rendering
r Doc AnsiStyle -> [()] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Rendering -> Bool
nullRendering Rendering
r))
             [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
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 Doc AnsiStyle
forall a. Monoid a => a
mempty [Delta]
forall a. Monoid a => a
mempty
  mappend :: ErrInfo -> ErrInfo -> ErrInfo
mappend = ErrInfo -> ErrInfo -> ErrInfo
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 ([Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep [Doc AnsiStyle
xs, Doc AnsiStyle
ys]) ([Delta] -> [Delta] -> [Delta]
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
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
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,a -> Result b -> Result a
(a -> b) -> Result a -> Result b
(forall a b. (a -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
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
<$ :: a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor,Result a -> Bool
(a -> m) -> Result a -> m
(a -> b -> b) -> b -> Result a -> b
(forall m. Monoid m => Result m -> m)
-> (forall m a. Monoid m => (a -> m) -> Result a -> m)
-> (forall m a. Monoid m => (a -> m) -> Result a -> m)
-> (forall a b. (a -> b -> b) -> b -> Result a -> b)
-> (forall a b. (a -> b -> b) -> b -> Result a -> b)
-> (forall b a. (b -> a -> b) -> b -> Result a -> b)
-> (forall b a. (b -> a -> b) -> b -> Result a -> b)
-> (forall a. (a -> a -> a) -> Result a -> a)
-> (forall a. (a -> a -> a) -> Result a -> a)
-> (forall a. Result a -> [a])
-> (forall a. Result a -> Bool)
-> (forall a. Result a -> Int)
-> (forall a. Eq a => a -> Result a -> Bool)
-> (forall a. Ord a => Result a -> a)
-> (forall a. Ord a => Result a -> a)
-> (forall a. Num a => Result a -> a)
-> (forall a. Num a => Result a -> a)
-> Foldable Result
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 :: Result a -> a
$cproduct :: forall a. Num a => Result a -> a
sum :: Result a -> a
$csum :: forall a. Num a => Result a -> a
minimum :: Result a -> a
$cminimum :: forall a. Ord a => Result a -> a
maximum :: Result a -> a
$cmaximum :: forall a. Ord a => Result a -> a
elem :: a -> Result a -> Bool
$celem :: forall a. Eq a => a -> Result a -> Bool
length :: Result a -> Int
$clength :: forall a. Result a -> Int
null :: Result a -> Bool
$cnull :: forall a. Result a -> Bool
toList :: Result a -> [a]
$ctoList :: forall a. Result a -> [a]
foldl1 :: (a -> a -> a) -> Result a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Result a -> a
foldr1 :: (a -> a -> a) -> Result a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Result a -> a
foldl' :: (b -> a -> b) -> b -> Result a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Result a -> b
foldl :: (b -> a -> b) -> b -> Result a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Result a -> b
foldr' :: (a -> b -> b) -> b -> Result a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Result a -> b
foldr :: (a -> b -> b) -> b -> Result a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Result a -> b
foldMap' :: (a -> m) -> Result a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Result a -> m
foldMap :: (a -> m) -> Result a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Result a -> m
fold :: Result m -> m
$cfold :: forall m. Monoid m => Result m -> m
Foldable,Functor Result
Foldable Result
Functor Result
-> Foldable Result
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Result a -> f (Result b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Result (m a) -> m (Result a))
-> Traversable Result
(a -> f b) -> Result a -> f (Result b)
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 :: Result (m a) -> m (Result a)
$csequence :: forall (m :: * -> *) a. Monad m => Result (m a) -> m (Result a)
mapM :: (a -> m b) -> Result a -> m (Result b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Result a -> m (Result b)
sequenceA :: Result (f a) -> f (Result a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Result (f a) -> f (Result a)
traverse :: (a -> f b) -> Result a -> f (Result b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Result a -> f (Result b)
$cp2Traversable :: Foldable Result
$cp1Traversable :: Functor Result
Traversable)

-- | Fold over a 'Result'
foldResult :: (ErrInfo -> b) -> (a -> b) -> Result a -> b
foldResult :: (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 :: p (Result a) (f (Result b)) -> p (Result a) (f (Result b))
_Result = p (Result a) (f (Result b)) -> p (Result a) (f (Result b))
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 :: Prism s t a b
_Success = p (Result a) (f (Result b)) -> p s (f t)
forall s t a b. AsResult s t a b => Prism s t (Result a) (Result b)
_Result (p (Result a) (f (Result b)) -> p s (f t))
-> (p a (f b) -> p (Result a) (f (Result b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result a -> Either (f (Result b)) a)
-> (Either (f (Result b)) (f (Result b)) -> f (Result b))
-> p (Either (f (Result b)) a)
     (Either (f (Result b)) (f (Result b)))
-> p (Result a) (f (Result b))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Result a -> Either (f (Result b)) a
forall (f :: * -> *) b a.
Applicative f =>
Result b -> Either (f (Result a)) b
seta ((f (Result b) -> f (Result b))
-> (f (Result b) -> f (Result b))
-> Either (f (Result b)) (f (Result b))
-> f (Result b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f (Result b) -> f (Result b)
forall a. a -> a
id f (Result b) -> f (Result b)
forall a. a -> a
id) (p (Either (f (Result b)) a) (Either (f (Result b)) (f (Result b)))
 -> p (Result a) (f (Result b)))
-> (p a (f b)
    -> p (Either (f (Result b)) a)
         (Either (f (Result b)) (f (Result b))))
-> p a (f b)
-> p (Result a) (f (Result b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f (Result b))
-> p (Either (f (Result b)) a)
     (Either (f (Result b)) (f (Result b)))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' (p a (f (Result b))
 -> p (Either (f (Result b)) a)
      (Either (f (Result b)) (f (Result b))))
-> (p a (f b) -> p a (f (Result b)))
-> p a (f b)
-> p (Either (f (Result b)) a)
     (Either (f (Result b)) (f (Result b)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f b -> f (Result b)) -> p a (f b) -> p a (f (Result b))
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((b -> Result b) -> f b -> f (Result b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Result b
forall a. a -> Result a
Success) where
  seta :: Result b -> Either (f (Result a)) b
seta (Success b
a) = b -> Either (f (Result a)) b
forall a b. b -> Either a b
Right b
a
  seta (Failure ErrInfo
e) = f (Result a) -> Either (f (Result a)) b
forall a b. a -> Either a b
Left (Result a -> f (Result a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrInfo -> Result a
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 :: Prism' s ErrInfo
_Failure = p (Result a) (f (Result a)) -> p s (f s)
forall s t a b. AsResult s t a b => Prism s t (Result a) (Result b)
_Result (p (Result a) (f (Result a)) -> p s (f s))
-> (p ErrInfo (f ErrInfo) -> p (Result a) (f (Result a)))
-> p ErrInfo (f ErrInfo)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result a -> Either (f (Result a)) ErrInfo)
-> (Either (f (Result a)) (f (Result a)) -> f (Result a))
-> p (Either (f (Result a)) ErrInfo)
     (Either (f (Result a)) (f (Result a)))
-> p (Result a) (f (Result a))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Result a -> Either (f (Result a)) ErrInfo
forall (f :: * -> *) a.
Applicative f =>
Result a -> Either (f (Result a)) ErrInfo
seta ((f (Result a) -> f (Result a))
-> (f (Result a) -> f (Result a))
-> Either (f (Result a)) (f (Result a))
-> f (Result a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either f (Result a) -> f (Result a)
forall a. a -> a
id f (Result a) -> f (Result a)
forall a. a -> a
id) (p (Either (f (Result a)) ErrInfo)
   (Either (f (Result a)) (f (Result a)))
 -> p (Result a) (f (Result a)))
-> (p ErrInfo (f ErrInfo)
    -> p (Either (f (Result a)) ErrInfo)
         (Either (f (Result a)) (f (Result a))))
-> p ErrInfo (f ErrInfo)
-> p (Result a) (f (Result a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ErrInfo (f (Result a))
-> p (Either (f (Result a)) ErrInfo)
     (Either (f (Result a)) (f (Result a)))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' (p ErrInfo (f (Result a))
 -> p (Either (f (Result a)) ErrInfo)
      (Either (f (Result a)) (f (Result a))))
-> (p ErrInfo (f ErrInfo) -> p ErrInfo (f (Result a)))
-> p ErrInfo (f ErrInfo)
-> p (Either (f (Result a)) ErrInfo)
     (Either (f (Result a)) (f (Result a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ErrInfo -> f (Result a))
-> p ErrInfo (f ErrInfo) -> p ErrInfo (f (Result a))
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((ErrInfo -> Result a) -> f ErrInfo -> f (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrInfo -> Result a
forall a. ErrInfo -> Result a
Failure) where
  seta :: Result a -> Either (f (Result a)) ErrInfo
seta (Failure ErrInfo
e) = ErrInfo -> Either (f (Result a)) ErrInfo
forall a b. b -> Either a b
Right ErrInfo
e
  seta (Success a
a) = f (Result a) -> Either (f (Result a)) ErrInfo
forall a b. a -> Either a b
Left (Result a -> f (Result a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Result a
forall a. a -> Result a
Success a
a))
{-# inlinable _Failure #-}

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

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

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