better shunting errors
This commit is contained in:
parent
14b77cd058
commit
8f47919624
|
|
@ -6,7 +6,7 @@ import qualified Data.Map as M
|
|||
{- VAM 2P, done the lazy way -}
|
||||
data StrTable =
|
||||
StrTable Int (M.Map String Int) (M.Map Int String)
|
||||
deriving Show
|
||||
deriving (Show)
|
||||
|
||||
emptystrtable = StrTable 0 M.empty M.empty
|
||||
|
||||
|
|
@ -15,12 +15,17 @@ strtablize t@(StrTable nxt fwd rev) str =
|
|||
Just i -> (t, i)
|
||||
_ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt)
|
||||
|
||||
data Id = Id {str::Int,arity::Int} deriving (Show, Eq, Ord)
|
||||
data Id =
|
||||
Id
|
||||
{ str :: Int
|
||||
, arity :: Int
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Datum
|
||||
= Atom Int -- unifies a constant
|
||||
| Struct Id -- unifies a structure with arity
|
||||
-- | VoidVar -- unifies with anything
|
||||
| VoidVar -- unifies with anything
|
||||
-- | LocalVar Int -- unifies with a local variable (possibly making a new one when it's not in use yet)
|
||||
-- | Ref Int -- unifies with the referenced value on the heap (not to be used in code)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
|
@ -89,10 +94,13 @@ proveStep c f i = go i
|
|||
= unify a b
|
||||
where
|
||||
uok = c i {cur = cur {hed = hs, gol = gs}}
|
||||
unify (Atom a) (Atom b)
|
||||
| a == b = uok
|
||||
unify (Struct a) (Struct b)
|
||||
| a == b = uok
|
||||
unify VoidVar VoidVar = uok
|
||||
unify (Atom a) (Atom b) | a == b = uok
|
||||
unify VoidVar (Atom _) = uok
|
||||
unify (Atom _) VoidVar = uok
|
||||
unify (Struct a) (Struct b) | a == b = uok
|
||||
unify VoidVar (Struct Id{arity=a}) = c i {cur = cur {hed = replicate a (U VoidVar) ++ hs, gol = gs}}
|
||||
unify (Struct Id{arity=a}) VoidVar = c i {cur = cur {hed = hs, gol = replicate a (U VoidVar) ++ gs}}
|
||||
unify _ _ = backtrack i
|
||||
{- Resulution -}
|
||||
go i@Interp { cur = cur@Cho {hed = hed, gol = gol, stk = stk, cut = cut}
|
||||
|
|
|
|||
12
app/Main.hs
12
app/Main.hs
|
|
@ -19,8 +19,8 @@ ppr =
|
|||
, outputOptionsPageWidth = 80
|
||||
}
|
||||
|
||||
interpret :: String -> InputT IO ()
|
||||
interpret = liftIO . lex
|
||||
interpret :: String -> IO ()
|
||||
interpret = lex
|
||||
where
|
||||
lex input =
|
||||
case MP.parse P.lexPrlg "-" input of
|
||||
|
|
@ -34,15 +34,13 @@ interpret = liftIO . lex
|
|||
|
||||
main :: IO ()
|
||||
main =
|
||||
runInputT defaultSettings $ do
|
||||
outputStrLn "PRLG."
|
||||
loop
|
||||
runInputT defaultSettings loop
|
||||
where
|
||||
loop :: InputT IO ()
|
||||
loop = do
|
||||
minput <- getInputLine "|= "
|
||||
minput <- getInputLine "prlg> "
|
||||
case minput of
|
||||
Nothing -> return ()
|
||||
Just input -> do
|
||||
interpret input
|
||||
liftIO $ interpret input
|
||||
loop
|
||||
|
|
|
|||
107
app/Parser.hs
107
app/Parser.hs
|
|
@ -227,64 +227,71 @@ defaultOps =
|
|||
, (":-", Op 1000 $ Infix X X)
|
||||
]
|
||||
|
||||
ast2prlg :: Ops -> AST -> PrlgStr
|
||||
ast2prlg ot (List _ _) = error "no lists yet"
|
||||
ast2prlg ot (Seq ss) = shunt ot ss
|
||||
ast2prlg ot (Literal s) = LiteralS s
|
||||
ast2prlg ot (Call fn ss) = CallS fn $ map (shunt ot) ss
|
||||
type PrlgError = String
|
||||
type PrlgResult = Either PrlgError PrlgStr
|
||||
err :: PrlgError -> Either PrlgError a
|
||||
err = Left
|
||||
|
||||
shunt :: Ops -> [AST] -> PrlgStr
|
||||
ast2prlg :: Ops -> AST -> PrlgResult
|
||||
ast2prlg ot (List _ _) = err "no lists yet"
|
||||
ast2prlg ot (Seq ss) = shunt ot ss
|
||||
ast2prlg ot (Literal s) = pure (LiteralS s)
|
||||
ast2prlg ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
|
||||
|
||||
shunt :: Ops -> [AST] -> PrlgResult
|
||||
shunt optable = start
|
||||
where
|
||||
start :: [AST] -> PrlgStr
|
||||
start :: [AST] -> PrlgResult
|
||||
start [x] = rec x --singleton, possibly either a single operator name or a single value
|
||||
start [] = error "wat seq"
|
||||
start [] = err "empty parentheses?"
|
||||
start xs = wo [] [] xs
|
||||
{- "want operand" state, incoming literal -}
|
||||
wo :: Ops -> [PrlgStr] -> [AST] -> PrlgStr
|
||||
wo :: Ops -> [PrlgStr] -> [AST] -> PrlgResult
|
||||
wo ops vs (l@(Literal x):xs)
|
||||
| Just _ <- getPrefix x
|
||||
, Just (ops', vs') <- pushPrefix ops vs x = wo ops' vs' xs
|
||||
| isOperand x = ho ops (rec l : vs) xs
|
||||
| otherwise = error $ "want valid operand"
|
||||
| Right _ <- getPrefix x
|
||||
, Right (ops', vs') <- pushPrefix ops vs x = wo ops' vs' xs
|
||||
| isOperand x = do l' <- rec l
|
||||
ho ops (l' : vs) xs
|
||||
| otherwise = err "expected operand"
|
||||
{- incoming non-literal (i.e., surely operand), push it and switch to "have operand" -}
|
||||
wo ops vs (x:xs) = ho ops (rec x : vs) xs
|
||||
wo ops vs (x:xs) = do x' <- rec x
|
||||
ho ops (x' : vs) xs
|
||||
{- end of stream, but the operand is missing -}
|
||||
wo ops vs [] = error "missing final operand"
|
||||
wo ops vs [] = err "expected final operand"
|
||||
{- "have operand" state, incoming operator -}
|
||||
ho :: Ops -> [PrlgStr] -> [AST] -> PrlgStr
|
||||
ho :: Ops -> [PrlgStr] -> [AST] -> PrlgResult
|
||||
ho ops vs xs'@(Literal x:xs)
|
||||
| Just _ <- getSuffix x
|
||||
, Just (ops', vs') <- pushSuffix ops vs x = ho ops' vs' xs
|
||||
| Just _ <- getInfix x
|
||||
, Just (ops', vs') <- pushInfix ops vs x = wo ops' vs' xs
|
||||
| Right _ <- getSuffix x
|
||||
, Right (ops', vs') <- pushSuffix ops vs x = ho ops' vs' xs
|
||||
| Right _ <- getInfix x
|
||||
, Right (ops', vs') <- pushInfix ops vs x = wo ops' vs' xs
|
||||
| isOperand x = ho ops vs (Literal "" : xs') -- app (see below)
|
||||
| Just _ <- getPrefix x = ho ops vs (Literal "" : xs') -- also app!
|
||||
| otherwise = error "want valid infix"
|
||||
| Right _ <- getPrefix x = ho ops vs (Literal "" : xs') -- also app!
|
||||
| otherwise = err "expected infix or suffix operator"
|
||||
{- incoming operand; there's an app between -}
|
||||
ho ops vs xs@(_:_) = ho ops vs (Literal "" : xs)
|
||||
{- the last operand was last, pop until finished -}
|
||||
ho [] [res] [] = res
|
||||
ho ops vs [] =
|
||||
let (ops', vs') = pop ops vs
|
||||
in ho ops' vs' []
|
||||
ho [] [res] [] = pure res
|
||||
ho ops vs [] = do (ops', vs') <- pop ops vs
|
||||
ho ops' vs' []
|
||||
{- recurse to delimited subexpression -}
|
||||
rec :: AST -> PrlgStr
|
||||
rec :: AST -> PrlgResult
|
||||
rec = ast2prlg optable
|
||||
{- pop a level, possibly uncovering a higher prio -}
|
||||
pop ((x, Op _ (Infix _ _)):ops) (r:l:vs) = (ops, (CallS x [l, r] : vs))
|
||||
pop ((x, Op _ (Prefix _)):ops) (p:vs) = (ops, (CallS x [p] : vs))
|
||||
pop ((x, Op _ (Suffix _)):ops) (p:vs) = (ops, (CallS x [p] : vs))
|
||||
pop _ _ = error "pop borked"
|
||||
pop ((x, Op _ (Infix _ _)):ops) (r:l:vs) = pure (ops, (CallS x [l, r] : vs))
|
||||
pop ((x, Op _ (Prefix _)):ops) (p:vs) = pure (ops, (CallS x [p] : vs))
|
||||
pop ((x, Op _ (Suffix _)):ops) (p:vs) = pure (ops, (CallS x [p] : vs))
|
||||
pop _ _ = err "internal err: pop borked"
|
||||
{- Operator checks -}
|
||||
uniq [x] = Just x
|
||||
uniq _ = Nothing
|
||||
uniq [x] = pure x
|
||||
uniq _ = err "ambiguous operator"
|
||||
getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x]
|
||||
getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x]
|
||||
getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x]
|
||||
isOperand x = null [op | (s, op) <- optable, s == x]
|
||||
{- actual pushery -}
|
||||
canPush [] op = Just True
|
||||
canPush :: Ops -> Op -> Either PrlgError Bool
|
||||
canPush [] op = pure True
|
||||
canPush ((_, Op p f):ops) (Op np nf) = go p f np nf
|
||||
{- helper -}
|
||||
where
|
||||
|
|
@ -293,34 +300,34 @@ shunt optable = start
|
|||
{- pushing a prefix -}
|
||||
go prio (Infix _ l) nprio (Prefix _) =
|
||||
if prioLtOp l nprio prio
|
||||
then Just True
|
||||
else Nothing
|
||||
then pure True
|
||||
else err "prefix on infix"
|
||||
go prio (Prefix l) nprio (Prefix r) =
|
||||
if prioLtOp l nprio prio
|
||||
then Just True
|
||||
else Nothing
|
||||
go prio (Suffix l) nprio (Prefix r) = error "wat sufix" --not just a normal prio clash
|
||||
then pure True
|
||||
else err "prefix on prefix"
|
||||
go prio (Suffix l) nprio (Prefix r) = err "wat suffix?!" --not just a normal prio clash
|
||||
{- pushing a suffix -}
|
||||
go prio (Prefix l) nprio (Suffix r) = clash prio l nprio r
|
||||
go prio (Suffix _) nprio (Suffix r) = Just $ prioLtOp r nprio prio
|
||||
go prio (Suffix _) nprio (Suffix r) = pure $ prioLtOp r nprio prio
|
||||
go prio (Infix _ l) nprio (Suffix r) = clash prio l nprio r
|
||||
{- pushing an infix -}
|
||||
go prio (Prefix l) nprio (Infix r _) = clash prio l nprio r
|
||||
go prio (Suffix _) nprio (Infix r _) =
|
||||
if prioLtOp r nprio prio
|
||||
then Nothing
|
||||
else Just False
|
||||
then err "infix on suffix"
|
||||
else pure False
|
||||
go prio (Infix _ l) nprio (Infix r _) = clash prio l nprio r
|
||||
{- helper for cases that look like: a `xfy` b `yfx` c -}
|
||||
clash p l np r
|
||||
| p < np = Just False
|
||||
| p > np = Just True
|
||||
| p < np = pure False
|
||||
| p > np = pure True
|
||||
| p == np
|
||||
, r == Y = Just False
|
||||
, r == Y = pure False
|
||||
| p == np
|
||||
, l == Y
|
||||
, r == X = Just True
|
||||
| otherwise = Nothing
|
||||
, r == X = pure True
|
||||
| otherwise = err "priority clash"
|
||||
{- actual shunting -}
|
||||
pushPrefix ops vs x = getPrefix x >>= shunt1 ops vs x
|
||||
pushSuffix ops vs x = getSuffix x >>= shunt1 ops vs x
|
||||
|
|
@ -328,6 +335,6 @@ shunt optable = start
|
|||
shunt1 ops vs x op = do
|
||||
cp <- canPush ops op
|
||||
if cp
|
||||
then return ((x, op) : ops, vs)
|
||||
else let (ops', vs') = pop ops vs
|
||||
in shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush
|
||||
then pure ((x, op) : ops, vs)
|
||||
else do (ops', vs') <- pop ops vs
|
||||
shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush
|
||||
|
|
|
|||
Loading…
Reference in a new issue