yi-0.4: Yi/IncrementalParse.hs
-- Copyright (c) JP Bernardy 2008
{-# OPTIONS -fglasgow-exts #-}
module Yi.IncrementalParse (Process, Void,
recoverWith, symbol, eof, runPolish,
P, AlexState (..), scanner) where
import Yi.Lexer.Alex (AlexState (..))
import Yi.Prelude
import Prelude ()
import Yi.Syntax
import Data.List hiding (map)
{- ----------------------------------------
- Based on a mix between "Polish Parsers, Step by Step (Hughes and Swierstra)",
and "Parallel Parsing Processes (Claessen)"
It's strongly advised to read the papers! :)
- The parser has "online" behaviour.
This is a big advantage because we don't have to parse the whole file to
begin syntax highlight the beginning of it.
- Basic error correction
- Based on Applicative functors.
This is not as powerful as Monadic parsers, but easier to work with. This is
needed if we want to build the result lazily.
-------------------------------------------}
data Void
type Process s a = Steps s a (Steps s Void Void)
-- | Our parsing processes.
-- To understand the design of this data type it is important to consider the
-- basic design goal: Our parser should return a (partial) result as soon as
-- possible, that is, as soon as only one of all possible parses of an input
-- can succeed. This also means we want to be able to return partial results.
-- We therefore have to transform our parse tree into a linearized form that
-- allows us to return parts of it as we parse them. Consider the following
-- data type:
--
-- > data BinTree = Node BinTree BinTree | Leaf Int
-- > ex1 = Node (Leaf 1) (Node (Leaf 2) (Leaf 3))
--
-- Provided we know the arity of each constructor, we can unambiguously
-- represent @ex1@ (without using parentheses to resolve ambiguity) as:
--
-- > Node Leaf 1 Node Leaf 2 Leaf 3
--
-- This is simply a pre-order printing of the tree type and, in this case, is
-- exactly how we defined @ex1@ without all the parentheses. It would,
-- however, be unnecessarily complicated to keep track of the arity of each
-- constructor, so we use a well-known trick: currying. Note, that the
-- original definition of @ex1@ is actually a shorter notation for
--
-- > ((Node $ (Leaf $ 1)) $ ((Node $ (Leaf $ 2)) $ (Leaf $ 3)))
--
-- or as a tree
--
-- > $
-- > .-------------'----------------------.
-- > $ $
-- > .--'-------. .-------------'-------.
-- > Node $ $ $
-- > .--'-. .--'-------. .--'-.
-- > Leaf 1 Node $ Leaf 3
-- > .--'-.
-- > Leaf 2
--
-- where @$@ represents function application. We can print this tree in
-- prefix-order:
--
-- > ($) ($) Node ($) Leaf 1 ($) ($) Node ($) Leaf 2 ($) Leaf 3
--
-- This consists of only two types of nodes -- values and applications -- but
-- we can construct values of any (non-strict) Haskell data type with it.
--
-- Unfortunately, it is a bit tricky to type those kinds of expressions in
-- Haskell. [XXX: example; develop solution step by step; continuations]
--
-- The parameter @r@ represents the type of the remainder of our expression.
-- TODO: Replace 'Doc:' by ^ when haddock supports GADTs
data Steps s a r where
-- These constructors describe the tree of values, as above
Val :: a -> Steps s b r -> Steps s a (Steps s b r)
-- Doc: The process that returns the value of type @a@ which is followed by a parser returning a value of type @b@.
App :: Steps s (b -> a) (Steps s b r) -> Steps s a r
-- Doc: Takes a process that returns a function @f@ of type @b -> a@ and is
-- followed by a process returning a value @x@ of type @b@. The resulting
-- process will return the result of applying the function @f@ to @x@.
Stop :: Steps s Void Void
-- These constructors describe the parser state
Shift :: Steps s a r -> Steps s a r
Done :: Steps s a r -> Steps s a r
-- Doc: The parser that signals success. The argument is the continuation.
Fails :: Steps s a r
-- Doc: The parser that signals failure.
Dislike :: Steps s a r -> Steps s a r
Suspend :: (Maybe [s] -> Steps s a r) -> Steps s a r
-- Doc: A suspension of the parser (this is the part borrowed from
-- Parallel Parsing Processes) The parameter to suspend's
-- continuation is a whole chunk of text; Nothing represents the
-- end of the input
instance Show (Steps s a r) where
show (Val _ p) = "v" ++ show p
show (App p) = "*" ++ show p
show (Stop) = "1"
show (Shift p) = ">" ++ show p
show (Done p) = "!" ++ show p
show (Dislike p) = "?" ++ show p
show (Fails) = "0"
show (Suspend _) = "..."
-- data F a b where
-- Snoc :: F a b -> (b -> c) -> F a c
-- Nil :: F a b
--
-- data S s a r where
-- S :: F a b -> Steps s a r -> S s a r
-- | Right-eval a fully defined process (ie. one that has no Suspend)
-- Returns value and continuation.
evalR :: Steps s a r -> (a, r)
evalR (Val a r) = (a,r)
evalR (App s) = let (f, s') = evalR s
(x, s'') = evalR s'
in (f x, s'')
evalR Stop = error "evalR: Can't create values of type Void"
evalR (Shift v) = evalR v
evalR (Done v) = evalR v
evalR (Dislike v) = -- trace "Yuck!" $
evalR v
evalR (Fails) = error "evalR: No parse!"
evalR (Suspend _) = error "evalR: Not fully evaluated!"
-- | Pre-compute a left-prefix of some steps (as far as possible)
evalL :: Steps s a r -> Steps s a r
evalL (Shift p) = evalL p
evalL (Dislike p) = evalL p
evalL (Val x r) = Val x (evalL r)
evalL (App f) = case evalL f of
(Val a (Val b r)) -> Val (a b) r
(Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r)
r -> App r
evalL x = x
-- | Push a chunk of symbols or eof in the process. This forces some suspensions.
push :: Maybe [s] -> Steps s a r -> Steps s a r
push ss p = case p of
(Suspend f) -> f ss
(Dislike p') -> Dislike (push ss p')
(Shift p') -> Shift (push ss p')
(Done p') -> Done (push ss p')
(Val x p') -> Val x (push ss p')
(App p') -> App (push ss p')
Stop -> Stop
Fails -> Fails
-- | Push some symbols.
pushSyms :: [s] -> Steps s a r -> Steps s a r
pushSyms x = push (Just x)
-- | Push eof
pushEof :: Steps s a r -> Steps s a r
pushEof = push Nothing
-- | A parser. (This is actually a parsing process segment)
newtype P s a = P (forall b r. Steps s b r -> Steps s a (Steps s b r))
instance Functor (P s) where
fmap f x = pure f <*> x
instance Applicative (P s) where
P f <*> P x = P (App . f . x)
pure x = P (Val x)
instance Alternative (P s) where
empty = P $ \_fut -> Fails
P a <|> P b = P $ \fut -> best (a fut) (b fut)
-- | Advance in the result steps, pushing results in the continuation.
-- (Must return one of: Done, Shift, Fail)
getProgress :: (Steps s a r -> Steps s b t) -> Steps s a r -> Steps s b t
getProgress f (Val a s) = getProgress (f . Val a) s
getProgress f (App s) = getProgress (f . App) s
-- getProgress f Stop = f Stop
getProgress f (Done p) = Done (f p)
getProgress f (Shift p) = Shift (f p)
getProgress f (Dislike p) = Dislike (f p)
getProgress _ (Fails) = Fails
getProgress _ Stop = error "getProgress: try to enter void"
getProgress f (Suspend p) = Suspend (\input -> f (p input))
best :: Steps x a s -> Steps x a s -> Steps x a s
--l `best` r | trace ("best: "++show (l,r)) False = undefined
Suspend f `best` Suspend g = Suspend (\input -> f input `best` g input)
Fails `best` p = p
p `best` Fails = p
Dislike a `best` b = bestD a b
a `best` Dislike b = bestD b a
Done a `best` Done _ = Done a -- error "ambiguous grammar"
-- There are sometimes many ways to fix an error. Pick the 1st one.
Done a `best` _ = Done a
_ `best` Done a = Done a
Shift v `best` Shift w = Shift (v `best` w)
p `best` q = getProgress id p `best` getProgress id q
-- as best, but lhs is disliked.
bestD :: Steps x a s -> Steps x a s -> Steps x a s
Suspend f `bestD` Suspend g = Suspend (\input -> f input `bestD` g input)
Fails `bestD` p = p
p `bestD` Fails = Dislike p
a `bestD` Dislike b = Dislike (best a b) -- back to equilibrium (prefer to do this, hence 1st case)
Dislike _ `bestD` b = b -- disliked twice: forget it.
Done _ `bestD` Done a = Done a -- we prefer rhs in this case
Done a `bestD` _ = Dislike (Done a)
_ `bestD` Done a = Done a
Shift v `bestD` Shift w = Shift (v `bestD` w)
_ `bestD` Shift w = Shift w -- prefer shifting than keeping a disliked possibility forever
p `bestD` q = getProgress id p `bestD` getProgress id q
runP :: forall t t1.
P t t1 -> Steps t t1 (Steps t Void Void)
runP (P p) = p (Done Stop)
-- | Run a parser.
runPolish :: forall s a. P s a -> [s] -> a
runPolish p input = fst $ evalR $ pushEof $ pushSyms input $ runP p
-- | Parse a symbol
symbol :: (s -> Bool) -> P s s
symbol f = P (\fut -> Suspend (symHelper fut))
where symHelper fut input =
case input of
Nothing -> Fails -- This is the eof!
Just [] -> Suspend (symHelper fut) -- end of the chunk: to be continued
Just (s:ss) -> if f s then push (Just ss) (Shift (Val s (fut)))
else Fails
-- | Parse the eof
eof :: P s ()
eof = P (\fut -> Suspend (symHelper fut))
where symHelper fut input =
case input of
Nothing -> Val () fut
Just [] -> Suspend (symHelper fut) -- end of the chunk: to be continued
Just (_:_) -> Fails
-- | Parse the same thing as the argument, but will be used only as
-- backup. ie, it will be used only if disjuncted with a failing
-- parser.
recoverWith :: forall s a. P s a -> P s a
recoverWith (P p) = P (Dislike . p)
----------------------------------------------------
type State st token result = (st, Process token result)
scanner :: forall st token result. P token result -> Scanner st token -> Scanner (State st token result) result
scanner parser input = Scanner
{
scanInit = (scanInit input, runP parser),
scanLooked = scanLooked input . fst,
scanRun = run,
scanEmpty = fst $ evalR $ pushEof $ runP parser
}
where
run :: State st token result -> [(State st token result, result)]
run (st,process) = updateState0 process $ scanRun input st
updateState0 :: Process token result -> [(st,token)] -> [(State st token result, result)]
updateState0 _ [] = []
updateState0 curState toks@((st,tok):rest) = ((st, curState), result) : updateState0 nextState rest
where nextState = evalL $ pushSyms [tok] $ curState
result = fst $ evalR $ pushEof $ pushSyms (fmap snd toks) $ curState