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

-- | 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 (forall a. a -> Set a
S.singleton Text
a) 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 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 #-}

-- | Run a 'forward' or 'backward' pass of a 'Grammar'.
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

-- | 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 :: 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

-- | 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 :: 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

-- | 'Grammar' run error messages type.
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 #-}