builtins are built in

app/Builtins.hs

@@ -1,15 +1,19 @@
 module Builtins where
 
 import Code
+import Control.Monad.IO.Class
 import Control.Monad.Trans.State.Lazy
 import qualified Data.Map as M
-import Env
+import Env hiding (PrlgEnv)
+import Interpreter (backtrack)
 import qualified Operators as O
 
-import Debug.Trace
+bi = Builtin
 
-hello :: BuiltinFunc
+hello =
-hello = BuiltinFunc $ trace "hllo prlg"
+  bi $ do
+    liftIO $ putStrLn "hllo prlg"
+    return Nothing
 
 addBuiltins :: PrlgEnv ()
 addBuiltins = do
@@ -21,6 +25,9 @@ addBuiltins = do
   any1 <- findStruct "any" 1
   eq2 <- findStruct "=" 2
   hello0 <- findStruct "hello" 0
+  fail0 <- findStruct "fail" 0
+  true0 <- findStruct "true" 0
+  prlgstate0 <- findStruct "prlgstate" 0
   modify $ \s ->
     s
       { defs =
@@ -32,7 +39,11 @@ addBuiltins = do
                 , [Goal, U (Struct a1), U (Atom b), LastCall]
                 ])
             , (any1, [[U (VoidRef Nothing), NoGoal]])
-            , (hello0, [[Builtin hello]])
+            , (hello0, [[Invoke hello]])
+            , (fail0, [[Invoke $ bi backtrack]])
+            , (true0, [[Invoke $ bi (pure Nothing)]])
+            , ( prlgstate0
+              , [[Invoke $ bi (get >>= liftIO . print >> pure Nothing)]])
             ]
       , ops = [(O.xfy "," 1000), (O.xfx "=" 700)]
       }

app/Code.hs

@@ -1,8 +1,10 @@
 module Code where
 
+import Control.Monad.Trans.State.Lazy
 import qualified Data.Map as M
 import IR (Id(..), StrTable)
 import Operators (Ops)
+import System.Console.Haskeline
 
 data Datum
   = Atom Int -- unifies a constant
@@ -12,16 +14,10 @@ data Datum
   | HeapRef Int (Maybe Int) -- heap structure idx
   deriving (Show, Eq, Ord)
 
-data BuiltinFunc =
-  BuiltinFunc (Interp -> Interp)
-
-instance Show BuiltinFunc where
-  show _ = "BuiltinFunc _"
-
 data Instr
   = U Datum -- something unifiable
   | NoGoal -- trivial goal (directly after head)
-  | Builtin BuiltinFunc -- trivial goal (directly after head)
+  | Invoke Builtin -- also directly after head
   | Goal -- a new goal (set head)
   | Call -- all seems okay, call the head's hoal
   | LastCall -- tail call the head's goal
@@ -64,3 +60,13 @@ data Interp =
     , strtable :: StrTable -- string table
     }
   deriving (Show)
+
+type PrlgEnv a = StateT Interp (InputT IO) a
+
+type BuiltinFn = PrlgEnv (Maybe (Either String Bool))
+
+data Builtin =
+  Builtin BuiltinFn
+
+instance Show Builtin where
+  show _ = "Builtin _"

app/Env.hs

@@ -1,25 +1,22 @@
 module Env where
 
-import Code (Interp (..))
+import Code (Interp(..), PrlgEnv)
-import Control.Monad.IO.Class
 import Control.Monad.Trans.State.Lazy
 import qualified IR
-import qualified Operators
-import System.Console.Haskeline
 
