{-# LANGUAGE OverloadedStrings #-}
module Parsley.Internal.Core.CombinatorAST (module Parsley.Internal.Core.CombinatorAST) where
import Data.Kind (Type)
import Parsley.Internal.Common (IFunctor(..), Fix, Const1(..), cata, intercalateDiff, (:+:))
import Parsley.Internal.Core.Identifiers (MVar, ΣVar)
import Parsley.Internal.Core.CharPred (CharPred)
import Parsley.Internal.Core.Defunc (Defunc)
newtype Parser a = Parser {forall a. Parser a -> Fix (Combinator :+: ScopeRegister) a
unParser :: Fix (Combinator :+: ScopeRegister) a}
data Combinator (k :: Type -> Type) (a :: Type) where
Pure :: Defunc a -> Combinator k a
Satisfy :: CharPred -> Combinator k Char
(:<*>:) :: k (a -> b) -> k a -> Combinator k b
(:*>:) :: k a -> k b -> Combinator k b
(:<*:) :: k a -> k b -> Combinator k a
(:<|>:) :: k a -> k a -> Combinator k a
Empty :: Combinator k a
Try :: k a -> Combinator k a
LookAhead :: k a -> Combinator k a
Let :: MVar a -> Combinator k a
NotFollowedBy :: k a -> Combinator k ()
Branch :: k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c
Match :: k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b
Loop :: k () -> k a -> Combinator k a
MakeRegister :: ΣVar a -> k a -> k b -> Combinator k b
GetRegister :: ΣVar a -> Combinator k a
PutRegister :: ΣVar a -> k a -> Combinator k ()
Position :: PosSelector -> Combinator k Int
Debug :: String -> k a -> Combinator k a
MetaCombinator :: MetaCombinator -> k a -> Combinator k a
data ScopeRegister (k :: Type -> Type) (a :: Type) where
ScopeRegister :: k a -> (forall r. Reg r a -> k b) -> ScopeRegister k b
data PosSelector where
Line :: PosSelector
Col :: PosSelector
newtype Reg (r :: Type) a = Reg (ΣVar a)
data MetaCombinator where
Cut :: MetaCombinator
instance IFunctor Combinator where
imap :: forall (a :: Type -> Type) (b :: Type -> Type) i.
(forall j. a j -> b j) -> Combinator a i -> Combinator b i
imap forall j. a j -> b j
_ (Pure Defunc i
x) = forall a (k :: Type -> Type). Defunc a -> Combinator k a
Pure Defunc i
x
imap forall j. a j -> b j
_ (Satisfy CharPred
p) = forall (k :: Type -> Type). CharPred -> Combinator k Char
Satisfy CharPred
p
imap forall j. a j -> b j
f (a (a -> i)
p :<*>: a a
q) = forall j. a j -> b j
f a (a -> i)
p forall (k :: Type -> Type) a b. k (a -> b) -> k a -> Combinator k b
:<*>: forall j. a j -> b j
f a a
q
imap forall j. a j -> b j
f (a a
p :*>: a i
q) = forall j. a j -> b j
f a a
p forall (k :: Type -> Type) a b. k a -> k b -> Combinator k b
:*>: forall j. a j -> b j
f a i
q
imap forall j. a j -> b j
f (a i
p :<*: a b
q) = forall j. a j -> b j
f a i
p forall (k :: Type -> Type) a a. k a -> k a -> Combinator k a
:<*: forall j. a j -> b j
f a b
q
imap forall j. a j -> b j
f (a i
p :<|>: a i
q) = forall j. a j -> b j
f a i
p forall (k :: Type -> Type) a. k a -> k a -> Combinator k a
:<|>: forall j. a j -> b j
f a i
q
imap forall j. a j -> b j
_ Combinator a i
Empty = forall (k :: Type -> Type) a. Combinator k a
Empty
imap forall j. a j -> b j
f (Try a i
p) = forall (k :: Type -> Type) a. k a -> Combinator k a
Try (forall j. a j -> b j
f a i
p)
imap forall j. a j -> b j
f (LookAhead a i
p) = forall (k :: Type -> Type) a. k a -> Combinator k a
LookAhead (forall j. a j -> b j
f a i
p)
imap forall j. a j -> b j
_ (Let MVar i
v) = forall a (k :: Type -> Type). MVar a -> Combinator k a
Let MVar i
v
imap forall j. a j -> b j
f (NotFollowedBy a a
p) = forall (k :: Type -> Type) a. k a -> Combinator k ()
NotFollowedBy (forall j. a j -> b j
f a a
p)
imap forall j. a j -> b j
f (Branch a (Either a b)
b a (a -> i)
p a (b -> i)
q) = forall (k :: Type -> Type) a b c.
k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c
Branch (forall j. a j -> b j
f a (Either a b)
b) (forall j. a j -> b j
f a (a -> i)
p) (forall j. a j -> b j
f a (b -> i)
q)
imap forall j. a j -> b j
f (Match a a
p [Defunc (a -> Bool)]
fs [a i]
qs a i
d) = forall (k :: Type -> Type) a b.
k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b
Match (forall j. a j -> b j
f a a
p) [Defunc (a -> Bool)]
fs (forall a b. (a -> b) -> [a] -> [b]
map forall j. a j -> b j
f [a i]
qs) (forall j. a j -> b j
f a i
d)
imap forall j. a j -> b j
f (Loop a ()
body a i
exit) = forall (k :: Type -> Type) a. k () -> k a -> Combinator k a
Loop (forall j. a j -> b j
f a ()
body) (forall j. a j -> b j
f a i
exit)
imap forall j. a j -> b j
f (MakeRegister ΣVar a
σ a a
p a i
q) = forall a (k :: Type -> Type) b.
ΣVar a -> k a -> k b -> Combinator k b
MakeRegister ΣVar a
σ (forall j. a j -> b j
f a a
p) (forall j. a j -> b j
f a i
q)
imap forall j. a j -> b j
_ (GetRegister ΣVar i
σ) = forall a (k :: Type -> Type). ΣVar a -> Combinator k a
GetRegister ΣVar i
σ
imap forall j. a j -> b j
f (PutRegister ΣVar a
σ a a
p) = forall a (k :: Type -> Type). ΣVar a -> k a -> Combinator k ()
PutRegister ΣVar a
σ (forall j. a j -> b j
f a a
p)
imap forall j. a j -> b j
_ (Position PosSelector
sel) = forall (k :: Type -> Type). PosSelector -> Combinator k Int
Position PosSelector
sel
imap forall j. a j -> b j
f (Debug String
name a i
p) = forall (k :: Type -> Type) a. String -> k a -> Combinator k a
Debug String
name (forall j. a j -> b j
f a i
p)
imap forall j. a j -> b j
f (MetaCombinator MetaCombinator
m a i
p) = forall (k :: Type -> Type) a.
MetaCombinator -> k a -> Combinator k a
MetaCombinator MetaCombinator
m (forall j. a j -> b j
f a i
p)
instance Show (Fix Combinator a) where
show :: Fix Combinator a -> String
show = (forall a b. (a -> b) -> a -> b
$ String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} a (k2 :: k1). Const1 a k2 -> a
getConst1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type) i.
IFunctor f =>
(forall j. f a j -> a j) -> Fix f i -> a i
cata (forall {k} a (k1 :: k). a -> Const1 a k1
Const1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Combinator (Const1 ShowS) a -> ShowS
alg)
where
alg :: Combinator (Const1 ShowS) a -> ShowS
alg (Pure Defunc a
x) = ShowS
"pure " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Defunc a
x
alg (Satisfy CharPred
f) = ShowS
"satisfy " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows CharPred
f
alg (Const1 ShowS
pf :<*>: Const1 ShowS
px) = ShowS
"(" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
pf forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" <*> " forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
px forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Const1 ShowS
p :*>: Const1 ShowS
q) = ShowS
"(" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" *> " forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Const1 ShowS
p :<*: Const1 ShowS
q) = ShowS
"(" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" <* " forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Const1 ShowS
p :<|>: Const1 ShowS
q) = ShowS
"(" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" <|> " forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg Combinator (Const1 ShowS) a
Empty = ShowS
"empty"
alg (Try (Const1 ShowS
p)) = ShowS
"try ("forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (LookAhead (Const1 ShowS
p)) = ShowS
"lookAhead (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Let MVar a
v) = ShowS
"let-bound " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows MVar a
v
alg (NotFollowedBy (Const1 ShowS
p)) = ShowS
"notFollowedBy (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Branch (Const1 ShowS
b) (Const1 ShowS
p) (Const1 ShowS
q)) = ShowS
"branch (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
") (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
") (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Match (Const1 ShowS
p) [Defunc (a -> Bool)]
fs [Const1 ShowS a]
qs (Const1 ShowS
def)) = ShowS
"match (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
") " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows [Defunc (a -> Bool)]
fs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" [" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> [a -> a] -> a -> a
intercalateDiff ShowS
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {k1} a (k2 :: k1). Const1 a k2 -> a
getConst1 [Const1 ShowS a]
qs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
"] (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Loop (Const1 ShowS
body) (Const1 ShowS
exit)) = ShowS
"loop (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
") (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
exit forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (MakeRegister ΣVar a
σ (Const1 ShowS
p) (Const1 ShowS
q)) = ShowS
"make " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows ΣVar a
σ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
") (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (GetRegister ΣVar a
σ) = ShowS
"get " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows ΣVar a
σ
alg (PutRegister ΣVar a
σ (Const1 ShowS
p)) = ShowS
"put " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows ΣVar a
σ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
alg (Position PosSelector
Line) = ShowS
"line"
alg (Position PosSelector
Col) = ShowS
"col"
alg (Debug String
_ (Const1 ShowS
p)) = ShowS
p
alg (MetaCombinator MetaCombinator
m (Const1 ShowS
p)) = ShowS
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
" [" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows MetaCombinator
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
"]"
instance IFunctor ScopeRegister where
imap :: forall (a :: Type -> Type) (b :: Type -> Type) i.
(forall j. a j -> b j) -> ScopeRegister a i -> ScopeRegister b i
imap forall j. a j -> b j
f (ScopeRegister a a
p forall r. Reg r a -> a i
g) = forall (k :: Type -> Type) a b.
k a -> (forall r. Reg r a -> k b) -> ScopeRegister k b
ScopeRegister (forall j. a j -> b j
f a a
p) (forall j. a j -> b j
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Reg r a -> a i
g)
instance Show MetaCombinator where
show :: MetaCombinator -> String
show MetaCombinator
Cut = String
"cut point"
{-# INLINE traverseCombinator #-}
traverseCombinator :: Applicative m => (forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)
traverseCombinator :: forall (m :: Type -> Type) (f :: Type -> Type) (k :: Type -> Type)
a.
Applicative m =>
(forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)
traverseCombinator forall a. f a -> m (k a)
expose (f (a -> a)
pf :<*>: f a
px) = forall (k :: Type -> Type) a b. k (a -> b) -> k a -> Combinator k b
(:<*>:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f (a -> a)
pf forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
px
traverseCombinator forall a. f a -> m (k a)
expose (f a
p :*>: f a
q) = forall (k :: Type -> Type) a b. k a -> k b -> Combinator k b
(:*>:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
q
traverseCombinator forall a. f a -> m (k a)
expose (f a
p :<*: f b
q) = forall (k :: Type -> Type) a a. k a -> k a -> Combinator k a
(:<*:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f b
q
traverseCombinator forall a. f a -> m (k a)
expose (f a
p :<|>: f a
q) = forall (k :: Type -> Type) a. k a -> k a -> Combinator k a
(:<|>:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
q
traverseCombinator forall a. f a -> m (k a)
_ Combinator f a
Empty = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall (k :: Type -> Type) a. Combinator k a
Empty
traverseCombinator forall a. f a -> m (k a)
expose (Try f a
p) = forall (k :: Type -> Type) a. k a -> Combinator k a
Try forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p
traverseCombinator forall a. f a -> m (k a)
expose (LookAhead f a
p) = forall (k :: Type -> Type) a. k a -> Combinator k a
LookAhead forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p
traverseCombinator forall a. f a -> m (k a)
expose (NotFollowedBy f a
p) = forall (k :: Type -> Type) a. k a -> Combinator k ()
NotFollowedBy forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p
traverseCombinator forall a. f a -> m (k a)
expose (Branch f (Either a b)
b f (a -> a)
p f (b -> a)
q) = forall (k :: Type -> Type) a b c.
k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c
Branch forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f (Either a b)
b forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f (a -> a)
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f (b -> a)
q
traverseCombinator forall a. f a -> m (k a)
expose (Match f a
p [Defunc (a -> Bool)]
fs [f a]
qs f a
d) = forall (k :: Type -> Type) a b.
k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b
Match forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Defunc (a -> Bool)]
fs forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. f a -> m (k a)
expose [f a]
qs forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
d
traverseCombinator forall a. f a -> m (k a)
expose (Loop f ()
body f a
exit) = forall (k :: Type -> Type) a. k () -> k a -> Combinator k a
Loop forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f ()
body forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
exit
traverseCombinator forall a. f a -> m (k a)
expose (MakeRegister ΣVar a
σ f a
p f a
q) = forall a (k :: Type -> Type) b.
ΣVar a -> k a -> k b -> Combinator k b
MakeRegister ΣVar a
σ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. f a -> m (k a)
expose f a
q
traverseCombinator forall a. f a -> m (k a)
_ (GetRegister ΣVar a
σ) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall a (k :: Type -> Type). ΣVar a -> Combinator k a
GetRegister ΣVar a
σ)
traverseCombinator forall a. f a -> m (k a)
expose (PutRegister ΣVar a
σ f a
p) = forall a (k :: Type -> Type). ΣVar a -> k a -> Combinator k ()
PutRegister ΣVar a
σ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p
traverseCombinator forall a. f a -> m (k a)
_ (Position PosSelector
sel) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall (k :: Type -> Type). PosSelector -> Combinator k Int
Position PosSelector
sel)
traverseCombinator forall a. f a -> m (k a)
expose (Debug String
name f a
p) = forall (k :: Type -> Type) a. String -> k a -> Combinator k a
Debug String
name forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p
traverseCombinator forall a. f a -> m (k a)
_ (Pure Defunc a
x) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall a (k :: Type -> Type). Defunc a -> Combinator k a
Pure Defunc a
x)
traverseCombinator forall a. f a -> m (k a)
_ (Satisfy CharPred
f) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall (k :: Type -> Type). CharPred -> Combinator k Char
Satisfy CharPred
f)
traverseCombinator forall a. f a -> m (k a)
_ (Let MVar a
v) = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall a (k :: Type -> Type). MVar a -> Combinator k a
Let MVar a
v)
traverseCombinator forall a. f a -> m (k a)
expose (MetaCombinator MetaCombinator
m f a
p) = forall (k :: Type -> Type) a.
MetaCombinator -> k a -> Combinator k a
MetaCombinator MetaCombinator
m forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> m (k a)
expose f a
p