10h vacuum cleaner sound

app/Builtins.hs

@@ -46,9 +46,9 @@ printLocals = do
   scope <- gets (gvar . cur)
   heap <- gets (heap . cur)
   IR.StrTable _ _ itos <- gets strtable
-  flip traverse (M.elems scope) $ \(ref, name) ->
+  flip traverse (M.assocs scope) $ \(local, ref) ->
     lift . outputStrLn $
-    (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref
+    "_Local" ++ show local ++ " = " ++ showTerm itos heap ref
   return Nothing
 
 promptRetry :: InterpFn
@@ -65,15 +65,22 @@ promptRetry' = do
     Just ';' -> backtrack
     _ -> return Nothing
 
-write :: InterpFn
+withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn
-write
+withArgs as f = do
-  --TODO: prlgError on write(Unbound)
- = do
   scope <- gets (hvar . cur)
-  heap <- gets (heap . cur)
+  if all (`M.member` scope) as
-  IR.StrTable _ _ itos <- gets strtable
+    then f $ map (scope M.!) as
-  lift . outputStr . showTerm itos heap . fst $ scope M.! 0
+    else prlgError "arguments not bound"
-  return Nothing
+
+write' :: InterpFn -> InterpFn
+write' c =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    IR.StrTable _ _ itos <- gets strtable
+    lift . outputStr $ showTerm itos heap arg
+    c --this now allows error fallthrough but we might like EitherT
+
+write = write' $ return Nothing
 
 nl :: InterpFn
 nl = do
@@ -81,59 +88,71 @@ nl = do
   return Nothing
 
 writeln :: InterpFn
-writeln = write >> nl
+writeln = write' nl
 
 assertFact :: InterpFn
-assertFact = do
+assertFact =
-  scope <- gets (hvar . cur)
+  withArgs [0] $ \[arg] -> do
-  heap <- gets (heap . cur)
+    heap <- gets (heap . cur)
-  case Co.compileGoal . Co.squashVars <$>
+    case Co.compileGoal . Co.squashVars <$>
-       Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of
+         Co.heapStructPrlgInt Nothing heap arg of
-    Just (U (Struct s):head) -> do
+      Just (U (Struct s):head) -> do
-      addClause s $ head ++ [NoGoal]
+        addClause s $ head ++ [NoGoal]
-      return Nothing
+        return Nothing
-    _ -> prlgError "assert fact failure"
+      _ -> prlgError "assert fact failure"
 
 assertClause :: InterpFn
-assertClause = do
+assertClause =
-  scope <- gets (hvar . cur)
+  withArgs [0, 1] $ \args -> do
-  heap <- gets (heap . cur)
+    scope <- gets (hvar . cur)
-  commaId <- findStruct "," 2
+    heap <- gets (heap . cur)
-  cut <- findAtom "!"
+    comma <- findAtom ","
-  case Co.squashVars . IR.CallI (IR.Id 0 0) <$>
+    cut <- findAtom "!"
-       traverse (Co.heapStructPrlgInt Nothing heap . fst . (M.!) scope) [0, 1] of
+    case Co.squashVars . IR.CallI 0 <$>
-    Just (IR.CallI (IR.Id 0 0) [hs, gs]) ->
+         traverse (Co.heapStructPrlgInt Nothing heap) args of
-      let (U (Struct s):cs) =
+      Just (IR.CallI 0 [hs, gs]) ->
-            Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
+        let (U (Struct s):cs) =
-       in do addClause s cs
+              Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals comma cut gs)
-             return Nothing
+         in do addClause s cs
-    _ -> prlgError "assert clause failure"
+               return Nothing
+      _ -> prlgError "assert clause failure"
 
 retractall :: InterpFn
-retractall = prlgError "no retractall yet"
+retractall =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    case derefHeap heap arg of
+      BoundRef _ (Atom a) -> dropProcedure (IR.Id {IR.arity = 0, IR.str = a})
+      BoundRef _ (Struct id) -> dropProcedure id
+      _ -> prlgError "retractall needs a struct"
 
 call :: InterpFn
