better shunting errors

1 files changed, 56 insertions, 49 deletions

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