prototype 0.4.1 → 0.5.0
raw patch · 2 files changed
+35/−35 lines, 2 files
Files
- prototype.cabal +3/−3
- src/Control/Prototype.hs +32/−32
prototype.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.2 name: prototype-version: 0.4.1+version: 0.5.0 stability: experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -25,7 +25,7 @@ > import Control.Prototype > > main :: IO ()- > main = fmap fst $ flip runPT initPTEnv $ do+ > main = fmap fst $ flip runProt initProtEnv $ do > ( dog, setName, sit ) <- package "dog" $ do > dog <- clone object > name <- makeMember "name"@@ -36,7 +36,7 @@ > return [ ] > setMethod dog sit $ \this _ -> do > n <- member this name- > liftPT $ putStrLn $ fromPrimStr n ++ " sitting."+ > liftProt $ putStrLn $ fromPrimStr n ++ " sitting." > return [ ] > return ( dog, setName, sit ) > myDog <- clone dog
src/Control/Prototype.hs view
@@ -1,30 +1,30 @@ {-# LANGUAGE PackageImports #-} module Control.Prototype (- PTMonad,+ Prot,+ ProtEnv, Object, Member, Method, - runPT,- initPTEnv,+ runProt,+ initProtEnv,+ package, object, clone, makeMember,- member,- method, setMember,+ member, setMethod,-- package,+ method, - liftPT,+ liftProt, primInt, primStr, fromPrimInt, fromPrimStr, - printMemberName,+ printMember, ) where import Prelude hiding ( head )@@ -41,21 +41,21 @@ -------------------------------------------------------------------------------- -type PTMonad m = StateT ( PTEnv m ) m+type Prot m = StateT ( ProtEnv m ) m -runPT :: Monad m => PTMonad m a -> PTEnv m -> m ( a, PTEnv m )-runPT = runStateT+runProt :: Monad m => Prot m a -> ProtEnv m -> m ( a, ProtEnv m )+runProt = runStateT -liftPT :: Monad m => m a -> PTMonad m a-liftPT = lift+liftProt :: Monad m => m a -> Prot m a+liftProt = lift -data PTEnv m = PTEnv {+data ProtEnv m = ProtEnv { packageName :: String, objectBodys :: [ ObjectBody m ] } deriving Show -initPTEnv :: PTEnv m-initPTEnv = PTEnv {+initProtEnv :: ProtEnv m+initProtEnv = ProtEnv { packageName = "main", objectBodys = [ ObjectBody object [ ] ] }@@ -84,7 +84,7 @@ objectMethod :: Method m } data Member = Member String deriving ( Eq, Show )-type Method m = Object -> [ Object ] -> PTMonad m [ Object ]+type Method m = Object -> [ Object ] -> Prot m [ Object ] instance Show ( ObjectBody m ) where show ( Method oid _ ) = "Method " ++ show oid@@ -92,62 +92,62 @@ -------------------------------------------------------------------------------- -getNewId :: Monad m => PTMonad m Object+getNewId :: Monad m => Prot m Object getNewId = gets $ ObjectId . head err . ( [ 1 .. ] \\ ) . map ( fromObjId . objectId ) . objectBodys where err = error "too many objects" -getObject :: Monad m => Object -> PTMonad m ( ObjectBody m )+getObject :: Monad m => Object -> Prot m ( ObjectBody m ) getObject obj = gets $ head err . filter ( ( == obj ) . objectId ) . objectBodys where err = error $ "no such object: " ++ show obj -putObject :: Monad m => ObjectBody m -> PTMonad m ()+putObject :: Monad m => ObjectBody m -> Prot m () putObject objBody = do- env@PTEnv { objectBodys = obs } <- get+ env@ProtEnv { objectBodys = obs } <- get put env { objectBodys = objBody : obs } -clone :: Monad m => Object -> PTMonad m Object+clone :: Monad m => Object -> Prot m Object clone obj = do newId <- getNewId objBody <- getObject obj putObject $ objBody { objectId = newId } return newId -makeMember :: Monad m => String -> PTMonad m Member+makeMember :: Monad m => String -> Prot m Member makeMember name = mmap ( Member . ( ++ name ) . ( ++ "::" ) ) $ gets packageName -member :: Monad m => Object -> Member -> PTMonad m Object+member :: Monad m => Object -> Member -> Prot m Object member obj mem = mmap ( fromMaybe err . lookup mem . objectMembers ) $ getObject obj where err = error $ "No such member: " ++ show mem ++ "\nobject: " ++ show obj -method :: Monad m => Object -> Member -> [ Object ] -> PTMonad m [ Object ]+method :: Monad m => Object -> Member -> [ Object ] -> Prot m [ Object ] method obj mem args = member obj mem >>= getObject >>= ( $ args ) . ( $ obj ) . objectMethod -setMember :: Monad m => Object -> Member -> Object -> PTMonad m ()+setMember :: Monad m => Object -> Member -> Object -> Prot m () setMember obj mn val = do objBody@ObjectBody { objectMembers = mems } <- getObject obj putObject objBody { objectMembers = ( mn, val ) : mems } -setMethod :: Monad m => Object -> Member -> Method m -> PTMonad m ()+setMethod :: Monad m => Object -> Member -> Method m -> Prot m () setMethod obj mem met = do newId <- getNewId putObject $ Method newId met setMember obj mem newId -package :: Monad m => String -> PTMonad m a -> PTMonad m a+package :: Monad m => String -> Prot m a -> Prot m a package pkg act = do- env0@PTEnv { packageName = oldPkg } <- get+ env0@ProtEnv { packageName = oldPkg } <- get put env0 { packageName = pkg } ret <- act env1 <- get put env1 { packageName = oldPkg } return ret -printMemberName :: MonadIO m => Member -> m ()-printMemberName ( Member name ) = liftIO $ putStrLn name+printMember :: MonadIO m => Member -> m ()+printMember ( Member name ) = liftIO $ putStrLn name