prototype 0.1 → 0.2

raw patch · 2 files changed

+75/−115 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• prototype.cabal +1/−1
• src/Control/Prototype.hs +74/−114

@@ -2,7 +2,7 @@ cabal-version:	>= 1.2  name:		prototype-version:	0.1+version:	0.2 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>

@@ -25,151 +25,111 @@ 	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+import Prelude hiding ( head )+import "monads-tf" Control.Monad.State (+	StateT, runStateT, lift, MonadIO, liftIO, modify, gets )+import Data.List ( (\\) )+import Data.Maybe ( fromMaybe, listToMaybe ) -makeMember :: Monad m => String -> ObjectMonad m VarName-makeMember = mkVarName+head :: a -> [ a ] -> a+head x = fromMaybe x . listToMaybe -method :: Monad m =>-	ObjectId -> VarName -> [ ObjectId ] -> ObjectMonad m [ ObjectId ]-method = sendMsg+mmap :: Monad m => ( a -> b ) -> m a -> m b+mmap f mx = mx >>= return . f -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 }+type PTMonad m = StateT ( PTEnv m ) m -primInt :: Int -> ObjectId-primInt = primitiveInt+runPT :: Monad m => PTMonad m a -> PTEnv m -> m ( a, PTEnv m )+runPT = runStateT -primStr :: String -> ObjectId-primStr = primitiveString+liftPT :: Monad m => m a -> PTMonad m a+liftPT = lift -fromPrimInt :: ObjectId -> Int-fromPrimInt = fromPrimitiveInt+type PTEnv m = [ ObjectBody m ] -fromPrimStr :: ObjectId -> String-fromPrimStr = fromPrimitiveString+initPTEnv :: PTEnv m+initPTEnv = [ ObjectBody object [ ] ] -data ObjectId =-	ObjectId { objectIdInt :: Int	} |-	PrimitiveInt { fromPrimitiveInt :: Int } |-	PrimitiveString { fromPrimitiveString :: String }+data Object =+	ObjectId { fromObjId :: Int } |+	PrimitiveInt { fromPrimInt :: Int } |+	PrimitiveString { fromPrimStr :: String } 	deriving ( Eq, Show ) -primitiveInt :: Int -> ObjectId-primitiveInt = PrimitiveInt--primitiveString :: String -> ObjectId-primitiveString = PrimitiveString+primInt :: Int -> Object+primInt = PrimitiveInt -type Method m = ObjectId -> [ ObjectId ] -> ObjectMonad m [ ObjectId ]+primStr :: String -> Object+primStr = PrimitiveString -object :: ObjectId+object :: Object 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+data ObjectBody m =+	ObjectBody {+		objectId	:: Object,+		objectMembers	:: [ ( Member, Object ) ] } |+	Method {+		objectId	:: Object,+		objectMethod	:: Method m } -type ObjectMonad m = StateT ( ObjectEnv m ) m+data Member = Member String deriving ( Eq, Show )+type Method m = Object -> [ Object ] -> PTMonad m [ Object ] -type ObjectEnv m = [ ObjectBody m ]+instance Show ( ObjectBody m ) where+	show ( Method oid _ ) = "Method " ++ show oid+	show ( ObjectBody oid st ) = "Object " ++ show oid ++ " " ++ show st -initObjectEnv :: ObjectEnv m-initObjectEnv = [ initObject ]+-------------------------------------------------------------------------------- -runObject :: Monad m => ObjectMonad m a -> ObjectEnv m -> m ( a, ObjectEnv m )-runObject = runStateT+getNewId :: Monad m => PTMonad m Object+getNewId = gets $+	ObjectId . head err . ( [ 1 .. ] \\ ) .	map ( fromObjId . objectId )+	where+	err = error "too many objects" -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+getObject :: Monad m => Object -> PTMonad m ( ObjectBody m )+getObject obj =	gets $ head err . filter ( ( == obj ) . objectId ) 	where-	hd [ ] = Nothing-	hd xs = Just $ head xs+	err = error $ "no such object: " ++ show obj -putObject :: Monad m => ObjectBody m -> ObjectMonad m ()+putObject :: Monad m => ObjectBody m -> PTMonad 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 :: Monad m => Object -> PTMonad m Object clone obj = do-	st <- getObject obj >>= return . objectStatus 	newId <- getNewId-	putObject $ Object newId st+	objBody <- getObject obj+	putObject $ objBody { objectId = newId } 	return newId -mkVarName :: Monad m => String -> ObjectMonad m VarName-mkVarName = return . VarName+makeMember :: Monad m => String -> PTMonad m Member+makeMember = return . Member -setMember :: Monad m => ObjectId -> VarName -> ObjectId -> ObjectMonad m ()-setMember = setVar+member :: Monad m => Object -> Member -> PTMonad m Object+member obj mem =+	mmap ( fromMaybe err . lookup mem . objectMembers ) $ getObject obj+	where+	err = error $ "No such member: " ++ show mem ++ "\nobject: " ++ show obj -setVar :: Monad m => ObjectId -> VarName -> ObjectId -> ObjectMonad m ()-setVar obj vn val = do-	st <- getObject obj >>= return . objectStatus-	putObject $ Object obj $ ( vn, val ) : st+method :: Monad m => Object -> Member -> [ Object ] -> PTMonad m [ Object ]+method obj mem args =+	member obj mem >>= getObject >>= ( $ args ) . ( $ obj ) . objectMethod -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+setMember :: Monad m => Object -> Member -> Object -> PTMonad m ()+setMember obj mn val = do+	objBody@ObjectBody { objectMembers = mems } <- getObject obj+	putObject objBody { objectMembers = ( mn, val ) : mems } -mkMethod :: Monad m => Method m -> ObjectMonad m ObjectId-mkMethod m = do+setMethod :: Monad m => Object -> String -> Method m -> PTMonad m Member+setMethod obj name met = do 	newId <- getNewId-	putObject $ Method newId m-	return newId+	putObject $ Method newId met+	mem <- makeMember name+	setMember obj mem newId+	return mem -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+printMemberName :: MonadIO m => Member -> m ()+printMemberName ( Member name ) = liftIO $ putStrLn name