-- The default type signature of type class methods are changed
--- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
+-- to introduce a 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
-- this setup avoids to define the method with boilerplate code when its default
--- definition with lift* and 'trans' does what is expected by an instance
+-- definition with 'liftDerived'* and 'derive' does what is expected by an instance
-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
+{-# LANGUAGE DerivingStrategies #-} -- For UnscopedRegister
{-# LANGUAGE PatternSynonyms #-} -- For Failure
{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
{-# LANGUAGE InstanceSigs #-}
import GHC.Generics (Generic)
-- import Data.Set (Set)
-- import GHC.TypeLits (KnownSymbol)
+import Data.Bifunctor (second)
import Data.Bool (Bool(..), not, (||))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
+import Data.Function ((.), flip, const, fix)
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 Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Typed.Trans as Sym
-import qualified Symantic.Typed.Lang as Prod
+import Symantic.Syntaxes.Derive
+import qualified Symantic.Syntaxes.Classes 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)
, Typeable comb
- ) =>
- SomeFailure (Failure comb {-repr a-})
+ ) => SomeFailure (Failure comb {-repr a-})
instance Eq SomeFailure where
SomeFailure (x::Failure x) == SomeFailure (y::Failure y) =
case typeRep @x `eqTypeRep` typeRep @y of
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))@
data Exception
= ExceptionLabel ExceptionLabel
| ExceptionFailure
+ -- | ExceptionEnd
deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
type ExceptionLabel = String
-- type Exceptions = Set Exception
infixl 3 <|>, <+>
-optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production 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 Prod.unit
+optional = flip optionally (Prod.constant ())
-option :: CombApplicable repr => CombAlternable repr => Production 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
-- * Class 'CombApplicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes
--- from the @base@ package, but using @('Production' a)@ instead of just @(a)@
+-- from the @base@ package, but using @('Production' vs a)@ instead of just @(a)@
-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'Prod.id')
-- and thus apply some optimizations.
-- @(repr)@, for "representation", is the usual tagless-final abstraction
-- 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)@.
- (<$>) :: Production (a -> b) -> repr a -> repr b
+ (<$>) :: Production '[] (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
- (<$>%) :: (Production a -> Production b) -> repr a -> repr b
+ (<$>%) :: (Production '[] a -> Production '[] b) -> repr a -> repr b
a2b <$>% ma = Prod.lam a2b <$> ma
-- | Like '<$>' but with its arguments 'flip'-ped.
- (<&>) :: repr a -> Production (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)@.
- (<$) :: Production 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 -> Production b -> repr b
+ ($>) :: repr a -> Production '[] b -> repr b
($>) = flip (<$)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
- pure :: Production a -> repr a
+ pure :: Production '[] a -> repr a
default pure ::
- Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
- Production a -> repr a
- pure = Sym.lift . pure
+ FromDerived CombApplicable repr =>
+ Production '[] a -> repr a
+ pure = liftDerived . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
-- and returns the application of the function returned by @(ra2b)@
-- to the value returned by @(ra)@.
(<*>) :: repr (a -> b) -> repr a -> repr b
default (<*>) ::
- Sym.Liftable2 repr => 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)@.
-}
-- | @('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 :: Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (f <$> x)
infixl 4 <*>, <*, *>, <**>
void p = p *> unit
unit :: CombApplicable repr => repr ()
-unit = pure Prod.unit
+unit = pure (Prod.constant ())
-- * Class 'CombFoldable'
class CombFoldable repr where
- chainPre :: repr (a -> a) -> repr a -> repr a
+ chainPre :: repr (a -> a) -> repr a -> repr a
chainPost :: repr a -> repr (a -> a) -> repr a
- {-
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
default chainPre ::
- Sym.Liftable2 repr => 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
- -}
+ {-
default chainPre ::
CombApplicable repr =>
CombAlternable repr =>
repr a -> repr (a -> a) -> repr a
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 => [(Production (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 =>
- Production (a -> b -> b) -> Production 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 =>
- Production (a -> b -> b) -> Production 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 =>
- Production (b -> a -> b) -> Production b -> repr a -> repr b
+ 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 =>
- Production (b -> a -> b) -> Production b -> repr a -> repr b
+ 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 =>
- Production (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+ Production '[] (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
chainl1 ::
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
chainr1 = chainr1' Prod.id
-chainr :: repr a -> repr (a -> a -> a) -> Production 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) -> Production a -> repr a
+ repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
chainl p op x = option x (chainl1 p op)
-- Derived Combinators
-- * Class 'CombMatchable'
class CombMatchable repr where
conditional ::
- Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
+ repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
+ conditional a bs = liftDerived1
+ (conditional (derive a) (second derive Functor.<$> bs))
default conditional ::
- Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Output 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))
-
- 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)
+ FromDerived1 CombMatchable repr => Derivable repr =>
+ repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
data instance Failure CombMatchable
+match ::
+ CombMatchable repr =>
+ Eq a => TH.Lift a =>
+ repr a -> [Production '[] a] -> (Production '[] a -> repr b) -> repr b -> repr b
+match a as p = conditional a
+ ((\v ->
+ ( Prod.lam (v Prod.==)
+ , p v
+ )
+ ) Functor.<$> as)
+
+predicate ::
+ CombMatchable repr =>
+ Production '[] (a -> Bool) -> repr a -> repr b -> repr b -> repr b
+predicate p a b = conditional a [(p, b)]
+
+infixl 4 <?:>
+(<?:>) ::
+ CombMatchable repr =>
+ repr Bool -> (repr a, repr a) -> repr a
+cond <?:> (p, q) = predicate Prod.id cond p q
+
-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
-- | Like 'satisfyOrFail' but with no custom failure.
- satisfy :: Production (tok -> Bool) -> repr tok
+ satisfy :: Production '[] (tok -> Bool) -> repr tok
satisfy = satisfyOrFail Set.empty
-- | Like 'satisfy' but with a custom set of 'SomeFailure's.
satisfyOrFail ::
Set SomeFailure ->
- Production (tok -> Bool) -> repr tok
+ 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
+ Production '[] (tok -> Bool) -> repr tok
+ satisfyOrFail fs = liftDerived . satisfyOrFail fs
data instance Failure (CombSatisfiable tok)
= FailureAny
Char -> repr Char
char c = satisfyOrFail
(Set.singleton (SomeFailure (FailureToken c)))
- (Prod.equal Prod..@ Prod.char c)
- $> Prod.char c
+ (Prod.equal Prod..@ Prod.constant c)
+ $> Prod.constant c
item :: forall tok repr.
Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr => repr tok
item = satisfyOrFail
(Set.singleton (SomeFailure (FailureAny @tok)))
- (Prod.const Prod..@ Prod.bool True)
+ (Prod.const Prod..@ Prod.constant True)
anyChar ::
CombAlternable repr =>
{-alternatives-}[tok] ->
{-input-}TH.CodeQ tok ->
TH.CodeQ Bool
-ofChars = List.foldr (\tok acc ->
- \inp -> [|| tok == $$inp || $$(acc inp) ||])
+ofChars = List.foldr
+ (\tok acc inp -> [|| tok == $$inp || $$(acc inp) ||])
(const [||False||])
more ::
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
+when ::
+ CombMatchable repr =>
+ CombSelectable repr =>
+ Prod.Constantable () repr =>
+ repr Bool -> repr () -> repr ()
+when p q = p <?:> (q, Prod.constant ())
+
+while ::
+ CombMatchable repr =>
+ CombSelectable repr =>
+ Prod.Constantable () repr =>
+ repr Bool -> repr ()
+while x = fix (when x)
+
-- * Class 'CombLookable'
class CombLookable repr where
look :: repr a -> repr a
negLook :: repr a -> repr ()
- default look :: 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 = liftDerived eof
+ default eof ::
+ FromDerived CombLookable repr =>
+ repr ()
-- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
-- (item @Char)
data instance Failure CombLookable
-- Lift Operations
liftA2 ::
CombApplicable repr =>
- Production (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 =>
- Production (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
-}
instance CombLookable repr => CombLookable (Sym.Any repr)
instance CombFoldable repr => CombFoldable (Sym.Any repr)
-}
+
+-- * Type 'Register'
+newtype Register r a = Register { unRegister :: UnscopedRegister a }
+ deriving (Eq, Show)
+
+-- ** Type 'UnscopedRegister'
+newtype UnscopedRegister r = UnscopedRegister { unUnscopedRegister :: TH.Name }
+ deriving (Eq)
+ deriving newtype Show
+
+
+{-
+put_ :: ParserOps rep => Register r a -> rep a -> Parser ()
+put_ r = put r . pure
+
+gets_ :: ParserOps rep => Register r a -> rep (a -> b) -> Parser b
+gets_ r = gets r . pure
+
+modify_ :: ParserOps rep => Register r a -> rep (a -> a) -> Parser ()
+modify_ r = modify r . pure
+-}
+
+gets ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr (a -> b) -> repr b
+gets r p = p <*> get r
+
+modify ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr (a -> a) -> repr ()
+modify r p = put r (gets r p)
+
+move ::
+ CombRegisterable repr =>
+ Register r1 a -> Register r2 a -> repr ()
+move dst src = put dst (get src)
+
+bind ::
+ CombRegisterable repr =>
+ repr a -> (repr a -> repr b) -> repr b
+bind p f = new p (f . get)
+
+local ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr a -> repr b -> repr b
+local r p q = bind (get r) (\x -> put r p *> q <* put r x)
+
+swap ::
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r1 a -> Register r2 a -> repr ()
+swap r1 r2 = bind (get r1) (\x -> move r1 r2 *> put r2 x)
+
+rollback ::
+ CombAlternable repr =>
+ CombApplicable repr =>
+ CombRegisterable repr =>
+ Register r a -> repr b -> repr b
+rollback r p = bind (get r) (\x -> p <|> put r x *> empty)
+
+for ::
+ CombApplicable repr =>
+ CombMatchable repr =>
+ CombSelectable repr =>
+ CombRegisterable repr =>
+ Prod.Constantable () repr =>
+ repr a -> repr (a -> Bool) -> repr (a -> a) -> repr () -> repr ()
+for init cond step body =
+ new init (\i ->
+ let cond' = gets i cond in
+ when cond' (while (body *> modify i step *> cond'))
+ )
+
+
+-- ** Class 'CombRegisterable'
+class CombRegisterable (repr::ReprComb) where
+ new :: repr a -> (forall r. Register r a -> repr b) -> repr b
+ get :: Register r a -> repr a
+ put :: Register r a -> repr a -> repr ()
+ default new ::
+ FromDerived CombRegisterable repr => Derivable repr =>
+ repr a -> (forall r. Register r a -> repr b) -> repr b
+ default get ::
+ FromDerived CombRegisterable repr =>
+ Register r a -> repr a
+ default put ::
+ FromDerived1 CombRegisterable repr =>
+ Register r a -> repr a -> repr ()
+ new ini f = liftDerived (new (derive ini) (derive . f))
+ get = liftDerived . get
+ put = liftDerived1 . put
sourcephile / git / haskell / symantic-parser.git / blobdiff