karakuri 0.1 → 0.1.1

raw patch · 3 files changed

+150/−84 lines, 3 filesdep +containersdep +minioperationaldep +mtl

Dependencies added: containers, minioperational, mtl

Files

• Control/Monad/Butai.hs +66/−0
• Data/Karakuri.hs +63/−63
• karakuri.cabal +21/−21

@@ -0,0 +1,66 @@+{-# LANGUAGE Rank2Types, TemplateHaskell, GADTs, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Monad.Butai (ButaiT, register, look, updateAll, Key(..), transButaiT, runButaiT) where
+
+import Data.Karakuri
+import Unsafe.Coerce
+import Control.Monad.Trans.Operational.Mini
+import Control.Monad.Operational.TH
+import Control.Monad.State.Class
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Applicative
+import qualified Data.IntMap as IM
+import Control.Comonad
+import Control.Monad.Trans.Class
+
+newtype Key a = Kao Int
+
+data ButaiBase m a where
+    Register :: Karakuri m r -> ButaiBase m (Key r)
+    Look :: Key r -> ButaiBase m r
+    UpdateAll :: ButaiBase m ()
+makeSingletons ''ButaiBase
+
+newtype ButaiT m a = ButaiT { unButaiT :: ReifiedProgramT (ButaiBase (ButaiT m)) m a } deriving (Monad, Applicative, Functor)
+
+
+instance MonadIO m => MonadIO (ButaiT m) where
+    liftIO = lift . liftIO
+
+instance MonadTrans ButaiT where
+    lift = ButaiT . lift
+
+instance Monad m => ButaiBase (ButaiT m) :! ButaiT m where
+    singleton = ButaiT . singleton
+
+instance MonadState s m => MonadState s (ButaiT m) where
+    get = lift get
+    put = lift . put
+
+transButaiBase :: (forall a. m a -> n a) -> ButaiBase m a -> ButaiBase n a
+transButaiBase t (Register k) = Register (transKarakuri t k)
+transButaiBase _ (Look k) = Look k
+transButaiBase _ UpdateAll = UpdateAll
+
+transButaiT :: (Monad m, Monad n) => (forall x. m x -> n x) -> ButaiT m a -> ButaiT n a
+transButaiT t = ButaiT . hoistReifiedT (transButaiBase (transButaiT t)) . transReifiedT t . unButaiT
+
+data Any
+
+runButaiT :: forall m a. Monad m => ButaiT m a -> m a
+runButaiT = go 0 IM.empty . unButaiT where
+    go :: Int -> IM.IntMap (Karakuri (ButaiT m) Any) -> ReifiedProgramT (ButaiBase (ButaiT m)) m a -> m a
+    go i m (Register k :>>= cont) = go (succ i) (IM.insert i (unsafeCoerce k) m) $ cont (Kao i)
+    go i m (Look k@(Kao j) :>>= cont) = go i m $ cont $ extract (unsafeCoerce (m IM.! j) `asKarakuriOf` k)
+    go i m (UpdateAll :>>= cont) = do
+        rs <- runButaiT $ forM (IM.toAscList m) (\(i, m) -> (,) i `liftM` step m)
+        go i (IM.fromAscList rs) (cont ())
+    go i m (Lift a cont) = a >>= go i m . cont
+    go _ _ (Return a) = return a
+
+    asKarakuriOf :: Karakuri m x -> p x -> Karakuri m x
+    asKarakuriOf x _ = x

@@ -1,63 +1,63 @@-{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
-
-module Data.Karakuri (
-    Karakuri(..)
-    , Karakuri'
-    , step
-    , transKarakuri
-    , stateful
-    , stateful'
-    , effective
-    ) where
-
-import Control.Monad.Trans.State
-import Control.Applicative
-import Control.Comonad
-import Data.Functor.Identity
-import Control.Monad
-
--- | Karakuri means automaton in Japanese.
-data Karakuri m a = forall s. Karakuri (s -> m s) (s -> a) s
-
--- | Run a 'Karakuri'.
-step :: Monad m => Karakuri m a -> m (Karakuri m a)
-step (Karakuri m f s) = Karakuri m f `liftM` m s
-
-instance Functor (Karakuri m) where
-    fmap f (Karakuri m g s) = Karakuri m (f . g) s
-    {-# INLINE fmap #-}
-
-instance Monad m => Applicative (Karakuri m) where
-    pure a = Karakuri return (const a) ()
-    {-# INLINE pure #-}
-    Karakuri m f s <*> Karakuri n g t = Karakuri
-        (\(a, b) -> m a >>= \r -> n b >>= \s -> return (r, s))
-        (\(x, y) -> f x (g y))
-        (s, t)
-
-instance Comonad (Karakuri m) where
-    extract (Karakuri _ f s) = f s
-    {-# INLINE extract #-}
-    extend k (Karakuri m f s) = Karakuri m (k . Karakuri m f) s
-    {-# INLINE extend #-}
-
-instance Monad m => ComonadApply (Karakuri m) where
-    (<@>) = (<*>)
-    {-# INLINE (<@>) #-}
-
-transKarakuri :: (forall s. m s -> n s) -> Karakuri m a -> Karakuri n a
-transKarakuri t (Karakuri f e s) = Karakuri (t . f) e s
-
--- | Create a 'Karakuri' from the stateful action.
-stateful :: Monad m => StateT s m () -> s -> Karakuri m s
-stateful m s = Karakuri (execStateT m) id s
-
-type Karakuri' = Karakuri Identity
-
--- | Create a 'Karakuri' from the stateful action.
-stateful' :: Monad m => State s () -> s -> Karakuri m s
-stateful' m s = Karakuri (return . execState m) id s
-
--- | Create a 'Karakuri' that performs the given action every time.
-effective :: Monad m => a -> m a -> Karakuri m a
-effective a m = Karakuri (const m) id a
+{-# LANGUAGE ExistentialQuantification, Rank2Types #-}++module Data.Karakuri (+    Karakuri(..)+    , Karakuri'+    , step+    , transKarakuri+    , stateful+    , stateful'+    , effective+    ) where++import Control.Monad.Trans.State+import Control.Applicative+import Control.Comonad+import Data.Functor.Identity+import Control.Monad++-- | Karakuri means automaton in Japanese.+data Karakuri m a = forall s. Karakuri (s -> m s) (s -> a) s++-- | Run a 'Karakuri'.+step :: Monad m => Karakuri m a -> m (Karakuri m a)+step (Karakuri m f s) = Karakuri m f `liftM` m s++instance Functor (Karakuri m) where+    fmap f (Karakuri m g s) = Karakuri m (f . g) s+    {-# INLINE fmap #-}++instance Monad m => Applicative (Karakuri m) where+    pure a = Karakuri return (const a) ()+    {-# INLINE pure #-}+    Karakuri m f s <*> Karakuri n g t = Karakuri+        (\(a, b) -> m a >>= \r -> n b >>= \s -> return (r, s))+        (\(x, y) -> f x (g y))+        (s, t)++instance Comonad (Karakuri m) where+    extract (Karakuri _ f s) = f s+    {-# INLINE extract #-}+    extend k (Karakuri m f s) = Karakuri m (k . Karakuri m f) s+    {-# INLINE extend #-}++instance Monad m => ComonadApply (Karakuri m) where+    (<@>) = (<*>)+    {-# INLINE (<@>) #-}++transKarakuri :: (forall s. m s -> n s) -> Karakuri m a -> Karakuri n a+transKarakuri t (Karakuri f e s) = Karakuri (t . f) e s++-- | Create a 'Karakuri' from the stateful action.+stateful :: Monad m => StateT s m () -> s -> Karakuri m s+stateful m s = Karakuri (execStateT m) id s++type Karakuri' = Karakuri Identity++-- | Create a 'Karakuri' from the stateful action.+stateful' :: Monad m => State s () -> s -> Karakuri m s+stateful' m s = Karakuri (return . execState m) id s++-- | Create a 'Karakuri' that performs the given action every time.+effective :: Monad m => a -> m a -> Karakuri m a+effective a m = Karakuri (const m) id a

@@ -1,22 +1,22 @@-name:                karakuri
-version:             0.1
-synopsis:            Good stateful automata 
--- description:         
-homepage:            https://github.com/fumieval/karakuri
-license:             BSD3
-license-file:        LICENSE
-author:              Fumiaki Kinoshita
-maintainer:          fumiexcel@gmail.com
-copyright:           Copyright (C) 2013 Fumiaki Kinoshita
-category:            Data
-build-type:          Simple
--- extra-source-files:  
-cabal-version:       >=1.10
-
-library
-  exposed-modules:     Data.Karakuri
-  -- other-modules:       
-  other-extensions:    ExistentialQuantification, Rank2Types
-  build-depends:       base == 4.*, transformers >=0.3 && <0.4, comonad == 3.*
-  -- hs-source-dirs:      
+name:                karakuri+version:             0.1.1+synopsis:            Good stateful automata +-- description:         +homepage:            https://github.com/fumieval/karakuri+license:             BSD3+license-file:        LICENSE+author:              Fumiaki Kinoshita+maintainer:          fumiexcel@gmail.com+copyright:           Copyright (C) 2013 Fumiaki Kinoshita+category:            Data+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Data.Karakuri, Control.Monad.Butai+  -- other-modules:       +  other-extensions:    ExistentialQuantification, Rank2Types+  build-depends:       base == 4.*, transformers >=0.3 && <0.4, comonad == 3.*, mtl == 2.*, containers, minioperational == 0.4.*+  -- hs-source-dirs:         default-language:    Haskell2010