-call = do
+call =
-  ref <- gets (fst . (M.! 0) . hvar . cur)
+  withArgs [0] $ \[arg] -> do
-  heap@(Heap _ hmap) <- gets (heap . cur)
+    heap@(Heap _ hmap) <- gets (heap . cur)
-  let exec base struct arity = do
+    let exec base struct arity = do
-        cur <- gets cur
+          cur <- gets cur
-        modify $ \s ->
+          modify $ \s ->
-          s
+            s
-            { cur =
+              { cur =
-                cur
+                  cur
-                  { gol =
+                    { gol =
-                      [Call, Goal, U struct] ++
+                        [Call, Goal, U struct] ++
-                      [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
+                        [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
-                  }
+                    }
-            }
+              }
-        return Nothing
+          return Nothing
-  case derefHeap heap ref of
+    case derefHeap heap arg of
-    BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) ->
+      BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) ->
-      exec addr struct arity
+        exec addr struct arity
-    BoundRef addr (Atom a) ->
+      BoundRef addr (Atom a) ->
-      exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
+        exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
-    _ -> prlgError "not callable"
+      _ -> prlgError "not callable"
+
+struct :: InterpFn
+struct = do
+  scope <- gets (hvar . cur)
+  prlgError "not yet"
 
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
@@ -145,20 +164,29 @@ addClause struct code =
 addProcedure struct heads =
   modify $ \s -> s {defs = M.insert struct heads $ defs s}
 
+dropProcedure struct = do
+  d <- gets defs
+  if struct `M.member` d
+    then do
+      modify $ \s -> s {defs = M.delete struct d}
+      return Nothing
+    else prlgError "no such definition" -- this should backtrack?
+
 addProc n a c = do
   sym <- findStruct n a
   addProcedure sym c
 
-addBi0 n b = addProc n 0 [[Invoke $ bi b]]
+addBi n i b =
+  addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]]
 
 addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
   {- primitives -}
-  addBi0 "true" (pure Nothing)
+  addBi "true" 0 (pure Nothing)
-  addBi0 "fail" backtrack
+  addBi "fail" 0 backtrack
   addOp $ O.xfx "=" 700
-  addProc "=" 2 [[U (LocalRef 0 0), U (LocalRef 0 0), NoGoal]]
+  addProc "=" 2 [[U (LocalRef 0), U (LocalRef 0), NoGoal]]
   {- clauses -}
   addOp $ O.xfy "," 1000
   addOp $ O.xfx ":-" 1200
@@ -168,22 +196,23 @@ addPrelude = do
     "assert"
     1
     [ [ U (Struct horn2)
-      , U (LocalRef 0 0)
+      , U (LocalRef 0)
-      , U (LocalRef 1 0)
+      , U (LocalRef 1)
       , Cut
       , Invoke (bi assertClause)
       ]
-    , [U (LocalRef 0 0), Invoke (bi assertFact)]
+    , [U (LocalRef 0), Invoke (bi assertFact)]
     ]
-  addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
+  addBi "retractall" 1 retractall
-  addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]]
+  addBi "call" 1 call
+  addBi "struct" 3 struct
   {- query tools -}
-  addBi0 "print_locals" printLocals
+  addBi "print_locals" 0 printLocals
-  addBi0 "prompt_retry" promptRetry'
+  addBi "prompt_retry" 0 promptRetry'
-  addBi0 "query" (printLocals >> promptRetry)
+  addBi "query" 0 (printLocals >> promptRetry)
   {- IO -}
-  addProc "write" 1 [[U (LocalRef 0 0), Invoke (bi write)]]
+  addBi "write" 1 write
-  addProc "writeln" 1 [[U (LocalRef 0 0), Invoke (bi writeln)]]
+  addBi "writeln" 1 writeln
-  addBi0 "nl" nl
+  addBi "nl" 0 nl
   {- debug -}
-  addBi0 "interpreter_trace" (get >>= liftIO . print >> pure Nothing)
+  addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing)

app/Code.hs

@@ -12,7 +12,7 @@ data Datum
   = Atom Int -- unifies a constant
   | Struct Id -- unifies a structure with arity
   | VoidRef -- unifies with anything
-  | LocalRef Int Int -- code-local variable idx (should never occur on heap)
+  | LocalRef Int -- code-local variable idx (should never occur on heap)
   | HeapRef Int -- something further on the heap
   deriving (Show, Eq, Ord)
 
@@ -36,7 +36,7 @@ data Heap =
 
 emptyHeap = Heap 1 M.empty
 
