{-# 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

import Data.Text.Prettyprint.Doc
  ( Doc, Pretty, pretty, vsep, hsep, line, indent, fillSep, punctuate
  , comma, colon, (<+>), layoutSmart, PageWidth(..), LayoutOptions(..)
  )

#if 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 :: p -> Propagation p
initPropagation = [Int] -> [Text] -> p -> Propagation p
forall p. [Int] -> [Text] -> p -> Propagation p
Propagation [Int
0] []

data Propagation p = Propagation
  { Propagation p -> [Int]
pProp :: [Int]
  , Propagation p -> [Text]
pAnns :: [Text]
  , Propagation p -> p
pPos  :: p
  } deriving (Int -> Propagation p -> ShowS
[Propagation p] -> ShowS
Propagation p -> String
(Int -> Propagation p -> ShowS)
-> (Propagation p -> String)
-> ([Propagation p] -> ShowS)
-> Show (Propagation p)
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 [Int] -> [Int] -> Bool
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
_) =
    [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
as [Int] -> [Int] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
bs
  {-# INLINE compare #-}

-- | Data type to encode mismatches during parsing or generation, kept
-- abstract. Use 'expected' and 'unexpected' constructors to build a
-- mismatch report.
data Mismatch = Mismatch
  { Mismatch -> Set Text
mismatchExpected :: Set Text
  , Mismatch -> Maybe Text
mismatchGot :: Maybe Text
  } deriving (Int -> Mismatch -> ShowS
[Mismatch] -> ShowS
Mismatch -> String
(Int -> Mismatch -> ShowS)
-> (Mismatch -> String) -> ([Mismatch] -> ShowS) -> Show Mismatch
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
(Mismatch -> Mismatch -> Bool)
-> (Mismatch -> Mismatch -> Bool) -> Eq Mismatch
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)

-- | Construct a mismatch report with specified expectation. Can be
-- appended to other expectations and 'unexpected' reports to clarify
-- a mismatch.
expected :: Text -> Mismatch
expected :: Text -> Mismatch
expected Text
a = Set Text -> Maybe Text -> Mismatch
Mismatch (Text -> Set Text
forall a. a -> Set a
S.singleton Text
a) Maybe Text
forall a. Maybe a
Nothing

-- | Construct a mismatch report with information what occurred during
-- the processing but was not expected.
unexpected :: Text -> Mismatch
unexpected :: Text -> Mismatch
unexpected Text
a = Set Text -> Maybe Text -> Mismatch
Mismatch Set Text
forall a. Set a
S.empty (Text -> Maybe Text
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 Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
Semi.<> Mismatch -> Set Text
mismatchExpected Mismatch
m')
      (Mismatch -> Maybe Text
mismatchGot Mismatch
m Maybe Text -> Maybe Text -> Maybe Text
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 Set Text
forall a. Monoid a => a
mempty Maybe Text
forall a. Monoid a => a
mempty
  {-# INLINE mempty #-}
  mappend :: Mismatch -> Mismatch -> Mismatch
mappend = Mismatch -> Mismatch -> Mismatch
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}

-- | Run a 'forward' or 'backward' pass of a 'Grammar'.
runGrammar :: p -> ContextError (Propagation p) (GrammarError p) a -> Either (ErrorMessage p) a
runGrammar :: p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m =
  case ContextError (Propagation p) (GrammarError p) a
-> Propagation p -> Either (GrammarError p) a
forall c e a. ContextError c e a -> c -> Either e a
runContextError ContextError (Propagation p) (GrammarError p) a
m (p -> Propagation p
forall p. p -> Propagation p
initPropagation p
initPos) of
    Left (GrammarError Propagation p
p Mismatch
mismatch) ->
      ErrorMessage p -> Either (ErrorMessage p) a
forall a b. a -> Either a b
Left (ErrorMessage p -> Either (ErrorMessage p) a)
-> ErrorMessage p -> Either (ErrorMessage p) a
forall a b. (a -> b) -> a -> b
$ p -> [Text] -> Set Text -> Maybe Text -> ErrorMessage p
forall p. p -> [Text] -> Set Text -> Maybe Text -> ErrorMessage p
ErrorMessage
        (Propagation p -> p
forall p. Propagation p -> p
pPos Propagation p
p)
        ([Text] -> [Text]
forall a. [a] -> [a]
reverse (Propagation p -> [Text]
forall p. Propagation p -> [Text]
pAnns Propagation p
p))
        (Mismatch -> Set Text
mismatchExpected Mismatch
mismatch)
        (Mismatch -> Maybe Text
mismatchGot Mismatch
mismatch)
    Right a
a ->
      a -> Either (ErrorMessage p) a
forall a b. b -> Either a b
Right a
a

-- | Run a 'forward' or 'backward' pass of a 'Grammar', report errors
-- as pretty printed 'Doc' message.
runGrammarDoc :: (Pretty p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either (Doc ann) a
runGrammarDoc :: p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (Doc ann) a
runGrammarDoc p
initPos ContextError (Propagation p) (GrammarError p) a
m =
  (ErrorMessage p -> Doc ann)
-> Either (ErrorMessage p) a -> Either (Doc ann) a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((p -> Doc ann) -> ErrorMessage p -> Doc ann
forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError p -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) (Either (ErrorMessage p) a -> Either (Doc ann) a)
-> Either (ErrorMessage p) a -> Either (Doc ann) a
forall a b. (a -> b) -> a -> b
$
    p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
forall p a.
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m

-- | Run a 'forward' or 'backward' pass of a 'Grammar', report errors
-- as 'String' message.
runGrammarString :: (Show p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either String a
runGrammarString :: p
-> ContextError (Propagation p) (GrammarError p) a
-> Either String a
runGrammarString p
initPos ContextError (Propagation p) (GrammarError p) a
m =
  (ErrorMessage p -> String)
-> Either (ErrorMessage p) a -> Either String a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream Any -> String)
-> (ErrorMessage p -> SimpleDocStream Any)
-> ErrorMessage p
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
79 Double
0.75)) (Doc Any -> SimpleDocStream Any)
-> (ErrorMessage p -> Doc Any)
-> ErrorMessage p
-> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> Doc Any) -> ErrorMessage p -> Doc Any
forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError (String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc Any) -> (p -> String) -> p -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> String
forall a. Show a => a -> String
show)) (Either (ErrorMessage p) a -> Either String a)
-> Either (ErrorMessage p) a -> Either String a
forall a b. (a -> b) -> a -> b
$
    p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
forall p a.
p
-> ContextError (Propagation p) (GrammarError p) a
-> Either (ErrorMessage p) a
runGrammar p
initPos ContextError (Propagation p) (GrammarError p) a
m

-- | 'Grammar' run error messages type.
data ErrorMessage p = ErrorMessage
  { ErrorMessage p -> p
emPosition :: p
  , ErrorMessage p -> [Text]
emAnnotations :: [Text]
  , ErrorMessage p -> Set Text
emExpected :: Set Text
  , ErrorMessage p -> Maybe Text
emGot :: Maybe Text
  } deriving (ErrorMessage p -> ErrorMessage p -> Bool
(ErrorMessage p -> ErrorMessage p -> Bool)
-> (ErrorMessage p -> ErrorMessage p -> Bool)
-> Eq (ErrorMessage p)
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, Eq (ErrorMessage p)
Eq (ErrorMessage p)
-> (ErrorMessage p -> ErrorMessage p -> Ordering)
-> (ErrorMessage p -> ErrorMessage p -> Bool)
-> (ErrorMessage p -> ErrorMessage p -> Bool)
-> (ErrorMessage p -> ErrorMessage p -> Bool)
-> (ErrorMessage p -> ErrorMessage p -> Bool)
-> (ErrorMessage p -> ErrorMessage p -> ErrorMessage p)
-> (ErrorMessage p -> ErrorMessage p -> ErrorMessage p)
-> Ord (ErrorMessage p)
ErrorMessage p -> ErrorMessage p -> Bool
ErrorMessage p -> ErrorMessage p -> Ordering
ErrorMessage p -> ErrorMessage p -> ErrorMessage p
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
$cp1Ord :: forall p. Ord p => Eq (ErrorMessage p)
Ord, (forall x. ErrorMessage p -> Rep (ErrorMessage p) x)
-> (forall x. Rep (ErrorMessage p) x -> ErrorMessage p)
-> Generic (ErrorMessage p)
forall x. Rep (ErrorMessage p) x -> ErrorMessage p
forall x. ErrorMessage p -> Rep (ErrorMessage p) x
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 :: ErrorMessage p -> Doc ann
pretty = (p -> Doc ann) -> ErrorMessage p -> Doc ann
forall p ann. (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError p -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

ppMismatch :: Set Text -> Maybe Text -> Doc ann
ppMismatch :: Set Text -> Maybe Text -> Doc ann
ppMismatch (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> []) Maybe Text
Nothing =
  Doc ann
"Unknown mismatch occurred"
ppMismatch (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> []) Maybe Text
unexpected =
  Doc ann
"Unexpected:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
unexpected
ppMismatch (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
expected) Maybe Text
Nothing =
  Doc ann
"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 Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
expected)
ppMismatch (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
expected) (Just Text
got) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ann
"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 Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
expected)
  , Doc ann
"But got: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
got
  ]

