packages feed

coroutine-object (empty) → 0.1

raw patch · 13 files changed

+714/−0 lines, 13 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, lens, mtl, safecopy, transformers, transformers-free, uuid

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012 Ian-Woo Kim++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 EVENT SHALL THE AUTHORS 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.lhs view
@@ -0,0 +1,10 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.PackageDescription+> --import System.Process+> main = defaultMain+> --main = defaultMainWithHooks testUserHooks+> --testUserHooks = simpleUserHooks { +>  --   preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo+>   --  }
+ coroutine-object.cabal view
@@ -0,0 +1,42 @@+Name:		coroutine-object+Version:	0.1+Synopsis:       Object-oriented programming realization using coroutine +Description: 	Object-oriented programming realization using coroutine +License: 	BSD3+License-file:	LICENSE+Author:		Ian-Woo Kim+Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>+Build-Type: 	Simple+Cabal-Version:  >= 1.8+data-files:      +Library+  hs-source-dirs: src+  ghc-options: 	-Wall -O2 -threaded -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans+  ghc-prof-options: -caf-all -auto-all+  Build-Depends:   base >4 && <5, +                   mtl>2, +                   lens >= 2.4 && < 2.7,+                   containers == 0.4.*,+                   transformers == 0.3.*, +                   transformers-free == 1.0.*, +                   bytestring == 0.9.*,+                   safecopy == 0.6.*,+                   uuid == 1.2.*,+                   cereal == 0.3.*+  Other-Modules:   +  exposed-modules:+                   Control.Monad.Trans.Crtn+                   Control.Monad.Trans.Crtn.Driver+                   Control.Monad.Trans.Crtn.EventHandler +                   Control.Monad.Trans.Crtn.Event +                   Control.Monad.Trans.Crtn.IOActor +                   Control.Monad.Trans.Crtn.Logger+                   Control.Monad.Trans.Crtn.Logger.Simple  +                   Control.Monad.Trans.Crtn.Object +                   Control.Monad.Trans.Crtn.Queue +                   Control.Monad.Trans.Crtn.World+++++
+ src/Control/Monad/Trans/Crtn.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, +             MultiParamTypeClasses, UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- definition of coroutine+-- +-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn where ++import Control.Monad.Error+import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Free+++----------------------------+-- added instance of FreeT monad+----------------------------++instance (Monad m, MonadState st m, Functor f) => MonadState st (FreeT f m) where +  get = lift get+  put = lift . put++---------------------------+-- general generator +---------------------------++-- | yield command functor+data Yld o x = Yld o x ++instance Functor (Yld o) where +  fmap f (Yld o x) = Yld o (f x)++-- | Generator type is single-sided coroutine which only gives an output +--   without getting any request. +type GenT o = FreeT (Yld o)++-- | primitive coroutine action yielding an output+yield :: (Monad m) => o -> GenT o m ()  +yield o = wrap (Yld o (return ()))++---------------------------+-- general consumer+---------------------------++-- | await command functor for consumer coroutine+newtype Awt a x = Awt (a->x)++-- | +instance Functor (Awt g) where +  fmap f (Awt g) = Awt (f.g)++-- | Consumer type is a single-sided coroutine which only gets an input +--   without producing output. +type CnsmT a = FreeT (Awt a) ++-- | primitive coroutine action awaiting an input+await :: (Monad m) => CnsmT a m a+await = wrap (Awt return)++----------------------------+-- general coroutine+----------------------------++-- | command functor of general bidirectional coroutine+data Rqst req ans x = Rqst req (ans -> x)++instance Functor (Rqst req ans) where+  fmap f (Rqst req g) = Rqst req (f.g)++-- | general symmetric bidirectional coroutine+type CrtnT req ans = FreeT (Rqst req ans)++-- | primitive request coroutine  +request :: Monad m => req -> CrtnT req ans m ans+request r = wrap (Rqst r return)++-------------------------------+-- server/client model+------------------------------++-- | Server type +type SrvT req ans m = ReaderT req (CrtnT ans req m) ++-- | Coroutine type is regarded as a Client type +--   which can be paired with Server type with opposite request +--   and answer type.  +type CliT req ans = CrtnT req ans  ++-- | type for coroutine status after execution+data CrtnErr r = NoError +               | ServerFinished r +               | Other String ++-- | +deriving instance (Show r) => Show (CrtnErr r) ++-- | +instance Error (CrtnErr r) where +  noMsg = NoError +  strMsg str = Other str ++-----------------------------+-- communication combinator +-------------------------------++-- | connecting server and client in error monad+(<==|) :: Monad m => +          SrvT req ans m r'    -- ^ server coroutine+       -> CliT req ans m r  -- ^ client coroutine+       -> ErrorT (CrtnErr r') m (SrvT req ans m r', r)+s <==| c = do +    y <- lift (runFreeT c)+    case y of+      Pure r -> return (s,r)+      Free (Rqst rq af) -> do +        x <- lift (runFreeT (runReaderT s rq))+        case x of +          Pure r' -> throwError (ServerFinished r')+          Free (Rqst ans rf) -> (ReaderT rf) <==| (af ans)++{-+-- | synonym of connectE+(<==>) :: Monad m => SrvT req ans m r' -> CliT req ans m r+          -> ErrorT (CrtnErr r') m (SrvT req ans m r', r)+(<==>) = connectE+ -}         +++----------------------+-- some utility +------------------------++-- | combine state and free monad with base state monad transformer +--   with a base monad m to free monad with the base monad m+--   Think this as fusing down the state monad  +mapStateDown :: (Monad m, Functor f) => +                s -> FreeT f (StateT s m) a -> FreeT f m a +mapStateDown st m =+    FreeT $ do x <- flip runStateT st $ runFreeT m +               case x of +                 (Pure r,_) -> return (Pure r) +                 (Free f,st') -> +                   return . Free . fmap (mapStateDown st') $ f
+ src/Control/Monad/Trans/Crtn/Driver.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE GADTs, FlexibleInstances, ScopedTypeVariables #-}++----------------------------+-- | IO event driverzo+--+----------------------------++module Control.Monad.Trans.Crtn.Driver where ++import Control.Monad.Error+import Control.Monad.Reader+import Data.Foldable+-- +import Control.Monad.Trans.Crtn +import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Logger +import Control.Monad.Trans.Crtn.Object+import Control.Monad.Trans.Crtn.World  +-- ++-- | signature of IO event driver+data DrvOp e i o where +  Dispatch :: DrvOp e e (Maybe (ActionOrder e)) ++-- | driver +type Driver e m = SObjT (DrvOp e) m  ++-- | driver client +type DrvClient e m r = CObjT (DrvOp e) m r ++-- | +dispatch :: (Monad m) => e -> DrvClient e m (Maybe (ActionOrder e)) +dispatch ev = do Res Dispatch r <- request (Arg Dispatch ev) +                 return r+              +-- | basic driver +driver :: forall m e. (Monad m, MonadLog m, MonadIO m) => +           LogServer (SObjBT (DrvOp e) m) ()+           -> SObjT (WorldOp e (SObjBT (DrvOp e) m)) (SObjBT (DrvOp e) m) () +           -> Driver e m ()  +driver logger world = +    ReaderT (driverW logger world) +  where +    driverW :: LogServer (SObjBT (DrvOp e) m) () +            -> SObjT (WorldOp e (SObjBT (DrvOp e) m)) (SObjBT (DrvOp e) m) () +            -> Arg (DrvOp e)+            -> SObjBT (DrvOp e) m () +    driverW logobj worldobj (Arg Dispatch ev) = do +      (logobj',worldobj') <- multiDispatchTillEnd (logobj,worldobj) [Right ev]+      req <- request (Res Dispatch Nothing) +      driverW logobj' worldobj' req ++++-- | single event dispatch +singleDispatch :: (Monad m) =>  +                  Either (ActionOrder e) e+               -> ( LogServer (SObjBT (DrvOp e) m) ()+                  , World e (SObjBT (DrvOp e) m) ()+                  , [EvOrAct e])+               -> SObjBT (DrvOp e) m +                    ( LogServer (SObjBT (DrvOp e) m) ()+                    , World e (SObjBT (DrvOp e) m) ()+                    , [EvOrAct e])+singleDispatch (Right ev) (logobj,worldobj,evacc) = do+    Right (logobj',worldobj',events) <- +      runErrorT $ do (worldobj1,_)  <- worldobj  <==| giveEvent ev+                     (worldobj2,logobj1) <- worldobj1 <==| flushLog logobj+                     (worldobj3,events) <- worldobj2 <==| flushQueue +                     return (logobj1,worldobj3,events)+    return (logobj',worldobj',evacc++events) +singleDispatch (Left act) (logobj,worldobj,evacc) = do +    Arg Dispatch ev <- request (Res Dispatch (Just act))+    return (logobj,worldobj,evacc++[Right ev]) ++++-- | a single feedback step of multiple event dispatch+multiDispatch :: (Monad m) => +                 ( LogServer (SObjBT (DrvOp e) m) ()+                 , World e (SObjBT (DrvOp e) m) ())+              -> [EvOrAct e]+              -> SObjBT (DrvOp e) m +                   ( LogServer (SObjBT (DrvOp e) m) ()+                   , World e  (SObjBT (DrvOp e) m) ()+                   , [EvOrAct e] )+multiDispatch (logobj,worldobj) events = do +  foldrM singleDispatch (logobj,worldobj,[]) events   ++-- | full multiple event dispatch with feedback+multiDispatchTillEnd :: (Monad m) => +                        ( LogServer (SObjBT (DrvOp e) m) ()+                        , World e (SObjBT (DrvOp e) m) ()) +                     -> [EvOrAct e] +                     -> SObjBT (DrvOp e) m +                          (LogServer (SObjBT (DrvOp e) m) ()+                          , World e  (SObjBT (DrvOp e) m) ())+multiDispatchTillEnd (logobj,worldobj) events = +    go (logobj,worldobj,events)+  where go (l,w,evs) = do  +          (l',w',evs') <- multiDispatch (l,w) evs +          if (not.null) evs' +            then go (l',w',evs')+            else return (l',w')+          ++-- | convenience routine for driver +fire :: (Monad m, MonadLog m) => e -> EStT (Driver e m ()) m +                                           (Maybe (ActionOrder e)) +fire = query . dispatch  ++
+ src/Control/Monad/Trans/Crtn/Event.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn.Event+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- coroutine that can be interpreted as an object+-- +-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn.Event where ++{-+import Data.ByteString +import Data.UUID+import Data.SafeCopy++class (Show e,Eq e, SafeCopy e) => Eventable e where +  eventClassID :: e -> UUID +  eventWrap :: e -> Event ++-- | event +data Event = Event (UUID,ByteString)+           deriving (Show,Eq)+++{-+data Event = Message String +           | Open +           | Close +           | Render +           | Sound String +           | Start+           | Finished +           | Init Int +           | Finish Int +             deriving (Show,Eq) -}+-}++-- | action order +data ActionOrder e = ActionOrder ((e -> IO ()) -> IO e)++++-- | event or action+type EvOrAct e = Either (ActionOrder e) e +
+ src/Control/Monad/Trans/Crtn/EventHandler.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn.EventHandler+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Common event handling +-- +-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn.EventHandler where +  +import Control.Concurrent.MVar +import Control.Monad.State +import Control.Monad.Error+-- from this package +-- import Control.Monad.Trans.Crtn+import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Driver +import Control.Monad.Trans.Crtn.Logger ++-- | +eventHandler :: MVar (Maybe (Driver e IO ())) -> e -> IO ()+eventHandler evar ev = do +    mnext <- takeMVar evar+    case mnext of +      Nothing -> return () +      Just drv -> do                +        (r,drv') <- eaction drv +        putMVar evar (Just drv')+        case r of    +          Left err -> scribe (show err) +          Right Nothing -> return () +          Right (Just (ActionOrder act)) -> +            act (eventHandler evar) >>= eventHandler evar +  where eaction = runStateT (runErrorT $ fire ev) +
+ src/Control/Monad/Trans/Crtn/IOActor.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs, NoMonomorphismRestriction, ScopedTypeVariables #-}++------------------------------+-- | special actor for IO action +------------------------------++module Control.Monad.Trans.Crtn.IOActor where++import Control.Monad.Reader+-- +import Control.Monad.Trans.Crtn+-- import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Object +++-- | first is +data IOOp e i o where+  DoIOAction :: IOOp e ((e -> IO ()) -> IO ()) (Either String ())++type IOActor e m r = SObjT (IOOp e) m r++-- | +doIOAction :: (Monad m) => ((e -> IO ()) -> IO ()) +           -> CObjT (IOOp e) m (Either String ())+doIOAction act = do ans <- request (Arg DoIOAction act) +                    case ans of +                      Res DoIOAction r -> return r+                      Ign -> return (Left "error in doing doIOAction")++-- | +ioactorgen :: (MonadIO m) => (e -> IO ()) -> SObjT (IOOp e) m ()+ioactorgen evhandler = ReaderT ioactorW +  where ioactorW (Arg DoIOAction act) = do +          liftIO (act evhandler) +          req <- request (Res DoIOAction (Right ()))+          ioactorW req +++ ++
+ src/Control/Monad/Trans/Crtn/Logger.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE GADTs, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn.Logger +-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- describe logger+--+-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn.Logger where++import Control.Monad.Reader+--+import Control.Monad.Trans.Crtn +import Control.Monad.Trans.Crtn.Object++-------------------------+-- Logging monad +-------------------------++class (Monad m) => MonadLog m where +    scribe :: String -> m () ++instance (MonadTrans t, MonadLog m, Monad (t m)) => MonadLog (t m) where +  scribe = lift . scribe  +  +instance MonadLog IO where+    scribe = putStrLn +++data LogOp i o where +  WriteLog :: LogOp String () +++type LogInput = Arg LogOp ++type LogServer m r = SObjT LogOp m r ++type LogClient m r = CObjT LogOp m r++-- | +writeLog :: (Monad m) => String -> LogClient m () +writeLog msg = do request (Arg WriteLog msg) +                  return () +++++++++
+ src/Control/Monad/Trans/Crtn/Logger/Simple.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE GADTs #-}++module Control.Monad.Trans.Crtn.Logger.Simple where++import Control.Monad.Reader +-- from this package+import Control.Monad.Trans.Crtn+import Control.Monad.Trans.Crtn.Logger +import Control.Monad.Trans.Crtn.Object+++-- | +simplelogger :: (MonadLog m) => LogServer m () +simplelogger = loggerW 0+ +-- |+loggerW :: (MonadLog m) => Int -> LogServer m () +loggerW num = ReaderT (f num)+  where f n req = +          case req of +            Arg WriteLog msg -> do lift (scribe ("log number "++show n++" : "++ msg))+                                   req' <- request (Res WriteLog ())+                                   f (n+1) req' +
+ src/Control/Monad/Trans/Crtn/Object.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GADTs, RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn.Object +-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- coroutine that can be interpreted as an object+-- +-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn.Object where ++-- from other packages+import Control.Monad.State +import Control.Monad.Error +-- from this package+import Control.Monad.Trans.Crtn++-- | input of method of an object with signature s +data Arg s = forall i o. Arg (s i o) i ++-- | output of methdo of an object with signature s +data Res s = forall i o.  Res (s i o) o +           | Ign++{-+-- |+type SObjT s = CrtnT (Arg s) (ResMethodInput s)  ++-- | +type ClientT s = CoroutineT (MethodInput s) (MethodOutput s)+-}++-- | Server object+type SObjT s m = SrvT (Arg s) (Res s) m  + +-- | Client object+type CObjT s = CliT (Arg s) (Res s)  ++-- | Server object base coroutine+type SObjBT s m = CrtnT (Res s) (Arg s) m+++++-- | convenient error state monad for object  +type EStT s m = ErrorT (CrtnErr ()) (StateT s m)  ++-- |  +query :: (Monad m) => CObjT s m r -> EStT (SObjT s m ()) m r  +query cli = do +  qserv <- lift get +  (qserv',r) <- mapErrorT lift (qserv <==| cli )+  lift (put qserv')+  return r+  +  ++
+ src/Control/Monad/Trans/Crtn/Queue.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE StandaloneDeriving #-}++module Control.Monad.Trans.Crtn.Queue where ++---------------------------+-- queue+---------------------------+++data Queue a = Queue { fqueue :: [a] +                     , bqueue :: [a] } ++deriving instance (Show a) => Show (Queue a)++emptyQueue :: Queue a +emptyQueue = Queue [] []++enqueue :: a -> Queue a -> Queue a +enqueue y (Queue xs ys) = Queue xs (y:ys) ++dequeue :: Queue a -> (Queue a, Maybe a) +dequeue (Queue (x:xs) ys) = (Queue xs ys, Just x)+dequeue q@(Queue [] []) = (q,Nothing)+dequeue (Queue [] ys) = dequeue (Queue (reverse ys) [])+
+ src/Control/Monad/Trans/Crtn/World.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GADTs, NoMonomorphismRestriction, ScopedTypeVariables, KindSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Trans.Crtn.World+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- describe world object+--+-----------------------------------------------------------------------------++module Control.Monad.Trans.Crtn.World where ++import Control.Monad.Error +-- +import Control.Monad.Trans.Crtn+import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Logger +import Control.Monad.Trans.Crtn.Object+-- +import Prelude hiding ((.),id)+++-- | +data WorldOp e m i o where +  GiveEvent :: WorldOp e m e ()+  FlushLog :: WorldOp e m (LogServer m ()) (LogServer m ())+  FlushQueue :: WorldOp e m () [Either (ActionOrder e) e]++-- | +type World e m r = SObjT (WorldOp e m) m r  +++-- | +giveEvent :: (Monad m) => e -> CObjT (WorldOp e m) m () +giveEvent ev = request (Arg GiveEvent ev) >> return () +++-- | +flushLog :: (Monad m) => LogServer m () -> CObjT (WorldOp e m) m (LogServer m ()) +flushLog logobj = do req <- request (Arg FlushLog logobj) +                     case req of +                       Res FlushLog logobj' -> return logobj' +                       Ign -> return logobj +                       _ -> error "error in flushLog"  -- allow partiality++-- | +flushQueue :: (Monad m) => CObjT (WorldOp e m) m [Either (ActionOrder e) e]+flushQueue = do req <- request (Arg FlushQueue ())+                case req of +                  Res FlushQueue lst -> return lst +                  Ign -> return [] +                  _ -> error "error in flushQueue" -- allow partiality+