-type PrlgEnv a = StateT Code.Interp (InputT IO) a
+withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
-
-withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> PrlgEnv a
 withStrTable f = do
   st <- gets strtable
   let (st', x) = f st
   modify (\s -> s {strtable = st'})
   return x
 
-findStruct :: String -> Int -> PrlgEnv IR.Id
+findStruct :: String -> Int -> Env.PrlgEnv IR.Id
 findStruct str arity = do
   stri <- findAtom str
   return IR.Id {IR.str = stri, IR.arity = arity}
 
-findAtom :: String -> PrlgEnv Int
+findAtom :: String -> Env.PrlgEnv Int
 findAtom = withStrTable . flip IR.strtablize
+
+type PrlgEnv a = Code.PrlgEnv a

app/Frontend.hs

@@ -87,4 +87,10 @@ interpreter :: InputT IO ()
 interpreter =
   evalStateT
     interpreterStart
-    (Interp {defs = M.empty, ops = [], strtable = IR.emptystrtable, cur=error "no cur", cho=[]})
+    (Interp
+       { defs = M.empty
+       , ops = []
+       , strtable = IR.emptystrtable
+       , cur = error "no cur"
+       , cho = []
+       })

app/Interpreter.hs

@@ -2,11 +2,11 @@
 module Interpreter where
 
 import Code
+import qualified Control.Monad.Trans.State.Lazy as St
+
 --import Data.Function
 import qualified Data.Map as M
-import Env (PrlgEnv(..))
 import IR (Id(..))
-import qualified Control.Monad.Trans.State.Lazy as St
 
 prove :: Code -> PrlgEnv (Either String Bool)
 prove g = do
@@ -27,32 +27,43 @@ prove g = do
   loop
   where
     loop = do
-      i <- St.get
+      x <- proveStep
-      proveStep cont finish i
+      case x of
-    cont i = St.put i >> loop
+        Nothing -> loop -- not finished yet
-    finish i res = St.put i >> return res
+        Just x -> return x
 
 data Dereferenced
   = FreeRef Int
   | BoundRef Int Datum
   | NoRef
 
-proveStep :: (Interp -> a) -> (Interp -> Either String Bool -> a) -> Interp -> a
+{- Simple "fail" backtracking -}
-proveStep c f i = go i
+backtrack :: PrlgEnv (Maybe (Either String Bool))
+backtrack = do
+  chos <- St.gets cho
+  case chos
+    {- if available, restore the easiest choicepoint -}
+        of
+    (c:cs) -> do
+      St.modify $ \i -> i {cur = c, cho = cs}
+      pure Nothing
+    {- if there's no other choice, answer no -}
+    _ -> pure . Just $ Right False
+
+proveStep :: PrlgEnv (Maybe (Either String Bool))
+proveStep = St.get >>= go
   where
-    ifail msg = f i $ Left msg
+    finish = pure . Just
+    c i = St.put i >> pure Nothing
+    ifail msg = finish $ Left msg
     tailcut [LastCall] chos _ = Just chos
     tailcut [LastCall, Cut] _ cut = Just cut
     tailcut _ _ _ = Nothing
-    withDef fn
+    withDef fn cont = do
-      | Just d <- defs i M.!? fn = ($ d)
+      d <- St.gets defs
-      | otherwise = const $ ifail $ "no definition: " ++ show fn
+      case d M.!? fn of
-    {- Backtracking -}
+        Just d -> cont d
-    backtrack i@Interp {cho = chos}
+        _ -> ifail $ "no definition: " ++ show fn
-      {- if available, restore the easiest choicepoint -}
-      | (cho:chos) <- chos = c i {cur = cho, cho = chos}
-      {- if there's no other choice, answer no -}
-      | otherwise = f i $ Right False
     {- Unification -}
     go i@Interp {cur = cur@Cho { hed = U h:hs
                                , gol = U g:gs
@@ -206,7 +217,7 @@ proveStep c f i = go i
                         }
                   }
             _ -> ifail "dangling goal ref"
-        unify _ _ = backtrack i
+        unify _ _ = backtrack
     {- Resolution -}
     go i@Interp { cur = cur@Cho { hed = hed
                                 , hvar = hvar
@@ -219,14 +230,15 @@ proveStep c f i = go i
                 , cho = chos
                 }
       {- invoke a built-in (this gets replaced by NoGoal by default but the
-       - builtin can actually do whatever it wants with the code -}
+       - builtin can actually do whatever it wants with the code) -}
-      | [Builtin (BuiltinFunc bf)] <- hed =
+      | [Invoke (Builtin bf)] <- hed =
-        c (bf i {cur = cur {hed = [NoGoal]}})
+        St.put i {cur = cur {hed = [NoGoal]}} >> bf
       {- top-level success -}
       | [NoGoal] <- hed
       , Just nchos <- tailcut gol chos cut
-      , [] <- stk =
+      , [] <- stk = do
-        f i {cur = cur {hed = [], gol = []}, cho = nchos} $ Right True
+        St.put i {cur = cur {hed = [], gol = []}, cho = nchos}
+        finish $ Right True
       {- cut before the first goal (this solves all cuts in head) -}
       | Cut:hs <- hed = c i {cur = cur {hed = hs}, cho = cut}
       {- succeed and return to caller -}

app/Main.hs

@@ -1,6 +1,5 @@
 module Main where
 
-import Control.Monad
 import Frontend (interpreter)
 import System.Console.Haskeline
 

app/Parser.hs

@@ -6,10 +6,8 @@ module Parser
   , shuntPrlg
   ) where
 
-import Control.Applicative (liftA2)
 import Control.Monad (void)
 import Data.Char
-import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.Split (splitOn)
 import Data.Void

prlg.cabal

@@ -3,7 +3,7 @@ name:               prlg
 version:            0.1.0.0
 
 -- A short (one-line) description of the package.
--- synopsis:
+synopsis: A small Vienna-style interpreter.
 
 -- A longer description of the package.
 -- description:
@@ -32,3 +32,4 @@ executable prlg
     build-depends:    base >=4.16, containers, megaparsec, haskeline, pretty-simple, split, transformers
     hs-source-dirs:   app
     default-language: Haskell2010
+    ghc-options:      -Wunused-imports