{-# LANGUAGE GADTs #-}
module Parsers
( P -- :: * -> * -> *
, symbol -- :: P s s
, pfail -- :: P s a
, (+++) -- :: P s a -> P s a -> P s a
, Semantics -- :: * -> * -> *
, parse -- :: P s a -> Semantics s a
) where
-- | Naive deep embedding: each operation is implemented as a
-- constructor.
type P s a = Parser1 s a
symbol :: P s s
symbol = Symbol
pfail :: P s a
pfail = Fail
(+++) :: P s a -> P s a -> P s a
(+++) = Choice
instance Monad (Parser1 s) where
return = Return
(>>=) = (:>>=)
data Parser1 s a where
Symbol :: Parser1 s s
Fail :: Parser1 s a
Choice :: Parser1 s a -> Parser1 s a -> Parser1 s a
Return :: a -> Parser1 s a
(:>>=) :: Parser1 s a -> (a -> Parser1 s b) -> Parser1 s b
-- Final semantics to expose:
type Semantics s a = [s] -> [(a,[s])]
-- | Reference implementation/Semantics. (It's easy to see that
-- it's what we want, but maybe inefficient.)
run :: Parser1 s a -> Semantics s a
run Symbol = symbolS
run Fail = failS
run (Choice p q) = choiceS (run p) (run q)
run (Return x) = returnS x
run (p :>>= f) = run p `bindS` (run . f)
{- Starting point:
symbolS :: Semantics s s -- [s] -> [(s, [s])]
symbolS = error "TBD"
failS :: Semantics s a
failS = error "TBD
choiceS :: Semantics s a -> Semantics s a -> Semantics s a
choiceS = error "TBD"
returnS :: a -> Semantics s a
returnS = error "TBD"
bindS :: Semantics s a -> (a -> Semantics s b) -> Semantics s b
bindS = error "TBD"
-}
symbolS :: [s] -> [(s, [s])] -- Semantics s s
symbolS [] = [] -- no parse
symbolS (s:ss) = [(s, ss)] -- exactly one parse resuls
failS :: Semantics s a
failS _ = []
choiceS :: ([s] -> [(a, [s])]) -> Semantics s a -> ([s] -> [(a,[s])])
choiceS p q = \ss -> p ss ++ q ss
returnS :: a -> [s] -> [(a, [s])]
returnS x = \ss -> [(x, ss)] -- exactly one parse, input unchanged
-- bindS :: Semantics s a -> (a -> Semantics s b) -> Semantics s b
{-
bindS :: ( [s] -> [(a, [s])]) -> -- ^ the parser p
(a -> ([s] -> [(b, [s])])) -> -- ^ the function f
([s] -> -- ^ the input string
[(b, [s])])
-}
-- bindS p f = \ss -> concatMap (uncurry f) (p ss)
bindS p f = concatMap (uncurry f) . p
{-
symbolS :: Semantics s s
symbolS (c : s) = [(c, s)]
symbolS [] = []
failS :: Semantics s a
failS _ = []
choiceS :: Semantics s a -> Semantics s a -> Semantics s a
choiceS left right = \s -> left s ++ right s
returnS :: a -> Semantics s a
returnS x = \s -> [(x, s)]
bindS :: Semantics s a -> (a -> Semantics s b) -> Semantics s b
bindS pa a2pb = concatMap (uncurry a2pb) . pa
bindS' :: Semantics s a -> (a -> Semantics s b) -> Semantics s b
bindS' pa a2pb = \s -> let pas = pa s -- :: [(a, [s])]
pbss = map (uncurry a2pb) pas
in concat pbss
bindS'' :: Semantics s a ->(a -> Semantics s b) -> Semantics s b
bindS'' pa a2pb = \s -> [(y, s'') | (x, s') <- pa s
, (y, s'') <- a2pb x s']
-}
{-
Using this reference semantics we can prove (exercise) a number
of useful laws about parsers. We will use these laws later to
derive an efficient implementation of the library.
Notation: [| p |] = run p
For two parsers p and q we define
p == q iff ∀ s. [| p |] s == [| q |] s,
up to the order of elements in the result
(list is interpreted as a multiset).
Monad Laws
L1. return x >>= f == f x
L2. p >>= return == p
L3. (p >>= f) >>= g == p >>= (\x -> f x >>= g)
More laws about >>=, (+++) and fail
L4. fail >>= f == fail
L5. (p +++ q) >>= f == (p >>= f) +++ (q >>= f)
Laws about (+++) and fail
L6. fail +++ q == q
L7. p +++ fail == p
Laws about (+++)
L8. (p +++ q) +++ r == p +++ (q +++ r)
L9. p +++ q == q +++ p
-- multisets are important in L9!
Laws about >>=, (+++) and symbol
L10. (symbol >>= f) +++ (symbol >>= g)
== symbol >>= (\c -> f c +++ g c)
Here is the proof of L10 for the case of a non-empty input
string:
[| (symbol >>= f) +++ (symbol >>= g) |] (c:s)
== { semantics of (+++) }
[| symbol >>= f |] (c:s) ++ [| symbol >>= g |] (c:s)
== { semantics of >>= and symbol }
[| f c |] s ++ [| g c |] s
== { semantics of (+++) }
[| f c +++ g c |] s
== { semantics of symbol and >>= }
[| symbol >>= (\x -> f x +++ g x) |] (c:s)
Exercise: prove or test the laws
-}
{- The reference semantics is useful for reasoning, but
inefficient. There are three sources of inefficiency that we
can identify:
1. The list comprehension builds a lot of intermediate lists
which might be costly.
2. List append (++) is linear in its first argument which
means that left nested appl.s of (+++) get a quadratic
behaviour.
3. (+++) is treated in a depth first way, first computing the
results of the left parser, then computing the results of the
second parser. This leads to a space leak since we have to
hang on to the full input string to feed to the second
parser, while traversing the string with the first parser.
-}
-- To solve them we'll invent clever intermediate
-- representations.
-- Can we linearize sequencing (>>=)? (Would help with 1.)
data Parser2 s a where
SymbolBind2 :: (s -> Parser2 s a) -> Parser2 s a
-- SymbolBind f ≜ Symbol >>= f
Return2 :: a -> Parser2 s a
Choice2 :: Parser2 s a -> Parser2 s a -> Parser2 s a
Fail2 :: Parser2 s a
run2 :: Parser2 s a -> Semantics s a
run2 (SymbolBind2 f) = symbolBind2S (\s -> run2 (f s))
run2 (Return2 y) = returnS y
run2 (Choice2 p q) = choiceS (run2 p) (run2 q)
run2 Fail2 = failS
symbolBind2S :: (s -> Semantics s a) -> Semantics s a
symbolBind2S f [] = []
symbolBind2S f (x:xs) = f x xs
symbolBind2S' :: (s -> Semantics s a) -> Semantics s a
symbolBind2S' f = symbolS `bindS` f
{-
symbolS `bindS` f
= { def. of bindS }
concatMap (uncurry f) . symbolS
= { def. of symbolS }
\cs -> case cs of [] -> concatMap (uncurry f) []
(c : s) -> concatMap (uncurry f) [(c, s)]
= { concatMap lemmas }
\cs -> case cs of [] -> []
(c : s) -> uncurry f (c, s)
= { def. of uncurry }
\cs -> case cs of [] -> []
(c : s) -> f c s
-}
-- It turns out that we can also translate Parser1 into Parser2.
p12 :: Parser1 s a -> Parser2 s a
p12 Symbol = SymbolBind2 Return2 -- L1
p12 Fail = Fail2
p12 (Choice p q)= Choice2 (p12 p) (p12 q)
p12 (Return y) = Return2 y
p12 (Symbol :>>= k) = SymbolBind2 (p12 . k)
-- def of SymbolBind
p12 (Fail :>>= k) = Fail2
-- Parser law. L4.
p12 ((Choice p q):>>= k) = Choice2 (p12 (p :>>= k))
(p12 (q :>>= k))
-- Parser law. L5
p12 (Return y :>>= k) = p12 (k y)
-- monad law, L1
p12 ((p :>>= k') :>>= k) = p12 (p :>>= (\x -> k' x :>>= k))
-- monad law, L3
-- Can we linearize choice as well (+++)?
data Parser3 s a where
SymbolBind3 :: (s -> Parser3 s a) -> Parser3 s a
ReturnChoice3 :: a -> Parser3 s a -> Parser3 s a
-- ReturnChoice x p ≜ Return x +++ p
Fail3 :: Parser3 s a
run3 :: Parser3 s a -> Semantics s a
run3 (SymbolBind3 f) [] = []
run3 (SymbolBind3 f) (s : ss) = run3 (f s) ss
run3 (ReturnChoice3 x p) l = (x , l) : run3 p l
-- ~= run (Return x +++ p)
run3 Fail3 l = []
-- But it turns out that we can translate 2 into 3!
p23 :: Parser2 s a -> Parser3 s a
p23 (SymbolBind2 f) = SymbolBind3 (p23 . f)
p23 (Return2 x) = ReturnChoice3 x Fail3
-- def. of ReturnChoice
p23 (Choice2 p q) = best (p23 p) (p23 q)
p23 Fail2 = Fail3
best :: Parser3 s a -> Parser3 s a -> Parser3 s a
best (SymbolBind3 f) (SymbolBind3 g) -- L10
= SymbolBind3 (\s -> best (f s) (g s))
best p (ReturnChoice3 x q) -- L8 (+++ commut)
= ReturnChoice3 x (best p q)
best (ReturnChoice3 x q) p -- L9 (+++ assoc)
= ReturnChoice3 x (best p q)
best p Fail3 = p -- L6
best Fail3 q = q -- L7
-- | Efficient implementation for general syntax:
parse :: P s a -> Semantics s a
parse = run3 . p23 . p12
-- we could show formally:
-- (x , s) ∈ run p ss <=> (x , s) ∈ run2 (p12 p) ss
-- (x , s) ∈ run2 p ss <=> (x , s) ∈ run3 (p23 p) ss
-- and therefore:
-- (x , s) ∈ run p ss <=> (x , s) ∈ parse p ss
-- Exercise: prove or test
{----------------------
NOTES:
* L4 to L10 are "parser laws", expected to hold of any
well-behaved parser.
-}