+-- 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,
+-- 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
+-- of the type class. This is almost as explained in:
+-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
--- The default type signature of type class methods are changed to introduce a Liftable constraint and the same type class but on the 'Unlift' 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 of the type class. This is almost as explained in: https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
+{-# LANGUAGE DeriveLift #-} -- For TH.Lift (ErrorItem tok)
+{-# LANGUAGE StandaloneDeriving #-} -- For Show (ErrorItem (InputToken inp))
{-# LANGUAGE TemplateHaskell #-}
+-- | Semantic of the grammar combinators used to express parsers,
+-- in the convenient tagless-final encoding.
module Symantic.Parser.Grammar.Combinators where
import Data.Bool (Bool(..), not, (||))
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 Language.Haskell.TH (TExpQ)
+import GHC.TypeLits (KnownSymbol, Symbol)
+import Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
+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.Staging as Hask
+import qualified Symantic.Parser.Haskell as H
+
+-- * Type 'TermGrammar'
+type TermGrammar = H.Term H.ValueCode
-- * Class 'Applicable'
--- | This is like the usual 'Functor' and 'Applicative' type classes from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@ to be able to use and pattern match on some usual terms of type @(a)@ (like 'Hask.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.
+-- | 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')
+-- 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
-- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
- (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
+ (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
-- | Like '<$>' but with its arguments 'flip'-ped.
- (<&>) :: repr a -> Hask.Haskell (a -> b) -> repr b
+ (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
(<&>) = flip (<$>)
-- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
- (<$) :: Hask.Haskell a -> repr b -> repr a
+ (<$) :: TermGrammar 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 -> Hask.Haskell b -> repr b
+ ($>) :: repr a -> TermGrammar b -> repr b
($>) = flip (<$)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
- pure :: Hask.Haskell a -> repr a
+ pure :: TermGrammar a -> repr a
default pure ::
- Sym.Liftable repr => Applicable (Sym.Unlift repr) =>
- Hask.Haskell a -> repr a
+ Sym.Liftable repr => Applicable (Sym.Output repr) =>
+ TermGrammar a -> repr a
pure = Sym.lift . 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)@.
+ -- | @(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.Unlift repr) =>
+ Sym.Liftable2 repr => Applicable (Sym.Output 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 :: Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
+ -- | @('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)
- -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(ra)@, discarding the return value of @(rb)@.
+ -- | @(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 Hask.const
+ (<*) = liftA2 H.const
- -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(rb)@, discarding the return value of @(ra)@.
+ -- | @(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 = (Hask.id <$ x) <*> y
+ x *> y = (H.id <$ x) <*> y
-- | Like '<*>' but with its arguments 'flip'-ped.
(<**>) :: repr a -> repr (a -> b) -> repr b
- (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
+ (<**>) = liftA2 (H.flip H..@ (H.$))
{-
(<**>) :: repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (\a f -> f a)
-- * 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.
+ -- | @(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.
+ -- | @('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.Unlift repr) =>
+ Sym.Liftable2 repr => Alternable (Sym.Output repr) =>
repr a -> repr a -> repr a
default empty ::
- Sym.Liftable repr => Alternable (Sym.Unlift repr) =>
+ Sym.Liftable repr => Alternable (Sym.Output repr) =>
repr a
default try ::
- Sym.Liftable1 repr => Alternable (Sym.Unlift repr) =>
+ 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.
+ -- | 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 = Hask.left <$> p <|> Hask.right <$> q
+ p <+> q = H.left <$> p <|> H.right <$> q
infixl 3 <|>, <+>
-optionally :: Applicable repr => Alternable repr => repr a -> Hask.Haskell b -> repr b
+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 Hask.unit
+optional = flip optionally H.unit
-option :: Applicable repr => Alternable repr => Hask.Haskell a -> repr a -> repr a
+option :: Applicable repr => Alternable repr => TermGrammar a -> repr a -> repr a
option x p = p <|> pure x
choice :: Alternable repr => [repr a] -> repr a
-- but at this point there is no asum for our own (<|>)
maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
-maybeP p = option Hask.nothing (Hask.just <$> p)
+maybeP p = option H.nothing (H.just <$> p)
manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
-manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
+manyTill p end = let go = end $> H.nil <|> p <:> go in go
-- * 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.Unlift repr) =>
+ Sym.Liftable3 repr => Selectable (Sym.Output repr) =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
branch = Sym.lift3 branch
-- * Class 'Matchable'
class Matchable repr where
conditional ::
- Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
+ Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
default conditional ::
- Sym.Unliftable repr => Sym.Liftable2 repr => Matchable (Sym.Unlift repr) =>
- Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
- conditional cs bs = Sym.lift2 (conditional cs (Sym.trans Functor.<$> bs))
+ 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))
- match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
- match as a a2b = conditional (Hask.eq Functor.<$> as) (a2b Functor.<$> as) a
+ 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 'Foldable'
class Foldable 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.Unlift repr) =>
+ Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Sym.Liftable2 repr => Foldable (Sym.Unlift repr) =>
+ Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
repr a -> repr (a -> a) -> repr a
chainPre = Sym.lift2 chainPre
chainPost = Sym.lift2 chainPost
+ -}
+ default chainPre ::
+ Applicable repr =>
+ Alternable repr =>
+ repr (a -> a) -> repr a -> repr a
+ default chainPost ::
+ Applicable repr =>
+ Alternable 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 => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: Selectable 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 'Charable'
-class Charable repr where
- satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
+-- * Class 'Satisfiable'
+class Satisfiable tok repr where
+ satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
default satisfy ::
- Sym.Liftable repr => Charable (Sym.Unlift repr) =>
- Hask.Haskell (Char -> Bool) -> repr Char
- satisfy = Sym.lift . 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.Unlift repr) => repr a -> repr a
- default negLook :: Sym.Liftable1 repr => Lookable (Sym.Unlift repr) => 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 Hask.cons
+(<:>) = liftA2 H.cons
sequence :: Applicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure Hask.nil)
+sequence = List.foldr (<:>) (pure H.nil)
traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f
between :: Applicable repr => repr o -> repr c -> repr a -> repr a
between open close p = open *> p <* close
-string :: Applicable repr => Charable repr => String -> repr String
-string = traverse char
-
--- oneOf :: [Char] -> repr Char
--- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
-
-noneOf :: Charable repr => String -> repr Char
-noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
- where
- value = Hask.Value (not . flip List.elem cs)
- code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
-
-ofChars :: String -> TExpQ Char -> TExpQ Bool
-ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
-
-token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
-token = try . string
-
-eof :: Charable repr => Lookable repr => repr ()
-eof = negLook item
-
-more :: Applicable repr => Charable repr => Lookable repr => repr ()
-more = look (void item)
-
-char :: Applicable repr => Charable repr => Char -> repr Char
-char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
-
-item :: Charable repr => repr Char
-item = satisfy (Hask.const Hask..@ Hask.bool True)
+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]
void p = p *> unit
unit :: Applicable repr => repr ()
-unit = pure Hask.unit
+unit = pure H.unit
{-
-
constp :: Applicable repr => repr a -> repr (b -> a)
-constp = (Hask.const <$>)
+constp = (H.const <$>)
-- Alias Operations
infixl 4 <~>
(<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (Hask.runtime (,))
+(<~>) = liftA2 (H.runtime (,))
infixl 4 <~
(<~) :: Applicable repr => repr a -> repr b -> repr a
-- Lift Operations
liftA2 ::
Applicable repr =>
- Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
+ TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)
liftA3 ::
Applicable repr =>
- Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+ 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 =>
- Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
+ TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
Applicable repr => Foldable repr =>
- Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
+ 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 =>
- Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
+ 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 =>
- Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
+ 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 =>
- Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
+ 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 =>
repr a -> repr (a -> a -> a) -> repr a
-chainl1 = chainl1' Hask.id
+chainl1 = chainl1' H.id
{-
chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
-chainr1' f p op = newRegister_ Hask.id $ \acc ->
+chainr1' f p op = newRegister_ H.id $ \acc ->
let go = bind p $ \x ->
- modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
+ modify acc (H.flip (H..@) <$> (op <*> x)) *> go
<|> f <$> x
in go <**> get acc
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
-chainr1 = chainr1' Hask.id
+chainr1 = chainr1' H.id
-chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> TermGrammar 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) -> Hask.Haskell a -> repr a
+ 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 =>
repr a -> repr [a]
-many = pfoldr Hask.cons Hask.nil
+many = pfoldr H.cons H.nil
manyN ::
Applicable repr => Foldable repr =>
Applicable repr => Foldable repr =>
repr a -> repr ()
--skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
-skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
+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 =>
sepBy ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
-sepBy p sep = option Hask.nil (sepBy1 p sep)
+sepBy p sep = option H.nil (sepBy1 p sep)
sepBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
sepEndBy ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
-sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
+sepEndBy p sep = option H.nil (sepEndBy1 p sep)
sepEndBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
repr a -> repr b -> repr [a]
sepEndBy1 p sep =
- let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
- <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
+ let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
+ <|> pure (H.flip H..@ H.cons H..@ H.nil))
in seb1
{-
sepEndBy1 :: repr a -> repr b -> repr [a]
-sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
- let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
+sepEndBy1 p sep = newRegister_ H.id $ \acc ->
+ let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
*> (sep *> (go <|> get acc) <|> get acc)
- in go <*> pure Hask.nil
+ in go <*> pure H.nil
-}
+{-
-- Combinators interpreters for 'Sym.Any'.
instance Applicable repr => Applicable (Sym.Any repr)
-instance Charable repr => Charable (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)
+-}
sourcephile / git / haskell / symantic-parser.git / blobdiff