app/Builtins.hs

@@ -2,10 +2,9 @@ module Builtins where
 
 import Paths_prlg
 
-import Code (Builtin(..), Code, Datum(..), Id(..), Instr(..), InterpFn)
+import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
 import CodeLens
 import qualified Compiler as Co
-import Constant
 import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
@@ -17,7 +16,7 @@ import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
-import IR (PrlgInt(..), StrTable(..))
+import qualified IR
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
 import Load (processInput)
@@ -30,11 +29,10 @@ continue = pure Nothing
 
 showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
   where
-    atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
-    atom (C (Number n)) = pure (show n)
-    atom (C (Str str)) = pure (show str)
+    atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
+    atom (Number n) = pure (show n)
     atom VoidRef = pure "_"
-    struct (Struct (Id h _)) args =
+    struct (Struct (IR.Id h _)) args =
       pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
     hrec (HeapRef hr) ref =
       pure $
@@ -47,7 +45,7 @@ printLocals :: InterpFn
 printLocals = do
   scope <- use (cur . gvar)
   heap <- use (cur . heap)
-  StrTable _ _ itos <- use strtable
+  IR.StrTable _ _ itos <- use strtable
   flip traverse (M.assocs scope) $ \(local, ref) ->
     lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
     showTerm itos heap ref
@@ -78,7 +76,7 @@ write' :: InterpFn -> InterpFn
 write' c =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    StrTable _ _ itos <- use strtable
+    IR.StrTable _ _ itos <- use strtable
     lift . outputStr $ showTerm itos heap arg
     c --this now allows error fallthrough but we might like EitherT
 
@@ -92,31 +90,32 @@ nl = do
 writeln :: InterpFn
 writeln = write' nl
 
-assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
+assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
 assertFact addClause =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    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
+    case Co.compileGoal . Co.squashVars <$>
+         Co.heapStructPrlgInt Nothing heap arg of
+      Just (U (Struct s):head) -> do
+        addClause (head ++ [Done]) s
+        continue
       _ -> prlgError "assert fact failure"
 
-assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
+assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
 assertRule addClause =
   withArgs [0, 1] $ \args -> do
     scope <- use (cur . hvar)
     heap <- use (cur . heap)
-    [comma, semi, cut] <- traverse findAtom [",", ";", "!"]
+    comma <- findAtom ","
+    semi <- findAtom ";"
+    cut <- findAtom "!"
     case Co.squashVars . IR.CallI 0 <$>
          traverse (Co.heapStructPrlgInt Nothing heap) args of
       Just (IR.CallI 0 [hs, gs]) ->
-        case (++) <$> Co.compileGoal hs <*> Co.compileGoals comma semi cut gs of
-          Right (U (Struct s):cs) -> addClause cs s >> continue
-          Left err -> prlgError err
+        let (U (Struct s):cs) =
+              Co.compileGoal hs ++ Co.compileGoals comma semi cut gs
+         in do addClause cs s
+               continue
       _ -> prlgError "assert clause failure"
 
 retractall :: InterpFn
@@ -124,29 +123,37 @@ retractall =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (C (Atom a)) ->
-        dropProcedure (Id {arity = 0, str = a}) >> continue
+      BoundRef _ (Atom a) ->
+        dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
       BoundRef _ (Struct id) -> dropProcedure id >> continue
       _ -> prlgError "retractall needs a struct"
 
-call :: InterpFn
-call =
+exec' :: (Code -> Code) -> InterpFn
+exec' fgol =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    case derefHeap heap arg of
-      BoundRef _ (C (Atom a)) -> do
-        cur . hed .= [U (Struct (Id {str = a, arity = 0})), Done]
+    case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of
+      Just gs -> do
+        comma <- findAtom ","
+        semi <- findAtom ";"
+        cut <- findAtom "!"
+        zoom cur $ do
+          hvar .= M.empty
+          hed .= Co.compileGoals comma semi cut gs
+          gol %= fgol
         continue
-      BoundRef addr s@(Struct Id {arity = arity}) -> do
-        cur . hed .= [U s] ++ [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++
-          [Done]
-        continue
-      _ -> prlgError "bad call"
+      _ -> prlgError "bad goal"
+
+call :: InterpFn
+call = exec' id
+
+exec :: InterpFn
+exec = exec' (const [Done])
 
 stop :: InterpFn
 stop =
   withArgs [0] $ \[arg] -> do
-    StrTable _ _ itos <- use strtable
+    IR.StrTable _ _ itos <- use strtable
     heap <- use (cur . heap)
     prlgError $ "stop: " ++ showTerm itos heap arg
 
@@ -156,18 +163,17 @@ struct = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (Struct Id {arity = arity, str = str})) ->
+    Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
       structUnify arity str
-    Just (BoundRef _ _) -> backtrack
     _ -> structAssemble
 
 heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
   where
     nil r
-      | BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
+      | BoundRef _ str <- derefHeap heap r = str == Atom listAtom
       | otherwise = False
     step r
-      | BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
+      | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
          derefHeap heap r
       , listAtom == listAtom' = Just (addr + 2)
       | otherwise = Nothing
@@ -184,7 +190,7 @@ structAssemble = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 1 of
-    Just (BoundRef addr (C (Atom str))) -> do
+    Just (BoundRef addr (Atom str)) -> do
       listAtom <- findAtom "[]"
       case scope M.!? 2 >>= heapListLength listAtom heap of
         Just arity -> structUnify arity str
