%/cover: TESTFLAGS+=--enable-coverage
%/cover: %
+t/prof: OPTIFLAGS?=-xc
t/prof:
cabal v2-build lib:symantic-parser --enable-profiling --write-ghc-environment-files=always
cabal test $(TESTFLAGS) --enable-profiling -fprof-auto -fprof-auto-calls \
--test-show-details always --test-options "$(TESTOPTIONS) $${p:+-p $$p}" \
- --ghc-options "-opti+RTS -opti-p -opti-L100 -opti-ls -opti-xc"
+ --ghc-options "-opti+RTS -opti-p -opti-L100 -opti-ls $(addprefix -opti,$(OPTIFLAGS))"
t/repl:
cabal repl --enable-tests symantic-parser-test
-- * Class 'Grammar'
type Grammar tok repr =
- ( Applicable repr
- , Alternable repr
- , Satisfiable tok repr
+ ( CombAlternable repr
+ , CombApplicable repr
+ , CombFoldable repr
, Letable TH.Name repr
, Letsable TH.Name repr
- , Selectable repr
- , Matchable repr
- , Foldable repr
- , Lookable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSatisfiable tok repr
+ , CombSelectable repr
+ , CombThrowable repr
)
-- | A usual pipeline to interpret 'Comb'inators:
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function ((.), flip, const)
-import Data.Kind (Constraint)
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Proxy (Proxy(..))
import Data.String (String)
-import GHC.TypeLits (KnownSymbol, Symbol)
+import GHC.TypeLits (KnownSymbol)
import Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
-- * Type 'TermGrammar'
type TermGrammar = H.Term H.ValueCode
--- * Class 'Applicable'
+-- * Class 'CombAlternable'
+class CombAlternable 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 => CombAlternable (Sym.Output repr) =>
+ repr a -> repr a -> repr a
+ default empty ::
+ Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
+ repr a
+ default try ::
+ Sym.Liftable1 repr => CombAlternable (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.
+ (<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
+ p <+> q = H.left <$> p <|> H.right <$> q
+infixl 3 <|>, <+>
+
+optionally :: CombApplicable repr => CombAlternable repr => repr a -> TermGrammar b -> repr b
+optionally p x = p $> x <|> pure x
+
+optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
+optional = flip optionally H.unit
+
+option :: CombApplicable repr => CombAlternable repr => TermGrammar 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 (<|>)
+
+maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
+maybeP p = option H.nothing (H.just <$> p)
+
+manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
+manyTill p end = let go = end $> H.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')
-- @(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
(<$>) f = (pure f <*>)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
pure :: TermGrammar a -> repr a
default pure ::
- Sym.Liftable repr => Applicable (Sym.Output repr) =>
+ Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
TermGrammar a -> repr a
pure = Sym.lift . pure
-- to the value returned by @(ra)@.
(<*>) :: repr (a -> b) -> repr a -> repr b
default (<*>) ::
- Sym.Liftable2 repr => Applicable (Sym.Output repr) =>
+ Sym.Liftable2 repr => CombApplicable (Sym.Output repr) =>
repr (a -> b) -> repr a -> repr b
(<*>) = Sym.lift2 (<*>)
-}
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 <|>, <+>
-
-class Throwable repr where
- type ThrowableLabel repr (lbl::Symbol) :: Constraint
- --type ThrowableLabel repr lbl = ThrowableLabel (Sym.Output repr) lbl
- throw ::
- KnownSymbol lbl =>
- ThrowableLabel repr lbl =>
- Proxy lbl -> repr a
- default throw ::
- forall lbl a.
- Sym.Liftable repr => Alternable (Sym.Output repr) =>
- KnownSymbol lbl =>
- Throwable (Sym.Output repr) =>
- ThrowableLabel (Sym.Output repr) lbl =>
- Proxy lbl -> repr a
- throw lbl = Sym.lift (throw lbl)
-
-optionally :: Applicable repr => Alternable repr => repr a -> TermGrammar b -> repr b
-optionally p x = p $> x <|> pure x
-
-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 H.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 H.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 H.unit
--- * Class 'Foldable'
-class Foldable repr where
+-- * Class 'CombFoldable'
+class CombFoldable repr where
chainPre :: repr (a -> a) -> repr a -> repr a
chainPost :: repr a -> repr (a -> a) -> repr a
{-
default chainPre ::
- Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+ Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+ Sym.Liftable2 repr => CombFoldable (Sym.Output 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
-}
{-
-conditional :: Selectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: CombSelectable repr => [(TermGrammar (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 =>
+ CombApplicable repr => CombFoldable repr =>
TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
pfoldl1 ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable 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)
-- Chain Combinators
chainl1' ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
chainl1 ::
- Applicable repr => Foldable repr =>
+ CombApplicable repr => CombFoldable repr =>
repr a -> repr (a -> a -> a) -> repr a
chainl1 = chainl1' H.id
-}
chainl ::
- Applicable repr => Alternable repr => Foldable repr =>
+ CombApplicable repr => CombAlternable repr => CombFoldable repr =>
repr a -> repr (a -> a -> a) -> TermGrammar 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
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
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)
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)
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)
in go <*> pure H.nil
-}
+-- * Class 'CombMatchable'
+class CombMatchable repr where
+ conditional ::
+ Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
+ default conditional ::
+ Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (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))
+
+ 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)
+
+-- * Class 'CombSatisfiable'
+class CombSatisfiable tok repr where
+ satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
+ default satisfy ::
+ Sym.Liftable repr => CombSatisfiable 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)
+
+string ::
+ CombApplicable repr => CombAlternable repr =>
+ CombSatisfiable Char repr =>
+ [Char] -> repr [Char]
+string = try . traverse char
+
+oneOf ::
+ TH.Lift tok => Eq tok =>
+ CombSatisfiable 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 =>
+ CombSatisfiable 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 :: CombApplicable repr => CombSatisfiable Char repr => CombLookable repr => repr ()
+more = look (void (item @Char))
+
+char ::
+ CombApplicable repr => CombSatisfiable 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 :: CombSatisfiable Char repr => repr Char
+anyChar = satisfy [] (H.const H..@ H.bool True)
+
+token ::
+ TH.Lift tok => Show tok => Eq tok =>
+ CombApplicable repr => CombSatisfiable 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 =>
+ 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 ::
+ Sym.Liftable3 repr => CombSelectable (Sym.Output repr) =>
+ repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+ branch = Sym.lift3 branch
+
+-- * Class 'CombThrowable'
+class CombThrowable repr where
+ throw :: KnownSymbol lbl => Proxy lbl -> repr a
+ default throw ::
+ forall lbl a.
+ Sym.Liftable repr => CombThrowable (Sym.Output repr) =>
+ KnownSymbol lbl => Proxy lbl -> repr a
+ throw lbl = Sym.lift (throw lbl)
+
+-- ** 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 'CombLookable'
+class CombLookable repr where
+ look :: repr a -> repr a
+ negLook :: repr a -> repr ()
+ default look :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr a
+ default negLook :: Sym.Liftable1 repr => CombLookable (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 => CombLookable (Sym.Output repr) => repr ()
+ -- eof = negLook (satisfy @Char [ErrorItemAny] (H.const H..@ H.bool True))
+ -- (item @Char)
+
+-- 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 = (H.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 (H.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 =>
+ TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
+liftA2 f x = (<*>) (fmap f x)
+
+liftA3 ::
+ CombApplicable repr =>
+ TermGrammar (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)
-}
-- | Like 'Letable.observeSharing'
-- but type-binding @(letName)@ to 'TH.Name'
-- to avoid the trouble to always set it.
-observeSharing ::
- Letsable TH.Name repr =>
- ObserveSharing TH.Name repr a ->
- repr a
+observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
observeSharing os = lets defs body
where (body, defs) = Letable.observeSharing os
makeLetName _ = TH.qNewName "name"
-- Combinators semantics for the 'ObserveSharing' interpreter.
+instance (Letable TH.Name repr, CombAlternable repr) =>
+ CombAlternable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombApplicable repr) =>
+ CombApplicable (ObserveSharing TH.Name repr)
instance
( Letable TH.Name repr
- , Satisfiable tok repr
- ) => Satisfiable tok (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Alternable repr
- ) => Alternable (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Applicable repr
- ) => Applicable (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Selectable repr
- ) => Selectable (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Matchable repr
- ) => Matchable (ObserveSharing TH.Name repr) where
+ , CombFoldable repr
+ {- TODO: the following constraints are for the current CombFoldable,
+ - they will have to be removed when CombFoldable will have Sym.lift2 as defaults
+ -}
+ , CombApplicable repr
+ , CombAlternable repr
+ ) => CombFoldable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombLookable repr) =>
+ CombLookable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombMatchable repr) =>
+ CombMatchable (ObserveSharing TH.Name repr) where
-- Here the default definition does not fit
-- since there is no lift* for the type of 'conditional'
-- and its default definition does not handles 'bs'
Functor.<*> Functor.pure cs
Functor.<*> mapM unObserveSharing bs
Functor.<*> unObserveSharing b
-instance
- ( Letable TH.Name repr
- , Foldable repr
- {- TODO: the following constraints are for the current Foldable,
- - they will have to be removed when Foldable will have Sym.lift2 as defaults
- -}
- , Applicable repr
- , Alternable repr
- ) => Foldable (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Lookable repr
- ) => Lookable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombSelectable repr) =>
+ CombSelectable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombSatisfiable tok repr) =>
+ CombSatisfiable tok (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombThrowable repr) =>
+ CombThrowable (ObserveSharing TH.Name repr)
-- Combinators semantics for the 'FinalizeSharing' interpreter.
-instance Applicable repr => Applicable (FinalizeSharing TH.Name repr)
-instance Alternable repr => Alternable (FinalizeSharing TH.Name repr)
-instance Satisfiable tok repr => Satisfiable tok (FinalizeSharing TH.Name repr)
-instance Selectable repr => Selectable (FinalizeSharing TH.Name repr)
-instance Matchable repr => Matchable (FinalizeSharing TH.Name repr) where
+instance CombApplicable repr => CombApplicable (FinalizeSharing TH.Name repr)
+instance CombAlternable repr => CombAlternable (FinalizeSharing TH.Name repr)
+instance CombFoldable repr => CombFoldable (FinalizeSharing TH.Name repr) where
+ chainPre = Sym.lift2 chainPre
+ chainPost = Sym.lift2 chainPost
+instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
+instance CombMatchable repr => CombMatchable (FinalizeSharing TH.Name repr) where
conditional a cs bs b = FinalizeSharing $
conditional
Functor.<$> unFinalizeSharing a
Functor.<*> Functor.pure cs
Functor.<*> mapM unFinalizeSharing bs
Functor.<*> unFinalizeSharing b
-instance Lookable repr => Lookable (FinalizeSharing TH.Name repr)
-instance Foldable repr => Foldable (FinalizeSharing TH.Name repr) where
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+instance CombSatisfiable tok repr => CombSatisfiable tok (FinalizeSharing TH.Name repr)
+instance CombSelectable repr => CombSelectable (FinalizeSharing TH.Name repr)
+instance CombThrowable repr => CombThrowable (FinalizeSharing TH.Name repr)
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
import Data.Function ((.))
+import Data.Kind (Constraint, Type)
import Data.Maybe (Maybe(..))
+import Data.Proxy (Proxy(..))
+import GHC.TypeLits (KnownSymbol)
+import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
+import qualified Data.Foldable as CombFoldable
import qualified Data.Functor as Functor
-import qualified Data.Foldable as Foldable
import qualified Data.List as List
-import Data.Kind (Constraint, Type)
-import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
import Symantic.Parser.Grammar.Combinators as Comb
import Symantic.Parser.Haskell ()
Just HRefl -> Just c
Nothing -> Nothing
--- Applicable
-data instance Comb Applicable repr a where
- Pure :: TermGrammar a -> Comb Applicable repr a
- (:<*>:) :: SomeComb repr (a -> b) -> SomeComb repr a -> Comb Applicable repr b
- (:<*:) :: SomeComb repr a -> SomeComb repr b -> Comb Applicable repr a
- (:*>:) :: SomeComb repr a -> SomeComb repr b -> Comb Applicable repr b
+-- CombAlternable
+data instance Comb CombAlternable repr a where
+ Empty :: Comb CombAlternable repr a
+ (:<|>:) :: SomeComb repr a -> SomeComb repr a -> Comb CombAlternable repr a
+ Try :: SomeComb repr a -> Comb CombAlternable repr a
+infixl 3 :<|>:
+instance CombAlternable repr => Trans (Comb CombAlternable repr) repr where
+ trans = \case
+ Empty -> empty
+ f :<|>: x -> trans f <|> trans x
+ Try x -> try (trans x)
+instance
+ ( CombAlternable repr
+ , CombApplicable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSelectable repr
+ ) => CombAlternable (SomeComb repr) where
+ empty = SomeComb Empty
+
+ p@(Comb Pure{}) <|> _ = p
+ -- & trace "Left Catch Law"
+ Comb Empty <|> u = u
+ -- & trace "Left Neutral Law"
+ u <|> Comb Empty = u
+ -- & trace "Right Neutral Law"
+ Comb (u :<|>: v) <|> w = u <|> (v <|> w)
+ -- & trace "Associativity Law"
+ Comb (Look p) <|> Comb (Look q) = look (try p <|> q)
+ -- & trace "Distributivity Law"
+ x <|> y = SomeComb (x :<|>: y)
+
+ try (Comb (p :$>: x)) = try p $> x
+ -- & trace "Try Interchange Law"
+ try (Comb (f :<$>: p)) = f <$> try p
+ -- & trace "Try Interchange Law"
+ try x = SomeComb (Try x)
+
+-- CombApplicable
+data instance Comb CombApplicable repr a where
+ Pure :: TermGrammar a -> Comb CombApplicable repr a
+ (:<*>:) :: SomeComb repr (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
+ (:<*:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr a
+ (:*>:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr b
infixl 4 :<*>:, :<*:, :*>:
-pattern (:<$>:) :: TermGrammar (a -> b) -> SomeComb repr a -> Comb Applicable repr b
+pattern (:<$>:) :: TermGrammar (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
pattern t :<$>: x <- Comb (Pure t) :<*>: x
-pattern (:$>:) :: SomeComb repr a -> TermGrammar b -> Comb Applicable repr b
+pattern (:$>:) :: SomeComb repr a -> TermGrammar b -> Comb CombApplicable repr b
pattern x :$>: t <- x :*>: Comb (Pure t)
-instance Applicable repr => Trans (Comb Applicable repr) repr where
+instance CombApplicable repr => Trans (Comb CombApplicable repr) repr where
trans = \case
Pure x -> pure (H.optimizeTerm x)
f :<*>: x -> trans f <*> trans x
x :<*: y -> trans x <* trans y
x :*>: y -> trans x *> trans y
instance
- ( Applicable repr
- , Alternable repr
- , Lookable repr
- , Matchable repr
- , Selectable repr
- ) => Applicable (SomeComb repr) where
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombMatchable repr
+ , CombSelectable repr
+ ) => CombApplicable (SomeComb repr) where
pure = SomeComb . Pure
f <$> Comb (Branch b l r) =
branch b
-- & trace "Associativity Law"
x <* y = SomeComb (x :<*: y)
--- Alternable
-data instance Comb Alternable repr a where
- Empty :: Comb Alternable repr a
- (:<|>:) :: SomeComb repr a -> SomeComb repr a -> Comb Alternable repr a
- Try :: SomeComb repr a -> Comb Alternable repr a
-infixl 3 :<|>:
-instance Alternable repr => Trans (Comb Alternable repr) repr where
+-- CombFoldable
+data instance Comb CombFoldable repr a where
+ ChainPreC :: SomeComb repr (a -> a) -> SomeComb repr a -> Comb CombFoldable repr a
+ ChainPostC :: SomeComb repr a -> SomeComb repr (a -> a) -> Comb CombFoldable repr a
+instance CombFoldable repr => Trans (Comb CombFoldable repr) repr where
trans = \case
- Empty -> empty
- f :<|>: x -> trans f <|> trans x
- Try x -> try (trans x)
-instance
- ( Alternable repr
- , Applicable repr
- , Lookable repr
- , Matchable repr
- , Selectable repr
- ) => Alternable (SomeComb repr) where
- empty = SomeComb Empty
-
- p@(Comb Pure{}) <|> _ = p
- -- & trace "Left Catch Law"
- Comb Empty <|> u = u
- -- & trace "Left Neutral Law"
- u <|> Comb Empty = u
- -- & trace "Right Neutral Law"
- Comb (u :<|>: v) <|> w = u <|> (v <|> w)
- -- & trace "Associativity Law"
- Comb (Look p) <|> Comb (Look q) = look (try p <|> q)
- -- & trace "Distributivity Law"
- x <|> y = SomeComb (x :<|>: y)
-
- try (Comb (p :$>: x)) = try p $> x
- -- & trace "Try Interchange Law"
- try (Comb (f :<$>: p)) = f <$> try p
- -- & trace "Try Interchange Law"
- try x = SomeComb (Try x)
+ ChainPreC x y -> chainPre (trans x) (trans y)
+ ChainPostC x y -> chainPost (trans x) (trans y)
+instance CombFoldable repr => CombFoldable (SomeComb repr) where
+ chainPre x = SomeComb . ChainPreC x
+ chainPost x = SomeComb . ChainPostC x
--- Selectable
-data instance Comb Selectable repr a where
- Branch ::
- SomeComb repr (Either a b) ->
- SomeComb repr (a -> c) ->
- SomeComb repr (b -> c) ->
- Comb Selectable repr c
-instance Selectable repr => Trans (Comb Selectable repr) repr where
- trans = \case
- Branch lr l r -> branch (trans lr) (trans l) (trans r)
+-- Letable
+data instance Comb (Letable letName) repr a where
+ Shareable :: letName -> SomeComb repr a -> Comb (Letable letName) repr a
+ Ref :: Bool -> letName -> Comb (Letable letName) repr a
instance
- ( Applicable repr
- , Alternable repr
- , Lookable repr
- , Selectable repr
- , Matchable repr
- ) => Selectable (SomeComb repr) where
- branch (Comb Empty) _ _ = empty
- -- & trace "Branch Absorption Law"
- branch b (Comb Empty) (Comb Empty) = b *> empty
- -- & trace "Branch Weakening Law"
- branch (Comb (Pure (trans -> lr))) l r =
- case H.value lr of
- Left value -> l <*> pure (trans H.ValueCode{..})
- where code = [|| case $$(H.code lr) of Left x -> x ||]
- Right value -> r <*> pure (trans H.ValueCode{..})
- where code = [|| case $$(H.code lr) of Right x -> x ||]
- -- & trace "Branch Pure Left/Right Law"
- branch b (Comb (Pure (trans -> l))) (Comb (Pure (trans -> r))) =
- trans H.ValueCode{..} <$> b
- -- & trace "Branch Generalised Identity Law"
- where
- value = either (H.value l) (H.value r)
- code = [|| either $$(H.code l) $$(H.code r) ||]
- branch (Comb (x :*>: y)) p q = x *> branch y p q
- -- & trace "Interchange Law"
- branch b l (Comb Empty) =
- branch (pure (trans (H.ValueCode{..})) <*> b) empty l
- -- & trace "Negated Branch Law"
- where
- value = either Right Left
- code = [||either Right Left||]
- branch (Comb (Branch b (Comb Empty) (Comb (Pure (trans -> lr))))) (Comb Empty) br =
- branch (pure (trans H.ValueCode{..}) <*> b) empty br
- -- & trace "Branch Fusion Law"
- where
- value Left{} = Left ()
- value (Right r) = case H.value lr r of
- Left _ -> Left ()
- Right rr -> Right rr
- code = [|| \case Left{} -> Left ()
- Right r -> case $$(H.code lr) r of
- Left _ -> Left ()
- Right rr -> Right rr ||]
- branch b l r = SomeComb (Branch b l r)
-
--- Matchable
-data instance Comb Matchable repr a where
- Conditional :: Eq a =>
- SomeComb repr a ->
- [TermGrammar (a -> Bool)] ->
- [SomeComb repr b] ->
- SomeComb repr b ->
- Comb Matchable repr b
-instance Matchable repr => Trans (Comb Matchable repr) repr where
+ Letable letName repr =>
+ Trans (Comb (Letable letName) repr) repr where
trans = \case
- Conditional a ps bs b ->
- conditional (trans a)
- (H.optimizeTerm Functor.<$> ps)
- (trans Functor.<$> bs) (trans b)
+ Shareable n x -> shareable n (trans x)
+ Ref isRec n -> ref isRec n
instance
- ( Applicable repr
- , Alternable repr
- , Lookable repr
- , Selectable repr
- , Matchable repr
- ) => Matchable (SomeComb repr) where
- conditional (Comb Empty) _ _ d = d
- -- & trace "Conditional Absorption Law"
- conditional p _ qs (Comb Empty)
- | Foldable.all (\case { Comb Empty -> True; _ -> False }) qs = p *> empty
- -- & trace "Conditional Weakening Law"
- conditional a _ps bs (Comb Empty)
- | Foldable.all (\case { Comb Empty -> True; _ -> False }) bs = a *> empty
- -- & trace "Conditional Weakening Law"
- conditional (Comb (Pure (trans -> a))) ps bs d =
- Foldable.foldr (\(trans -> p, b) next ->
- if H.value p (H.value a) then b else next
- ) d (List.zip ps bs)
- -- & trace "Conditional Pure Law"
- conditional a ps bs d = SomeComb (Conditional a ps bs d)
+ (Letable letName repr, Typeable letName) =>
+ Letable letName (SomeComb repr) where
+ shareable n = SomeComb . Shareable n
+ ref isRec = SomeComb . Ref isRec
--- Foldable
-data instance Comb Foldable repr a where
- ChainPreC :: SomeComb repr (a -> a) -> SomeComb repr a -> Comb Foldable repr a
- ChainPostC :: SomeComb repr a -> SomeComb repr (a -> a) -> Comb Foldable repr a
-instance Foldable repr => Trans (Comb Foldable repr) repr where
+-- Letsable
+data instance Comb (Letsable letName) repr a where
+ Lets :: LetBindings letName (SomeComb repr) ->
+ SomeComb repr a -> Comb (Letsable letName) repr a
+instance
+ Letsable letName repr =>
+ Trans (Comb (Letsable letName) repr) repr where
trans = \case
- ChainPreC x y -> chainPre (trans x) (trans y)
- ChainPostC x y -> chainPost (trans x) (trans y)
-instance Foldable repr => Foldable (SomeComb repr) where
- chainPre x = SomeComb . ChainPreC x
- chainPost x = SomeComb . ChainPostC x
+ Lets defs x -> lets ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> defs) (trans x)
+instance
+ (Letsable letName repr, Typeable letName) =>
+ Letsable letName (SomeComb repr) where
+ lets defs = SomeComb . Lets defs
--- Lookable
-data instance Comb Lookable repr a where
- Look :: SomeComb repr a -> Comb Lookable repr a
- NegLook :: SomeComb repr a -> Comb Lookable repr ()
- Eof :: Comb Lookable repr ()
-instance Lookable repr => Trans (Comb Lookable repr) repr where
+-- CombLookable
+data instance Comb CombLookable repr a where
+ Look :: SomeComb repr a -> Comb CombLookable repr a
+ NegLook :: SomeComb repr a -> Comb CombLookable repr ()
+ Eof :: Comb CombLookable repr ()
+instance CombLookable repr => Trans (Comb CombLookable repr) repr where
trans = \case
Look x -> look (trans x)
NegLook x -> negLook (trans x)
Eof -> eof
instance
- ( Alternable repr
- , Applicable repr
- , Lookable repr
- , Selectable repr
- , Matchable repr
- ) => Lookable (SomeComb repr) where
+ ( CombAlternable repr
+ , CombApplicable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ ) => CombLookable (SomeComb repr) where
look p@(Comb Pure{}) = p
-- & trace "Pure Look Law"
look p@(Comb Empty) = p
eof = SomeComb Eof
--- Satisfiable
-data instance Comb (Satisfiable tok) repr a where
+-- CombMatchable
+data instance Comb CombMatchable repr a where
+ Conditional :: Eq a =>
+ SomeComb repr a ->
+ [TermGrammar (a -> Bool)] ->
+ [SomeComb repr b] ->
+ SomeComb repr b ->
+ Comb CombMatchable repr b
+instance CombMatchable repr => Trans (Comb CombMatchable repr) repr where
+ trans = \case
+ Conditional a ps bs b ->
+ conditional (trans a)
+ (H.optimizeTerm Functor.<$> ps)
+ (trans Functor.<$> bs) (trans b)
+instance
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ ) => CombMatchable (SomeComb repr) where
+ conditional (Comb Empty) _ _ d = d
+ -- & trace "Conditional Absorption Law"
+ conditional p _ qs (Comb Empty)
+ | CombFoldable.all (\case { Comb Empty -> True; _ -> False }) qs = p *> empty
+ -- & trace "Conditional Weakening Law"
+ conditional a _ps bs (Comb Empty)
+ | CombFoldable.all (\case { Comb Empty -> True; _ -> False }) bs = a *> empty
+ -- & trace "Conditional Weakening Law"
+ conditional (Comb (Pure (trans -> a))) ps bs d =
+ CombFoldable.foldr (\(trans -> p, b) next ->
+ if H.value p (H.value a) then b else next
+ ) d (List.zip ps bs)
+ -- & trace "Conditional Pure Law"
+ conditional a ps bs d = SomeComb (Conditional a ps bs d)
+
+-- CombSatisfiable
+data instance Comb (CombSatisfiable tok) repr a where
Satisfy ::
- Satisfiable tok repr =>
+ CombSatisfiable tok repr =>
[ErrorItem tok] ->
TermGrammar (tok -> Bool) ->
- Comb (Satisfiable tok) repr tok
+ Comb (CombSatisfiable tok) repr tok
Item ::
- Satisfiable tok repr =>
- Comb (Satisfiable tok) repr tok
-instance Satisfiable tok repr => Trans (Comb (Satisfiable tok) repr) repr where
+ CombSatisfiable tok repr =>
+ Comb (CombSatisfiable tok) repr tok
+instance CombSatisfiable tok repr => Trans (Comb (CombSatisfiable tok) repr) repr where
trans = \case
Satisfy es p -> satisfy es (H.optimizeTerm p)
Item -> item
instance
- (Satisfiable tok repr, Typeable tok) =>
- Satisfiable tok (SomeComb repr) where
+ (CombSatisfiable tok repr, Typeable tok) =>
+ CombSatisfiable tok (SomeComb repr) where
satisfy es = SomeComb . Satisfy es
item = SomeComb Item
--- Letable
-data instance Comb (Letable letName) repr a where
- Shareable :: letName -> SomeComb repr a -> Comb (Letable letName) repr a
- Ref :: Bool -> letName -> Comb (Letable letName) repr a
-instance
- Letable letName repr =>
- Trans (Comb (Letable letName) repr) repr where
+-- CombSelectable
+data instance Comb CombSelectable repr a where
+ Branch ::
+ SomeComb repr (Either a b) ->
+ SomeComb repr (a -> c) ->
+ SomeComb repr (b -> c) ->
+ Comb CombSelectable repr c
+instance CombSelectable repr => Trans (Comb CombSelectable repr) repr where
trans = \case
- Shareable n x -> shareable n (trans x)
- Ref isRec n -> ref isRec n
+ Branch lr l r -> branch (trans lr) (trans l) (trans r)
instance
- (Letable letName repr, Typeable letName) =>
- Letable letName (SomeComb repr) where
- shareable n = SomeComb . Shareable n
- ref isRec = SomeComb . Ref isRec
+ ( CombApplicable repr
+ , CombAlternable repr
+ , CombLookable repr
+ , CombSelectable repr
+ , CombMatchable repr
+ ) => CombSelectable (SomeComb repr) where
+ branch (Comb Empty) _ _ = empty
+ -- & trace "Branch Absorption Law"
+ branch b (Comb Empty) (Comb Empty) = b *> empty
+ -- & trace "Branch Weakening Law"
+ branch (Comb (Pure (trans -> lr))) l r =
+ case H.value lr of
+ Left value -> l <*> pure (trans H.ValueCode{..})
+ where code = [|| case $$(H.code lr) of Left x -> x ||]
+ Right value -> r <*> pure (trans H.ValueCode{..})
+ where code = [|| case $$(H.code lr) of Right x -> x ||]
+ -- & trace "Branch Pure Left/Right Law"
+ branch b (Comb (Pure (trans -> l))) (Comb (Pure (trans -> r))) =
+ trans H.ValueCode{..} <$> b
+ -- & trace "Branch Generalised Identity Law"
+ where
+ value = either (H.value l) (H.value r)
+ code = [|| either $$(H.code l) $$(H.code r) ||]
+ branch (Comb (x :*>: y)) p q = x *> branch y p q
+ -- & trace "Interchange Law"
+ branch b l (Comb Empty) =
+ branch (pure (trans (H.ValueCode{..})) <*> b) empty l
+ -- & trace "Negated Branch Law"
+ where
+ value = either Right Left
+ code = [||either Right Left||]
+ branch (Comb (Branch b (Comb Empty) (Comb (Pure (trans -> lr))))) (Comb Empty) br =
+ branch (pure (trans H.ValueCode{..}) <*> b) empty br
+ -- & trace "Branch Fusion Law"
+ where
+ value Left{} = Left ()
+ value (Right r) = case H.value lr r of
+ Left _ -> Left ()
+ Right rr -> Right rr
+ code = [|| \case Left{} -> Left ()
+ Right r -> case $$(H.code lr) r of
+ Left _ -> Left ()
+ Right rr -> Right rr ||]
+ branch b l r = SomeComb (Branch b l r)
--- Letsable
-data instance Comb (Letsable letName) repr a where
- Lets :: LetBindings letName (SomeComb repr) ->
- SomeComb repr a -> Comb (Letsable letName) repr a
-instance
- Letsable letName repr =>
- Trans (Comb (Letsable letName) repr) repr where
+-- CombThrowable
+data instance Comb CombThrowable repr a where
+ Throw ::
+ KnownSymbol lbl => Proxy lbl ->
+ Comb CombThrowable repr a
+instance CombThrowable repr => Trans (Comb CombThrowable repr) repr where
trans = \case
- Lets defs x -> lets ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> defs) (trans x)
-instance
- (Letsable letName repr, Typeable letName) =>
- Letsable letName (SomeComb repr) where
- lets defs = SomeComb . Lets defs
+ Throw lbl -> throw lbl
+instance CombThrowable repr => CombThrowable (SomeComb repr) where
+ throw lbl = SomeComb (Throw lbl)
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tuple (fst)
+import GHC.TypeLits (symbolVal)
import Text.Show (Show(..))
import qualified Control.Applicative as Fct
import qualified Data.Functor as Functor
drawTrees (t:ts) = shift "+ " "| " (draw t) <> drawTrees ts
shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind)
+instance CombAlternable (ViewGrammar sN) where
+ empty = ViewGrammar $ Tree.Node ("empty", "") []
+ x <|> y = ViewGrammar $ Tree.Node ("<|>", "") [unViewGrammar x, unViewGrammar y]
+ try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
+instance CombApplicable (ViewGrammar sN) where
+ _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
+ pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "", "") []
+ x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
+ x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
+ x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
+instance CombFoldable (ViewGrammar sN) where
+ chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
+ chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
instance
ShowLetName sN letName =>
Letable letName (ViewGrammar sN) where
(\name (SomeLet val) ->
(Tree.Node ("let", " "<>showLetName @sN name) [unViewGrammar val] :))
[] defs
-instance Applicable (ViewGrammar sN) where
- _f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
- pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "", "") []
- x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
- x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
- x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
-instance Alternable (ViewGrammar sN) where
- empty = ViewGrammar $ Tree.Node ("empty", "") []
- x <|> y = ViewGrammar $ Tree.Node ("<|>", "") [unViewGrammar x, unViewGrammar y]
- try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
-instance Satisfiable tok (ViewGrammar sN) where
- satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
-instance Selectable (ViewGrammar sN) where
- branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
- [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
-instance Matchable (ViewGrammar sN) where
+instance CombLookable (ViewGrammar sN) where
+ look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
+ negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
+ eof = ViewGrammar $ Tree.Node ("eof", "") []
+instance CombMatchable (ViewGrammar sN) where
conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
[ unViewGrammar a
, Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
, unViewGrammar b
]
-instance Lookable (ViewGrammar sN) where
- look x = ViewGrammar $ Tree.Node ("look", "") [unViewGrammar x]
- negLook x = ViewGrammar $ Tree.Node ("negLook", "") [unViewGrammar x]
- eof = ViewGrammar $ Tree.Node ("eof", "") []
-instance Foldable (ViewGrammar sN) where
- chainPre f x = ViewGrammar $ Tree.Node ("chainPre", "") [unViewGrammar f, unViewGrammar x]
- chainPost x f = ViewGrammar $ Tree.Node ("chainPost", "") [unViewGrammar x, unViewGrammar f]
+instance CombSatisfiable tok (ViewGrammar sN) where
+ satisfy _es _p = ViewGrammar $ Tree.Node ("satisfy", "") []
+instance CombSelectable (ViewGrammar sN) where
+ branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
+ [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
+instance CombThrowable (ViewGrammar sN) where
+ throw lbl = ViewGrammar $ Tree.Node ("throw "<>symbolVal lbl, "") []
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
-import qualified Data.Functor as Pre
+import GHC.TypeLits (symbolVal)
+import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
else s
where (o,c) = writeGrammarInh_pair inh
-instance
- ShowLetName sN letName =>
- Letable letName (WriteGrammar sN) where
- shareable name x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "shareable "
- <> Just (fromString (showLetName @sN name))
- <> unWriteGrammar x inh
- where
- op = infixN 9
- ref rec name = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just (if rec then "rec " else "ref ") <>
- Just (fromString (showLetName @sN name))
- where
- op = infixN 9
-instance
- ShowLetName sN letName =>
- Letsable letName (WriteGrammar sN) where
- lets defs x = WriteGrammar $ \inh ->
- pairWriteGrammarInh inh op $
- Just "let "
- <> HM.foldMapWithKey
- (\name (SomeLet val) ->
- Just (fromString (showLetName @sN name))
- <> unWriteGrammar val inh)
- defs
- <> unWriteGrammar x inh
- where
- op = infixN 9
-instance Applicable (WriteGrammar sN) where
+instance CombApplicable (WriteGrammar sN) where
pure _ = WriteGrammar $ return Nothing
-- pure _ = "pure"
WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
Just $ xt <> ", " <> yt
where
op = infixN 1
-instance Alternable (WriteGrammar sN) where
+instance CombAlternable (WriteGrammar sN) where
empty = "empty"
try x = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
, writeGrammarInh_pair = pairParen
}
where op = infixB SideL 3
-instance Satisfiable tok (WriteGrammar sN) where
- satisfy _es _f = "satisfy"
-instance Selectable (WriteGrammar sN) where
- branch lr l r = WriteGrammar $ \inh ->
+instance CombFoldable (WriteGrammar sN) where
+ chainPre f x = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
- Just "branch " <>
- unWriteGrammar lr inh <> Just " " <>
- unWriteGrammar l inh <> Just " " <>
- unWriteGrammar r inh
+ Just "chainPre " <>
+ unWriteGrammar f inh <> Just " " <>
+ unWriteGrammar x inh
+ where op = infixN 9
+ chainPost f x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "chainPost " <>
+ unWriteGrammar f inh <> Just " " <>
+ unWriteGrammar x inh
+ where op = infixN 9
+instance
+ ShowLetName sN letName =>
+ Letable letName (WriteGrammar sN) where
+ shareable name x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "shareable "
+ <> Just (fromString (showLetName @sN name))
+ <> unWriteGrammar x inh
where
op = infixN 9
-instance Matchable (WriteGrammar sN) where
- conditional a _ps bs d = WriteGrammar $ \inh ->
+ ref rec name = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
- Just "conditional " <>
- unWriteGrammar a inh <>
- Just " [" <>
- Just (mconcat (List.intersperse ", " $
- catMaybes $ (Pre.<$> bs) $ \x ->
- unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
- Just "] " <>
- unWriteGrammar d inh
+ Just (if rec then "rec " else "ref ") <>
+ Just (fromString (showLetName @sN name))
+ where
+ op = infixN 9
+instance
+ ShowLetName sN letName =>
+ Letsable letName (WriteGrammar sN) where
+ lets defs x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "let "
+ <> HM.foldMapWithKey
+ (\name (SomeLet val) ->
+ Just (fromString (showLetName @sN name))
+ <> unWriteGrammar val inh)
+ defs
+ <> unWriteGrammar x inh
where
op = infixN 9
-instance Lookable (WriteGrammar sN) where
+instance CombLookable (WriteGrammar sN) where
look x = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
Just "look " <> unWriteGrammar x inh
Just "negLook " <> unWriteGrammar x inh
where op = infixN 9
eof = "eof"
-instance Foldable (WriteGrammar sN) where
- chainPre f x = WriteGrammar $ \inh ->
+instance CombMatchable (WriteGrammar sN) where
+ conditional a _ps bs d = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
- Just "chainPre " <>
- unWriteGrammar f inh <> Just " " <>
- unWriteGrammar x inh
- where op = infixN 9
- chainPost f x = WriteGrammar $ \inh ->
+ Just "conditional " <>
+ unWriteGrammar a inh <>
+ Just " [" <>
+ Just (mconcat (List.intersperse ", " $
+ catMaybes $ (Functor.<$> bs) $ \x ->
+ unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
+ Just "] " <>
+ unWriteGrammar d inh
+ where
+ op = infixN 9
+instance CombSatisfiable tok (WriteGrammar sN) where
+ satisfy _es _f = "satisfy"
+instance CombSelectable (WriteGrammar sN) where
+ branch lr l r = WriteGrammar $ \inh ->
pairWriteGrammarInh inh op $
- Just "chainPost " <>
- unWriteGrammar f inh <> Just " " <>
- unWriteGrammar x inh
- where op = infixN 9
+ Just "branch " <>
+ unWriteGrammar lr inh <> Just " " <>
+ unWriteGrammar l inh <> Just " " <>
+ unWriteGrammar r inh
+ where
+ op = infixN 9
+instance CombThrowable (WriteGrammar sN) where
+ throw lbl = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just ("throw "<>fromString (symbolVal lbl))
+ where
+ op = infixN 9
IO (repr inp '[] a)
optimizeMachine (Program f) = trans Functor.<$> f @'[] ret
-instance
- InstrValuable repr =>
- Applicable (Program repr inp) where
- pure x = Program $ return . pushValue (trans x)
- Program f <*> Program x = Program $ (f <=< x) . applyValue
- liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
- Program x *> Program y = Program (x <=< return . popValue <=< y)
- Program x <* Program y = Program (x <=< y <=< return . popValue)
instance
( Cursorable (Cursor inp)
, InstrBranchable repr
, InstrInputable repr
, InstrJoinable repr
, InstrValuable repr
- ) => Alternable (Program repr inp) where
+ ) => CombAlternable (Program repr inp) where
empty = Program $ \_next -> return $ fail []
Program l <|> Program r = joinNext $ Program $ \next ->
liftM2 (catchException (Proxy @"fail"))
Functor.<$> m (refJoin (LetName joinName))
instance
- InstrExceptionable repr =>
- Throwable (Program repr inp) where
- type ThrowableLabel (Program repr inp) lbl =
- ()
- throw lbl = Program $ \_next -> return $ raiseException lbl []
-instance
- ( tok ~ InputToken inp
- , InstrReadable tok repr
- , Typeable tok
- ) => Satisfiable tok (Program repr inp) where
- satisfy es p = Program $ return . read es (trans p)
+ InstrValuable repr =>
+ CombApplicable (Program repr inp) where
+ pure x = Program $ return . pushValue (trans x)
+ Program f <*> Program x = Program $ (f <=< x) . applyValue
+ liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
+ Program x *> Program y = Program (x <=< return . popValue <=< y)
+ Program x <* Program y = Program (x <=< y <=< return . popValue)
instance
- ( InstrBranchable repr
+ ( Cursorable (Cursor inp)
+ , InstrBranchable repr
+ , InstrExceptionable repr
+ , InstrInputable repr
, InstrJoinable repr
, InstrValuable repr
- ) => Selectable (Program repr inp) where
- branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
- lr =<< liftM2 caseBranch
- (l (swapValue (applyValue next)))
- (r (swapValue (applyValue next)))
+ ) => CombFoldable (Program repr inp) where
+ {-
+ 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
+ -}
instance
- ( InstrBranchable repr
- , InstrJoinable repr
- ) => Matchable (Program repr inp) where
- conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
- bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
- a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
+ InstrCallable repr =>
+ Letable TH.Name (Program repr inp) where
+ shareable n (Program sub) = Program $ \next -> do
+ sub' <- sub ret
+ return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
+ ref _isRec n = Program $ \case
+ -- Returning just after a 'call' is useless:
+ -- using 'jump' lets the 'ret' of the 'defLet'
+ -- directly return where it would in two 'ret's.
+ Instr Ret{} -> return $ jump (LetName n)
+ next -> return $ call (LetName n) next
+instance
+ InstrCallable repr =>
+ Letsable TH.Name (Program repr inp) where
+ lets defs (Program x) = Program $ \next -> do
+ defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
+ liftM (defLet defs') (x next)
instance
( Ord (InputToken inp)
, Cursorable (Cursor inp)
, InstrReadable (InputToken inp) repr
, Typeable (InputToken inp)
, InstrValuable repr
- ) => Lookable (Program repr inp) where
+ ) => CombLookable (Program repr inp) where
look (Program x) = Program $ \next ->
liftM pushInput (x (swapValue (loadInput next)))
eof = negLook (satisfy [{-discarded by negLook-}] (H.lam1 (\_x -> H.bool True)))
-- and go on with the next 'Instr'uctions.
(return $ loadInput $ pushValue H.unit next)
instance
- InstrCallable repr =>
- Letable TH.Name (Program repr inp) where
- shareable n (Program sub) = Program $ \next -> do
- sub' <- sub ret
- return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
- ref _isRec n = Program $ \case
- -- Returning just after a 'call' is useless:
- -- using 'jump' lets the 'ret' of the 'defLet'
- -- directly return where it would in two 'ret's.
- Instr Ret{} -> return $ jump (LetName n)
- next -> return $ call (LetName n) next
+ ( InstrBranchable repr
+ , InstrJoinable repr
+ ) => CombMatchable (Program repr inp) where
+ conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
+ bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
+ a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
instance
- InstrCallable repr =>
- Letsable TH.Name (Program repr inp) where
- lets defs (Program x) = Program $ \next -> do
- defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
- liftM (defLet defs') (x next)
+ ( tok ~ InputToken inp
+ , InstrReadable tok repr
+ , Typeable tok
+ ) => CombSatisfiable tok (Program repr inp) where
+ satisfy es p = Program $ return . read es (trans p)
instance
- ( Cursorable (Cursor inp)
- , InstrBranchable repr
- , InstrExceptionable repr
- , InstrInputable repr
+ ( InstrBranchable repr
, InstrJoinable repr
, InstrValuable repr
- ) => Foldable (Program repr inp) where
- {-
- 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
- -}
+ ) => CombSelectable (Program repr inp) where
+ branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
+ lr =<< liftM2 caseBranch
+ (l (swapValue (applyValue next)))
+ (r (swapValue (applyValue next)))
+instance
+ InstrExceptionable repr =>
+ CombThrowable (Program repr inp) where
+ throw lbl = Program $ \_next -> return $ raiseException lbl []
import Symantic.Parser
import qualified Symantic.Parser.Haskell as H
-boom :: Applicable repr => repr ()
+boom :: CombApplicable repr => repr ()
boom =
let foo = (-- newRegister_ unit (\r0 ->
let goo = (-- newRegister_ unit (\r1 ->
sourcephile / git / haskell / symantic-parser.git / commitdiff