prototype (empty) → 0.1

raw patch · 4 files changed

+264/−0 lines, 4 filesdep +basedep +monads-tfsetup-changed

Dependencies added: base, monads-tf

Files

LICENSE +27/−0
Setup.hs +2/−0
prototype.cabal +60/−0
src/Control/Prototype.hs +175/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2010, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ prototype.cabal view

@@ -0,0 +1,60 @@+build-type:	Simple+cabal-version:	>= 1.2++name:		prototype+version:	0.1+stability:	experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>++license:	BSD3+license-file:	LICENSE++category:	Development+synopsis:	prototype-based programming on Haskell+description:	prototype-based programming on Haskell+		.+		You can download source codes by git.+		.+		git clone git:\/\/github.com\/YoshikuniJujo\/prototype.git prototype+		.+		Example code+		.+		> module Main where+		>+		> import Control.Prototype+		>+		> main :: IO ()+		> main = fmap fst $ flip runPT initPTEnv $ do+		>	dog <- clone object+		>	name <- makeMember "name"+		>	setName <- setMethod dog "setName" $ \this [ n ] -> do+		>		setMember this name n+		>		return [ ]+		>	sit <- setMethod dog "sit" $ \this _ -> do+		>		n <- member this name+		>		liftPT $ putStrLn $ fromPrimStr n ++ " sitting."+		>	myDog <- clone dog+		>	method myDog setName [ primStr "John" ]+		>	method myDog sit [ ]+		>	return ()+		.+		Another sample+		.+		> module Main where+		>+		> import MyToolkit+		>+		> main :: IO ()+		> main = runToolKit $ do+		>	( textView, setText, setContentView ) <- importMyToolkit+		>	myTV <- clone textView+		>	method myTV setText [ primStr "Hello, world!" ]+		>	method myTV setContentView [ ]+		>	return ()++library+  hs-source-dirs:	src+  exposed-modules:	Control.Prototype+  build-depends:	base > 3 && < 5, monads-tf+  ghc-options:		-Wall

+ src/Control/Prototype.hs view

@@ -0,0 +1,175 @@+{-# LANGUAGE PackageImports #-}++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