module Text.Trifecta.Result
(
Result(..)
, AsResult(..)
, _Success
, _Failure
, Err(..), HasErr(..), Errable(..)
, explain
, failed
) where
import Control.Applicative as Alternative
import Control.Lens hiding (snoc, cons)
import Control.Monad (guard)
import Data.Foldable
import Data.Maybe (fromMaybe, isJust)
import qualified Data.List as List
import Data.Semigroup
import Data.Set as Set hiding (empty, toList)
import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty)
import Text.Trifecta.Instances ()
import Text.Trifecta.Rendering
import Text.Trifecta.Delta as Delta
data Err = Err
{ _reason :: Maybe Doc
, _footnotes :: [Doc]
, _expected :: Set String
}
makeClassy ''Err
instance Semigroup Err where
Err md mds mes <> Err nd nds nes
= Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes)
instance Monoid Err where
mempty = Err Nothing [] mempty
mappend = (<>)
failed :: String -> Err
failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty
explain :: Rendering -> Err -> Doc
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 $ List.nub $ toList es
spaceHack [""] = ["space"]
spaceHack xs = List.filter (/= "") xs
withEx x = fromMaybe (fillSep $ text <$> words "unspecified error") mm <> x
expecting = text "expected:" <+> fillSep (punctuate (Pretty.char ',') (text <$> now))
report txt = vsep $ [pretty (delta r) <> Pretty.char ':' <+> red (text "error") <> Pretty.char ':' <+> nest 4 txt]
<|> pretty r <$ guard (not (nullRendering r))
<|> as
class Errable m where
raiseErr :: Err -> m a
data Result a
= Success a
| Failure Doc
deriving (Show,Functor,Foldable,Traversable)
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
_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 d) = Left (pure (Failure d))
_Failure :: AsResult s s a a => Prism' s Doc
_Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where
seta (Failure d) = Right d
seta (Success a) = Left (pure (Success a))
instance Show a => Pretty (Result a) where
pretty (Success a) = pretty (show a)
pretty (Failure xs) = pretty xs
instance Applicative Result where
pure = Success
Success f <*> Success a = Success (f a)
Success _ <*> Failure ys = Failure ys
Failure xs <*> Success _ = Failure xs
Failure xs <*> Failure ys = Failure $ vsep [xs, ys]
instance Alternative Result where
Failure xs <|> Failure ys = Failure $ vsep [xs, ys]
Success a <|> Success _ = Success a
Success a <|> Failure _ = Success a
Failure _ <|> Success a = Success a
empty = Failure mempty