From 8d5353dc8c7ef3eefb0ae4860e67602c455c1a58 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 13 Nov 2022 00:46:38 +0100 Subject: [PATCH] builtins are built in --- app/Builtins.hs | 21 ++++++++++++---- app/Code.hs | 20 ++++++++++------ app/Env.hs | 15 +++++------- app/Frontend.hs | 8 ++++++- app/Interpreter.hs | 60 +++++++++++++++++++++++++++------------------- app/Main.hs | 1 - app/Parser.hs | 2 -- prlg.cabal | 3 ++- 8 files changed, 80 insertions(+), 50 deletions(-) diff --git a/app/Builtins.hs b/app/Builtins.hs index 06c35a3..9e4215c 100644 --- a/app/Builtins.hs +++ b/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 = BuiltinFunc $ trace "hllo prlg" +hello = + 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)] } diff --git a/app/Code.hs b/app/Code.hs index 00d1d1c..5721d17 100644 --- a/app/Code.hs +++ b/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 _" diff --git a/app/Env.hs b/app/Env.hs index ba86c9e..744762b 100644 --- a/app/Env.hs +++ b/app/Env.hs @@ -1,25 +1,22 @@ module Env where -import Code (Interp (..)) -import Control.Monad.IO.Class +import Code (Interp(..), PrlgEnv) 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)) -> PrlgEnv a +withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.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 diff --git a/app/Frontend.hs b/app/Frontend.hs index 0677889..b1ae79a 100644 --- a/app/Frontend.hs +++ b/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 = [] + }) diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 743f68b..3d1c569 100644 --- a/app/Interpreter.hs +++ b/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 - proveStep cont finish i - cont i = St.put i >> loop - finish i res = St.put i >> return res + x <- proveStep + case x of + Nothing -> loop -- not finished yet + Just x -> return x data Dereferenced = FreeRef Int | BoundRef Int Datum | NoRef -proveStep :: (Interp -> a) -> (Interp -> Either String Bool -> a) -> Interp -> a -proveStep c f i = go i +{- Simple "fail" backtracking -} +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 - | Just d <- defs i M.!? fn = ($ d) - | otherwise = const $ ifail $ "no definition: " ++ show fn - {- Backtracking -} - backtrack i@Interp {cho = chos} - {- 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 + withDef fn cont = do + d <- St.gets defs + case d M.!? fn of + Just d -> cont d + _ -> ifail $ "no definition: " ++ show fn {- 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 (BuiltinFunc bf)] <- hed = - c (bf i {cur = cur {hed = [NoGoal]}}) + - builtin can actually do whatever it wants with the code) -} + | [Invoke (Builtin bf)] <- hed = + St.put i {cur = cur {hed = [NoGoal]}} >> bf {- top-level success -} | [NoGoal] <- hed , Just nchos <- tailcut gol chos cut - , [] <- stk = - f i {cur = cur {hed = [], gol = []}, cho = nchos} $ Right True + , [] <- stk = do + 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 -} diff --git a/app/Main.hs b/app/Main.hs index 1e639d2..d394ee6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,5 @@ module Main where -import Control.Monad import Frontend (interpreter) import System.Console.Haskeline diff --git a/app/Parser.hs b/app/Parser.hs index de6af9c..e710b75 100644 --- a/app/Parser.hs +++ b/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 diff --git a/prlg.cabal b/prlg.cabal index f46dd84..f59fb3a 100644 --- a/prlg.cabal +++ b/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