-- The default type signature of type class methods are changed
--- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
+-- to introduce a 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
-- this setup avoids to define the method with boilerplate code when its default
--- definition with lift* and 'trans' does what is expected by an instance
+-- definition with 'liftDerived'* and 'derive' does what is expected by an instance
-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Ord (Ord(..))
-import Data.Functor (Functor)
-import Data.Functor.Identity (Identity(..))
-import Data.Functor.Product (Product(..))
-import Data.Function ((.), flip, id, const)
+import Data.Ord (Ord(..), Ordering(..))
+import Data.Function ((.), flip, const)
import Data.Int (Int)
import Data.Kind (Type, Constraint)
import Data.Maybe (Maybe(..))
import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Prelude
-import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Univariant.Lang as H
-import qualified Symantic.Univariant.Data as Prod
-import qualified Symantic.Univariant.Reify as Reify
-import qualified Symantic.Univariant.View
+import Symantic.Typed.Derive
+import qualified Symantic.Typed.Lang as Prod
import Symantic.Parser.Grammar.Production
-- * Type 'ReprComb'
-- Generally used on the first alternative: @('try' rl '<|>' rr)@.
try :: repr a -> repr a
default alt ::
- Sym.Liftable2 repr => CombAlternable (Sym.Output repr) =>
+ FromDerived2 CombAlternable repr =>
Exception -> repr a -> repr a -> repr a
default throw ::
- Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
+ FromDerived CombAlternable repr =>
ExceptionLabel -> repr a
default try ::
- Sym.Liftable1 repr => CombAlternable (Sym.Output repr) =>
+ FromDerived1 CombAlternable repr =>
repr a -> repr a
- alt = Sym.lift2 . alt
- throw = Sym.lift . throw
- try = Sym.lift1 try
+ alt = liftDerived2 . alt
+ throw = liftDerived . throw
+ try = liftDerived1 try
failure :: SomeFailure -> repr a
default failure ::
- Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
+ FromDerived CombAlternable repr =>
SomeFailure -> repr a
- failure = Sym.lift . failure
+ failure = liftDerived . failure
-- | @(empty)@ parses nothing, always failing to return a value.
empty :: repr a
-- ** Type 'SomeFailure'
data SomeFailure =
forall comb.
- ({-Trans (Failure comb repr) repr,-}
- Eq (Failure comb)
+ ( Eq (Failure comb)
+ , Ord (Failure comb)
, Show (Failure comb)
, TH.Lift (Failure comb)
, NFData (Failure comb)
) =>
SomeFailure (Failure comb {-repr a-})
instance Eq SomeFailure where
- SomeFailure (_x::Failure x) == SomeFailure (_y::Failure y) =
+ SomeFailure (x::Failure x) == SomeFailure (y::Failure y) =
case typeRep @x `eqTypeRep` typeRep @y of
- Just HRefl -> True
+ Just HRefl -> x == y
Nothing -> False
instance Ord SomeFailure where
- SomeFailure (_x::Failure x) `compare` SomeFailure (_y::Failure y) =
- SomeTypeRep (typeRep @x) `compare`
- SomeTypeRep (typeRep @y)
+ SomeFailure (x::Failure x) `compare` SomeFailure (y::Failure y) =
+ -- WARNING: this ordering is convenient to make a 'Set' of 'SomeFailure's
+ -- but it is based upon a hash which changes with packages' ABI
+ -- and also if the install is "inplace" or not.
+ -- Therefore this 'Ord' is not stable enough to put 'SomeFailure'
+ -- in golden tests.
+ let xT = typeRep @x in
+ let yT = typeRep @y in
+ case SomeTypeRep xT `compare` SomeTypeRep yT of
+ EQ | Just HRefl <- xT `eqTypeRep` yT -> compare x y
+ o -> o
instance Show SomeFailure where
showsPrec p (SomeFailure x) = showsPrec p x
instance TH.Lift SomeFailure where
rnf (SomeFailure x) = rnf x
{-
-instance Trans (SomeFailure repr) repr where
- trans (SomeFailure x) = trans x
+instance Derivable (SomeFailure repr) where
+ derive (SomeFailure x) = derive x
-}
-- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
-- | 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
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 => Production a -> repr a -> repr a
option x p = p <|> pure x
-- 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 @('Production' a)@ instead of just @(a)@
--- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
+-- 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
(<$>) :: Production (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
(<$>%) :: (Production a -> Production b) -> repr a -> repr b
- a2b <$>% ma = H.lam a2b <$> ma
+ a2b <$>% ma = Prod.lam a2b <$> ma
-- | Like '<$>' but with its arguments 'flip'-ped.
(<&>) :: repr a -> Production (a -> b) -> repr b
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
pure :: Production a -> repr a
default pure ::
- Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
+ FromDerived CombApplicable repr =>
Production a -> repr a
- pure = Sym.lift . pure
+ pure = liftDerived . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
-- and returns the application of the function returned by @(ra2b)@
-- to the value returned by @(ra)@.
(<*>) :: repr (a -> b) -> repr a -> repr b
default (<*>) ::
- Sym.Liftable2 repr => CombApplicable (Sym.Output repr) =>
+ FromDerived2 CombApplicable repr =>
repr (a -> b) -> repr a -> repr b
- (<*>) = Sym.lift2 (<*>)
+ (<*>) = liftDerived2 (<*>)
-- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(ra)@, discarding the return value of @(rb)@.
(<*) :: repr a -> repr b -> repr a
- (<*) = liftA2 H.const
+ (<*) = liftA2 Prod.const
-- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(rb)@, discarding the return value of @(ra)@.
(*>) :: repr a -> repr b -> repr b
- x *> y = (H.id <$ x) <*> y
+ x *> y = (Prod.id <$ x) <*> y
-- | Like '<*>' but with its arguments 'flip'-ped.
(<**>) :: repr a -> repr (a -> b) -> repr b
- (<**>) = liftA2 (H.flip H..@ (H.$))
+ (<**>) = liftA2 (Prod.flip Prod..@ (Prod.$))
{-
(<**>) :: repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (\a f -> f a)
{-# 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
chainPost :: repr a -> repr (a -> a) -> repr a
{-
default chainPre ::
- Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
+ FromDerived2 CombFoldable repr =>
repr (a -> a) -> repr a -> repr a
default chainPost ::
- Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
+ FromDerived2 CombFoldable repr =>
repr a -> repr (a -> a) -> repr a
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
-}
default chainPre ::
CombApplicable repr =>
CombApplicable repr =>
CombAlternable repr =>
repr a -> repr (a -> a) -> repr a
- chainPre op p = go <*> p where go = (H..) <$> op <*> go <|> pure H.id
- chainPost p op = p <**> go where go = (H..) <$> op <*> go <|> pure H.id
+ chainPre op p = go <*> p where go = (Prod..) <$> op <*> go <|> pure Prod.id
+ chainPost p op = p <**> go where go = (Prod..) <$> op <*> go <|> pure Prod.id
{-
chainPre op p = flip (foldr ($)) <$> many op <*> p
chainPost p op = foldl' (flip ($)) <$> p <*> many op
pfoldl ::
CombApplicable repr => CombFoldable repr =>
Production (b -> a -> b) -> Production b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
+pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
pfoldl1 ::
CombApplicable repr => CombFoldable repr =>
Production (b -> a -> b) -> Production b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Prod.flip <$> pure f) <*> p)
-- Chain Combinators
chainl1' ::
CombApplicable repr => CombFoldable repr =>
Production (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
+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) -> Production a -> repr a
chainr p op x = option x (chainr1 p op)
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'
conditional ::
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) =>
+ FromDerived1 CombMatchable repr => Derivable repr =>
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))
+ conditional a ps bs = liftDerived1 (conditional (derive a) ps (derive Functor.<$> bs))
match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
- match a as a2b = conditional a ((H.equal H..@) Functor.<$> as) (a2b Functor.<$> as)
- -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
+ 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'
Set SomeFailure ->
Production (tok -> Bool) -> repr tok
default satisfyOrFail ::
- Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
+ FromDerived (CombSatisfiable tok) repr =>
Set SomeFailure ->
Production (tok -> Bool) -> repr tok
- satisfyOrFail fs = Sym.lift . satisfyOrFail fs
+ satisfyOrFail fs = liftDerived . satisfyOrFail fs
data instance Failure (CombSatisfiable tok)
= FailureAny
+ -- FIXME: this 'Failure' is a bit special since multiple ones
+ -- with different 'Horizon's makes no sense.
+ -- This should likely be treated separately in 'ParsingError'.
| FailureHorizon Int -- FIXME: use Natural?
| FailureLabel String
| FailureToken tok
- deriving (Eq, Show, Typeable, Generic, NFData)
+ deriving (Eq, Ord, Show, Typeable, Generic, NFData)
-- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
-- from TemplateHaskell code.
inputTokenProxy :: TH.Name
Char -> repr Char
char c = satisfyOrFail
(Set.singleton (SomeFailure (FailureToken c)))
- ((H.equal H..@ H.char c))
- $> H.char c
+ (Prod.equal Prod..@ Prod.char c)
+ $> Prod.char c
item :: forall tok repr.
- Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+ Ord 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)
+ (Prod.const Prod..@ Prod.bool True)
anyChar ::
CombAlternable repr =>
string = try . traverse char
oneOf ::
- Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+ Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr =>
[tok] -> repr tok
oneOf ts = satisfyOrFail
CombApplicable repr =>
CombSatisfiable tok repr =>
tok -> repr tok
-token tok = satisfy (H.equal H..@ H.constant tok) $> H.constant 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 => Typeable tok =>
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) =>
+ FromDerived3 CombSelectable repr =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
- branch = Sym.lift3 branch
+ branch = liftDerived3 branch
data instance Failure CombSelectable
-- * 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
+ default look ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr a
+ default negLook ::
+ FromDerived1 CombLookable repr =>
+ repr a -> repr ()
+ look = liftDerived1 look
+ negLook = liftDerived1 negLook
eof :: repr ()
- eof = Sym.lift eof
- default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
- -- eof = negLook (satisfy @Char (H.const H..@ H.bool True))
+ eof = liftDerived eof
+ default eof ::
+ FromDerived CombLookable repr =>
+ repr ()
+ -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
-- (item @Char)
data instance Failure CombLookable
= FailureEnd
- deriving (Eq, Show, Typeable, TH.Lift, Generic, NFData)
+ deriving (Eq, Ord, 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
sourcephile / git / haskell / symantic-parser.git / blobdiff