module Text.Syntactical.Yard (
Shunt(..), Failure(..), Rule(..),
initial, isDone, shunt, step, steps, showFailure
) where
import Data.List (intersperse)
import Text.Syntactical.Data (
SExpr(..), Tree(..),
Hole(..), Part(..), Table, Priority(..),
begin, end, leftOpen, rightOpen, rightHole, discard,
applicator, applicator', continue, original, priority,
arity, symbol, next, current,
findBoth, findBegin, FindBegin(..), FindBoth(..), Ambiguity(..),
Token, toString, operator,
showPart, showSExpr, showTree
)
data Rule a = Initial
| Argument
| Application
| ApplyOp
| StackApp
| StackL
| StackOp
| ContinueOp
| MatchedR
| SExpr
| Done (Result a)
deriving (Show, Eq)
isInitial :: Rule a -> Bool
isInitial Initial = True
isInitial _ = False
stackedOp :: Rule a -> Bool
stackedOp StackL = True
stackedOp StackOp = True
stackedOp ContinueOp = True
stackedOp _ = False
data Result a =
Success
| Failure (Failure a)
deriving (Eq, Show)
data Failure a =
MissingBefore [[a]] a
| MissingAfter [a] [a]
| CantMix (Part a) (Part a)
| MissingSubBetween a a
| MissingSubBefore a
| MissingSubAfter a
| Ambiguity Ambiguity
| Unexpected
deriving (Eq, Show)
failure :: Failure a -> Rule a
failure f = Done $ Failure f
data Shunt a = S
[SExpr a]
[Tree a]
[[SExpr a]]
(Rule a)
isDone :: Shunt a -> Bool
isDone (S _ _ _ (Done _)) = True
isDone _ = False
rule :: Shunt a -> Rule a -> Shunt a
rule (S tt st oo _) = S tt st oo
initial :: [SExpr a] -> Shunt a
initial ts = S ts [] [[]] Initial
shunt :: Token a => Table a -> [SExpr a] -> Either (Failure a) (SExpr a)
shunt table ts = case fix $ initial ts of
S [] [] [[o']] (Done Success) -> Right o'
S _ _ _ (Done (Failure f)) -> Left f
_ -> error "can't happen"
where fix s = let s' = step table s in
if isDone s' then s' else fix s'
step :: Token a => Table a -> Shunt a -> Shunt a
step _ (S tt (s@(Part y):ss) oo@(os:oss) _) | end y && not (rightOpen y)
= if discard y
then let (o:os') = os in S (o:tt) ss (os':oss) MatchedR
else let ((o:os'):oss') = apply s oo in S (o:tt) ss (os':oss') MatchedR
step table (S (t:ts) st@(s:_) oo@(os:oss) _)
| applicator table t = case s of
Part y
| rightHole y == Just SExpression ->
S ts st ((t:os):oss) SExpr
| otherwise ->
S ts (s2t t:st) ([]:oo) StackApp
Leaf _ -> S ts st ((t:os):oss) Argument
Branch _ -> S ts st ((t:os):oss) Argument
step table (S tt@(Atom x:ts) st@(s:ss) oo _)
| applicator' table s =
case findBoth table x st of
BBegin pt1
| not (leftOpen pt1) && rightHole pt1 == Just SExpression ->
S ts (Part pt1:st) ([]:oo) StackL
| not (leftOpen pt1) ->
S ts (Part pt1:st) oo StackL
_ ->
S tt ss (apply s oo) Application
step table sh@(S tt@(t@(Atom x):ts) st@(s@(Part y):ss) oo@(os:oss) ru) =
case findBoth table x st of
BContinue pt1 -> go pt1
BBegin pt1 -> go pt1
BMissingBegin ps -> rule sh (failure $ ps `MissingBefore` x)
BNothing -> error "can't happen"
BAmbiguous amb -> rule sh (failure $ Ambiguity amb)
where
go pt1
| rightHole y == Just SExpression && pt1 `continue` y && stackedOp ru =
let ([]:h:oss') = oo
in S ts (Part pt1:ss) ((List []:h):oss') ContinueOp
| rightHole y == Just SExpression && pt1 `continue` y =
let os':h:oss' = oo
ap = List (reverse os')
in S ts (Part pt1:ss) ((ap:h):oss') ContinueOp
| rightHole pt1 == Just Distfix && rightHole y == Just SExpression =
S ts (Part pt1:st) oo StackL
| rightHole pt1 == Just SExpression =
S ts (Part pt1:st) ([]:oo) StackL
| rightHole y == Just SExpression =
S ts st ((t:os):oss) SExpr
| rightOpen y && leftOpen pt1 && stackedOp ru =
rule sh (failure $ symbol y `MissingSubBetween` x)
| pt1 `continue` y = S ts (Part pt1:ss) oo ContinueOp
| not (leftOpen pt1) && begin pt1 = S ts (Part pt1:st) oo StackL
| otherwise = case pt1 `priority` y of
Lower -> S tt ss (apply s oo) ApplyOp
Higher -> S ts (Part pt1:st) oo StackOp
NoPriority -> rule sh (failure $ CantMix pt1 y)
step _ sh@(S [] (s:ss) oo ru) = case s of
Leaf _ -> S [] ss (apply s oo) Application
Branch _ -> S [] ss (apply s oo) Application
Part y | end y && rightOpen y && stackedOp ru ->
rule sh (failure $ MissingSubAfter $ symbol y)
| end y ->
S [] ss (apply s oo) ApplyOp
| otherwise ->
rule sh (failure $
next y `MissingAfter` current y)
step table sh@(S (t:ts) [] oo ru) = case t of
List _ -> S ts [s2t t] ([]:oo) StackApp
Atom x -> case findBegin table x of
NoBegin -> S ts [s2t t] ([]:oo) StackApp
Begin pt1 -> go pt1
MissingBegin xs -> rule sh (failure $ xs `MissingBefore` x)
AmbiguousBegin amb -> rule sh (failure $ Ambiguity amb)
where
go pt1
| leftOpen pt1 && isInitial ru =
rule sh (failure $ MissingSubBefore $ symbol pt1)
| leftOpen pt1 =
S ts [Part pt1] oo StackOp
| rightHole pt1 == Just SExpression =
S ts [Part pt1] ([]:oo) StackL
| otherwise =
S ts [Part pt1] oo StackL
step _ sh@(S [] [] [[_]] _) = rule sh $ Done Success
step _ sh = rule sh (failure Unexpected)
apply :: Token a => Tree a -> [[SExpr a]] -> [[SExpr a]]
apply (Part y) (os:oss) | end y =
if length l /= nargs
then error "can't happen"
else (operator (original y) (reverse l) : r) : oss
where nargs = arity y
(l,r) = splitAt nargs os
apply (Leaf x) (os:h:oss) = (ap:h):oss
where ap = if null os then Atom x else List (Atom x:reverse os)
apply (Branch xs) (os:h:oss) = (ap:h):oss
where ap = if null os then List (map t2s xs) else List (List (map t2s xs):reverse os)
apply _ _ = error "can't happen"
steps :: Token a => Table a -> [SExpr a] -> IO ()
steps table ts = do
putStrLn " Input Stack Output Rule"
let sh = iterate (step table) $ initial ts
l = length $ takeWhile (not . isDone) sh
mapM_ (putStrLn . showShunt) (take (l + 1) sh)
s2t :: SExpr a -> Tree a
s2t (Atom x) = Leaf x
s2t (List xs) = Branch $ map s2t xs
t2s :: Tree a -> SExpr a
t2s (Leaf x) = Atom x
t2s (Branch xs) = List $ map t2s xs
t2s (Part _) = error "can't convert a Tree Part to a SExpr"
showFailure :: Token a => Failure a -> String
showFailure f = case f of
MissingBefore ps p ->
"Parse error: missing operator parts " ++
concatMap (unwords . map toString) ps ++
" before " ++ toString p
MissingAfter p ps ->
"Parse error: missing operator part " ++
concat (intersperse ", " $ map toString p) ++ " after " ++
unwords (map toString ps)
CantMix a b ->
"Parse error: cannot mix operators " ++ showPart a ++
" and " ++ showPart b
MissingSubBetween a b ->
"Parse error: no sub-expression between " ++ toString a ++
" and " ++ toString b
MissingSubBefore a ->
"Parse error: no sub-expression before " ++ toString a
MissingSubAfter a ->
"Parse error: no sub-expression after " ++ toString a
Ambiguity _ ->
"Parse error: the symbol is an ambiguous part"
Unexpected ->
"Parsing raised a bug"
showRule :: Token a => Rule a -> String
showRule ru = case ru of
Initial -> "Initial"
Argument -> "Argument"
Application -> "Application"
StackApp -> "StackApp"
ApplyOp -> "ApplyOp"
StackL -> "StackL"
StackOp -> "StackOp"
ContinueOp -> "ContinueOp"
MatchedR -> "MatchedR"
SExpr -> "SExpr"
Done result -> case result of
Success -> "Success"
Failure f -> "Failure:\n" ++ showFailure f
showShunt :: Token a => Shunt a -> String
showShunt (S ts ss os ru) =
pad 20 ts ++ pad' 20 ss ++ pads 20 os ++ " " ++ showRule ru
bracket :: [String] -> String
bracket s = "[" ++ (concat . intersperse ",") s ++ "]"
pad' :: Token a => Int -> [Tree a] -> String
pad' n s =
let s' = bracket . map showTree $ s
in replicate (n length s') ' ' ++ s'
pad :: Token a => Int -> [SExpr a] -> String
pad n s =
let s' = bracket . map showSExpr $ s
in replicate (n length s') ' ' ++ s'
pads :: Token a => Int -> [[SExpr a]] -> String
pads n s =
let s' = bracket .
map (bracket . map showSExpr) $ s
in replicate (n length s') ' ' ++ s'