-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
{-# LANGUAGE PatternSynonyms #-} -- For Failure
{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
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.Bool (Bool(..), not, (||))
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
-
--- * Type 'TermGrammar'
-type TermGrammar = H.Term H.ValueCode
+import qualified Symantic.Typed.Trans as Sym
+import qualified Symantic.Typed.Lang as Prod
+import Symantic.Parser.Grammar.Production
-- * Type 'ReprComb'
type ReprComb = Type -> Type
-code :: TH.Lift a => a -> TermGrammar a
-code x = H.Term (H.ValueCode x [||x||])
-
-- * Class 'CombAlternable'
class CombAlternable repr where
-- | @('alt' es l r)@ parses @(l)@ and return its return value or,
data instance Failure CombAlternable
= FailureEmpty
- deriving (Eq, Ord, Show, TH.Lift)
+ deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
-- ** Data family 'Failure'
-- | 'Failure's of the 'Grammar'.
Eq (Failure comb)
, Show (Failure comb)
, TH.Lift (Failure comb)
+ , NFData (Failure comb)
, Typeable comb
) =>
SomeFailure (Failure comb {-repr a-})
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 Trans (SomeFailure repr) repr where
data Exception
= ExceptionLabel ExceptionLabel
| ExceptionFailure
- deriving (Eq, Ord, Show, TH.Lift)
+ 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 = H.left <$> p <|> H.right <$> q
+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 -> TermGrammar b -> repr b
+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 H.unit
+optional = flip optionally Prod.unit
-option :: CombApplicable repr => CombAlternable repr => TermGrammar a -> repr a -> repr a
+option :: CombApplicable repr => CombAlternable repr => Production a -> repr a -> repr a
option x p = p <|> pure x
choice :: CombAlternable repr => [repr a] -> repr a
-- 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)
+maybeP p = option Prod.nothing (Prod.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
-
+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' 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 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 => CombApplicable (Sym.Output repr) =>
- TermGrammar a -> repr a
+ Production a -> repr a
pure = Sym.lift . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
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)
-
-- | @(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 <$>, <&>, <$, $>, <*>, <*, *>, <**>
+ -- | @('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)
+
+infixl 4 <*>, <*, *>, <**>
data instance Failure CombApplicable
+
{-# INLINE (<:>) #-}
infixl 4 <:>
(<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
-(<:>) = liftA2 H.cons
+(<:>) = liftA2 Prod.cons
sequence :: CombApplicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure H.nil)
+sequence = List.foldr (<:>) (pure Prod.nil)
traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f
void p = p *> unit
unit :: CombApplicable repr => repr ()
-unit = pure H.unit
+unit = pure Prod.unit
-- * Class 'CombFoldable'
class CombFoldable repr where
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 :: CombSelectable 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
-}
-- Parser Folds
pfoldr ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ Production (a -> b -> b) -> Production b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ Production (a -> b -> b) -> Production b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
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)
+ Production (b -> a -> b) -> Production b -> repr a -> repr b
+pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
pfoldl1 ::
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)
+ 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' ::
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)
+ Production (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
chainl1 ::
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 ::
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
- repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+ repr a -> repr (a -> a -> a) -> Production a -> repr a
chainl p op x = option x (chainl1 p op)
-- Derived Combinators
many ::
CombApplicable repr => CombFoldable repr =>
repr a -> repr [a]
-many = pfoldr H.cons H.nil
+many = pfoldr Prod.cons Prod.nil
manyN ::
CombApplicable repr => CombFoldable 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 ::
CombApplicable repr => CombFoldable repr =>
sepBy ::
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 ::
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
sepEndBy ::
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 ::
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 ::
- Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
+ Eq a => repr a -> [Production (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
+ Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift 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)
+ match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
+ match a as a2b = conditional a ((Prod.equal Prod..@) Functor.<$> as) (a2b Functor.<$> as)
+ -- match a as a2b = conditional a (((Prod.eq Prod..@ Prod.qual) Prod..@) Functor.<$> as) (a2b Functor.<$> as)
data instance Failure CombMatchable
-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
-- | Like 'satisfyOrFail' but with no custom failure.
- satisfy :: TermGrammar (tok -> Bool) -> repr tok
+ satisfy :: Production (tok -> Bool) -> repr tok
satisfy = satisfyOrFail Set.empty
-- | Like 'satisfy' but with a custom set of 'SomeFailure's.
satisfyOrFail ::
Set SomeFailure ->
- TermGrammar (tok -> Bool) -> repr tok
+ Production (tok -> Bool) -> repr tok
default satisfyOrFail ::
Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
Set SomeFailure ->
- TermGrammar (tok -> Bool) -> repr tok
+ Production (tok -> Bool) -> repr tok
satisfyOrFail fs = Sym.lift . satisfyOrFail fs
data instance Failure (CombSatisfiable tok)
| FailureHorizon Int -- FIXME: use Natural?
| FailureLabel String
| FailureToken tok
- deriving (Eq, Show, Typeable)
+ deriving (Eq, 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
CombApplicable repr =>
CombSatisfiable Char repr =>
Char -> repr Char
-char c = satisfyOrFail (Set.singleton (SomeFailure (FailureToken c)))
- (H.eq H..@ H.char c) $> H.char c
+char c = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureToken c)))
+ ((Prod.equal Prod..@ Prod.char c))
+ $> Prod.char c
item :: forall tok repr.
- Eq tok => Show tok => Typeable tok => TH.Lift tok =>
+ Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr => repr tok
-item = satisfyOrFail (Set.singleton (SomeFailure (FailureAny @tok)))
- (H.const H..@ H.bool True)
+item = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureAny @tok)))
+ (Prod.const Prod..@ Prod.bool True)
anyChar ::
CombAlternable repr =>
string = try . traverse char
oneOf ::
- Eq tok => Show tok => Typeable tok => TH.Lift tok =>
+ Eq 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))
- (Sym.trans H.ValueCode
- { value = (`List.elem` ts)
- , code = [||\t -> $$(ofChars ts [||t||])||] })
+ (production
+ (`List.elem` ts)
+ [||\t -> $$(ofChars ts [||t||])||])
noneOf ::
TH.Lift tok => Eq tok =>
CombSatisfiable tok repr =>
[tok] -> repr tok
-noneOf cs = satisfy (Sym.trans H.ValueCode
- { value = not . (`List.elem` cs)
- , code = [||\c -> not $$(ofChars cs [||c||])||]
- })
+noneOf cs = satisfy (production
+ (not . (`List.elem` cs))
+ [||\c -> not $$(ofChars cs [||c||])||])
ofChars ::
TH.Lift tok => Eq tok =>
more = look (void (item @Char))
token ::
- TH.Lift tok => Show tok => Eq tok =>
+ TH.Lift tok => Show tok => Eq tok => Typeable tok =>
CombAlternable repr =>
CombApplicable repr =>
CombSatisfiable tok repr =>
tok -> repr tok
-token tok = satisfy (H.eq H..@ H.char tok) $> H.char tok
--- token tok = satisfy [ExceptionToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char 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 =>
+ TH.Lift tok => Eq tok => Show tok => Typeable tok =>
CombApplicable repr => CombAlternable repr =>
CombSatisfiable tok repr => [tok] -> repr [tok]
tokens = try . traverse token
eof :: repr ()
eof = Sym.lift eof
default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
- -- eof = negLook (satisfy @Char (H.const H..@ H.bool True))
+ -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
-- (item @Char)
data instance Failure CombLookable
= FailureEnd
- deriving (Eq, Show, Typeable, TH.Lift)
+ deriving (Eq, Show, Typeable, TH.Lift, Generic, NFData)
-- Composite Combinators
-- someTill :: repr a -> repr b -> repr [a]
{-
constp :: CombApplicable repr => repr a -> repr (b -> a)
-constp = (H.const <$>)
+constp = (Prod.const <$>)
-- Alias Operations
infixl 4 <~>
(<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (H.runtime (,))
+(<~>) = liftA2 (Prod.runtime (,))
infixl 4 <~
(<~) :: CombApplicable repr => repr a -> repr b -> repr a
-- Lift Operations
liftA2 ::
CombApplicable repr =>
- TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
+ Production (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
+ Production (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
liftA3 f a b c = liftA2 f a b <*> c
-}