lookahead, sequence

app/Builtins.hs

@@ -2,9 +2,10 @@ module Builtins where
 
 import Paths_prlg
 
-import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
+import Code (Builtin(..), Code, Datum(..), Id(..), 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)
@@ -16,7 +17,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 qualified IR
+import IR (PrlgInt(..), StrTable(..))
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
 import Load (processInput)
@@ -29,10 +30,11 @@ continue = pure Nothing
 
 showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
   where
-    atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
-    atom (Number n) = pure (show n)
+    atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
+    atom (C (Number n)) = pure (show n)
+    atom (C (Str str)) = pure (show str)
     atom VoidRef = pure "_"
-    struct (Struct (IR.Id h _)) args =
+    struct (Struct (Id h _)) args =
       pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
     hrec (HeapRef hr) ref =
       pure $
@@ -45,7 +47,7 @@ printLocals :: InterpFn
 printLocals = do
   scope <- use (cur . gvar)
   heap <- use (cur . heap)
-  IR.StrTable _ _ itos <- use strtable
+  StrTable _ _ itos <- use strtable
   flip traverse (M.assocs scope) $ \(local, ref) ->
     lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
     showTerm itos heap ref
@@ -76,7 +78,7 @@ write' :: InterpFn -> InterpFn
 write' c =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     lift . outputStr $ showTerm itos heap arg
     c --this now allows error fallthrough but we might like EitherT
 
@@ -90,32 +92,31 @@ nl = do
 writeln :: InterpFn
 writeln = write' nl
 
-assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
+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 -> IR.Id -> PrlgEnv ()) -> InterpFn
+assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
 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
@@ -123,37 +124,29 @@ retractall =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Atom a) ->
-        dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
+      BoundRef _ (C (Atom a)) ->
+        dropProcedure (Id {arity = 0, str = a}) >> continue
       BoundRef _ (Struct id) -> dropProcedure id >> continue
       _ -> prlgError "retractall needs a struct"
 
-exec' :: (Code -> Code) -> InterpFn
-exec' fgol =
+call :: InterpFn
+call =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    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
+    case derefHeap heap arg of
+      BoundRef _ (C (Atom a)) -> do
+        cur . hed .= [U (Struct (Id {str = a, arity = 0})), Done]
         continue
