{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ViewPatterns #-}
module Data.InvertibleGrammar.Monad
( module Control.Monad.ContextError
, runGrammar
, runGrammarDoc
, runGrammarString
, ErrorMessage (..)
, doAnnotate
, doDive
, doStep
, doLocate
, doError
, Propagation
, GrammarError (..)
, Mismatch
, expected
, unexpected
) where
import Control.Arrow (left)
import Control.Applicative
import Control.Monad.ContextError
import Data.Maybe
import Data.Semigroup as Semi
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import GHC.Generics
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
( Doc, Pretty, pretty, vsep, hsep, line, indent, fillSep, punctuate
, comma, colon, (<+>), layoutSmart, PageWidth(..), LayoutOptions(..)
)
#else
import Data.Text.Prettyprint.Doc
( Doc, Pretty, pretty, vsep, hsep, line, indent, fillSep, punctuate
, comma, colon, (<+>), layoutSmart, PageWidth(..), LayoutOptions(..)
)
#endif
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter.Render.String
#elif MIN_VERSION_prettyprinter(1,2,0)
import Data.Text.Prettyprint.Doc.Render.String
#else
import Data.Text.Prettyprint.Doc (SimpleDocStream)
import Data.Text.Prettyprint.Doc.Render.ShowS
renderString :: SimpleDocStream ann -> String
renderString stream = renderShowS stream ""
#endif
initPropagation :: p -> Propagation p
initPropagation :: forall p. p -> Propagation p
initPropagation = forall p. [Int] -> [Text] -> p -> Propagation p
Propagation [Int
0] []
data Propagation p = Propagation
{ forall p. Propagation p -> [Int]
pProp :: [Int]
, forall p. Propagation p -> [Text]
pAnns :: [Text]
, forall p. Propagation p -> p
pPos :: p
} deriving (Int -> Propagation p -> ShowS
forall p. Show p => Int -> Propagation p -> ShowS
forall p. Show p => [Propagation p] -> ShowS
forall p. Show p => Propagation p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Propagation p] -> ShowS
$cshowList :: forall p. Show p => [Propagation p] -> ShowS
show :: Propagation p -> String
$cshow :: forall p. Show p => Propagation p -> String
showsPrec :: Int -> Propagation p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> Propagation p -> ShowS
Show)
instance Eq (Propagation p) where
Propagation [Int]
xs [Text]
_ p
_ == :: Propagation p -> Propagation p -> Bool
== Propagation [Int]
ys [Text]
_ p
_ = [Int]
xs forall a. Eq a => a -> a -> Bool
== [Int]
ys
{-# INLINE (==) #-}
instance Ord (Propagation p) where
compare :: Propagation p -> Propagation p -> Ordering
compare (Propagation [Int]
as [Text]
_ p
_) (Propagation [Int]
bs [Text]
_ p
_) =
forall a. [a] -> [a]
reverse [Int]
as forall a. Ord a => a -> a -> Ordering
`compare` forall a. [a] -> [a]
reverse [Int]
bs
{-# INLINE compare #-}
data Mismatch = Mismatch
{ Mismatch -> Set Text
mismatchExpected :: Set Text
, Mismatch -> Maybe Text
mismatchGot :: Maybe Text
} deriving (Int -> Mismatch -> ShowS
[Mismatch] -> ShowS
Mismatch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mismatch] -> ShowS
$cshowList :: [Mismatch] -> ShowS
show :: Mismatch -> String
$cshow :: Mismatch -> String
showsPrec :: Int -> Mismatch -> ShowS
$cshowsPrec :: Int -> Mismatch -> ShowS
Show, Mismatch -> Mismatch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mismatch -> Mismatch -> Bool
$c/= :: Mismatch -> Mismatch -> Bool
== :: Mismatch -> Mismatch -> Bool
$c== :: Mismatch -> Mismatch -> Bool
Eq)
expected :: Text -> Mismatch
expected :: Text -> Mismatch
expected Text
a = Set Text -> Maybe Text -> Mismatch
Mismatch (forall a. a -> Set a
S.singleton Text
a) forall a. Maybe a
Nothing
unexpected :: Text -> Mismatch
unexpected :: Text -> Mismatch
unexpected Text
a = Set Text -> Maybe Text -> Mismatch
Mismatch forall a. Set a
S.empty (forall a. a -> Maybe a
Just Text
a)
instance Semigroup Mismatch where
Mismatch
m <> :: Mismatch -> Mismatch -> Mismatch
<> Mismatch
m' =
Set Text -> Maybe Text -> Mismatch
Mismatch
(Mismatch -> Set Text
mismatchExpected Mismatch
m forall a. Semigroup a => a -> a -> a
Semi.<> Mismatch -> Set Text
mismatchExpected Mismatch
m')
(Mismatch -> Maybe Text
mismatchGot Mismatch
m forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mismatch -> Maybe Text
mismatchGot Mismatch
m')
{-# INLINE (<>) #-}
instance Monoid Mismatch where
mempty :: Mismatch
mempty = Set Text -> Maybe Text -> Mismatch
Mismatch forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
{-# INLINE mempty #-}
mappend :: Mismatch -> Mismatch -> Mismatch
mappend = forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE mappend #-}
runGrammar :: p -> ContextError (Propagation p) (GrammarError p) a -> Either (ErrorMessage p) a
runGrammar :: forall p a.
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m =
case forall c e a. ContextError c e a -> c -> Either e a
runContextError ContextError (Propagation p) (GrammarError p) a
m (forall p. p -> Propagation p
initPropagation p
initPos) of
Left (GrammarError Propagation p
p Mismatch
mismatch) ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall p. p -> [Text] -> Set Text -> Maybe Text -> ErrorMessage p
ErrorMessage
(forall p. Propagation p -> p
pPos Propagation p
p)
(forall a. [a] -> [a]
reverse (forall p. Propagation p -> [Text]
pAnns Propagation p
p))
(Mismatch -> Set Text
mismatchExpected Mismatch
mismatch)
(Mismatch -> Maybe Text
mismatchGot Mismatch
mismatch)
Right a
a ->
forall a b. b -> Either a b
Right a
a
runGrammarDoc :: (Pretty p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either (Doc ann) a
runGrammarDoc :: forall p a ann.
Pretty p =>
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (Doc ann) a
runGrammarDoc p
initPos ContextError (Propagation p) (GrammarError p) a
m =
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$
forall p a.
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m
runGrammarString :: (Show p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either String a
runGrammarString :: forall p a.
Show p =>
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either String a
runGrammarString p
initPos ContextError (Propagation p) (GrammarError p) a
m =
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (forall ann. SimpleDocStream ann -> String
renderString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
79 Double
0.75)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)) forall a b. (a -> b) -> a -> b
$
forall p a.
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m
data ErrorMessage p = ErrorMessage
{ forall p. ErrorMessage p -> p
emPosition :: p
, forall p. ErrorMessage p -> [Text]
emAnnotations :: [Text]
, forall p. ErrorMessage p -> Set Text
emExpected :: Set Text
, forall p. ErrorMessage p -> Maybe Text
emGot :: Maybe Text
} deriving (ErrorMessage p -> ErrorMessage p -> Bool
forall p. Eq p => ErrorMessage p -> ErrorMessage p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorMessage p -> ErrorMessage p -> Bool
$c/= :: forall p. Eq p => ErrorMessage p -> ErrorMessage p -> Bool
== :: ErrorMessage p -> ErrorMessage p -> Bool
$c== :: forall p. Eq p => ErrorMessage p -> ErrorMessage p -> Bool
Eq, ErrorMessage p -> ErrorMessage p -> Bool
ErrorMessage p -> ErrorMessage p -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {p}. Ord p => Eq (ErrorMessage p)
forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Bool
forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Ordering
forall p.
Ord p =>
ErrorMessage p -> ErrorMessage p -> ErrorMessage p
min :: ErrorMessage p -> ErrorMessage p -> ErrorMessage p
$cmin :: forall p.
Ord p =>
ErrorMessage p -> ErrorMessage p -> ErrorMessage p
max :: ErrorMessage p -> ErrorMessage p -> ErrorMessage p
$cmax :: forall p.
Ord p =>
ErrorMessage p -> ErrorMessage p -> ErrorMessage p
>= :: ErrorMessage p -> ErrorMessage p -> Bool
$c>= :: forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Bool
> :: ErrorMessage p -> ErrorMessage p -> Bool
$c> :: forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Bool
<= :: ErrorMessage p -> ErrorMessage p -> Bool
$c<= :: forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Bool
< :: ErrorMessage p -> ErrorMessage p -> Bool
$c< :: forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Bool
compare :: ErrorMessage p -> ErrorMessage p -> Ordering
$ccompare :: forall p. Ord p => ErrorMessage p -> ErrorMessage p -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (ErrorMessage p) x -> ErrorMessage p
forall p x. ErrorMessage p -> Rep (ErrorMessage p) x
$cto :: forall p x. Rep (ErrorMessage p) x -> ErrorMessage p
$cfrom :: forall p x. ErrorMessage p -> Rep (ErrorMessage p) x
Generic)
instance (Pretty p) => Pretty (ErrorMessage p) where
pretty :: forall ann. ErrorMessage p -> Doc ann
pretty = forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError forall a ann. Pretty a => a -> Doc ann
pretty
ppMismatch :: Set Text -> Maybe Text -> Doc ann
ppMismatch :: forall ann. Set Text -> Maybe Text -> Doc ann
ppMismatch (forall a. Set a -> [a]
S.toList -> []) Maybe Text
Nothing =
Doc ann
"Unknown mismatch occurred"
ppMismatch (forall a. Set a -> [a]
S.toList -> []) Maybe Text
unexpected =
Doc ann
"Unexpected:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
unexpected
ppMismatch (forall a. Set a -> [a]
S.toList -> [Text]
expected) Maybe Text
Nothing =
Doc ann
"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 ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
expected)
ppMismatch (forall a. Set a -> [a]
S.toList -> [Text]
expected) (Just Text
got) =
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"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 ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
expected)
, Doc ann
"But got: " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
got
]
ppError :: (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError :: forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError p -> Doc ann
ppPosition (ErrorMessage p
pos [Text]
annotations Set Text
expected Maybe Text
got) =
forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
[ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ p -> Doc ann
ppPosition p
pos forall a. Monoid a => a -> a -> a
`mappend` Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"mismatch:"
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
annotations
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc ann
"In" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (forall ann. Doc ann
comma forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> Doc ann
"in") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Text]
annotations) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
colon
, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
4 forall a b. (a -> b) -> a -> b
$ forall ann. Set Text -> Maybe Text -> Doc ann
ppMismatch Set Text
expected Maybe Text
got
]
data GrammarError p = GrammarError (Propagation p) Mismatch
deriving (Int -> GrammarError p -> ShowS
forall p. Show p => Int -> GrammarError p -> ShowS
forall p. Show p => [GrammarError p] -> ShowS
forall p. Show p => GrammarError p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GrammarError p] -> ShowS
$cshowList :: forall p. Show p => [GrammarError p] -> ShowS
show :: GrammarError p -> String
$cshow :: forall p. Show p => GrammarError p -> String
showsPrec :: Int -> GrammarError p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> GrammarError p -> ShowS
Show)
instance Semigroup (GrammarError p) where
GrammarError Propagation p
pos Mismatch
m <> :: GrammarError p -> GrammarError p -> GrammarError p
<> GrammarError Propagation p
pos' Mismatch
m'
| Propagation p
pos forall a. Ord a => a -> a -> Bool
> Propagation p
pos' = forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos Mismatch
m
| Propagation p
pos forall a. Ord a => a -> a -> Bool
< Propagation p
pos' = forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos' Mismatch
m'
| Bool
otherwise = forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos (Mismatch
m forall a. Semigroup a => a -> a -> a
<> Mismatch
m')
{-# INLINE (<>) #-}
doAnnotate :: MonadContextError (Propagation p) e m => Text -> m a -> m a
doAnnotate :: forall p e (m :: * -> *) a.
MonadContextError (Propagation p) e m =>
Text -> m a -> m a
doAnnotate Text
ann =
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> c) -> m a -> m a
localContext forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
Propagation p
propagation { pAnns :: [Text]
pAnns = Text
ann forall a. a -> [a] -> [a]
: forall p. Propagation p -> [Text]
pAnns Propagation p
propagation }
{-# INLINE doAnnotate #-}
doDive :: MonadContextError (Propagation p) e m => m a -> m a
doDive :: forall p e (m :: * -> *) a.
MonadContextError (Propagation p) e m =>
m a -> m a
doDive =
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> c) -> m a -> m a
localContext forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
Propagation p
propagation { pProp :: [Int]
pProp = Int
0 forall a. a -> [a] -> [a]
: forall p. Propagation p -> [Int]
pProp Propagation p
propagation }
{-# INLINE doDive #-}
doStep :: MonadContextError (Propagation p) e m => m ()
doStep :: forall p e (m :: * -> *).
MonadContextError (Propagation p) e m =>
m ()
doStep =
forall c e (m :: * -> *).
MonadContextError c e m =>
(c -> c) -> m ()
modifyContext forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
Propagation p
propagation
{ pProp :: [Int]
pProp = case forall p. Propagation p -> [Int]
pProp Propagation p
propagation of
(Int
x : [Int]
xs) -> forall a. Enum a => a -> a
succ Int
x forall a. a -> [a] -> [a]
: [Int]
xs
[] -> [Int
0]
}
{-# INLINE doStep #-}
doLocate :: MonadContextError (Propagation p) e m => p -> m ()
doLocate :: forall p e (m :: * -> *).
MonadContextError (Propagation p) e m =>
p -> m ()
doLocate p
pos =
forall c e (m :: * -> *).
MonadContextError c e m =>
(c -> c) -> m ()
modifyContext forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
Propagation p
propagation { pPos :: p
pPos = p
pos }
{-# INLINE doLocate #-}
doError :: MonadContextError (Propagation p) (GrammarError p) m => Mismatch -> m a
doError :: forall p (m :: * -> *) a.
MonadContextError (Propagation p) (GrammarError p) m =>
Mismatch -> m a
doError Mismatch
mismatch =
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> e) -> m a
throwInContext forall a b. (a -> b) -> a -> b
$ \Propagation p
ctx ->
forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
ctx Mismatch
mismatch
{-# INLINE doError #-}