{-# LANGUAGE ConstrainedClassMethods, FlexibleContexts, FlexibleInstances, GADTs,
RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Text.Grampa.Internal (BinTree(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),
AmbiguousAlternative(..), AmbiguityDecidable(..), AmbiguityWitness(..),
ParserFlags (ParserFlags, nullable, dependsOn),
Dependencies (DynamicDependencies, StaticDependencies),
TraceableParsing(..),
emptyFailure, erroneous, expected, expectedInput, replaceExpected, noFailure) where
import Control.Applicative (Applicative(..), Alternative(..))
import Data.Foldable (toList)
import Data.Functor.Classes (Show1(..))
import Data.Functor.Const (Const)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Monoid (Monoid(mappend, mempty))
import Data.Ord (Down(Down))
import Data.Semigroup (Semigroup((<>)))
import Data.Type.Equality ((:~:)(Refl))
import Witherable (Filterable(mapMaybe))
import Text.Grampa.Class (Ambiguous(..), FailureDescription(..), ParseFailure(..), InputParsing(..), Pos)
import Prelude hiding (length, showList)
data ResultsOfLength g s r = ResultsOfLength !Int ![(s, g (ResultList g s))] {-# UNPACK #-} !(NonEmpty r)
data ResultList g s r = ResultList ![ResultsOfLength g s r] (ParseFailure Pos s)
data BinTree a = Fork !(BinTree a) !(BinTree a)
| Leaf !a
| EmptyTree
deriving (Show)
data ParserFlags g = ParserFlags {
nullable :: Bool,
dependsOn :: Dependencies g}
data Dependencies g = DynamicDependencies
| StaticDependencies (g (Const Bool))
deriving instance Show (g (Const Bool)) => Show (Dependencies g)
data AmbiguityWitness a where
AmbiguityWitness :: (a :~: Ambiguous b) -> AmbiguityWitness a
class AmbiguityDecidable a where
ambiguityWitness :: Maybe (AmbiguityWitness a)
instance {-# overlappable #-} AmbiguityDecidable a where
ambiguityWitness = Nothing
instance AmbiguityDecidable (Ambiguous a) where
ambiguityWitness = Just (AmbiguityWitness Refl)
noFailure :: ParseFailure Pos s
noFailure = emptyFailure (Down maxBound)
emptyFailure :: Pos -> ParseFailure Pos s
emptyFailure pos = ParseFailure pos (FailureDescription [] []) []
expected :: Pos -> String -> ParseFailure Pos s
expected pos msg = ParseFailure pos (FailureDescription [msg] []) []
expectedInput :: Pos -> s -> ParseFailure Pos s
expectedInput pos s = ParseFailure pos (FailureDescription [] [s]) []
erroneous :: Pos -> String -> ParseFailure Pos s
erroneous pos msg = ParseFailure pos (FailureDescription [] []) [msg]
replaceExpected :: Pos -> String -> ParseFailure Pos s -> ParseFailure Pos s
replaceExpected pos msg f@(ParseFailure pos' msgs errs) = ParseFailure pos' msgs' errs
where msgs' | pos == pos' = FailureDescription [msg] []
| otherwise = msgs
instance (Show s, Show r) => Show (ResultList g s r) where
show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")
instance Show s => Show1 (ResultList g s) where
liftShowsPrec _sp showList _prec (ResultList rol f) rest =
"ResultList " ++ shows (simplify <$> toList rol) (shows f rest)
where simplify (ResultsOfLength l _ r) = "ResultsOfLength " <> show l <> " _ " <> showList (toList r) ""
instance Show r => Show (ResultsOfLength g s r) where
show (ResultsOfLength l _ r) = "(ResultsOfLength @" ++ show l ++ " " ++ shows r ")"
instance Functor (ResultsOfLength g s) where
fmap f (ResultsOfLength l t r) = ResultsOfLength l t (f <$> r)
{-# INLINE fmap #-}
instance Functor (ResultList g s) where
fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure
{-# INLINE fmap #-}
instance Ord s => Applicative (ResultsOfLength g s) where
pure = ResultsOfLength 0 mempty . pure
ResultsOfLength l1 _ fs <*> ResultsOfLength l2 t2 xs = ResultsOfLength (l1 + l2) t2 (fs <*> xs)
instance Ord s => Applicative (ResultList g s) where
pure a = ResultList [pure a] mempty
ResultList rl1 f1 <*> ResultList rl2 f2 = ResultList ((<*>) <$> rl1 <*> rl2) (f1 <> f2)
instance Ord s => Alternative (ResultList g s) where
empty = ResultList mempty mempty
(<|>) = (<>)
instance Filterable (ResultList g s) where
mapMaybe f (ResultList rols failure) = ResultList (mapMaybe maybeROL rols) failure
where maybeROL (ResultsOfLength l t rs) = ResultsOfLength l t <$> nonEmpty (mapMaybe f $ toList rs)
{-# INLINE mapMaybe #-}
instance Ord s => Semigroup (ResultList g s r) where
ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (merge rl1 rl2) (f1 <> f2)
where merge [] rl = rl
merge rl [] = rl
merge rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)
| l1 < l2 = rol1 : merge rest1 rl2'
| l1 > l2 = rol2 : merge rl1' rest2
| otherwise = ResultsOfLength l1 s1 (r1 <> r2) : merge rest1 rest2
instance Ord s => AmbiguousAlternative (ResultList g s) where
ambiguousOr (ResultList rl1 f1) (ResultList rl2 f2) = ResultList (merge rl1 rl2) (f1 <> f2)
where merge [] rl = rl
merge rl [] = rl
merge rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)
| l1 < l2 = rol1 : merge rest1 rl2'
| l1 > l2 = rol2 : merge rl1' rest2
| otherwise = ResultsOfLength l1 s1 (liftA2 collect r1 r2) : merge rest1 rest2
collect (Ambiguous xs) (Ambiguous ys) = Ambiguous (xs <> ys)
class Alternative f => AmbiguousAlternative f where
ambiguousOr :: f (Ambiguous a) -> f (Ambiguous a) -> f (Ambiguous a)
instance Ord s => Monoid (ResultList g s r) where
mempty = ResultList mempty mempty
mappend = (<>)
instance Functor BinTree where
fmap f (Fork left right) = Fork (fmap f left) (fmap f right)
fmap f (Leaf a) = Leaf (f a)
fmap _ EmptyTree = EmptyTree
instance Applicative BinTree where
pure = Leaf
EmptyTree <*> _ = EmptyTree
Leaf f <*> t = f <$> t
Fork f1 f2 <*> t = Fork (f1 <*> t) (f2 <*> t)
instance Foldable BinTree where
foldMap f (Fork left right) = foldMap f left `mappend` foldMap f right
foldMap f (Leaf a) = f a
foldMap _ EmptyTree = mempty
instance Traversable BinTree where
traverse f (Fork left right) = Fork <$> traverse f left <*> traverse f right
traverse f (Leaf a) = Leaf <$> f a
traverse _ EmptyTree = pure EmptyTree
instance Filterable BinTree where
mapMaybe f (Fork left right) = mapMaybe f left <> mapMaybe f right
mapMaybe f (Leaf a) = maybe EmptyTree Leaf (f a)
mapMaybe _ EmptyTree = EmptyTree
instance Semigroup (BinTree a) where
EmptyTree <> t = t
t <> EmptyTree = t
l <> r = Fork l r
instance Monoid (BinTree a) where
mempty = EmptyTree
mappend = (<>)
class FallibleResults f where
hasSuccess :: f s a -> Bool
failureOf :: f s a -> ParseFailure Pos s
failWith :: ParseFailure Pos s -> f s a
instance FallibleResults (ResultList g) where
hasSuccess (ResultList [] _) = False
hasSuccess _ = True
failureOf (ResultList _ failure) = failure
failWith = ResultList []
class InputParsing m => TraceableParsing m where
traceInput :: (ParserInput m -> String) -> m a -> m a
traceAs :: Show (ParserInput m) => String -> m a -> m a
traceAs description = traceInput (\input-> description <> " @ " <> show input)