-type Scope = M.Map Int (Int, Int)
+type Scope = M.Map Int Int
 
 emptyScope :: Scope
 emptyScope = M.empty
@@ -103,7 +103,7 @@ codeStruct ::
 codeStruct atom struct local rec end heap = go
   where
     go [] = ([], ) <$> end
-    go (U lr@(LocalRef _ _):cs) = do
+    go (U lr@(LocalRef _):cs) = do
       x <- local lr
       case x of
         Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref

app/Compiler.hs

@@ -10,8 +10,7 @@ desugarPrlg :: Int -> PrlgInt -> PrlgInt
 desugarPrlg list = go
   where
     go (CallI id ps) = CallI id $ map go ps
-    go (ListI (x:xs) t) =
+    go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
-      CallI Id {str = list, arity = 2} [go x, go (ListI xs t)]
     go (ListI [] Nothing) = LiteralI list
     go (ListI [] (Just x)) = go x
     go x = x
@@ -29,7 +28,7 @@ varOccurs _ = M.empty
 variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
 variablizePrlg void (StrTable _ _ itos) = go
   where
-    go (CallI id ps) = CallI id $ map go ps
+    go (CallI i ps) = CallI i $ map go ps
     go (LiteralI i)
       | i == void = VoidI
       | varname (itos M.! i) = VarI i i
@@ -38,7 +37,7 @@ variablizePrlg void (StrTable _ _ itos) = go
 renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
 renumVars rename = go
   where
-    go (CallI id ps) = CallI id $ map go ps
+    go (CallI i ps) = CallI i $ map go ps
     go (VarI idx i)
       | Just new <- rename idx = new
     go x = x
