better shunting errors

3 files changed, 76 insertions, 63 deletions

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"
+type PrlgError = String
+type PrlgResult = Either PrlgError PrlgStr
+err :: PrlgError -> Either PrlgError a
+err = Left
+
+ast2prlg :: Ops -> AST -> PrlgResult
+ast2prlg ot (List _ _) = err "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
+ast2prlg ot (Literal s) = pure (LiteralS s)
+ast2prlg ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
 
-shunt :: Ops -> [AST] -> PrlgStr
+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