interpreter interprets.

1 files changed, 51 insertions, 48 deletions

diff --git a/app/Parser.hs b/app/Parser.hs
index 694eb64..302194e 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -13,7 +13,6 @@ import Text.Megaparsec
 import Text.Megaparsec.Char
 
 import Compiler (PrlgStr(..))
-import Debug.Trace
 
 singleToks = ",;|()[]"
 
@@ -83,7 +82,8 @@ instance TraversableStream [Lexeme] where
       handleEmpty x = x
       go
         | o <= pstateOffset pst =
-          ( Just . handleEmpty $ pstateLinePrefix pst ++
+          ( Just . handleEmpty $
+            pstateLinePrefix pst ++
             takeWhile (/= '\n') (concatMap showTok $ pstateInput pst)
           , pst)
         | o > pstateOffset pst =
@@ -209,34 +209,21 @@ numArgs (Op _ f) = go f
 
 type Ops = [(String, Op)]
 
-defaultOps :: Ops
-defaultOps =
-  [ ("", Op 0 $ Infix X Y)
-  , ("+", Op 100 $ Prefix X)
-  , ("!", Op 100 $ Suffix Y)
-  , ("-", Op 100 $ Prefix Y)
-  , ("*", Op 100 $ Infix Y X)
-  , ("+", Op 200 $ Infix Y X)
-  , ("++", Op 200 $ Infix X Y)
-  , ("-", Op 200 $ Infix Y X)
-  , ("<", Op 300 $ Infix X X)
-  , (">", Op 300 $ Infix X X)
-  , ("=", Op 400 $ Infix X X)
-  , (",", Op 800 $ Infix X Y)
-  , (";", Op 900 $ Infix X Y)
-  , (":-", Op 1000 $ Infix X X)
-  ]
-
 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) = pure (LiteralS s)
-ast2prlg ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
+ast2prlg ot = ast2prlg' (("", Op 0 $ Infix X Y) : ot)
+
+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
@@ -245,38 +232,51 @@ shunt optable = start
     start [x] = rec x --singleton, possibly either a single operator name or a single value
     start [] = err "empty parentheses?"
     start xs = wo [] [] xs
+    resolve = foldr1 (<|>)
     {- "want operand" state, incoming literal -}
     wo :: Ops -> [PrlgStr] -> [AST] -> PrlgResult
-    wo ops vs (l@(Literal x):xs)
-      | 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"
+    wo ops vs (l@(Literal x):xs) =
+      resolve
+        [ do getPrefix x
+             (ops', vs') <- pushPrefix ops vs x
+             wo ops' vs' xs
+        , do getOperand x
+             l' <- rec l
+             ho ops (l' : vs) xs
+        , err "expected operand"
+        ]
     {- incoming non-literal (i.e., surely operand), push it and switch to "have operand" -}
-    wo ops vs (x:xs) = do x' <- rec x
-                          ho ops (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 [] = err "expected final operand"
-    {- "have operand" state, incoming operator -}
+    {- "have operand" state, expecting an operator -}
     ho :: Ops -> [PrlgStr] -> [AST] -> PrlgResult
-    ho ops vs xs'@(Literal x: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)
-      | 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'@(Literal x:xs) =
+      resolve
+        [ do getSuffix x
+             (ops', vs') <- pushSuffix ops vs x
+             ho ops' vs' xs
+        , do getInfix x
+             (ops', vs') <- pushInfix ops vs x
+             wo ops' vs' xs
+        , do getOperand x
+             ho ops vs (Literal "" : xs') -- app (see below)
+        , do getPrefix x
+             ho ops vs (Literal "" : xs') -- also app!
+        , err "expected infix or suffix operator"
+        ]
+    {- incoming non-literal operand; there must be an app in between -}
     ho ops vs xs@(_:_) = ho ops vs (Literal "" : xs)
     {- the last operand was last, pop until finished -}
     ho [] [res] [] = pure res
-    ho ops vs [] = do (ops', vs') <- pop ops vs
-                      ho ops' vs' []
+    ho ops vs [] = do
+      (ops', vs') <- pop ops vs
+      ho ops' vs' []
     {- recurse to delimited subexpression -}
     rec :: AST -> PrlgResult
-    rec = ast2prlg optable
+    rec = ast2prlg' optable
     {- pop a level, possibly uncovering a higher prio -}
     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))
@@ -288,7 +288,9 @@ shunt optable = start
     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]
+    getOperand x
+      | null [op | (s, op) <- optable, s == x] = pure ()
+      | otherwise = err "expected an operand"
     {- actual pushery -}
     canPush :: Ops -> Op -> Either PrlgError Bool
     canPush [] op = pure True
@@ -336,5 +338,6 @@ shunt optable = start
       cp <- canPush ops op
       if cp
         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
+        else do
+          (ops', vs') <- pop ops vs
+          shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush