module Control.Prototype (
PTMonad,
Object,
Member,
Method,
runPT,
initPTEnv,
object,
clone,
makeMember,
member,
method,
setMember,
setMethod,
liftPT,
primInt,
primStr,
fromPrimInt,
fromPrimStr,
printMemberName,
) where
import "monads-tf" Control.Monad.State
import Data.List
import Data.Maybe
runPT :: Monad m => PTMonad m a -> ObjectEnv m -> m ( a, ObjectEnv m )
runPT = runObject
initPTEnv :: ObjectEnv m
initPTEnv = initObjectEnv
type PTMonad m = ObjectMonad m
type Object = ObjectId
type Member = VarName
liftPT :: Monad m => m a -> ObjectMonad m a
liftPT = lift
makeMember :: Monad m => String -> ObjectMonad m VarName
makeMember = mkVarName
method :: Monad m =>
ObjectId -> VarName -> [ ObjectId ] -> ObjectMonad m [ ObjectId ]
method = sendMsg
setMethod :: Monad m => ObjectId -> String -> Method m -> ObjectMonad m VarName
setMethod obj mn m = do
vn <- mkVarName mn
mt <- mkMethod m
setVar obj vn mt
return vn
data ObjectBody m =
Object {
objectId :: ObjectId,
objectStatus :: [ ( VarName, ObjectId ) ] } |
Method {
objectId :: ObjectId,
_method :: Method m }
primInt :: Int -> ObjectId
primInt = primitiveInt
primStr :: String -> ObjectId
primStr = primitiveString
fromPrimInt :: ObjectId -> Int
fromPrimInt = fromPrimitiveInt
fromPrimStr :: ObjectId -> String
fromPrimStr = fromPrimitiveString
data ObjectId =
ObjectId { objectIdInt :: Int } |
PrimitiveInt { fromPrimitiveInt :: Int } |
PrimitiveString { fromPrimitiveString :: String }
deriving ( Eq, Show )
primitiveInt :: Int -> ObjectId
primitiveInt = PrimitiveInt
primitiveString :: String -> ObjectId
primitiveString = PrimitiveString
type Method m = ObjectId -> [ ObjectId ] -> ObjectMonad m [ ObjectId ]
object :: ObjectId
object = ObjectId 0
initObject :: ObjectBody m
initObject = Object object [ ]
instance Show ( ObjectBody m ) where
show Method { } = "method"
show ( Object oid st ) = "Object " ++ show oid ++ " " ++ show st
data VarName = VarName String deriving ( Eq, Show )
printMemberName :: MonadIO m => VarName -> m ()
printMemberName = printVarName
printVarName :: MonadIO m => VarName -> m ()
printVarName ( VarName vn ) = liftIO $ putStrLn vn
type ObjectMonad m = StateT ( ObjectEnv m ) m
type ObjectEnv m = [ ObjectBody m ]
initObjectEnv :: ObjectEnv m
initObjectEnv = [ initObject ]
runObject :: Monad m => ObjectMonad m a -> ObjectEnv m -> m ( a, ObjectEnv m )
runObject = runStateT
getObject :: Monad m => ObjectId -> ObjectMonad m ( ObjectBody m )
getObject obj = do
ret <- gets ( hd . filter ( ( == obj ) . objectId ) )
case ret of
Nothing -> get >>= error . show
Just x -> return x
where
hd [ ] = Nothing
hd xs = Just $ head xs
putObject :: Monad m => ObjectBody m -> ObjectMonad m ()
putObject = modify . ( : )
getNewId :: Monad m => ObjectMonad m ObjectId
getNewId = do
ids <- gets $ map ( objectIdInt . objectId )
return $ ObjectId $ head $ [ 1 .. ] \\ ids
clone :: Monad m => ObjectId -> ObjectMonad m ObjectId
clone obj = do
st <- getObject obj >>= return . objectStatus
newId <- getNewId
putObject $ Object newId st
return newId
mkVarName :: Monad m => String -> ObjectMonad m VarName
mkVarName = return . VarName
setMember :: Monad m => ObjectId -> VarName -> ObjectId -> ObjectMonad m ()
setMember = setVar
setVar :: Monad m => ObjectId -> VarName -> ObjectId -> ObjectMonad m ()
setVar obj vn val = do
st <- getObject obj >>= return . objectStatus
putObject $ Object obj $ ( vn, val ) : st
member :: Monad m => ObjectId -> VarName -> ObjectMonad m ObjectId
member = getVar
getVar :: Monad m => ObjectId -> VarName -> ObjectMonad m ObjectId
getVar obj vn = do
st <- getObject obj >>= return . objectStatus
return $ fromJust $ lookup vn st
mkMethod :: Monad m => Method m -> ObjectMonad m ObjectId
mkMethod m = do
newId <- getNewId
putObject $ Method newId m
return newId
sendMsg :: Monad m =>
ObjectId -> VarName -> [ ObjectId ] -> ObjectMonad m [ ObjectId ]
sendMsg obj mn args = do
Object { objectStatus = vs } <- getObject obj
let mt = fromJust $ lookup mn vs
Method _ m <- getObject mt
m obj args