{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} module Data.InvertibleGrammar.Monad ( module Control.Monad.ContextError , dive , step , locate , grammarError , runGrammarMonad , Propagation , GrammarError (..) , Mismatch (..) ) where import Control.Applicative import Data.Set (Set) import qualified Data.Set as S import Data.List (intercalate) import Data.Semigroup import Control.Monad.ContextError initPropagation :: p -> Propagation p initPropagation = Propagation [0] data Propagation p = Propagation { pProp :: [Int] , pPos :: p } deriving (Show) instance Eq (Propagation p) where Propagation xs _ == Propagation ys _ = xs == ys instance Ord (Propagation p) where compare (Propagation as _) (Propagation bs _) = reverse as `compare` reverse bs {-# INLINE compare #-} data Mismatch = Mismatch { mismatchExpected :: Set String , mismatchGot :: Maybe String } deriving (Show, Eq) runGrammarMonad :: p -> (p -> String) -> ContextError (Propagation p) (GrammarError p) a -> Either String a runGrammarMonad initPos showPos m = case runContextError m (initPropagation initPos) of Left (GrammarError p mismatch) -> Left $ renderMismatch (showPos (pPos p)) mismatch Right a -> Right a renderMismatch :: String -> Mismatch -> String renderMismatch pos (Mismatch (S.toList -> expected) got) = unlines $ [ pos ++ ": mismatch:" ] ++ case (expected, got) of ([], Nothing) -> [ "unknown error happened" ] ([], Just got') -> [ "unexpected: " ++ got' ] (_:_, Nothing) -> [ "expected: " ++ intercalate ", " expected ] (_:_, Just got') -> [ "expected: " ++ intercalate ", " expected , " got: " ++ got' ] data GrammarError p = GrammarError (Propagation p) Mismatch deriving (Show) instance Semigroup (GrammarError p) where GrammarError pos m <> GrammarError pos' m' | pos > pos' = GrammarError pos m | pos < pos' = GrammarError pos' m' | otherwise = GrammarError pos $ Mismatch (mismatchExpected m <> mismatchExpected m') (mismatchGot m <|> mismatchGot m') dive :: MonadContextError (Propagation p) e m => m a -> m a dive = localContext $ \(Propagation xs pos) -> Propagation (0 : xs) pos {-# INLINE dive #-} step :: MonadContextError (Propagation p) e m => m () step = modifyContext $ \propagation -> propagation { pProp = case pProp propagation of (x : xs) -> succ x : xs [] -> [0] } {-# INLINE step #-} locate :: MonadContextError (Propagation p) e m => p -> m () locate pos = modifyContext $ \propagation -> propagation { pPos = pos } {-# INLINE locate #-} grammarError :: MonadContextError (Propagation p) (GrammarError p) m => Mismatch -> m a grammarError mismatch = throwInContext (\ctx -> GrammarError ctx mismatch) {-# INLINE grammarError #-}