compiler can compile errors

app/Builtins.hs

@@ -96,11 +96,13 @@ assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 assertFact addClause =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    case Co.compileGoal . Co.squashVars <$>
-         Co.heapStructPrlgInt Nothing heap arg of
-      Just (U (Struct s):head) -> do
-        addClause (head ++ [Done]) s
-        continue
+    case Co.heapStructPrlgInt Nothing heap arg of
+      Just x -> do
+        case Co.compileGoal $ Co.squashVars x of
+          Right (U (Struct s):head) -> do
+            addClause (head ++ [Done]) s
+            continue
+          Left err -> prlgError err
       _ -> prlgError "assert fact failure"
 
 assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
@@ -108,16 +110,13 @@ assertRule addClause =
   withArgs [0, 1] $ \args -> do
     scope <- use (cur . hvar)
     heap <- use (cur . heap)
-    comma <- findAtom ","
-    semi <- findAtom ";"
-    cut <- findAtom "!"
+    [comma, semi, cut] <- traverse findAtom [",", ";", "!"]
     case Co.squashVars . IR.CallI 0 <$>
          traverse (Co.heapStructPrlgInt Nothing heap) args of
       Just (IR.CallI 0 [hs, gs]) ->
-        let (U (Struct s):cs) =
-              Co.compileGoal hs ++ Co.compileGoals comma semi cut gs
-         in do addClause cs s
-               continue
+        case (++) <$> Co.compileGoal hs <*> Co.compileGoals comma semi cut gs of
+          Right (U (Struct s):cs) -> addClause cs s >> continue
+          Left err -> prlgError err
       _ -> prlgError "assert clause failure"
 
 retractall :: InterpFn
@@ -139,11 +138,14 @@ exec' fgol =
         comma <- findAtom ","
         semi <- findAtom ";"
         cut <- findAtom "!"
-        zoom cur $ do
-          hvar .= M.empty
-          hed .= Co.compileGoals comma semi cut gs
-          gol %= fgol
-        continue
+        case Co.compileGoals comma semi cut gs of
+          Right nhed -> do
+            zoom cur $ do
+              hvar .= M.empty
+              hed .= nhed
+              gol %= fgol
+            continue
+          Left err -> prlgError err
       _ -> prlgError "bad goal"
 
 call :: InterpFn

app/Compiler.hs

@@ -1,6 +1,7 @@
 module Compiler where
 
 import Constant
+import Control.Monad
 import Data.Char (isUpper)
 import qualified Data.Map as M
 
@@ -45,28 +46,28 @@ squashVars x =
         [(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
    in renumVars (m' M.!?) x
 
-squashChoices :: [Code] -> Code
+squashChoices :: [Code] -> Either String Code
 squashChoices = out . concatMap go
   where
     go [Choices cs] = cs
     go x = [x]
-    out [] = error "choice compilation"
-    out [x] = x
-    out xs = [Choices xs]
+    out [] = Left "goal compilation has no choices?"
+    out [x] = pure x
+    out xs = pure [Choices xs]
 
-compileGoals :: Int -> Int -> Int -> PrlgInt -> Code
-compileGoals andop orop cut = (++ [Done]) . go'
+compileGoals :: Int -> Int -> Int -> PrlgInt -> Either String Code
+compileGoals andop orop cut = fmap (++ [Done]) . go'
   where
-    go' = go . struct2goal
+    go' = struct2goal >=> go
     go p@(CallI x args@[_, _])
-      | x == andop = concatMap go' args
-      | x == orop = squashChoices $ map go' args
+      | x == andop = concat <$> traverse go' args
+      | x == orop = traverse go' args >>= squashChoices
     go p@(CallI x [])
-      | x == cut = [Cut]
+      | x == cut = pure [Cut]
     go x = compileGoal x
 
-compileGoal :: PrlgInt -> Code
-compileGoal = compileArg . struct2goal
+compileGoal :: PrlgInt -> Either String Code
+compileGoal = fmap compileArg . struct2goal
 
 compileArg :: PrlgInt -> Code
 compileArg (CallI i args) =
@@ -88,12 +89,7 @@ heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
       | r == ref = pure $ VarI r
       | otherwise = heaperr
 
--- TODO check if this is used
-goal2struct :: PrlgInt -> PrlgInt
-goal2struct (CallI s []) = ConstI (Atom s)
-goal2struct x = x
-
-struct2goal :: PrlgInt -> PrlgInt
-struct2goal (ConstI (Atom s)) = CallI s []
-struct2goal call@(CallI _ _) = call
-struct2goal _ = error "TODO."
+struct2goal :: PrlgInt -> Either String PrlgInt
+struct2goal (ConstI (Atom s)) = pure $ CallI s []
+struct2goal call@(CallI _ _) = pure call
+struct2goal x = Left $ "cannot compile goal: " ++ show x

app/Frontend.hs

@@ -33,8 +33,8 @@ handleError m = do
 
 processCmd precompileHook ast' = do
   ast <- shunt ast'
-  code <- lift $ intern ast >>= precompileHook >>= compile
-  lift (I.prove code) >>= except
+  source <- lift $ intern ast >>= precompileHook
+  compile source >>= lift . I.prove >>= except
 
 interpreterStart :: PrlgEnv ()
 interpreterStart = do

app/Load.hs

@@ -31,16 +31,13 @@ intern :: P.PrlgStr -> PrlgEnv IR.PrlgInt
 intern prlgs = do
   prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
   underscore <- findAtom "_"
-  list <- findAtom "[]"
   withStrTable $ \st ->
     (st, C.squashVars $ C.variablizePrlg underscore st prlgi)
 
-compile :: IR.PrlgInt -> PrlgEnv Code
+compile :: IR.PrlgInt -> ExceptT String PrlgEnv Code
 compile prlgv = do
-  comma <- findAtom ","
-  semi <- findAtom ";"
-  cut <- findAtom "!"
-  return $ C.compileGoals comma semi cut prlgv
+  [comma, semi, cut] <- lift $ traverse findAtom [",", ";", "!"]
+  except $ C.compileGoals comma semi cut prlgv
 
 expansion ::
      (Int -> IR.PrlgInt -> IR.PrlgInt)