-      _ -> prlgError "bad goal"
-
-call :: InterpFn
-call = exec' id
-
-exec :: InterpFn
-exec = exec' (const [Done])
+      BoundRef addr s@(Struct Id {arity = arity}) -> do
+        cur . hed .= [U s] ++ [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++
+          [Done]
+        continue
+      _ -> prlgError "bad call"
 
 stop :: InterpFn
 stop =
   withArgs [0] $ \[arg] -> do
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     heap <- use (cur . heap)
     prlgError $ "stop: " ++ showTerm itos heap arg
 
@@ -163,17 +156,18 @@ struct = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
-    Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
+    Just (BoundRef _ (Struct Id {arity = arity, 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 == Atom listAtom
+      | BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
       | otherwise = False
     step r
-      | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
+      | BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
          derefHeap heap r
       , listAtom == listAtom' = Just (addr + 2)
       | otherwise = Nothing
@@ -190,7 +184,7 @@ structAssemble = do
   heap <- use (cur . heap)
   scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 1 of
-    Just (BoundRef addr (Atom str)) -> do
+    Just (BoundRef addr (C (Atom str))) -> do
       listAtom <- findAtom "[]"
       case scope M.!? 2 >>= heapListLength listAtom heap of
         Just arity -> structUnify arity str
@@ -203,17 +197,17 @@ structUnify arity str = do
   listAtom <- findAtom "[]"
   pvars <- newHeapVars arity
   let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
-      structData =
-        Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
+      structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
       paramsData =
         concatMap
-          (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
+          (\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
           pvars ++
-        [Atom listAtom]
-      gcode = map U $ structData ++ [Atom str] ++ paramsData
+        [C $ Atom listAtom]
+      gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
   zoom cur $ do
     gol %= (gcode ++)
     hed %= (hcode ++)
+    unis += 3
   continue
 
 {- terms -}
@@ -226,12 +220,29 @@ 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 _ (Number _)) -> continue
+    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
     _ -> backtrack
 
 sameTerm :: InterpFn
@@ -260,9 +271,9 @@ op :: InterpFn
 op =
   withArgs [0, 1, 2] $ \args -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case map (derefHeap heap) args of
-      [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
+      [BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (Atom opatom))]
         | Just op <-
            (,) <$> itos M.!? opatom <*>
            (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
@@ -274,9 +285,9 @@ deop :: InterpFn
 deop =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable
+    StrTable _ _ itos <- use strtable
     case derefHeap heap arg of
-      BoundRef _ (Atom opatom)
+      BoundRef _ (C (Atom opatom))
         | Just op <- itos M.!? opatom -> do
           ops %= filter ((/= op) . fst)
           continue
@@ -326,7 +337,8 @@ intBinary op =
   withArgs [0, 1] $ \[arg1, arg2] -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> [arg1, arg2] of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
+        putInt (op n1 n2) 2
       _ -> prlgError "int binary needs numbers"
 
 intBinPred :: (Int -> Int -> Bool) -> InterpFn
@@ -334,7 +346,7 @@ intBinPred op =
   withArgs [0, 1] $ \args -> do
     heap <- use (cur . heap)
     case derefHeap heap <$> args of
-      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
+      [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
         if op n1 n2
           then continue
           else backtrack
@@ -345,7 +357,7 @@ intUnary op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) -> putInt (op n) 1
+      BoundRef _ (C (Number n)) -> putInt (op n) 1
       _ -> prlgError "int unary needs number"
 
 intUnPred :: (Int -> Bool) -> InterpFn
@@ -353,7 +365,7 @@ intUnPred op =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
     case derefHeap heap arg of
-      BoundRef _ (Number n) ->
+      BoundRef _ (C (Number n)) ->
         if op n
           then continue
           else backtrack
@@ -366,28 +378,28 @@ putInt val sc = do
     Nothing -> continue
     Just a ->
       case derefHeap heap a of
-        BoundRef _ (Number val')
+        BoundRef _ (C (Number val'))
           | val == val' -> continue
-        FreeRef a' -> writeHeap a' (Number val) >> continue
+        FreeRef a' -> writeHeap a' (C (Number val)) >> continue
         _ -> backtrack
 
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
 
-modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
+modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv ()
 modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
 
-addClauseA :: Code -> IR.Id -> PrlgEnv ()
+addClauseA :: Code -> Id -> PrlgEnv ()
 addClauseA code = modDef $ Just . (code :)
 
-addClauseZ :: Code -> IR.Id -> PrlgEnv ()
+addClauseZ :: Code -> Id -> PrlgEnv ()
 addClauseZ code = modDef $ Just . (++ [code])
 
-addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
+addProcedure :: [Code] -> Id -> PrlgEnv ()
 addProcedure heads = modDef $ Just . const heads
 
-dropProcedure :: IR.Id -> PrlgEnv ()
+dropProcedure :: Id -> PrlgEnv ()
 dropProcedure = modDef $ const Nothing
 
 addProc :: [Code] -> String -> Int -> PrlgEnv ()
@@ -413,9 +425,9 @@ load :: Bool -> InterpFn
 load queryMode =
   withArgs [0] $ \[arg] -> do
     heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
+    StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
     case derefHeap heap arg of
-      BoundRef _ (Atom a) -> do
+      BoundRef _ (C (Atom a)) -> do
         let fn = itos M.! a
         doLoad queryMode (itos M.! a)
       _ -> prlgError "load needs an atom"
@@ -425,7 +437,7 @@ addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
   {- absolute primitives -}
-  addBi (pure Nothing) "true" 0
+  addProc [[Done]] "true" 0
   addBi backtrack "fail" 0
   addBi stop "stop" 1
   addOp $ O.xfx "=" 700
@@ -435,27 +447,58 @@ addPrelude = do
   addOp $ O.xfy ";" 1100
   addOp $ O.xfx ":-" 1200
   addOp $ O.fx ":-" 1200
-  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
+  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
   addBi retractall "retractall" 1
-  addBi call "call" 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
   {- 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 -}
@@ -489,30 +532,30 @@ addPrelude = do
           ]
           ("expand_" ++ q)
           2
-  expandCode "load"
-  expandCode "query"
+   in do 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
-  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" (/=)
+   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" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0

app/Code.hs

@@ -2,24 +2,31 @@
 
 module Code where
 
+import Constant
 import Control.Monad.Trans.State.Lazy (StateT)
 import qualified Data.Map as M
-import IR (Id(..), StrTable)
+import IR (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
-  = Atom Int -- unifies a symbolic constant
-  | Number Int -- unifies a numeric constant
-  | Struct Id -- unifies a structure with arity
+  = C !Constant -- unifies a 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
@@ -31,7 +38,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
@@ -51,7 +58,8 @@ 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
+    , _cut :: [Cho] -- snapshot of choicepoints before entering the goal
+    , _hcut :: [Cho] -- save of choicepoints just before starting to match head
     }
   deriving (Show)
 

app/Compiler.hs

@@ -1,20 +1,13 @@
 module Compiler where
 
+import Constant
+import Control.Monad
 import Data.Char (isUpper)
 import qualified Data.Map as M
 
-import Code (Code, Datum(..), Heap, Instr(..))
+import Code (Code, Datum(..), Heap, Id(..), Instr(..))
 import Heap (heapStruct)
-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
+import IR (PrlgInt(..), StrTable(..))
 
 varname :: String -> Bool
 varname ('_':_) = True
@@ -23,24 +16,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 (AtomI i)
+    go o@(ConstI (Atom i))
       | i == void = VoidI
-      | varname (itos M.! i) = VarI i i
-      | otherwise = AtomI i
+      | varname (itos M.! i) = VarI i
+      | otherwise = o
     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 i)
+    go (VarI idx)
       | Just new <- rename idx = new
     go x = x
 
@@ -50,38 +43,37 @@ squashVars x =
       m' =
         M.fromList $
         [(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
-        [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
+        [(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) =
   U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
-compileArg (AtomI s) = [U (Atom s)]
-compileArg (NumI s) = [U (Number s)]
-compileArg (VarI x _) = [U (LocalRef x)]
+compileArg (ConstI c) = [U (C c)]
+compileArg (VarI x) = [U (LocalRef x)]
 compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
@@ -90,20 +82,14 @@ seqGoals = (++ [Done]) . concat
 heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
 heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
   where
-    atom (Atom s) = pure $ AtomI s
-    atom (Number n) = pure $ NumI n
+    atom (C c) = pure (ConstI c)
     atom VoidRef = pure $ VoidI
     struct (Struct s) args = pure $ CallI (str s) args
     hrec (HeapRef r) ref
-      | r == ref = pure $ VarI r 0
+      | r == ref = pure $ VarI r
       | otherwise = heaperr
 
--- 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."
+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/Constant.hs

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

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/Heap.hs

@@ -4,7 +4,6 @@ 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,28 +1,15 @@
 module IR where
 
+import Constant
 import Data.Char (isNumber)
 import Data.List (mapAccumL)
 import qualified Data.Map as M
-
-data PrlgStr
-  = CallS String [PrlgStr]
-  | LiteralS String
-  | ListS [PrlgStr] (Maybe PrlgStr)
-  deriving (Show)
-
-data Id =
-  Id
-    { str :: Int
-    , arity :: Int
-    }
-  deriving (Show, Eq, Ord)
+import Parser (Lexeme(..), PrlgStr(..))
 
 data PrlgInt
   = CallI Int [PrlgInt]
-  | AtomI Int
-  | NumI Int
-  | ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
-  | VarI Int Int -- VarI localIndex strTableString
+  | ConstI Constant
+  | VarI Int -- VarI localIndex strTableString
   | VoidI
   deriving (Show)
 
@@ -37,16 +24,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 str)
-      | all isNumber str = (t, NumI $ read str)
-      | otherwise = AtomI <$> strtablize t str
+    go t (LiteralS lex) = internLexeme t lex
     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,6 +8,7 @@ import Code
   , Cho(..)
   , Code
   , Datum(..)
+  , Id(..)
   , Instr(..)
   , InterpFn
   , emptyHeap
@@ -18,7 +19,7 @@ import Control.Monad (when)
 import qualified Data.Map as M
 import Env (PrlgEnv)
 import Heap
-import IR (Id(..), StrTable(..))
+import IR (StrTable(..))
 import Lens.Micro
 import Lens.Micro.Mtl
 
@@ -35,6 +36,7 @@ prove g = do
       , _heap = emptyHeap
       , _stk = []
       , _cut = []
+      , _hcut = []
       }
   cho .= []
   loop
@@ -54,10 +56,14 @@ 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
@@ -92,7 +98,7 @@ headStep h = do
   case (h, g) of
     ([Done], _) -> succeedHead
     (Cut:_, _) -> cutHead
-    (Invoke (Builtin bf):_, _) -> advanceHead >> bf
+    (Invoke (Builtin bf):_, _) -> cur . hed .= [Done] >> bf
     (_, [Done]) -> tailCall
     (_, [Cut, Done]) -> tailCut
     (_, _) -> pushCall
@@ -134,11 +140,13 @@ retCut = do
     doCut
     cur . retcut .= False
 
-cutHead = doCut >> advanceHead
+cutHead = do
+  use (cur . hcut) >>= assign cho
+  advanceHead
 
 cutGoal = doCut >> advance
 
-openGoal :: IR.Id -> InterpFn
+openGoal :: Id -> InterpFn
 openGoal fn = do
   def <- (M.!? fn) <$> use defs
   case def of
@@ -147,7 +155,8 @@ openGoal fn = do
       cur . hvar .= emptyScope
       cur . unis .= arity fn
       cc <- use cur
-      let (newcur:newcho) = [cc & hed .~ h | h <- hs]
+      oldcho <- use cho
+      let (newcur:newcho) = [cc & hcut .~ oldcho & hed .~ h | h <- hs]
       cur .= newcur
       cho %= (newcho ++)
       continue
@@ -162,12 +171,15 @@ 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
 
@@ -179,6 +191,7 @@ tailCall = do
   cur . gvar .= ngvar
   cur . hed .= []
   cur . hvar .= emptyScope
+  cur . hcut .= []
   continue
 
 tailCut :: InterpFn
@@ -189,8 +202,9 @@ tailCut = do
 
 succeedHead :: InterpFn
 succeedHead = do
-  cur . hvar .= emptyScope
   cur . hed .= []
+  cur . hvar .= emptyScope
+  cur . hcut .= []
   continue
 
 succeedGoal :: InterpFn
@@ -231,13 +245,10 @@ uOK = uNext >> continue
 
 unify :: Datum -> Datum -> InterpFn
 unify VoidRef VoidRef = uOK
-unify (Atom _) VoidRef = uOK
-unify VoidRef (Atom _) = uOK
-unify (Atom a) (Atom b)
+unify (C _) VoidRef = uOK
+unify VoidRef (C _) = uOK
+unify (C a) (C 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, PrlgEnv)
+import Code (Code, Id(..), PrlgEnv)
 import CodeLens
 import qualified Compiler as C
 import Control.Monad.Trans.Class (lift)
@@ -21,27 +21,23 @@ 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 IR.PrlgStr
+shunt :: P.PAST -> ExceptT String PrlgEnv P.PrlgStr
 shunt past = do
   ops <- lift $ use ops
   except . left (\err -> "operator resolution: " ++ err ++ "\n") $
     P.shuntPrlg ops past
 
-intern :: IR.PrlgStr -> PrlgEnv IR.PrlgInt
+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 $ C.desugarPrlg list prlgi)
+    (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)
@@ -58,9 +54,7 @@ expansion noexpand expander output x = do
     if expand
       then IR.CallI
              comma
-             [ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
-             , IR.CallI o [IR.VarI (-1) 0]
-             ]
+             [IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]]
       else noexpand o x
 
 queryExpansion = expansion (\_ -> id) "expand_query" "call"

app/Parser.hs

@@ -5,7 +5,8 @@ module Parser
   , parsePrlg
   , shuntPrlg
   , PAST
-  , Lexeme
+  , Lexeme(..)
+  , PrlgStr(..)
   ) where
 
 import Control.Monad (void)
@@ -42,14 +43,13 @@ 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,6 +64,7 @@ data Lexeme
   = Blank String
   | Tok String
   | QTok String String -- unquoted quoted
+  | DQTok String String -- unquoted quoted
   deriving (Show, Eq, Ord)
 
 blank :: Lexer Lexeme
@@ -86,14 +87,15 @@ qtok = do
   z <- string "'"
   return $ QTok y (x ++ y ++ z)
 
-cmt :: Lexer Lexeme
-cmt =
-  Blank . concat <$>
-  sequence
-    [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
+dqtok :: Lexer Lexeme
+dqtok = do
+  x <- string "\""
+  y <- many $ satisfy (/= '\"') -- TODO actual escaping
+  z <- string "\""
+  return $ DQTok y (x ++ y ++ z)
 
 lexeme :: Lexer Lexeme
-lexeme = choice [blank, tok, qtok, cmt]
+lexeme = choice [blank, tok, qtok, dqtok]
 
 lexPrlg :: Lexer [Lexeme]
 lexPrlg = many lexeme <* (many blank >> eof)
@@ -101,6 +103,7 @@ 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)
@@ -146,9 +149,9 @@ instance TraversableStream [Lexeme] where
 
 data PAST
   = Call String [[PAST]]
-  | Seq [PAST]
+  | Group [PAST]
   | List [[PAST]] (Maybe [PAST])
-  | Literal String
+  | Literal Lexeme
   deriving (Show, Eq)
 
 type Parser = Parsec Void [Lexeme]
@@ -165,43 +168,46 @@ 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 _ = True
+isCallTok (QTok _ _) = True
+isCallTok _ = False
 
 unTok (Tok t) = t
 unTok (QTok t _) = t
+unTok (DQTok t _) = t
 
 literal :: Parser PAST
 literal =
-  Literal . unTok <$>
+  Literal <$>
   free
     (choice
        [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
        , satisfy (\x -> not (isCallTok x) && isNormalTok x)
        ])
 
-makeParams (Seq inner) = splitOn [Literal ","] inner
+makeParams (Group inner) = splitOn [Literal (Tok ",")] inner
 
 call eb contents fmod = do
   fn <- fmod . unTok <$> satisfy isCallTok -- not free
   (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
 
-parens = Seq <$> (free lParen *> some seqItem <* free rParen)
+parens = Group <$> (free lParen *> some seqItem <* free rParen)
 
-braces = Seq <$> (free lBrace *> some seqItem <* free rBrace)
+braces = Group <$> (free lBrace *> some seqItem <* free rBrace)
 
-emptyParens = Literal "()" <$ (free lParen >> free rParen)
+emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen)
 
-emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace)
+emptyBraces = Literal (QTok "{}" "{}") <$ (free lBrace >> free rBrace)
 
 list = do
   free lBracket
   (List [] Nothing <$ free rBracket) <|> do
-    items <- splitOn [Literal ","] <$> some seqItem
+    items <- splitOn [Literal (Tok ",")] <$> some seqItem
     (List items Nothing <$ free rBracket) <|>
       (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
 
@@ -237,7 +243,7 @@ lBrace = simpleTok "{"
 rBrace = simpleTok "}"
 
 clause :: Parser PAST
-clause = Seq <$> some (free seqItem) <* free period
+clause = Group <$> some (free seqItem) <* free period
 
 parsePrlg :: Parser [PAST]
 parsePrlg = ws *> many clause <* eof
@@ -246,6 +252,11 @@ type ShuntError = String
 
 type ShuntResult = Either ShuntError PrlgStr
 
+data PrlgStr
+  = CallS String [PrlgStr]
+  | LiteralS Lexeme
+  deriving (Show)
+
 err :: ShuntError -> Either ShuntError a
 err = Left
 
@@ -254,8 +265,10 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
 
 shuntPrlg' :: Ops -> PAST -> ShuntResult
 shuntPrlg' ot (List hs t) =
-  ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
-shuntPrlg' ot (Seq ss) = shunt ot ss
+  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
 shuntPrlg' ot (Literal s) = pure (LiteralS s)
 shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
 
@@ -296,13 +309,13 @@ shunt optable = start
              (ops', vs') <- pushInfix ops vs x
              wo ops' vs' xs
         , do getOperand x
-             ho ops vs (Literal "" : xs') -- app (see below)
+             ho ops vs (Literal (Tok "") : xs') -- app (see below)
         , do getPrefix x
-             ho ops vs (Literal "" : xs') -- also app!
+             ho ops vs (Literal (Tok "") : 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)
+    ho ops vs xs@(_:_) = ho ops vs (Literal (Tok "") : xs)
     {- the last operand was last, pop until finished -}
     ho [] [res] [] = pure res
     ho ops vs [] = do
@@ -319,11 +332,14 @@ shunt optable = start
     {- Operator checks -}
     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]
-    getOperand x
-      | null [op | (s, op) <- optable, s == x] = pure ()
+    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 ()
       | otherwise = err "expected an operand"
     {- actual pushery -}
     canPush :: Ops -> Op -> Either ShuntError Bool
@@ -371,7 +387,7 @@ shunt optable = start
     shunt1 ops vs x op = do
       cp <- canPush ops op
       if cp
-        then pure ((x, op) : ops, vs)
+        then pure ((unTok 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,9 +1,13 @@
 member(X, [X|_]).
 member(X, [_|T]) :- member(X,T).
 
-append([], X, X).
+append([], [], []).
+append([], [H|T], [H|T]).
 append([X|T], Y, [X|TY]) :- append(T,Y,TY).
 
+list([]).
+list([_|_]).
+
 :- op(700, xfx, is),
    op(700, xfx, <),
    op(700, xfx, =<),
@@ -45,17 +49,44 @@ 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) :- 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).
+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).
 
-test(X) :- writeln(there), zero(X), fail.
-test(X) :- writeln(here).
+lcm(X,Y,R) :- gcd(X,Y,GCD), R is X*(Y/GCD).
 
-test :- writeln(a), a=a, !, fail.
-test :- writeln(b).
+:- op(1200, xfx, -->).
 
-xxx :- test.
+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).

prlg.cabal

@@ -21,18 +21,40 @@ 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:    Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens, Heap, Paths_prlg
+    other-modules:    Paths_prlg,
+                      Builtins,
+                      Code,
+                      CodeLens,
+                      Compiler,
+                      Constant,
+                      Env,
+                      Frontend,
+                      Heap,
+                      Interpreter,
+                      IR,
+                      Load,
+                      Operators,
+                      Parser
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.14, containers, megaparsec, haskeline, split, transformers, microlens, microlens-th, microlens-mtl
+    build-depends:    base >=4.14,
+                      containers,
+                      haskeline,
+                      megaparsec,
+                      microlens,
+                      microlens-mtl,
+                      microlens-th,
+                      split,
+                      transformers
+
     hs-source-dirs:   app
     default-language: Haskell2010
     ghc-options:      -Wunused-imports