ppError :: (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError :: (p -> Doc ann) -> ErrorMessage p -> Doc ann
ppError p -> Doc ann
ppPosition (ErrorMessage p
pos [Text]
annotations Set Text
expected Maybe Text
got) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Maybe (Doc ann)] -> [Doc ann]
forall a. [Maybe a] -> [a]
catMaybes
    [ Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ p -> Doc ann
ppPosition p
pos Doc ann -> Doc ann -> Doc ann
forall a. Monoid a => a -> a -> a
`mappend` Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"mismatch:"
    , if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
annotations
      then Maybe (Doc ann)
forall a. Maybe a
Nothing
      else Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"In" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Doc ann
forall ann. Doc ann
comma Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"in") ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
annotations) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon
    , Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Set Text -> Maybe Text -> Doc ann
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
[GrammarError p] -> ShowS
GrammarError p -> String
(Int -> GrammarError p -> ShowS)
-> (GrammarError p -> String)
-> ([GrammarError p] -> ShowS)
-> Show (GrammarError p)
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 Propagation p -> Propagation p -> Bool
forall a. Ord a => a -> a -> Bool
> Propagation p
pos' = Propagation p -> Mismatch -> GrammarError p
forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos Mismatch
m
    | Propagation p
pos Propagation p -> Propagation p -> Bool
forall a. Ord a => a -> a -> Bool
< Propagation p
pos' = Propagation p -> Mismatch -> GrammarError p
forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos' Mismatch
m'
    | Bool