@@ -52,13 +51,13 @@ squashVars x =
         [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
    in renumVars (m' M.!?) x
 
-compileGoals :: Id -> Int -> PrlgInt -> [Code]
+compileGoals :: Int -> Int -> PrlgInt -> [Code]
 compileGoals andop cut = go'
   where
     go' = go . struct2goal
-    go p@(CallI x args)
+    go p@(CallI x args@[_, _])
       | x == andop = concatMap go' args
-    go p@(CallI (Id x 0) [])
+    go p@(CallI x [])
       | x == cut = [[Cut]]
     go x = [compileGoal x]
 
@@ -66,9 +65,10 @@ compileGoal :: PrlgInt -> Code
 compileGoal = compileArg . struct2goal
 
 compileArg :: PrlgInt -> Code
-compileArg (CallI s args) = U (Struct s) : concatMap compileArg args
+compileArg (CallI i args) =
+  U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
 compileArg (LiteralI s) = [U (Atom s)]
-compileArg (VarI x s) = [U (LocalRef x s)]
+compileArg (VarI x _) = [U (LocalRef x)]
 compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
@@ -84,16 +84,16 @@ heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
   where
     atom (Atom s) = pure $ LiteralI s
     atom VoidRef = pure $ VoidI
-    struct (Struct s) args = pure $ CallI s args
+    struct (Struct s) args = pure $ CallI (str s) args
     hrec (HeapRef r) ref
       | r == ref = pure $ VarI r 0
       | otherwise = heaperr
 
 -- TODO check if this is used
 goal2struct :: PrlgInt -> PrlgInt
-goal2struct (CallI (Id s 0) []) = LiteralI s
+goal2struct (CallI s []) = LiteralI s
 goal2struct x = x
 
 struct2goal :: PrlgInt -> PrlgInt
-struct2goal (LiteralI s) = CallI (Id s 0) []
+struct2goal (LiteralI s) = CallI s []
 struct2goal x = x

app/Frontend.hs

@@ -8,7 +8,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Lazy (evalStateT, gets)
 import Data.Foldable (traverse_)
 import qualified Data.Map as M
-import Env (PrlgEnv, findAtom, findStruct, withStrTable)
+import Env (PrlgEnv, findAtom, withStrTable)
 import qualified IR
 import qualified Interpreter as I
 import qualified Parser as P
@@ -55,9 +55,9 @@ interpret = (>> return True) . lex
             C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
       compile prlgv
     compile prlgv = do
-      commaId <- findStruct "," 2
+      comma <- findAtom ","
       cut <- findAtom "!"
-      let code = C.seqGoals $ C.compileGoals commaId cut prlgv
+      let code = C.seqGoals $ C.compileGoals comma cut prlgv
       execute code
     execute code = do
       res <- I.prove code

app/IR.hs

@@ -17,7 +17,7 @@ data Id =
   deriving (Show, Eq, Ord)
 
 data PrlgInt
-  = CallI Id [PrlgInt] --TODO this should be Int
+  = CallI Int [PrlgInt]
   | LiteralI Int
   | ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
   | VarI Int Int -- VarI localIndex strTableString
@@ -41,7 +41,7 @@ internPrlg = go
     go t (LiteralS str) = LiteralI <$> strtablize t str
     go t (CallS str ps) =
       let (t', i) = strtablize t str
-       in CallI (Id i $ length ps) <$> mapAccumL go t' ps
+       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

app/Interpreter.hs

@@ -89,10 +89,10 @@ proveStep = St.get >>= go
            in ( Heap (nxt + n) $
                 foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
               , addrs)
-        allocLocal (LocalRef reg ident) scope cont
+        allocLocal (LocalRef reg) scope cont
-          | Just (addr, _) <- scope M.!? reg = cont scope heap addr
+          | Just addr <- scope M.!? reg = cont scope heap addr
           | (heap', addr) <- newHeapVar heap =
-            cont (M.insert reg (addr, ident) scope) heap' addr
+            cont (M.insert reg addr scope) heap' addr
         newHeapStruct addr s@(Struct Id {arity = arity}) cont =
           let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
               m'' =
@@ -113,10 +113,10 @@ proveStep = St.get >>= go
         unify (Struct Id {arity = a}) VoidRef =
           c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ gs}}
         {- handle local refs; first ignore their combination with voids to save memory -}
-        unify (LocalRef _ _) VoidRef = uok
+        unify (LocalRef _) VoidRef = uok -- TRICKY: builtins need to check if locals actually exist because of this
-        unify VoidRef (LocalRef _ _) = uok
+        unify VoidRef (LocalRef _) = uok
         {- allocate heap for LocalRefs and retry with HeapRefs -}
-        unify lr@(LocalRef _ _) _ =
+        unify lr@(LocalRef _) _ =
           allocLocal lr (hvar cur) $ \hvar' heap' addr ->
             c
               i
@@ -124,7 +124,7 @@ proveStep = St.get >>= go
                     cur
                       {hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'}
                 }
-        unify _ lr@(LocalRef _ _) =
+        unify _ lr@(LocalRef _) =
           allocLocal lr (gvar cur) $ \gvar' heap' addr ->
             c
               i

app/Parser.hs

@@ -172,29 +172,27 @@ literal = Literal . unTok <$> free (satisfy isNormalTok <* notFollowedBy lParen)
 
 call = do
   fn <- unTok <$> satisfy isNormalTok -- not free
-  Seq inner <- free parens
+  (Call fn [] <$ try emptyParens) <|> do
-  return $ Call fn $ splitOn [Literal ","] inner
+    Seq inner <- free parens
+    return $ Call fn $ splitOn [Literal ","] inner
 
 parens = Seq <$> (free lParen *> some seqItem <* free rParen)
 
+emptyParens = Literal "()" <$ (free lParen >> free rParen)
+
 list = do
   free lBracket
-  choice
+  (List [] Nothing <$ free rBracket) <|> do
-    [ List [] Nothing <$ free rBracket
+    items <- splitOn [Literal ","] <$> some seqItem
-    , do items <- splitOn [Literal ","] <$> some seqItem
+    (List items Nothing <$ free rBracket) <|>
-         choice
+      (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
-           [ List items Nothing <$ free rBracket
-           , List items . Just <$>
-             (free listTail *> some seqItem <* free rBracket)
-           ]
-    ]
 
-seqItem = choice [try call, literal, parens, list]
+seqItem = choice [try call, literal, try emptyParens, parens, list]
 
 simpleTok :: String -> Parser ()
 simpleTok s = void $ single (Tok s)
 
-comma = simpleTok "."
+period = simpleTok "."
 
 lParen = simpleTok "("
 
@@ -207,7 +205,7 @@ listTail = simpleTok "|"
 rBracket = simpleTok "]"
 
 clause :: Parser PAST
-clause = Seq <$> some (free seqItem) <* free comma
+clause = Seq <$> some (free seqItem) <* free period
 
 parsePrlg :: Parser [PAST]
 parsePrlg = ws *> many clause <* eof