ideas-0.7: src/Common/Strategy/Parsing.hs
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- Basic machinery for executing a core strategy expression.
--
-----------------------------------------------------------------------------
module Common.Strategy.Parsing
( Step(..)
, State, makeState, stack, choices, trace, value
, parseDerivationTree, replay, runCore, runCoreWith
) where
import Common.Classes
import Common.Derivation
import Common.Strategy.Core
import Common.Transformation
import Control.Monad
----------------------------------------------------------------------
-- Step data type
data Step l a = Enter l | Exit l | RuleStep (Rule a)
deriving Show
instance Apply (Step l) where
applyAll (RuleStep r) = applyAll r
applyAll _ = return
----------------------------------------------------------------------
-- State data type
data State l a = S
{ stack :: [Either l (Core l a)]
, choices :: [Bool]
, trace :: [Step l a]
, value :: a
}
makeState :: Core l a -> a -> State l a
makeState core a = push core (S [] [] [] a)
----------------------------------------------------------------------
-- Parse derivation tree
parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a)
parseDerivationTree state = addBranches list node
where
xs = firsts state
empty = not (null [ () | (Ready, _) <- xs ])
node = singleNode state empty
list = [ (step, parseDerivationTree s) | (Result step, s) <- xs ]
firsts :: State l a -> [(Result (Step l a), State l a)]
firsts st =
case pop st of
Nothing -> [(Ready, st)]
Just (Left l, s) -> [(Result (Exit l), traceExit l s)]
Just (Right core, s) -> firstsStep core s
where
firstsStep core state =
case core of
a :*: b -> firstsStep a (push b state)
a :|: b -> chooseFor True a ++ chooseFor False b
Rec i a -> firstsStep (substCoreVar i core a) state
Var _ -> freeCoreVar "firsts"
Rule r -> hasStep (RuleStep r) (useRule r state)
Label l a -> hasStep (Enter l) [push a (pushExit l state)]
Not a -> guard (checkNot a state) >> firsts state
a :|>: b -> firstsStep (coreOrElse a b) state
Many a -> firstsStep (coreMany a) state
Repeat a -> firstsStep (coreRepeat a) state
Fail -> []
Succeed -> firsts state
where
chooseFor b = flip firstsStep (makeChoice b state)
hasStep step xs = [ (Result step, traceStep step s) | s <- xs ]
-- helper datatype
data Result a = Result a | Ready
----------------------------------------------------------------------
-- Running the parser
runCore :: Core l a -> a -> [a]
runCore core = runState . makeState core
runCoreWith :: CoreEnv l a -> Core l a -> a -> [a]
runCoreWith env = runCore . substCoreEnv env
runState :: State l a -> [a]
runState st =
case pop st of
Nothing -> [value st]
Just (Left _, s) -> runState s
Just (Right core, s) -> runStep core s
where
runStep core state =
case core of
a :*: b -> runStep a (push b state)
a :|: b -> runStep a state ++ runStep b state
Rec i a -> runStep (substCoreVar i core a) state
Var _ -> freeCoreVar "runState"
Rule r -> concatMap runState (useRule r state)
Label _ a -> runStep a state
Not a -> guard (checkNot a state) >> runState state
a :|>: b -> let xs = runStep a state
in if null xs then runStep b state else xs
Many a -> runStep (coreMany a) state
Repeat a -> runStep (coreRepeat a) state
Fail -> []
Succeed -> runState state
----------------------------------------------------------------------
-- Replay a parse run
replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a)
replay n0 bs0 = replayState n0 bs0 . flip makeState noValue
where
noValue = error "no value in replay"
replayState n bs state =
case pop state of
_ | n==0 -> return state
Nothing -> return state
Just (Left l, s) -> replayState (n-1) bs (traceExit l s)
Just (Right core, s) -> replayStep n bs core s
replayStep n bs core state =
case core of
_ | n==0 -> return state
a :*: b -> replayStep n bs a (push b state)
a :|: b -> case bs of
[] -> fail "replay failed"
x:xs -> let new = if x then a else b
in replayStep n xs new (makeChoice x state)
Rec i a -> replayStep n bs (substCoreVar i core a) state
Var _ -> freeCoreVar "replay"
Rule r -> replayState (n-1) bs (traceRule r state)
Label l a -> replayStep (n-1) bs a (pushExit l (traceEnter l state))
Not _ -> replayState n bs state
a :|>: b -> replayStep n bs (coreOrElse a b) state
Many a -> replayStep n bs (coreMany a) state
Repeat a -> replayStep n bs (coreRepeat a) state
Fail -> fail "replay failed"
Succeed -> replayState n bs state
----------------------------------------------------------------------
-- Local helper functions and instances
push :: Core l a -> State l a -> State l a
push core s = s {stack = Right core : stack s}
pushExit :: l -> State l a -> State l a
pushExit l s = s {stack = Left l : stack s}
pop :: State l a -> Maybe (Either l (Core l a), State l a)
pop s = case stack s of
[] -> Nothing
x:xs -> Just (x, s {stack = xs})
makeChoice :: Bool -> State l a -> State l a
makeChoice b s = s {choices = b : choices s}
checkNot :: Core l a -> State l a -> Bool
checkNot core = null . runCore core . value
useRule :: Rule a -> State l a -> [State l a]
useRule r state = [ state {value = b} | b <- applyAll r (value state) ]
traceEnter, traceExit :: l -> State l a -> State l a
traceEnter = traceStep . Enter
traceExit = traceStep . Exit
traceRule :: Rule a -> State l a -> State l a
traceRule = traceStep . RuleStep
traceStep :: Step l a -> State l a -> State l a
traceStep step s = s {trace = step : trace s}
substCoreVar :: Int -> Core l a -> Core l a -> Core l a
substCoreVar i a = substCoreEnv (insertCoreEnv i a emptyCoreEnv)
freeCoreVar :: String -> a
freeCoreVar caller = error $ "Free var in core expression: " ++ caller