diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 7df773e..76cef52 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -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} diff --git a/app/Main.hs b/app/Main.hs index 88b1782..5dfb25e 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/Parser.hs b/app/Parser.hs index dcdc347..694eb64 100644 --- a/app/Parser.hs +++ b/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