81 lines
2.2 KiB
Haskell
81 lines
2.2 KiB
Haskell
{-# LANGUAGE InstanceSigs #-}
|
|
module Primitives
|
|
( Globals(..)
|
|
, PrologIO(..)
|
|
, newGlobals
|
|
, newVarPrim, unnewVarPrim, getVarPrim, setVarPrim, errorPrim
|
|
) where
|
|
import Classes
|
|
import qualified Data.IntMap.Strict as M
|
|
import Data.IORef
|
|
import Terms
|
|
|
|
newtype PrologIO a = PrologIO { runPrologIO :: Globals -> IO a }
|
|
data Globals = Globals
|
|
{ values :: IORef (M.IntMap Term)
|
|
, names :: IORef (M.IntMap Name)
|
|
, nextSlot :: IORef Int
|
|
}
|
|
|
|
instance LiftIO PrologIO where
|
|
liftIO :: IO a -> PrologIO a
|
|
liftIO io = PrologIO (\_ -> io)
|
|
|
|
instance Functor PrologIO where
|
|
fmap :: (a -> b) -> PrologIO a -> PrologIO b
|
|
fmap f (PrologIO a) = PrologIO (\globals -> fmap f (a globals))
|
|
|
|
instance Applicative PrologIO where
|
|
pure :: a -> PrologIO a
|
|
pure x = PrologIO (\_ -> pure x)
|
|
|
|
(<*>) :: PrologIO (a -> b) -> PrologIO a -> PrologIO b
|
|
(PrologIO f) <*> (PrologIO x) = PrologIO (
|
|
\globals -> do
|
|
f' <- f globals
|
|
x' <- x globals
|
|
return (f' x')
|
|
)
|
|
|
|
instance Monad PrologIO where
|
|
return :: a -> PrologIO a
|
|
return = pure
|
|
|
|
(>>=) :: PrologIO a -> (a -> PrologIO b) -> PrologIO b
|
|
(PrologIO a) >>= f = PrologIO (
|
|
\globals -> do
|
|
a' <- a globals
|
|
let PrologIO b' = f a'
|
|
b' globals
|
|
)
|
|
|
|
newGlobals :: IO Globals
|
|
newGlobals = do
|
|
vs <- newIORef M.empty
|
|
ns <- newIORef M.empty
|
|
next <- newIORef 0
|
|
return Globals { values=vs, names=ns, nextSlot=next }
|
|
|
|
newVarPrim :: Name -> PrologIO Slot
|
|
newVarPrim name = PrologIO $ \globals -> do
|
|
slot <- readIORef (nextSlot globals)
|
|
modifyIORef (names globals) (M.insert slot name)
|
|
modifyIORef (nextSlot globals) (\s -> s + 1)
|
|
return (Slot slot)
|
|
|
|
unnewVarPrim :: PrologIO ()
|
|
unnewVarPrim = PrologIO $ \globals -> do
|
|
modifyIORef (nextSlot globals) (\s -> s - 1)
|
|
slot <- readIORef (nextSlot globals)
|
|
modifyIORef (names globals) (M.delete slot)
|
|
|
|
getVarPrim :: Slot -> PrologIO (Maybe Term)
|
|
getVarPrim (Slot slot) = PrologIO $ \globals ->
|
|
fmap (M.lookup slot) (readIORef (values globals))
|
|
|
|
setVarPrim :: Slot -> Maybe Term -> PrologIO ()
|
|
setVarPrim (Slot slot) term = PrologIO $ \globals ->
|
|
modifyIORef (values globals) (M.alter (\_ -> term) slot)
|
|
|
|
errorPrim :: String -> PrologIO a
|
|
errorPrim message = error message |