-- The default type signature of type class methods are changed
--- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
+-- to introduce a 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
-- this setup avoids to define the method with boilerplate code when its default
--- definition with lift* and 'trans' does what is expected by an instance
+-- definition with 'liftDerived'* and 'derive' does what is expected by an instance
-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveLift #-} -- For TH.Lift (ErrorItem tok)
-{-# LANGUAGE StandaloneDeriving #-} -- For Show (ErrorItem (InputToken inp))
+{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
+{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
+{-# LANGUAGE DerivingStrategies #-} -- For UnscopedRegister
+{-# LANGUAGE PatternSynonyms #-} -- For Failure
+{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
+{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
+-- | Semantic of the grammar combinators used to express parsers,
+-- in the convenient tagless-final encoding.
module Symantic.Parser.Grammar.Combinators where
+import Data.Proxy (Proxy(..))
+import Control.Monad (Monad(..))
+import Control.DeepSeq (NFData(..))
+import GHC.Generics (Generic)
+-- import Data.Set (Set)
+-- import GHC.TypeLits (KnownSymbol)
+import Data.Bifunctor (second)
import Data.Bool (Bool(..), not, (||))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Function ((.), flip, const)
+import Data.Function ((.), flip, const, fix)
+import Data.Ord (Ord(..), Ordering(..))
import Data.Int (Int)
+import Data.Kind (Type, Constraint)
import Data.Maybe (Maybe(..))
-import Data.Ord (Ord)
+import Data.Set (Set)
import Data.String (String)
import Text.Show (Show(..))
+import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
+import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Parser.Haskell as H
+import Symantic.Syntaxes.Derive
+import qualified Symantic.Syntaxes.Classes as Prod
+import Symantic.Parser.Grammar.Production
+
+-- * Type 'ReprComb'
+type ReprComb = Type -> Type
+
+-- * Class 'CombAlternable'
+class CombAlternable repr where
+ -- | @('alt' es l r)@ parses @(l)@ and return its return value or,
+ -- if it fails with an 'Exception' within @(es)@,
+ -- parses @(r)@ from where @(l)@ has left the input stream,
+ -- and returns its return value,
+ -- otherwise throw the 'Exception' again.
+ alt :: Exception -> repr a -> repr a -> repr a
+ throw :: ExceptionLabel -> repr a
+ -- | @('try' ra)@ records the input stream position,
+ -- then parses like @(ra)@ and either returns its value it it succeeds or fails
+ -- if it fails but with a reset of the input stream to the recorded position.
+ -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
+ try :: repr a -> repr a
+ default alt ::
+ FromDerived2 CombAlternable repr =>
+ Exception -> repr a -> repr a -> repr a
+ default throw ::
+ FromDerived CombAlternable repr =>
+ ExceptionLabel -> repr a
+ default try ::
+ FromDerived1 CombAlternable repr =>
+ repr a -> repr a
+ alt = liftDerived2 . alt
+ throw = liftDerived . throw
+ try = liftDerived1 try
+
+ failure :: SomeFailure -> repr a
+ default failure ::
+ FromDerived CombAlternable repr =>
+ SomeFailure -> repr a
+ failure = liftDerived . failure
+
+ -- | @(empty)@ parses nothing, always failing to return a value.
+ empty :: repr a
+ empty = failure (SomeFailure FailureEmpty)
+
+data instance Failure CombAlternable
+ = FailureEmpty
+ deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
+
+-- ** Data family 'Failure'
+-- | 'Failure's of the 'Grammar'.
+-- This is an extensible data-type.
+data family Failure
+ (comb :: ReprComb -> Constraint)
+ :: Type
+
+{-
+-- | Convenient utility to pattern-match a 'SomeFailure'.
+pattern Failure :: Typeable comb => Failure comb -> SomeFailure
+pattern Failure x <- (unSomeFailure -> Just x)
+-}
+
+-- ** Type 'SomeFailure'
+data SomeFailure =
+ forall comb.
+ ( Eq (Failure comb)
+ , Ord (Failure comb)
+ , Show (Failure comb)
+ , TH.Lift (Failure comb)
+ , NFData (Failure comb)
+ , Typeable comb
+ ) => SomeFailure (Failure comb {-repr a-})
+instance Eq SomeFailure where
+ SomeFailure (x::Failure x) == SomeFailure (y::Failure y) =
+ case typeRep @x `eqTypeRep` typeRep @y of
+ Just HRefl -> x == y
+ Nothing -> False
+instance Ord SomeFailure where
+ SomeFailure (x::Failure x) `compare` SomeFailure (y::Failure y) =
+ -- WARNING: this ordering is convenient to make a 'Set' of 'SomeFailure's
+ -- but it is based upon a hash which changes with packages' ABI
+ -- and also if the install is "inplace" or not.
+ -- Therefore this 'Ord' is not stable enough to put 'SomeFailure'
+ -- in golden tests.
+ let xT = typeRep @x in
+ let yT = typeRep @y in
+ case SomeTypeRep xT `compare` SomeTypeRep yT of
+ EQ | Just HRefl <- xT `eqTypeRep` yT -> compare x y
+ o -> o
+instance Show SomeFailure where
+ showsPrec p (SomeFailure x) = showsPrec p x
+instance TH.Lift SomeFailure where
+ liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
+instance NFData SomeFailure where
+ rnf (SomeFailure x) = rnf x
+
+{-
+instance Derivable (SomeFailure repr) where
+ derive (SomeFailure x) = derive x
+-}
+
+-- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
+-- extract the data-constructor from the given 'SomeFailure'
+-- iif. it belongs to the @('Failure' comb repr a)@ data-instance.
+unSomeFailure :: forall comb. Typeable comb => SomeFailure -> Maybe (Failure comb)
+unSomeFailure (SomeFailure (c::Failure c)) =
+ case typeRep @comb `eqTypeRep` typeRep @c of
+ Just HRefl -> Just c
+ Nothing -> Nothing
+
+-- ** Type 'Exception'
+data Exception
+ = ExceptionLabel ExceptionLabel
+ | ExceptionFailure
+ -- | ExceptionEnd
+ deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
+type ExceptionLabel = String
+-- type Exceptions = Set Exception
+
+-- | Like @('<|>')@ but with different returning types for the alternatives,
+-- and a return value wrapped in an 'Either' accordingly.
+(<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
+p <+> q = Prod.left <$> p <|> Prod.right <$> q
+
+(<|>) :: CombAlternable repr => repr a -> repr a -> repr a
+(<|>) = alt ExceptionFailure
+
+infixl 3 <|>, <+>
+
+optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production '[] b -> repr b
+optionally p x = p $> x <|> pure x
+
+optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
+optional = flip optionally (Prod.constant ())
+
+option :: CombApplicable repr => CombAlternable repr => Production '[] a -> repr a -> repr a
+option x p = p <|> pure x
+
+choice :: CombAlternable repr => [repr a] -> repr a
+choice = List.foldr (<|>) empty
+ -- FIXME: Here hlint suggests to use Data.Foldable.asum,
+ -- but at this point there is no asum for our own (<|>)
--- * Type 'TermGrammar'
-type TermGrammar = H.Term H.ValueCode
+maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
+maybeP p = option Prod.nothing (Prod.just <$> p)
--- * Class 'Applicable'
+manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
+manyTill p end = let go = end $> Prod.nil <|> p <:> go in go
+
+-- * Class 'CombApplicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes
--- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@
--- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
+-- from the @base@ package, but using @('Production' vs a)@ instead of just @(a)@
+-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'Prod.id')
-- and thus apply some optimizations.
-- @(repr)@, for "representation", is the usual tagless-final abstraction
-- over the many semantics that this syntax (formed by the methods
-- of type class like this one) will be interpreted.
-class Applicable repr where
+class CombApplicable repr where
-- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
- (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
+ (<$>) :: Production '[] (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
+ (<$>%) :: (Production '[] a -> Production '[] b) -> repr a -> repr b
+ a2b <$>% ma = Prod.lam a2b <$> ma
-- | Like '<$>' but with its arguments 'flip'-ped.
- (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
+ (<&>) :: repr a -> Production '[] (a -> b) -> repr b
(<&>) = flip (<$>)
-- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
- (<$) :: TermGrammar a -> repr b -> repr a
+ (<$) :: Production '[] a -> repr b -> repr a
(<$) x = (pure x <*)
-- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
- ($>) :: repr a -> TermGrammar b -> repr b
+ ($>) :: repr a -> Production '[] b -> repr b
($>) = flip (<$)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
- pure :: TermGrammar a -> repr a
+ pure :: Production '[] a -> repr a
default pure ::
- Sym.Liftable repr => Applicable (Sym.Output repr) =>
- TermGrammar a -> repr a
- pure = Sym.lift . pure
+ FromDerived CombApplicable repr =>
+ Production '[] a -> repr a
+ pure = liftDerived . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
-- and returns the application of the function returned by @(ra2b)@
-- to the value returned by @(ra)@.
(<*>) :: repr (a -> b) -> repr a -> repr b
default (<*>) ::
- Sym.Liftable2 repr => Applicable (Sym.Output repr) =>
+ FromDerived2 CombApplicable repr =>
repr (a -> b) -> repr a -> repr b
- (<*>) = Sym.lift2 (<*>)
-
- -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
- -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
- liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
- liftA2 f x = (<*>) (f <$> x)
+ (<*>) = liftDerived2 (<*>)
-- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(ra)@, discarding the return value of @(rb)@.
(<*) :: repr a -> repr b -> repr a
- (<*) = liftA2 H.const
+ (<*) = liftA2 Prod.const
-- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(rb)@, discarding the return value of @(ra)@.
(*>) :: repr a -> repr b -> repr b
- x *> y = (H.id <$ x) <*> y
+ x *> y = (Prod.id <$ x) <*> y
-- | Like '<*>' but with its arguments 'flip'-ped.
(<**>) :: repr a -> repr (a -> b) -> repr b
- (<**>) = liftA2 (H.flip H..@ (H.$))
+ (<**>) = liftA2 (Prod.flip Prod..@ (Prod.$))
{-
(<**>) :: repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (\a f -> f a)
-}
-infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
-
--- * Class 'Alternable'
-class Alternable repr where
- -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or,
- -- if it fails, parses @(rr)@ from where @(rl)@ has left the input stream,
- -- and returns its return value.
- (<|>) :: repr a -> repr a -> repr a
- -- | @(empty)@ parses nothing, always failing to return a value.
- empty :: repr a
- -- | @('try' ra)@ records the input stream position,
- -- then parses like @(ra)@ and either returns its value it it succeeds or fails
- -- if it fails but with a reset of the input stream to the recorded position.
- -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
- try :: repr a -> repr a
- default (<|>) ::
- Sym.Liftable2 repr => Alternable (Sym.Output repr) =>
- repr a -> repr a -> repr a
- default empty ::
- Sym.Liftable repr => Alternable (Sym.Output repr) =>
- repr a
- default try ::
- Sym.Liftable1 repr => Alternable (Sym.Output repr) =>
- repr a -> repr a
- (<|>) = Sym.lift2 (<|>)
- empty = Sym.lift empty
- try = Sym.lift1 try
- -- | Like @('<|>')@ but with different returning types for the alternatives,
- -- and a return value wrapped in an 'Either' accordingly.
- (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
- p <+> q = H.left <$> p <|> H.right <$> q
-infixl 3 <|>, <+>
+ -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
+ -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
+ liftA2 :: Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
+ liftA2 f x = (<*>) (f <$> x)
-optionally :: Applicable repr => Alternable repr => repr a -> TermGrammar b -> repr b
-optionally p x = p $> x <|> pure x
+infixl 4 <*>, <*, *>, <**>
+data instance Failure CombApplicable
-optional :: Applicable repr => Alternable repr => repr a -> repr ()
-optional = flip optionally H.unit
-option :: Applicable repr => Alternable repr => TermGrammar a -> repr a -> repr a
-option x p = p <|> pure x
+{-# INLINE (<:>) #-}
+infixl 4 <:>
+(<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
+(<:>) = liftA2 Prod.cons
-choice :: Alternable repr => [repr a] -> repr a
-choice = List.foldr (<|>) empty
- -- FIXME: Here hlint suggests to use Data.Foldable.asum,
- -- but at this point there is no asum for our own (<|>)
+sequence :: CombApplicable repr => [repr a] -> repr [a]
+sequence = List.foldr (<:>) (pure Prod.nil)
-maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
-maybeP p = option H.nothing (H.just <$> p)
+traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
+traverse f = sequence . List.map f
+ -- FIXME: Here hlint suggests to use Control.Monad.mapM,
+ -- but at this point there is no mapM for our own sequence
-manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
-manyTill p end = let go = end $> H.nil <|> p <:> go in go
+repeat :: CombApplicable repr => Int -> repr a -> repr [a]
+repeat n p = traverse (const p) [1..n]
--- * Class 'Selectable'
-class Selectable repr where
- branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
- default branch ::
- Sym.Liftable3 repr => Selectable (Sym.Output repr) =>
- repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
- branch = Sym.lift3 branch
+between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
+between open close p = open *> p <* close
--- * Class 'Matchable'
-class Matchable repr where
- conditional ::
- Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
- default conditional ::
- Sym.Unliftable repr => Sym.Liftable1 repr => Matchable (Sym.Output repr) =>
- Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
- conditional a ps bs = Sym.lift1 (conditional (Sym.trans a) ps (Sym.trans Functor.<$> bs))
+void :: CombApplicable repr => repr a -> repr ()
+void p = p *> unit
- match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b
- match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)
- -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
+unit :: CombApplicable repr => repr ()
+unit = pure (Prod.constant ())
--- * Class 'Foldable'
-class Foldable repr where
- chainPre :: repr (a -> a) -> repr a -> repr a
+-- * Class 'CombFoldable'
+class CombFoldable repr where
+ chainPre :: repr (a -> a) -> repr a -> repr a
chainPost :: repr a -> repr (a -> a) -> repr a
- {-
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
default chainPre ::
- Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+ FromDerived2 CombFoldable repr =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+ FromDerived2 CombFoldable repr =>
repr a -> repr (a -> a) -> repr a
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
- -}
+ {-
default chainPre ::
- Applicable repr =>
- Alternable repr =>
+ CombApplicable repr =>
+ CombAlternable repr =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Applicable repr =>
- Alternable repr =>
+ CombApplicable repr =>
+ CombAlternable repr =>
repr a -> repr (a -> a) -> repr a
- chainPre op p = go <*> p
- where go = (H..) <$> op <*> go <|> pure H.id
- chainPost p op = p <**> go
- where go = (H..) <$> op <*> go <|> pure H.id
+ chainPre op p = go <*> p where go = (Prod..) <$> op <*> go <|> pure Prod.id
+ chainPost p op = p <**> go where go = (Prod..) <$> op <*> go <|> pure Prod.id
+ -}
+ {-
+ chainPre op p = flip (foldr ($)) <$> many op <*> p
+ chainPost p op = foldl' (flip ($)) <$> p <*> many op
+ -}
+data instance Failure CombFoldable
{-
-conditional :: Selectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: CombSelectable repr => [(Production '[] (a -> Bool), repr b)] -> repr a -> repr b -> repr b
conditional cs p def = match p fs qs def
where (fs, qs) = List.unzip cs
-}
--- * Class 'Satisfiable'
-class Satisfiable tok repr where
- satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
- default satisfy ::
- Sym.Liftable repr => Satisfiable tok (Sym.Output repr) =>
- [ErrorItem tok] ->
- TermGrammar (tok -> Bool) -> repr tok
- satisfy es = Sym.lift . satisfy es
-
- item :: repr tok
- item = satisfy [] (H.const H..@ H.bool True)
-
--- ** Type 'ErrorItem'
-data ErrorItem tok
- = ErrorItemToken tok
- | ErrorItemLabel String
- | ErrorItemHorizon Int
- | ErrorItemEnd
-deriving instance Eq tok => Eq (ErrorItem tok)
-deriving instance Ord tok => Ord (ErrorItem tok)
-deriving instance Show tok => Show (ErrorItem tok)
-deriving instance TH.Lift tok => TH.Lift (ErrorItem tok)
-
--- * Class 'Lookable'
-class Lookable repr where
- look :: repr a -> repr a
- negLook :: repr a -> repr ()
- default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
- default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
- look = Sym.lift1 look
- negLook = Sym.lift1 negLook
-
- eof :: repr ()
- eof = Sym.lift eof
- default eof :: Sym.Liftable repr => Lookable (Sym.Output repr) => repr ()
- -- eof = negLook (satisfy @Char [ErrorItemAny] (H.const H..@ H.bool True))
- -- (item @Char)
-
-{-# INLINE (<:>) #-}
-infixl 4 <:>
-(<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
-(<:>) = liftA2 H.cons
-
-sequence :: Applicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure H.nil)
-
-traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
-traverse f = sequence . List.map f
- -- FIXME: Here hlint suggests to use Control.Monad.mapM,
- -- but at this point there is no mapM for our own sequence
-
-repeat :: Applicable repr => Int -> repr a -> repr [a]
-repeat n p = traverse (const p) [1..n]
-
-between :: Applicable repr => repr o -> repr c -> repr a -> repr a
-between open close p = open *> p <* close
-
-string ::
- Applicable repr => Alternable repr =>
- Satisfiable Char repr =>
- [Char] -> repr [Char]
-string = try . traverse char
-
-oneOf ::
- TH.Lift tok => Eq tok =>
- Satisfiable tok repr =>
- [tok] -> repr tok
-oneOf ts = satisfy [ErrorItemLabel "oneOf"]
- (Sym.trans H.ValueCode
- { value = (`List.elem` ts)
- , code = [||\t -> $$(ofChars ts [||t||])||] })
-
-noneOf ::
- TH.Lift tok => Eq tok =>
- Satisfiable tok repr =>
- [tok] -> repr tok
-noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (Sym.trans H.ValueCode
- { value = not . (`List.elem` cs)
- , code = [||\c -> not $$(ofChars cs [||c||])||]
- })
-
-ofChars ::
- TH.Lift tok => Eq tok =>
- {-alternatives-}[tok] ->
- {-input-}TH.CodeQ tok ->
- TH.CodeQ Bool
-ofChars = List.foldr (\alt acc ->
- \inp -> [|| alt == $$inp || $$(acc inp) ||])
- (const [||False||])
-
-more :: Applicable repr => Satisfiable Char repr => Lookable repr => repr ()
-more = look (void (item @Char))
-
-char ::
- Applicable repr => Satisfiable Char repr =>
- Char -> repr Char
-char c = satisfy [ErrorItemToken c] (H.eq H..@ H.char c) $> H.char c
--- char c = satisfy [ErrorItemToken c] (H.eq H..@ H.qual H..@ H.char c) $> H.char c
-
-anyChar :: Satisfiable Char repr => repr Char
-anyChar = satisfy [] (H.const H..@ H.bool True)
-
-token ::
- TH.Lift tok => Show tok => Eq tok =>
- Applicable repr => Satisfiable tok repr =>
- tok -> repr tok
-token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.char tok) $> H.char tok
--- token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
-
-tokens ::
- TH.Lift tok => Eq tok => Show tok =>
- Applicable repr => Alternable repr =>
- Satisfiable tok repr => [tok] -> repr [tok]
-tokens = try . traverse token
-
--- Composite Combinators
--- someTill :: repr a -> repr b -> repr [a]
--- someTill p end = negLook end *> (p <:> manyTill p end)
-
-void :: Applicable repr => repr a -> repr ()
-void p = p *> unit
-
-unit :: Applicable repr => repr ()
-unit = pure H.unit
-
-{-
-constp :: Applicable repr => repr a -> repr (b -> a)
-constp = (H.const <$>)
-
-
--- Alias Operations
-infixl 1 >>
-(>>) :: Applicable repr => repr a -> repr b -> repr b
-(>>) = (*>)
-
--- Monoidal Operations
-
-infixl 4 <~>
-(<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (H.runtime (,))
-
-infixl 4 <~
-(<~) :: Applicable repr => repr a -> repr b -> repr a
-(<~) = (<*)
-
-infixl 4 ~>
-(~>) :: Applicable repr => repr a -> repr b -> repr b
-(~>) = (*>)
-
--- Lift Operations
-liftA2 ::
- Applicable repr =>
- TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
-liftA2 f x = (<*>) (fmap f x)
-
-liftA3 ::
- Applicable repr =>
- TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
-liftA3 f a b c = liftA2 f a b <*> c
-
--}
-
-- Parser Folds
pfoldr ::
- Applicable repr => Foldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ CombApplicable repr => CombFoldable repr =>
+ Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
- Applicable repr => Foldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ CombApplicable repr => CombFoldable repr =>
+ Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
- Applicable repr => Foldable repr =>
- TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
+ CombApplicable repr => CombFoldable repr =>
+ Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
+pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
pfoldl1 ::
- Applicable repr => Foldable repr =>
- TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
+ CombApplicable repr => CombFoldable repr =>
+ Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Prod.flip <$> pure f) <*> p)
-- Chain Combinators
chainl1' ::
- Applicable repr => Foldable repr =>
- TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
+ CombApplicable repr => CombFoldable repr =>
+ Production '[] (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
chainl1 ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr (a -> a -> a) -> repr a
-chainl1 = chainl1' H.id
+chainl1 = chainl1' Prod.id
{-
chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
-chainr1' f p op = newRegister_ H.id $ \acc ->
+chainr1' f p op = newRegister_ Prod.id $ \acc ->
let go = bind p $ \x ->
- modify acc (H.flip (H..@) <$> (op <*> x)) *> go
+ modify acc (Prod.flip (Prod..@) <$> (op <*> x)) *> go
<|> f <$> x
in go <**> get acc
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
-chainr1 = chainr1' H.id
+chainr1 = chainr1' Prod.id
-chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
chainr p op x = option x (chainr1 p op)
-}
chainl ::
- Applicable repr => Alternable repr => Foldable repr =>
- repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
+ repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
chainl p op x = option x (chainl1 p op)
-- Derived Combinators
many ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr [a]
-many = pfoldr H.cons H.nil
+many = pfoldr Prod.cons Prod.nil
manyN ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
Int -> repr a -> repr [a]
manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
some ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr [a]
some = manyN 1
skipMany ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr ()
--skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
-skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused
+skipMany = void . pfoldl Prod.const Prod.unit -- the void here will encourage the optimiser to recognise that the register is unused
skipManyN ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
Int -> repr a -> repr ()
skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
skipSome ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr ()
skipSome = skipManyN 1
sepBy ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
-sepBy p sep = option H.nil (sepBy1 p sep)
+sepBy p sep = option Prod.nil (sepBy1 p sep)
sepBy1 ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
sepBy1 p sep = p <:> many (sep *> p)
endBy ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
endBy p sep = many (p <* sep)
endBy1 ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
endBy1 p sep = some (p <* sep)
sepEndBy ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
-sepEndBy p sep = option H.nil (sepEndBy1 p sep)
+sepEndBy p sep = option Prod.nil (sepEndBy1 p sep)
sepEndBy1 ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr b -> repr [a]
sepEndBy1 p sep =
- let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
- <|> pure (H.flip H..@ H.cons H..@ H.nil))
+ let seb1 = p <**> (sep *> (Prod.flip Prod..@ Prod.cons <$> option Prod.nil seb1)
+ <|> pure (Prod.flip Prod..@ Prod.cons Prod..@ Prod.nil))
in seb1
{-
sepEndBy1 :: repr a -> repr b -> repr [a]
-sepEndBy1 p sep = newRegister_ H.id $ \acc ->
- let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
+sepEndBy1 p sep = newRegister_ Prod.id $ \acc ->
+ let go = modify acc ((Prod.flip (Prod..)) Prod..@ Prod.cons <$> p)
*> (sep *> (go <|> get acc) <|> get acc)
- in go <*> pure H.nil
+ in go <*> pure Prod.nil
+-}
+
+-- * Class 'CombMatchable'
+class CombMatchable repr where
+ conditional ::
+ repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
+ conditional a bs = liftDerived1
+ (conditional (derive a) (second derive Functor.<$> bs))
+ default conditional ::
+ FromDerived1 CombMatchable repr => Derivable repr =>
+ repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
+data instance Failure CombMatchable
+
+match ::
+ CombMatchable repr =>
+ Eq a => TH.Lift a =>
+ repr a -> [Production '[] a] -> (Production '[] a -> repr b) -> repr b -> repr b
+match a as p = conditional a
+ ((\v ->
+ ( Prod.lam (v Prod.==)
+ , p v
+ )
+ ) Functor.<$> as)
+
+predicate ::
+ CombMatchable repr =>
+ Production '[] (a -> Bool) -> repr a -> repr b -> repr b -> repr b
+predicate p a b = conditional a [(p, b)]
+
+infixl 4 <?:>
+(<?:>) ::
+ CombMatchable repr =>
+ repr Bool -> (repr a, repr a) -> repr a
+cond <?:> (p, q) = predicate Prod.id cond p q
+
+-- * Class 'CombSatisfiable'
+class CombSatisfiable tok repr where
+ -- | Like 'satisfyOrFail' but with no custom failure.
+ satisfy :: Production '[] (tok -> Bool) -> repr tok
+ satisfy = satisfyOrFail Set.empty
+ -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
+ satisfyOrFail ::
+ Set SomeFailure ->
+ Production '[] (tok -> Bool) -> repr tok
+ default satisfyOrFail ::
+ FromDerived (CombSatisfiable tok) repr =>
+ Set SomeFailure ->
+ Production '[] (tok -> Bool) -> repr tok
+ satisfyOrFail fs = liftDerived . satisfyOrFail fs
+
+data instance Failure (CombSatisfiable tok)
+ = FailureAny
+ -- FIXME: this 'Failure' is a bit special since multiple ones
+ -- with different 'Horizon's makes no sense.
+ -- This should likely be treated separately in 'ParsingError'.
+ | FailureHorizon Int -- FIXME: use Natural?
+ | FailureLabel String
+ | FailureToken tok
+ deriving (Eq, Ord, Show, Typeable, Generic, NFData)
+-- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
+-- from TemplateHaskell code.
+inputTokenProxy :: TH.Name
+inputTokenProxy = TH.mkName "inputToken"
+instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
+ liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
+ liftTyped x = [||
+ case
+ $$(let inputToken :: TH.Code m (Proxy tok) =
+ TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
+ in inputToken) of
+ (Proxy :: Proxy tok') ->
+ $$(case x of
+ FailureAny -> [|| FailureAny @tok' ||]
+ FailureHorizon h -> [|| FailureHorizon @tok' h ||]
+ FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
+ FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
+ )
+ ||]
+
+char ::
+ CombApplicable repr =>
+ CombSatisfiable Char repr =>
+ Char -> repr Char
+char c = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureToken c)))
+ (Prod.equal Prod..@ Prod.constant c)
+ $> Prod.constant c
+
+item :: forall tok repr.
+ Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+ CombSatisfiable tok repr => repr tok
+item = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureAny @tok)))
+ (Prod.const Prod..@ Prod.constant True)
+
+anyChar ::
+ CombAlternable repr =>
+ CombSatisfiable Char repr =>
+ repr Char
+anyChar = item
+
+string ::
+ CombApplicable repr => CombAlternable repr =>
+ CombSatisfiable Char repr =>
+ [Char] -> repr [Char]
+string = try . traverse char
+
+oneOf ::
+ Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+ CombSatisfiable tok repr =>
+ [tok] -> repr tok
+oneOf ts = satisfyOrFail
+ (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
+ (production
+ (`List.elem` ts)
+ [||\t -> $$(ofChars ts [||t||])||])
+
+noneOf ::
+ TH.Lift tok => Eq tok =>
+ CombSatisfiable tok repr =>
+ [tok] -> repr tok
+noneOf cs = satisfy (production
+ (not . (`List.elem` cs))
+ [||\c -> not $$(ofChars cs [||c||])||])
+
+ofChars ::
+ TH.Lift tok => Eq tok =>
+ {-alternatives-}[tok] ->
+ {-input-}TH.CodeQ tok ->
+ TH.CodeQ Bool
+ofChars = List.foldr
+ (\tok acc inp -> [|| tok == $$inp || $$(acc inp) ||])
+ (const [||False||])
+
+more ::
+ CombAlternable repr =>
+ CombApplicable repr =>
+ CombSatisfiable Char repr =>
+ CombLookable repr => repr ()
+more = look (void (item @Char))
+
+token ::
+ TH.Lift tok => Show tok => Eq tok => Typeable tok =>
+ CombAlternable repr =>
+ CombApplicable repr =>
+ CombSatisfiable tok repr =>
+ tok -> repr tok
+token tok = satisfy (Prod.equal Prod..@ Prod.constant tok) $> Prod.constant tok
+-- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
+
+tokens ::
+ TH.Lift tok => Eq tok => Show tok => Typeable tok =>
+ CombApplicable repr => CombAlternable repr =>
+ CombSatisfiable tok repr => [tok] -> repr [tok]
+tokens = try . traverse token
+
+-- * Class 'CombSelectable'
+class CombSelectable repr where
+ branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+ default branch ::
+ FromDerived3 CombSelectable repr =>
+ repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+ branch = liftDerived3 branch
+data instance Failure CombSelectable
+
+when ::
+ CombMatchable repr =>
+ CombSelectable repr =>
+ Prod.Constantable () repr =>
+ repr Bool -> repr () -> repr ()
+when p q = p <?:> (q, Prod.constant ())
+
+while ::
+ CombMatchable repr =>
+ CombSelectable repr =>
+ Prod.Constantable () repr =>
+ repr Bool -> repr ()
+while x = fix (when x)
+
+-- * Class 'CombLookable'
+class CombLookable repr where
+ look :: repr a -> repr a
+ negLook :: repr a -> repr ()
+ default look ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr a
+ default negLook ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr ()
+ look = liftDerived1 look
+ negLook = liftDerived1 negLook
+
+ eof :: repr ()
+ eof = liftDerived eof
+ default eof ::
+ FromDerived CombLookable repr =>
+ repr ()
+ -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
+ -- (item @Char)
+data instance Failure CombLookable
+ = FailureEnd
+ deriving (Eq, Ord, Show, Typeable, TH.Lift, Generic, NFData)
+
+-- Composite Combinators
+-- someTill :: repr a -> repr b -> repr [a]
+-- someTill p end = negLook end *> (p <:> manyTill p end)
+
+{-
+constp :: CombApplicable repr => repr a -> repr (b -> a)
+constp = (Prod.const <$>)
+
+
+-- Alias Operations
+infixl 1 >>
+(>>) :: CombApplicable repr => repr a -> repr b -> repr b
+(>>) = (*>)
+
+-- Monoidal Operations
+
+infixl 4 <~>
+(<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
+(<~>) = liftA2 (Prod.runtime (,))
+
+infixl 4 <~
+(<~) :: CombApplicable repr => repr a -> repr b -> repr a
+(<~) = (<*)
+
+infixl 4 ~>
+(~>) :: CombApplicable repr => repr a -> repr b -> repr b
+(~>) = (*>)
+
+-- Lift Operations
+liftA2 ::
+ CombApplicable repr =>
+ Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
+liftA2 f x = (<*>) (fmap f x)
+
+liftA3 ::
+ CombApplicable repr =>
+ Production '[] (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+liftA3 f a b c = liftA2 f a b <*> c
+
-}
{-
-- Combinators interpreters for 'Sym.Any'.
-instance Applicable repr => Applicable (Sym.Any repr)
-instance Satisfiable repr => Satisfiable (Sym.Any repr)
-instance Alternable repr => Alternable (Sym.Any repr)
-instance Selectable repr => Selectable (Sym.Any repr)
-instance Matchable repr => Matchable (Sym.Any repr)
-instance Lookable repr => Lookable (Sym.Any repr)
-instance Foldable repr => Foldable (Sym.Any repr)
+instance CombApplicable repr => CombApplicable (Sym.Any repr)
+instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
+instance CombAlternable repr => CombAlternable (Sym.Any repr)
+instance CombSelectable repr => CombSelectable (Sym.Any repr)
+instance CombMatchable repr => CombMatchable (Sym.Any repr)
+instance CombLookable repr => CombLookable (Sym.Any repr)
+instance CombFoldable repr => CombFoldable (Sym.Any repr)
+-}
+
+-- * Type 'Register'
+newtype Register r a = Register { unRegister :: UnscopedRegister a }
+ deriving (Eq, Show)
+
+-- ** Type 'UnscopedRegister'
+newtype UnscopedRegister r = UnscopedRegister { unUnscopedRegister :: TH.Name }
+ deriving (Eq)
+ deriving newtype Show
+
+
+{-
+put_ :: ParserOps rep => Register r a -> rep a -> Parser ()
+put_ r = put r . pure
+
+gets_ :: ParserOps rep => Register r a -> rep (a -> b) -> Parser b
+gets_ r = gets r . pure
+
+modify_ :: ParserOps rep => Register r a -> rep (a -> a) -> Parser ()
+modify_ r = modify r . pure
-}
+
+gets ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr (a -> b) -> repr b
+gets r p = p <*> get r
+
+modify ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr (a -> a) -> repr ()
+modify r p = put r (gets r p)
+
+move ::
+ CombRegisterable repr =>
+ Register r1 a -> Register r2 a -> repr ()
+move dst src = put dst (get src)
+
+bind ::
+ CombRegisterable repr =>
+ repr a -> (repr a -> repr b) -> repr b
+bind p f = new p (f . get)
+
+local ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr a -> repr b -> repr b
+local r p q = bind (get r) (\x -> put r p *> q <* put r x)
+
+swap ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r1 a -> Register r2 a -> repr ()
+swap r1 r2 = bind (get r1) (\x -> move r1 r2 *> put r2 x)
+
+rollback ::
+ CombAlternable repr =>
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr b -> repr b
+rollback r p = bind (get r) (\x -> p <|> put r x *> empty)
+
+for ::
+ CombApplicable repr =>
+ CombMatchable repr =>
+ CombSelectable repr =>
+ CombRegisterable repr =>
+ Prod.Constantable () repr =>
+ repr a -> repr (a -> Bool) -> repr (a -> a) -> repr () -> repr ()
+for init cond step body =
+ new init (\i ->
+ let cond' = gets i cond in
+ when cond' (while (body *> modify i step *> cond'))
+ )
+
+
+-- ** Class 'CombRegisterable'
+class CombRegisterable (repr::ReprComb) where
+ new :: repr a -> (forall r. Register r a -> repr b) -> repr b
+ get :: Register r a -> repr a
+ put :: Register r a -> repr a -> repr ()
+ default new ::
+ FromDerived CombRegisterable repr => Derivable repr =>
+ repr a -> (forall r. Register r a -> repr b) -> repr b
+ default get ::
+ FromDerived CombRegisterable repr =>
+ Register r a -> repr a
+ default put ::
+ FromDerived1 CombRegisterable repr =>
+ Register r a -> repr a -> repr ()
+ new ini f = liftDerived (new (derive ini) (derive . f))
+ get = liftDerived . get
+ put = liftDerived1 . put