@@ -197,17 +203,17 @@ structUnify arity str = do
   listAtom <- findAtom "[]"
   pvars <- newHeapVars arity
   let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
-      structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
+      structData =
+        Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
       paramsData =
         concatMap
-          (\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
+          (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
           pvars ++
-        [C $ Atom listAtom]
-      gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
+        [Atom listAtom]
+      gcode = map U $ structData ++ [Atom str] ++ paramsData
   zoom cur $ do
     gol %= (gcode ++)
     hed %= (hcode ++)
-    unis += 3
   continue
 
 {- terms -}
@@ -220,29 +226,12 @@ var = do
     Just (FreeRef _) -> continue
     _ -> backtrack
 
-atom :: InterpFn
-atom = do
-  heap <- use (cur . heap)
-  scope <- use (cur . hvar)
-  case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (C (Atom _))) -> continue
-    _ -> backtrack
-
 number :: InterpFn
 number = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (C (Number _))) -> continue
-    _ -> backtrack
-
-string :: InterpFn
-string = do
-  heap <- use (cur . heap)
-  scope <- use (cur . hvar)
-  --TODO unify with number/var/...
-  case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef _ (C (Str _))) -> continue
+    Just (BoundRef _ (Number _)) -> continue
     _ -> backtrack
 
 sameTerm :: InterpFn
@@ -271,9 +260,9 @@ op :: InterpFn
 op =
   withArgs [0, 1, 2] $ \args -> do
     heap <- use (cur . heap)
-    StrTable _ _ itos <- use strtable
+    IR.StrTable _ _ itos <- use strtable
     case map (derefHeap heap) args of