otherwise  = Propagation p -> Mismatch -> GrammarError p
forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
pos (Mismatch
m Mismatch -> Mismatch -> Mismatch
forall a. Semigroup a => a -> a -> a
<> Mismatch
m')
  {-# INLINE (<>) #-}

doAnnotate :: MonadContextError (Propagation p) e m => Text -> m a -> m a
doAnnotate :: Text -> m a -> m a
doAnnotate Text
ann =
  (Propagation p -> Propagation p) -> m a -> m a
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> c) -> m a -> m a
localContext ((Propagation p -> Propagation p) -> m a -> m a)
-> (Propagation p -> Propagation p) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
    Propagation p
propagation { pAnns :: [Text]
pAnns = Text
ann Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Propagation p -> [Text]
forall p. Propagation p -> [Text]
pAnns Propagation p
propagation }
{-# INLINE doAnnotate #-}

doDive :: MonadContextError (Propagation p) e m => m a -> m a
doDive :: m a -> m a
doDive =
  (Propagation p -> Propagation p) -> m a -> m a
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> c) -> m a -> m a
localContext ((Propagation p -> Propagation p) -> m a -> m a)
-> (Propagation p -> Propagation p) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
    Propagation p
propagation { pProp :: [Int]
pProp = Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Propagation p -> [Int]
forall p. Propagation p -> [Int]
pProp Propagation p
propagation }
{-# INLINE doDive #-}

doStep :: MonadContextError (Propagation p) e m => m ()
doStep :: m ()
doStep =
  (Propagation p -> Propagation p) -> m ()
forall c e (m :: * -> *).
MonadContextError c e m =>
(c -> c) -> m ()
modifyContext ((Propagation p -> Propagation p) -> m ())
-> (Propagation p -> Propagation p) -> m ()
forall a b. (a -> b) -> a -> b
$ \Propagation p
propagation ->
    Propagation p
propagation
      { pProp :: [Int]
pProp = case Propagation p -> [Int]
forall p. Propagation p -> [Int]
pProp Propagation p
propagation of
          (Int
x : [Int]
xs) -> Int -> Int
forall a. Enum a => a -> a
succ Int
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
xs
          [] -> [Int
0]
      }
{-# INLINE doStep #-}

doLocate :: MonadContextError (Propagation p) e m => p -> m ()
doLocate :: p -> m ()
doLocate p
pos =
  (Propagation p -> Propagation p) -> m ()
forall c e (m :: * -> *).
MonadContextError c e m =>
(c -> c) -> m ()
modifyContext ((Propagation p -> Propagation p) -> m ())
-> (Propagation p -> Propagation p) -> m ()
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 :: Mismatch -> m a
doError Mismatch
mismatch =
  (Propagation p -> GrammarError p) -> m a
forall c e (m :: * -> *) a.
MonadContextError c e m =>
(c -> e) -> m a
throwInContext ((Propagation p -> GrammarError p) -> m a)
-> (Propagation p -> GrammarError p) -> m a
forall a b. (a -> b) -> a -> b
$ \Propagation p
ctx ->
    Propagation p -> Mismatch -> GrammarError p
forall p. Propagation p -> Mismatch -> GrammarError p
GrammarError Propagation p
ctx Mismatch
mismatch
{-# INLINE doError #-}