-      [BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (Atom opatom))]
+      [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
         | Just op <-
            (,) <$> itos M.!? opatom <*>
            (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
@@ -285,9 +274,9 @@ deop :: InterpFn
 deop =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    StrTable _ _ itos <- use strtable
+    IR.StrTable _ _ itos <- use strtable
     case derefHeap heap arg of
-      BoundRef _ (C (Atom opatom))
+      BoundRef _ (Atom opatom)
         | Just op <- itos M.!? opatom -> do
           ops %= filter ((/= op) . fst)
           continue
@@ -337,8 +326,7 @@ intBinary op =
   withArgs [0, 1] $ \[arg1, arg2] -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> [arg1, arg2] of
-      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
-        putInt (op n1 n2) 2
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
       _ -> prlgError "int binary needs numbers"
 
 intBinPred :: (Int -> Int -> Bool) -> InterpFn
@@ -346,7 +334,7 @@ intBinPred op =
   withArgs [0, 1] $ \args -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> args of
-      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
         if op n1 n2
           then continue
           else backtrack
@@ -357,7 +345,7 @@ intUnary op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (C (Number n)) -> putInt (op n) 1
+      BoundRef _ (Number n) -> putInt (op n) 1
       _ -> prlgError "int unary needs number"
 
 intUnPred :: (Int -> Bool) -> InterpFn
@@ -365,7 +353,7 @@ intUnPred op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (C (Number n)) ->
+      BoundRef _ (Number n) ->
         if op n
           then continue
           else backtrack
@@ -378,28 +366,28 @@ putInt val sc = do
     Nothing -> continue
     Just a ->
       case derefHeap heap a of
-        BoundRef _ (C (Number val'))
+        BoundRef _ (Number val')
           | val == val' -> continue
-        FreeRef a' -> writeHeap a' (C (Number val)) >> continue
+        FreeRef a' -> writeHeap a' (Number val) >> continue
         _ -> backtrack
 
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
 
-modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv ()
+modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
 modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
 
-addClauseA :: Code -> Id -> PrlgEnv ()
+addClauseA :: Code -> IR.Id -> PrlgEnv ()
 addClauseA code = modDef $ Just . (code :)
 
-addClauseZ :: Code -> Id -> PrlgEnv ()
+addClauseZ :: Code -> IR.Id -> PrlgEnv ()
 addClauseZ code = modDef $ Just . (++ [code])
 
-addProcedure :: [Code] -> Id -> PrlgEnv ()
+addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
 addProcedure heads = modDef $ Just . const heads
 
-dropProcedure :: Id -> PrlgEnv ()
+dropProcedure :: IR.Id -> PrlgEnv ()
 dropProcedure = modDef $ const Nothing
 
 addProc :: [Code] -> String -> Int -> PrlgEnv ()
@@ -425,9 +413,9 @@ load :: Bool -> InterpFn
 load queryMode =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
+    IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
     case derefHeap heap arg of
-      BoundRef _ (C (Atom a)) -> do
+      BoundRef _ (Atom a) -> do
         let fn = itos M.! a
         doLoad queryMode (itos M.! a)
       _ -> prlgError "load needs an atom"
@@ -437,7 +425,7 @@ addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
   {- absolute primitives -}
-  addProc [[Done]] "true" 0
+  addBi (pure Nothing) "true" 0
   addBi backtrack "fail" 0
   addBi stop "stop" 1
   addOp $ O.xfx "=" 700
@@ -447,58 +435,27 @@ addPrelude = do
   addOp $ O.xfy ";" 1100
   addOp $ O.xfx ":-" 1200
   addOp $ O.fx ":-" 1200
-  do [horn1, horn2] <- traverse (findStruct ":-") [1, 2]
-     doCall <- U . Struct <$> findStruct "call" 1
-     let assertCode ac =
-           [ [ U (Struct horn2)
-             , U (LocalRef 0)
-             , U (LocalRef 1)
-             , Cut
-             , Invoke . bi $ assertRule ac
-             ]
-           , [ U (Struct horn1)
-             , U (LocalRef 0)
-             , Cut
-             , doCall
-             , U (LocalRef 0)
-             , Done
-             ]
-           , [U (LocalRef 0), Invoke . bi $ assertFact ac]
-           ]
-     addProc (assertCode addClauseA) "asserta" 1
-     addProc (assertCode addClauseZ) "assertz" 1
-     addProc (assertCode addClauseZ) "assert" 1
+  horn1 <- findStruct ":-" 1
+  horn2 <- findStruct ":-" 2
+  let assertCode ac =
+        [ [ U (Struct horn2)
+          , U (LocalRef 0)
+          , U (LocalRef 1)
+          , Cut
+          , Invoke . bi $ assertRule ac
+          ]
+        , [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec]
+        , [U (LocalRef 0), Invoke . bi $ assertFact ac]
+        ]
+   in do addProc (assertCode addClauseA) "asserta" 1
+         addProc (assertCode addClauseZ) "assertz" 1
+         addProc (assertCode addClauseZ) "assert" 1
   addBi retractall "retractall" 1
-  do [comma, semi] <- traverse (flip findStruct 2) [",", ";"]
-     doCall <- U . Struct <$> findStruct "call" 1
-     addProc
-       [ [ U (Struct comma)
-         , U (LocalRef 0)
-         , U (LocalRef 1)
-         , Cut
-         , doCall
-         , U (LocalRef 0)
-         , doCall
-         , U (LocalRef 1)
-         , Done
-         ]
-       , [ U (Struct semi)
-         , U (LocalRef 0)
-         , U (LocalRef 1)
-         , Cut
-         , Choices [[doCall, U (LocalRef 0)], [doCall, U (LocalRef 1)]]
-         , Done
-         ]
-       , [U (LocalRef 0), Invoke $ bi call]
-       ]
-       "call"
-       1
+  addBi call "call" 1
   {- terms -}
   addBi struct "struct" 3
   addBi var "var" 1
-  addBi atom "atom" 1
   addBi number "number" 1
-  addBi string "string" 1
   addBi sameTerm "same_term" 2
   addBi currentPredicate "current_predicate" 1
   {- code loading -}
@@ -532,30 +489,30 @@ addPrelude = do
           ]
           ("expand_" ++ q)
           2
-   in do expandCode "load"
-         expandCode "query"
+  expandCode "load"
+  expandCode "query"
   {- int primops -}
   let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
       add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
       add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
       add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
-   in do add2IntOp "add" (+)
-         add2IntOp "sub" (-)
-         add1IntOp "neg" negate
-         add1IntOp "abs" abs
-         add2IntOp "mul" (*)
-         add2IntOp "div" div
-         add2IntOp "mod" mod
-         add2IntOp "bitand" (.&.)
-         add2IntOp "bitor" (.|.)
-         add2IntOp "bitxor" xor
-         add2IntOp "shl" shiftL
-         add2IntOp "shr" shiftR
-         add1IntPred "zero" (== 0)
-         add2IntPred "eq" (==)
-         add2IntPred "lt" (<)
-         add2IntPred "leq" (<=)
-         add2IntPred "neq" (/=)
+  add2IntOp "add" (+)
+  add2IntOp "sub" (-)
+  add1IntOp "neg" negate
+  add1IntOp "abs" abs
+  add2IntOp "mul" (*)
+  add2IntOp "div" div
+  add2IntOp "mod" mod
+  add2IntOp "bitand" (.&.)
+  add2IntOp "bitor" (.|.)
+  add2IntOp "bitxor" xor
+  add2IntOp "shl" shiftL
+  add2IntOp "shr" shiftR
+  add1IntPred "zero" (== 0)
+  add2IntPred "eq" (==)
+  add2IntPred "lt" (<)
+  add2IntPred "leq" (<=)
+  add2IntPred "neq" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0

app/Code.hs

@@ -2,31 +2,24 @@
 
 module Code where
 
-import Constant
 import Control.Monad.Trans.State.Lazy (StateT)
 import qualified Data.Map as M
-import IR (StrTable)
+import IR (Id(..), StrTable)
 import Operators (Ops)
 import Parser (PAST)
 import System.Console.Haskeline (InputT)
 
-data Id =
-  Id
-    { str :: !Int
-    , arity :: !Int
-    }
-  deriving (Show, Eq, Ord)
-
 data Datum
-  = C !Constant -- unifies a constant
-  | Struct !Id -- unifies a structure with arity
+  = Atom Int -- unifies a symbolic constant
+  | Number Int -- unifies a numeric constant
+  | Struct Id -- unifies a structure with arity
   | VoidRef -- unifies with anything
-  | LocalRef !Int -- code-local variable idx (should never occur on heap)
-  | HeapRef !Int -- something further on the heap
+  | LocalRef Int -- code-local variable idx (should never occur on heap)
+  | HeapRef Int -- something further on the heap
   deriving (Show, Eq, Ord)
 
 data Instr
-  = U !Datum -- unify/resolve something
+  = U Datum -- unify/resolve something
   | Invoke Builtin -- give control to a builtin (invoked from head)
   | Done -- all done, can return
   | Cut -- remove choicepoints of the current goal
@@ -38,7 +31,7 @@ type Code = [Instr]
 type Defs = M.Map Id [Code]
 
 data Heap =
-  Heap !Int (M.Map Int Datum)
+  Heap Int (M.Map Int Datum)
   deriving (Show)
 
 emptyHeap = Heap 1 M.empty
@@ -58,8 +51,7 @@ data Cho =
     , _retcut :: Bool -- cut after this goal succeeds
     , _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
     , _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag
-    , _cut :: [Cho] -- snapshot of choicepoints before entering the goal
-    , _hcut :: [Cho] -- save of choicepoints just before starting to match head
+    , _cut :: [Cho] -- snapshot of choicepoints before entering
     }
   deriving (Show)
 

app/Compiler.hs

@@ -1,13 +1,20 @@
 module Compiler where
 
-import Constant
-import Control.Monad
 import Data.Char (isUpper)
 import qualified Data.Map as M
 
-import Code (Code, Datum(..), Heap, Id(..), Instr(..))
+import Code (Code, Datum(..), Heap, Instr(..))
 import Heap (heapStruct)
-import IR (PrlgInt(..), StrTable(..))
+import IR (Id(..), PrlgInt(..), StrTable(..))
+
+desugarPrlg :: Int -> PrlgInt -> PrlgInt
+desugarPrlg list = go
+  where
+    go (CallI id ps) = CallI id $ map go ps
+    go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
+    go (ListI [] Nothing) = AtomI list
+    go (ListI [] (Just x)) = go x
+    go x = x
 
 varname :: String -> Bool
 varname ('_':_) = True
@@ -16,24 +23,24 @@ varname _ = False
 
 varOccurs :: PrlgInt -> M.Map Int Int
 varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
-varOccurs (VarI idx) = M.singleton idx 1
+varOccurs (VarI idx _) = M.singleton idx 1
 varOccurs _ = M.empty
 
 variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
 variablizePrlg void (StrTable _ _ itos) = go
   where
     go (CallI i ps) = CallI i $ map go ps
-    go o@(ConstI (Atom i))
+    go (AtomI i)
       | i == void = VoidI
-      | varname (itos M.! i) = VarI i
-      | otherwise = o
+      | varname (itos M.! i) = VarI i i
+      | otherwise = AtomI i
     go x = x
 
 renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
 renumVars rename = go
   where
     go (CallI i ps) = CallI i $ map go ps
-    go (VarI idx)
+    go (VarI idx i)
       | Just new <- rename idx = new
     go x = x
 
@@ -43,37 +50,38 @@ squashVars x =
       m' =
         M.fromList $
         [(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
-        [(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
+        [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
    in renumVars (m' M.!?) x
 
-squashChoices :: [Code] -> Either String Code
+squashChoices :: [Code] -> Code
 squashChoices = out . concatMap go
   where
     go [Choices cs] = cs
     go x = [x]
-    out [] = Left "goal compilation has no choices?"
-    out [x] = pure x
-    out xs = pure [Choices xs]
+    out [] = error "choice compilation"
+    out [x] = x
+    out xs = [Choices xs]
 
-compileGoals :: Int -> Int -> Int -> PrlgInt -> Either String Code
-compileGoals andop orop cut = fmap (++ [Done]) . go'
+compileGoals :: Int -> Int -> Int -> PrlgInt -> Code
+compileGoals andop orop cut = (++ [Done]) . go'
   where
-    go' = struct2goal >=> go
+    go' = go . struct2goal
     go p@(CallI x args@[_, _])
-      | x == andop = concat <$> traverse go' args
-      | x == orop = traverse go' args >>= squashChoices
+      | x == andop = concatMap go' args
+      | x == orop = squashChoices $ map go' args
     go p@(CallI x [])
-      | x == cut = pure [Cut]
+      | x == cut = [Cut]
     go x = compileGoal x
 
-compileGoal :: PrlgInt -> Either String Code
-compileGoal = fmap compileArg . struct2goal
+compileGoal :: PrlgInt -> Code
+compileGoal = compileArg . struct2goal
 
 compileArg :: PrlgInt -> Code
 compileArg (CallI i args) =
   U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
-compileArg (ConstI c) = [U (C c)]
-compileArg (VarI x) = [U (LocalRef x)]
+compileArg (AtomI s) = [U (Atom s)]
+compileArg (NumI s) = [U (Number s)]
+compileArg (VarI x _) = [U (LocalRef x)]
 compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
@@ -82,14 +90,20 @@ seqGoals = (++ [Done]) . concat
 heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
 heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
   where
-    atom (C c) = pure (ConstI c)
+    atom (Atom s) = pure $ AtomI s
+    atom (Number n) = pure $ NumI n
     atom VoidRef = pure $ VoidI
     struct (Struct s) args = pure $ CallI (str s) args
     hrec (HeapRef r) ref
-      | r == ref = pure $ VarI r
+      | r == ref = pure $ VarI r 0
       | otherwise = heaperr
 
-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
+-- TODO check if this is used
+goal2struct :: PrlgInt -> PrlgInt
+goal2struct (CallI s []) = AtomI s
+goal2struct x = x
+
+struct2goal :: PrlgInt -> PrlgInt
+struct2goal (AtomI s) = CallI s []
+struct2goal call@(CallI _ _) = call
+struct2goal _ = error "TODO."

app/Constant.hs

@@ -1,7 +0,0 @@
-module Constant where
-
-data Constant
-  = Atom Int
-  | Number Int
-  | Str String
-  deriving (Show, Eq, Ord)

app/Env.hs

@@ -1,23 +1,23 @@
 module Env where
 
-import Code (Id(..), InterpFn, PrlgEnv)
+import Code (InterpFn, PrlgEnv)
 import CodeLens
-import IR (StrTable, strtablize)
+import qualified IR
 import Lens.Micro.Mtl
 
-withStrTable :: (StrTable -> (StrTable, a)) -> Env.PrlgEnv a
+withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
 withStrTable f = do
   (st', x) <- f <$> use strtable
   strtable .= st'
   return x
 
-findStruct :: String -> Int -> Env.PrlgEnv Id
+findStruct :: String -> Int -> Env.PrlgEnv IR.Id
 findStruct str arity = do
   stri <- findAtom str
-  return Id {str = stri, arity = arity}
+  return IR.Id {IR.str = stri, IR.arity = arity}
 
 findAtom :: String -> Env.PrlgEnv Int
-findAtom = withStrTable . flip strtablize
+findAtom = withStrTable . flip IR.strtablize
 
 type PrlgEnv a = Code.PrlgEnv a
 

app/Frontend.hs

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

app/Heap.hs

@@ -4,6 +4,7 @@ import Code
 import CodeLens
 import Data.Foldable (traverse_)
 import qualified Data.Map as M
+import IR (Id(..))
 import Lens.Micro.Mtl
 
 data Dereferenced

app/IR.hs

@@ -1,15 +1,28 @@
 module IR where
 
-import Constant
 import Data.Char (isNumber)
 import Data.List (mapAccumL)
 import qualified Data.Map as M
-import Parser (Lexeme(..), PrlgStr(..))
+
+data PrlgStr
+  = CallS String [PrlgStr]
+  | LiteralS String
+  | ListS [PrlgStr] (Maybe PrlgStr)
+  deriving (Show)
+
+data Id =
+  Id
+    { str :: Int
+    , arity :: Int
+    }
+  deriving (Show, Eq, Ord)
 
 data PrlgInt
   = CallI Int [PrlgInt]
-  | ConstI Constant
-  | VarI Int -- VarI localIndex strTableString
+  | AtomI Int
+  | NumI Int
+  | ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
+  | VarI Int Int -- VarI localIndex strTableString
   | VoidI
   deriving (Show)
 
@@ -24,16 +37,16 @@ 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)
 
-internLexeme t (Tok str)
-  | all isNumber str = (t, ConstI . Number $ read str)
-  | otherwise = ConstI . Atom <$> strtablize t str
-internLexeme t (QTok str _) = ConstI . Atom <$> strtablize t str
-internLexeme t (DQTok str _) = (t, ConstI $ Str str)
-
 internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
 internPrlg = go
   where
-    go t (LiteralS lex) = internLexeme t lex
+    go t (LiteralS str)
+      | all isNumber str = (t, NumI $ read str)
+      | otherwise = AtomI <$> strtablize t str
     go t (CallS str ps) =
       let (t', i) = strtablize t str
        in CallI i <$> mapAccumL go t' ps
+    go t (ListS elems Nothing) = flip ListI Nothing <$> mapAccumL go t elems
+    go t (ListS elems (Just tail)) =
+      let (t', tail') = go t tail
+       in flip ListI (Just tail') <$> mapAccumL go t' elems

app/Interpreter.hs

@@ -8,7 +8,6 @@ import Code
   , Cho(..)
   , Code
   , Datum(..)
-  , Id(..)
   , Instr(..)
   , InterpFn
   , emptyHeap
@@ -19,7 +18,7 @@ import Control.Monad (when)
 import qualified Data.Map as M
 import Env (PrlgEnv)
 import Heap
-import IR (StrTable(..))
+import IR (Id(..), StrTable(..))
 import Lens.Micro
 import Lens.Micro.Mtl
 
@@ -36,7 +35,6 @@ prove g = do
       , _heap = emptyHeap
       , _stk = []
       , _cut = []
-      , _hcut = []
       }
   cho .= []
   loop
@@ -56,14 +54,10 @@ proveStep = do
   import Control.Monad.Trans.Class (lift)
   import System.Console.Haskeline
   g <- use (cur . gol)
-  cho <- use cho
-  cut <- use (cur . cut)
   lift $ do
     outputStrLn $ "STEP (unis="++show u++")"
     outputStrLn $ "head = "++ show h
     outputStrLn $ "goal = "++ show g
-    outputStrLn $ "cut = " ++ show cut
-    outputStrLn $ "cho = " ++ show cho
   -}
   case (u, h) of
     (0, []) -> goalStep
@@ -98,7 +92,7 @@ headStep h = do
   case (h, g) of
     ([Done], _) -> succeedHead
     (Cut:_, _) -> cutHead
-    (Invoke (Builtin bf):_, _) -> cur . hed .= [Done] >> bf
+    (Invoke (Builtin bf):_, _) -> advanceHead >> bf
     (_, [Done]) -> tailCall
     (_, [Cut, Done]) -> tailCut
     (_, _) -> pushCall
@@ -140,13 +134,11 @@ retCut = do
     doCut
     cur . retcut .= False
 
-cutHead = do
-  use (cur . hcut) >>= assign cho
-  advanceHead
+cutHead = doCut >> advanceHead
 
 cutGoal = doCut >> advance
 
-openGoal :: Id -> InterpFn
+openGoal :: IR.Id -> InterpFn
 openGoal fn = do
   def <- (M.!? fn) <$> use defs
   case def of
@@ -155,8 +147,7 @@ openGoal fn = do
       cur . hvar .= emptyScope
       cur . unis .= arity fn
       cc <- use cur
-      oldcho <- use cho
-      let (newcur:newcho) = [cc & hcut .~ oldcho & hed .~ h | h <- hs]
+      let (newcur:newcho) = [cc & hed .~ h | h <- hs]
       cur .= newcur
       cho %= (newcho ++)
       continue
@@ -171,15 +162,12 @@ pushCall = do
   ngol <- use (cur . hed)
   ngvar <- use (cur . hvar)
   scut <- use (cur . cut)
-  ncut <- use (cur . hcut)
   sretcut <- use (cur . retcut)
   cur . stk %= ((sgol, sgvar, scut, sretcut) :)
   cur . gol .= ngol
   cur . gvar .= ngvar
-  cur . cut .= ncut
   cur . hed .= []
   cur . hvar .= emptyScope
-  cur . hcut .= []
   cur . retcut .= False
   continue
 
@@ -191,7 +179,6 @@ tailCall = do
   cur . gvar .= ngvar
   cur . hed .= []
   cur . hvar .= emptyScope
-  cur . hcut .= []
   continue
 
 tailCut :: InterpFn
@@ -202,9 +189,8 @@ tailCut = do
 
 succeedHead :: InterpFn
 succeedHead = do
-  cur . hed .= []
   cur . hvar .= emptyScope
-  cur . hcut .= []
+  cur . hed .= []
   continue
 
 succeedGoal :: InterpFn
@@ -245,10 +231,13 @@ uOK = uNext >> continue
 
 unify :: Datum -> Datum -> InterpFn
 unify VoidRef VoidRef = uOK
-unify (C _) VoidRef = uOK
-unify VoidRef (C _) = uOK
-unify (C a) (C b)
+unify (Atom _) VoidRef = uOK
+unify VoidRef (Atom _) = uOK
+unify (Atom a) (Atom b)
   | a == b = uOK
+unify (Number _) VoidRef = uOK
+unify VoidRef (Number _) = uOK
+unify (Number a) (Number b)
   | a == b = uOK
 unify (Struct a) VoidRef = do
   uNext

app/Load.hs

@@ -1,6 +1,6 @@
 module Load where
 
-import Code (Code, Id(..), PrlgEnv)
+import Code (Code, PrlgEnv)
 import CodeLens
 import qualified Compiler as C
 import Control.Monad.Trans.Class (lift)
@@ -21,23 +21,27 @@ tokenize fn = left MP.errorBundlePretty . MP.parse P.lexPrlg fn
 parse :: String -> [P.Lexeme] -> Either String [P.PAST]
 parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn
 
-shunt :: P.PAST -> ExceptT String PrlgEnv P.PrlgStr
+shunt :: P.PAST -> ExceptT String PrlgEnv IR.PrlgStr
 shunt past = do
   ops <- lift $ use ops
   except . left (\err -> "operator resolution: " ++ err ++ "\n") $
     P.shuntPrlg ops past
 
-intern :: P.PrlgStr -> PrlgEnv IR.PrlgInt
+intern :: IR.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)
+    ( st
+    , C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
 
-compile :: IR.PrlgInt -> ExceptT String PrlgEnv Code
+compile :: IR.PrlgInt -> PrlgEnv Code
 compile prlgv = do
-  [comma, semi, cut] <- lift $ traverse findAtom [",", ";", "!"]
-  except $ C.compileGoals comma semi cut prlgv
+  comma <- findAtom ","
+  semi <- findAtom ";"
+  cut <- findAtom "!"
+  return $ C.compileGoals comma semi cut prlgv
 
 expansion ::
      (Int -> IR.PrlgInt -> IR.PrlgInt)
@@ -54,7 +58,9 @@ expansion noexpand expander output x = do
     if expand
       then IR.CallI
              comma
-             [IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]]
+             [ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
+             , IR.CallI o [IR.VarI (-1) 0]
+             ]
       else noexpand o x
 
 queryExpansion = expansion (\_ -> id) "expand_query" "call"

app/Parser.hs

@@ -5,8 +5,7 @@ module Parser
   , parsePrlg
   , shuntPrlg
   , PAST
-  , Lexeme(..)
-  , PrlgStr(..)
+  , Lexeme
   ) where
 
 import Control.Monad (void)
@@ -43,13 +42,14 @@ import Text.Megaparsec
   )
 import Text.Megaparsec.Char (string)
 
+import IR (PrlgStr(..))
 import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
 
 singleToks = ",;|()[]{}!"
 
 identParts = "_"
 
-notOpToks = "'\"" ++ identParts
+notOpToks = "\'" ++ identParts
 
 isOperatorlike x =
   (isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
@@ -64,7 +64,6 @@ data Lexeme
   = Blank String
   | Tok String
   | QTok String String -- unquoted quoted
-  | DQTok String String -- unquoted quoted
   deriving (Show, Eq, Ord)
 
 blank :: Lexer Lexeme
@@ -87,15 +86,14 @@ qtok = do
   z <- string "'"
   return $ QTok y (x ++ y ++ z)
 
-dqtok :: Lexer Lexeme
-dqtok = do
-  x <- string "\""
-  y <- many $ satisfy (/= '\"') -- TODO actual escaping
-  z <- string "\""
-  return $ DQTok y (x ++ y ++ z)
+cmt :: Lexer Lexeme
+cmt =
+  Blank . concat <$>
+  sequence
+    [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
 
 lexeme :: Lexer Lexeme
-lexeme = choice [blank, tok, qtok, dqtok]
+lexeme = choice [blank, tok, qtok, cmt]
 
 lexPrlg :: Lexer [Lexeme]
 lexPrlg = many lexeme <* (many blank >> eof)
@@ -103,7 +101,6 @@ lexPrlg = many lexeme <* (many blank >> eof)
 showTok (Blank x) = x
 showTok (Tok x) = x
 showTok (QTok _ x) = x
-showTok (DQTok _ x) = x
 
 instance VisualStream [Lexeme] where
   showTokens _ (a :| b) = concatMap showTok (a : b)
@@ -149,9 +146,9 @@ instance TraversableStream [Lexeme] where
 
 data PAST
   = Call String [[PAST]]
-  | Group [PAST]
+  | Seq [PAST]
   | List [[PAST]] (Maybe [PAST])
-  | Literal Lexeme
+  | Literal String
   deriving (Show, Eq)
 
 type Parser = Parsec Void [Lexeme]
@@ -168,46 +165,43 @@ isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
 isNormalTok :: Lexeme -> Bool
 isNormalTok (Tok x) = isNormalTokStr x
 isNormalTok (QTok _ _) = True
-isNormalTok (DQTok _ _) = True
 isNormalTok _ = False
 
 isCallTok :: Lexeme -> Bool
 isCallTok (Tok x) =
   all (\c -> not (isSymbol c) && not (isPunctuation c) || c `elem` identParts) x
-isCallTok (QTok _ _) = True
-isCallTok _ = False
+isCallTok _ = True
 
 unTok (Tok t) = t
 unTok (QTok t _) = t
-unTok (DQTok t _) = t
 
 literal :: Parser PAST
 literal =
-  Literal <$>
+  Literal . unTok <$>
   free
     (choice
        [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
        , satisfy (\x -> not (isCallTok x) && isNormalTok x)
        ])
 
-makeParams (Group inner) = splitOn [Literal (Tok ",")] inner
+makeParams (Seq inner) = splitOn [Literal ","] inner
 
 call eb contents fmod = do
   fn <- fmod . unTok <$> satisfy isCallTok -- not free
   (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
 
-parens = Group <$> (free lParen *> some seqItem <* free rParen)
+parens = Seq <$> (free lParen *> some seqItem <* free rParen)
 
-braces = Group <$> (free lBrace *> some seqItem <* free rBrace)
+braces = Seq <$> (free lBrace *> some seqItem <* free rBrace)
 
-emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen)
+emptyParens = Literal "()" <$ (free lParen >> free rParen)
 
-emptyBraces = Literal (QTok "{}" "{}") <$ (free lBrace >> free rBrace)
+emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace)
 
 list = do
   free lBracket
   (List [] Nothing <$ free rBracket) <|> do
-    items <- splitOn [Literal (Tok ",")] <$> some seqItem
+    items <- splitOn [Literal ","] <$> some seqItem
     (List items Nothing <$ free rBracket) <|>
       (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
 
@@ -243,7 +237,7 @@ lBrace = simpleTok "{"
 rBrace = simpleTok "}"
 
 clause :: Parser PAST
-clause = Group <$> some (free seqItem) <* free period
+clause = Seq <$> some (free seqItem) <* free period
 
 parsePrlg :: Parser [PAST]
 parsePrlg = ws *> many clause <* eof
@@ -252,11 +246,6 @@ type ShuntError = String
 
 type ShuntResult = Either ShuntError PrlgStr
 
-data PrlgStr
-  = CallS String [PrlgStr]
-  | LiteralS Lexeme
-  deriving (Show)
-
 err :: ShuntError -> Either ShuntError a
 err = Left
 
@@ -265,10 +254,8 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
 
 shuntPrlg' :: Ops -> PAST -> ShuntResult
 shuntPrlg' ot (List hs t) =
-  foldr (\x y -> CallS "[]" [x, y]) <$>
-  (maybe (LiteralS $ Tok "[]") id <$> traverse (shunt ot) t) <*>
-  traverse (shunt ot) hs
-shuntPrlg' ot (Group ss) = shunt ot ss
+  ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
+shuntPrlg' ot (Seq ss) = shunt ot ss
 shuntPrlg' ot (Literal s) = pure (LiteralS s)
 shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
 
@@ -309,13 +296,13 @@ shunt optable = start
              (ops', vs') <- pushInfix ops vs x
              wo ops' vs' xs
         , do getOperand x
-             ho ops vs (Literal (Tok "") : xs') -- app (see below)
+             ho ops vs (Literal "" : xs') -- app (see below)
         , do getPrefix x
-             ho ops vs (Literal (Tok "") : xs') -- also app!
+             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 (Tok "") : xs)
+    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
@@ -332,14 +319,11 @@ shunt optable = start
     {- Operator checks -}
     uniq [x] = pure x
     uniq _ = err "ambiguous operator"
-    getPrefix t =
-      uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x]
-    getSuffix t =
-      uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x]
-    getInfix t =
-      uniq [op | Tok x <- [t], (s, op@(Op _ (Infix _ _))) <- optable, s == x]
-    getOperand t
-      | null [op | Tok x <- [t], (s, op) <- optable, s == x] = pure ()
+    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]
+    getOperand x
+      | null [op | (s, op) <- optable, s == x] = pure ()
       | otherwise = err "expected an operand"
     {- actual pushery -}
     canPush :: Ops -> Op -> Either ShuntError Bool
@@ -387,7 +371,7 @@ shunt optable = start
     shunt1 ops vs x op = do
       cp <- canPush ops op
       if cp
-        then pure ((unTok x, op) : ops, vs)
+        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

inst/prelude.pl

@@ -1,13 +1,9 @@
 member(X, [X|_]).
 member(X, [_|T]) :- member(X,T).
 
-append([], [], []).
-append([], [H|T], [H|T]).
+append([], X, X).
 append([X|T], Y, [X|TY]) :- append(T,Y,TY).
 
-list([]).
-list([_|_]).
-
 :- op(700, xfx, is),
    op(700, xfx, <),
    op(700, xfx, =<),
@@ -49,44 +45,17 @@ Ax > Bx :- A is Ax, B is Bx, int2p_lt(B,A).
 Ax >= Bx :- A is Ax, B is Bx, int2p_leq(B,A).
 zero(Ax) :- A is Ax, int1p_zero(A).
 
-gcd(X,Y,R) :- Y > X, !, gcd(Y,X,R).
-gcd(X,Y,R) :- zero(Y), !, R=X.
-gcd(X,Y,R) :- X1 is X mod Y, gcd(Y,X1,R).
+gcd(X,Y,R) :- writeln(a), fail.
+gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
+gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
+gcd(X,Y,R) :- writeln(a), Y > X, writeln(wat), !, gcd(Y,X,R).
+gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
+gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
 
-lcm(X,Y,R) :- gcd(X,Y,GCD), R is X*(Y/GCD).
+test(X) :- writeln(there), zero(X), fail.
+test(X) :- writeln(here).
 
-:- op(1200, xfx, -->).
+test :- writeln(a), a=a, !, fail.
+test :- writeln(b).
 
-sequence([], SameState, SameState) :- !.
-sequence(Tokens, ParsedList, Rest) :-
-  append(Tokens, Rest, ParsedList).
-
-load_expansion((X, L) --> Y, Xp :- (Yp, Lp)) :- !,
-  expand_phrasecall(X, Xp, S0, S),
-  expand_phrase(Y, Yp, S0, S),
-  expand_phrase(L, Lp, S, _).
-
-load_expansion(X --> Y, Xp :- Yp) :- !,
-  expand_phrasecall(X, Xp, S0, S),
-  expand_phrase(Y, Yp, S0, S).
-
-expand_phrase((A, B), (Ap, Bp), S0, S) :- !,
-  expand_phrase(A, Ap, S0, S1),
-  expand_phrase(B, Bp, S1, S).
-expand_phrase((A; B), (Ap; Bp), S0, S) :- !,
-  expand_phrase(A, Ap, S0, S),
-  expand_phrase(B, Bp, S0, S).
-expand_phrase(L, sequence(L, S0, S), S0, S) :- list(L), !.
-expand_phrase({X}, X, S, S) :- !.
-expand_phrase(!, !, S, S) :- !.
-expand_phrase(X, Xp, S0, S) :- expand_phrasecall(X, Xp, S0, S).
-
-expand_phrasecall(X, Xp, S0, S) :-
-  atom(X), !,
-  struct(Xp, X, [S0, S]).
-expand_phrasecall(X, Xp, S0, S) :- !,
-  struct(X, Id, Args),
-  append(Args, [S0, S], Args1),
-  struct(Xp, Id, Args1).
-
-phrase(X, S0, S) :- expand_phrasecall(X, Xp, S0, S), call(Xp).
+xxx :- test.

prlg.cabal

@@ -21,40 +21,18 @@ maintainer:         exa.exa@gmail.com
 -- category:
 extra-source-files: CHANGELOG.md
 
-data-dir:           inst
-data-files:         *.pl
+data-dir:       inst
+data-files:     *.pl
 
 executable prlg
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    other-modules:    Paths_prlg,
-                      Builtins,
-                      Code,
-                      CodeLens,
-                      Compiler,
-                      Constant,
-                      Env,
-                      Frontend,
-                      Heap,
-                      Interpreter,
-                      IR,
-                      Load,
-                      Operators,
-                      Parser
+    other-modules:    Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens, Heap, Paths_prlg
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.14,
-                      containers,
-                      haskeline,
-                      megaparsec,
-                      microlens,
-                      microlens-mtl,
-                      microlens-th,
-                      split,
-                      transformers
-
+    build-depends:    base >=4.14, containers, megaparsec, haskeline, split, transformers, microlens, microlens-th, microlens-mtl
     hs-source-dirs:   app
     default-language: Haskell2010
     ghc-options:      -Wunused-imports