minioperational 0.1 → 0.4.9

raw patch · 5 files changed

Files

Control/Monad/Operational/Class.hs +11/−54
Control/Monad/Operational/Mini.hs +78/−11
Control/Monad/Operational/TH.hs +70/−0
Control/Monad/Trans/Operational/Mini.hs +132/−0
minioperational.cabal +7/−7

Control/Monad/Operational/Class.hs view

@@ -1,5 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Operational.Class
@@ -10,60 +14,13 @@ -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- A class for operational monads
+-- Just for compatibility
 ----------------------------------------------------------------------------
-module Control.Monad.Operational.Class (Operational(..)) where
-
-import Control.Monad.Trans.Reader
-import qualified Control.Monad.Trans.State.Strict as Strict
-import qualified Control.Monad.Trans.State.Lazy as Lazy
-import qualified Control.Monad.Trans.Writer.Strict as Strict
-import qualified Control.Monad.Trans.Writer.Lazy as Lazy
-import qualified Control.Monad.Trans.RWS.Strict as Strict
-import qualified Control.Monad.Trans.RWS.Lazy as Lazy
-import Control.Monad.Trans.Cont
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.List
-import Control.Monad.Trans.Error
-import Control.Monad.Trans.Identity
-import Control.Monad.Trans.Class
-import Data.Monoid
-
-class Monad m => Operational t m | m -> t where
-  singleton :: t a -> m a
-
-instance (Operational f m) => Operational f (ReaderT e m) where
-  singleton = lift . singleton
-
-instance (Operational f m) => Operational f (Lazy.StateT s m) where
-  singleton = lift . singleton
-
-instance (Operational f m) => Operational f (Strict.StateT s m) where
-  singleton = lift . singleton
-
-instance (Operational f m) => Operational f (ContT r m) where
-  singleton = lift . singleton
-
-instance (Operational f m, Monoid w) => Operational f (Lazy.WriterT w m) where
-  singleton = lift . singleton
-
-instance (Operational f m, Monoid w) => Operational f (Strict.WriterT w m) where
-  singleton = lift . singleton
-
-instance (Operational f m, Monoid w) => Operational f (Strict.RWST r w s m) where
-  singleton = lift . singleton
-
-instance (Operational f m, Monoid w) => Operational f (Lazy.RWST r w s m) where
-  singleton = lift . singleton
-
-instance (Operational f m) => Operational f (MaybeT m) where
-  singleton = lift . singleton
+module Control.Monad.Operational.Class ((:!), singleton) where
 
-instance (Operational f m) => Operational f (IdentityT m) where
-  singleton = lift . singleton
+import Control.Elevator
 
-instance (Operational f m) => Operational f (ListT m) where
-  singleton = lift . singleton
+type t :! m = Elevate t m
 
-instance (Operational f m, Error e) => Operational f (ErrorT e m) where
-  singleton = lift . singleton+singleton :: Elevate f g => f a -> g a
+singleton = elevate

Control/Monad/Operational/Mini.hs view

@@ -1,26 +1,93 @@-{-# LANGUAGE Rank2Types, GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators, DataKinds, TypeFamilies, ConstraintKinds, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Operational.Mini
 -- Copyright   :  (C) 2012-2013 Fumiaki Kinoshita
 -- License     :  BSD-style (see the file LICENSE)
 --
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
 -- Stability   :  experimental
--- Portability :  non-portable
+-- Portability :  RankNTypes
 --
--- Simple operational monad from a free monad
+-- Simple operational monad
 ----------------------------------------------------------------------------
-module Control.Monad.Operational.Mini (Program, interpret, module Control.Monad.Operational.Class) where
+module Control.Monad.Operational.Mini (Program(..)
+    , interpret
+    , cloneProgram
+    , ReifiedProgram(..)
+    , fromReified
+    , module Control.Monad.Operational.Class
+    , module Control.Monad.Operational.TH) where
 
-import Data.Functor.Yoneda.Contravariant
-import Control.Monad.Free.Church
 import Control.Monad.Operational.Class
+import Control.Monad.Operational.TH
+import Data.Extensible
+import Control.Elevator
+import Control.Applicative
+import Data.Functor.Identity
 
-type Program t = F (Yoneda t)
+infixl 1 :>>=
 
+-- | Program t is a 'Monad' that represents a sequence of imperatives.
+-- To construct imperatives, use 'singleton' :: t a -> Program t a.
+newtype Program t a = Program { unProgram :: forall r. (a -> r) -> (forall x. t x -> (x -> r) -> r) -> r }
+
+instance Functor (Program t) where
+    fmap f (Program m) = Program $ \p i -> m (p . f) i
+
+instance Applicative (Program t) where
+    pure a = Program $ \p _ -> p a
+    Program mf <*> Program ma = Program $ \p i -> mf (\f -> ma (p . f) i) i
+
+instance Monad (Program t) where
+    return a = Program $ \p _ -> p a
+    Program m >>= k = Program $ \p i -> m (\a -> unProgram (k a) p i) i
+
+-- | Interpret a 'Program' using the given transformation.
 interpret :: Monad m => (forall x. t x -> m x) -> Program t a -> m a
-interpret e (F m) = m return (\(Yoneda f t) -> e t >>= f)
+interpret e (Program m) = m return (\t f -> e t >>= f)
 
-instance Operational t (Program t) where
-    singleton = liftF . liftYoneda+cloneProgram :: (Monad m, Elevate t m) => Program t a -> m a
+cloneProgram (Program m) = m return ((>>=) . elevate)
+
+instance Tower (Program t) where
+    type Floors (Program t) = '[t, ReifiedProgram t, Identity]
+    stairs = (\t -> Program $ \p i -> i t p)
+        `rung` fromReified
+        `rung` pure . runIdentity
+        `rung` Nil
+
+-- | Reified version of 'Program'. It is useful for testing.
+data ReifiedProgram t a where
+    Return :: a -> ReifiedProgram t a
+    (:>>=) :: t a -> (a -> ReifiedProgram t b) -> ReifiedProgram t b
+
+fromReified :: ReifiedProgram t a -> Program t a
+fromReified m = Program $ \p i ->
+    let go (Return a) = p a
+        go (t :>>= c) = i t (go . c) in go m
+
+instance Functor (ReifiedProgram t) where
+    fmap f = go where
+        go (Return a) = Return (f a)
+        go (t :>>= k) = t :>>= go . k
+    {-# INLINE fmap #-}
+
+instance Applicative (ReifiedProgram t) where
+    pure = Return
+    {-# INLINE pure #-}
+    Return f <*> Return a = Return (f a)
+    mf <*> m = mf >>= \f -> fmap f m
+
+instance Monad (ReifiedProgram t) where
+    return = Return
+    {-# INLINE return #-}
+    Return a >>= f = f a
+    (t :>>= m) >>= k = t :>>= (>>= k) . m
+
+instance Tower (ReifiedProgram t) where
+    type Floors (ReifiedProgram t) = '[t, Program t, Identity]
+    stairs = (:>>= Return)
+        `rung` (\(Program m) -> m Return (:>>=))
+        `rung` pure . runIdentity
+        `rung` Nil

+ Control/Monad/Operational/TH.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}
+module Control.Monad.Operational.TH (makeSingletons) where
+import Prelude hiding (mapM)
+import Language.Haskell.TH
+import Data.Char
+import qualified Data.Map as Map
+import Data.List (nub)
+import Data.Traversable
+import Control.Elevator
+
+renameType :: Map.Map Name Type -> Type -> Type
+renameType m (VarT n) = case n `Map.lookup` m of
+    Just t -> t
+    Nothing -> VarT n
+renameType m (SigT t k)          = SigT (renameType m t) k
+renameType m (AppT l r)          = AppT (renameType m l) (renameType m r)
+renameType _ t                   = t
+
+tyVars :: Type -> [Name]
+tyVars (VarT n) = [n]
+tyVars (AppT l r) = tyVars l ++ tyVars r
+tyVars _ = []
+
+makeSingletons :: Name -> Q [Dec]
+makeSingletons name = do
+    TyConI dec <- reify name
+    case dec of
+        DataD _ _ vs cs _ -> fmap concat $ mapM (fromCon (map fromTyVarBndr vs)) cs
+        _ -> fail "Expecting a type construcor"
+    where
+        gen vs_ eqs_ conName argTypes_ resultType_ = do
+            let bodyName = let (b:bs) = nameBase conName in mkName (toLower b : bs)
+            
+            let refresh1 m i = case Map.lookup i m of
+                    Just (VarT v) -> v
+                    _ -> i
+
+            let ref = Map.fromList [(v, VarT $ mkName $ "v" ++ show i) | (i, v) <- zip [(0 :: Int)..] vs_]
+            let vs = map (refresh1 ref) vs_
+            let resultType = renameType ref resultType_
+            let argTypes = map (renameType ref) argTypes_
+            let eqs = [EqualP (renameType ref s) (renameType ref t) | EqualP s t <- eqs_]
+
+            let eqm = Map.fromList [(v, t) | EqualP (VarT v) t <- eqs]
+            let vs' = map (refresh1 eqm) vs
+            let resultType' = renameType eqm resultType
+            let argTypes' = map (renameType eqm) argTypes
+
+            let instr = renameType eqm $ foldl AppT (ConT name) $ map VarT (init vs')
+            let m = mkName "m"
+
+            let vars = map PlainTV $ (m :) $ nub
+                    $ tyVars instr ++ tyVars resultType' ++ concatMap tyVars argTypes'
+
+            let sig = SigD bodyName $ ForallT vars [ClassP ''Elevate [instr, VarT m]]
+                    $ foldr (\x y -> AppT ArrowT x `AppT` y) (AppT (VarT m) resultType') argTypes'
+            
+            ps <- mapM (newName . ("p"++) . show) [0..length argTypes - 1]
+
+            let body = AppE (VarE 'elevate) $ foldl AppE (ConE conName) (map VarE ps)
+
+            return [sig, FunD bodyName [Clause (map VarP ps) (NormalB body) []]]  
+
+        fromCon vs (ForallC _ eqs (NormalC conName ts)) = gen vs eqs conName (map snd ts) (VarT $ last vs)
+        fromCon vs (NormalC conName ts) = gen vs [] conName (map snd ts) (VarT $ last vs)
+        fromCon _ _ = fail "Unsupported data constructor"
+
+        fromTyVarBndr :: TyVarBndr -> Name
+        fromTyVarBndr (PlainTV n) = n
+        fromTyVarBndr (KindedTV n _) = n

+ Control/Monad/Trans/Operational/Mini.hs view

@@ -0,0 +1,132 @@+{-# LANGUAGE RankNTypes, GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,KindSignatures, DataKinds, TypeFamilies, ConstraintKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.Operational.Mini+-- Copyright   :  (C) 2013 Fumiaki Kinoshita+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+-- Stability   :  experimental+-- Portability :  RankNTypes+--+-- Simple operational monad transformer+----------------------------------------------------------------------------+module Control.Monad.Trans.Operational.Mini (+  ProgramT(..)+  , unProgram+  , cloneProgramT+  , interpret+  , ReifiedProgramT(..)+  , fromReifiedT+  , transReifiedT+  , hoistReifiedT+  , module Control.Monad.Operational.Class+  , module Control.Monad.Operational.TH+  ) where++import Control.Monad+import Control.Monad.Operational.Class+import Control.Monad.Operational.TH+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Elevator+import qualified Control.Monad.Operational.Mini as P++newtype ProgramT t m a = ProgramT+  { unProgramT :: forall r. (a -> r) -> (m r -> r) -> (forall x. t x -> (x -> r) -> r) -> r }++cloneProgramT :: (Monad n, Elevate t n, Elevate m n) => ProgramT t m a -> n a+cloneProgramT (ProgramT m) = m return (join . elevate) ((>>=) . elevate)++unProgram :: Monad m => ProgramT t m a -> (a -> m r) -> (forall x. t x -> (x -> m r) -> m r) -> m r+unProgram (ProgramT m) r b = m r join b++instance Functor (ProgramT t m) where+    fmap f (ProgramT m) = ProgramT $ \p l i -> m (p . f) l i++instance Applicative (ProgramT t m) where+    pure a = ProgramT $ \p _ _ -> p a+    ProgramT mf <*> ProgramT ma = ProgramT $ \p l i -> mf (\f -> ma (p . f) l i) l i++instance Monad (ProgramT t m) where+    return a = ProgramT $ \p _ _ -> p a+    ProgramT m >>= k = ProgramT $ \p l i -> m (\a -> unProgramT (k a) p l i) l i++-- | Interpret a 'Program' using the given transformation.+interpret :: Monad m => (forall x. t x -> m x) -> ProgramT t m a -> m a+interpret e (ProgramT m) = m return join (\t c -> e t >>= c)++instance (Monad m, Tower m) => Tower (ProgramT t m) where+    type Floors (ProgramT t m) = t+      ': ReifiedProgramT t m+      ': P.Program t+      ': P.ReifiedProgram t+      ': Floors1 m+    stairs = (\t -> ProgramT $ \p _ i -> i t p)+      `rung` fromReifiedT+      `rung` (\(P.Program m) -> ProgramT $ \r _ b -> m r b)+      `rung` (\(P.Program m) -> ProgramT $ \r _ b -> m r b) . P.fromReified+      `rung` liftGondolas++instance MonadTrans (ProgramT t) where+    lift m = ProgramT $ \p l _ -> l (liftM p m)++infix 1 :>>=++data ReifiedProgramT t (m :: * -> *) a where+  Return :: a -> ReifiedProgramT t m a+  (:>>=) :: t a -> (a -> ReifiedProgramT t m b) -> ReifiedProgramT t m b+  Lift :: m a -> (a -> ReifiedProgramT t m b) -> ReifiedProgramT t m b++fromReifiedT :: Monad m => ReifiedProgramT t m a -> ProgramT t m a+fromReifiedT m = ProgramT $ \p l i ->+  let go (Return a) = p a+      go (t :>>= c) = i t (go . c)+      go (Lift a c) = l $ liftM (go . c) a+   in go m++transReifiedT :: Monad m => (forall x. m x -> n x) -> ReifiedProgramT t m a -> ReifiedProgramT t n a+transReifiedT _ (Return a) = Return a+transReifiedT t (i :>>= cont) = i :>>= transReifiedT t . cont+transReifiedT t (Lift m cont) = Lift (t m) (transReifiedT t . cont)++hoistReifiedT :: Monad m => (forall x. t x -> s x) -> ReifiedProgramT t m a -> ReifiedProgramT s m a+hoistReifiedT _ (Return a) = Return a+hoistReifiedT t (i :>>= cont) = t i :>>= hoistReifiedT t . cont+hoistReifiedT t (Lift m cont) = Lift m (hoistReifiedT t . cont)++instance Monad m => Functor (ReifiedProgramT t m) where+    fmap f = go where+        go (Return a) = Return (f a)+        go (t :>>= k) = t :>>= go . k+        go (Lift a c) = Lift a (go.c)+    {-# INLINE fmap #-}++instance Monad m => Applicative (ReifiedProgramT t m) where+    pure = Return+    {-# INLINE pure #-}+    Return f <*> Return a = Return (f a)+    mf <*> m = mf >>= \f -> fmap f m++instance Monad m => Monad (ReifiedProgramT t m) where+    return = Return+    {-# INLINE return #-}+    Return a >>= f = f a+    (t :>>= m) >>= k = t :>>= (>>= k) . m+    Lift a c >>= f = Lift a (c >=> f)++instance (Monad m, Tower m) => Tower (ReifiedProgramT t m) where+    type Floors (ReifiedProgramT t m) = t+      ': ProgramT t m+      ': P.Program t+      ': P.ReifiedProgram t+      ': Floors1 m+    stairs = (:>>= Return)+      `rung` (\(ProgramT m) -> m Return (flip Lift id) (:>>=))+      `rung` (\(P.Program m) -> m Return (:>>=))+      `rung` (\(P.Program m) -> m Return (:>>=)) . P.fromReified+      `rung` liftGondolas++instance MonadTrans (ReifiedProgramT t) where lift = flip Lift Return

minioperational.cabal view

@@ -1,8 +1,5 @@--- Initial minioperational.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
 name:                minioperational
-version:             0.1
+version:             0.4.9
 synopsis:            fast and simple operational monad
 description:         This package provides tiny implementation of operational monad.
 homepage:            https://github.com/fumieval/minioperational
@@ -22,6 +19,9 @@ library
   default-language:   Haskell2010
   ghc-options: -Wall -O2
-  exposed-modules:     Control.Monad.Operational.Mini, Control.Monad.Operational.Class
-  -- other-modules:       
-  build-depends:       base ==4.*, kan-extensions ==3.*, free ==3.*, transformers >= 0.2.0 && <0.4+  exposed-modules:     Control.Monad.Operational.Mini
+    , Control.Monad.Trans.Operational.Mini
+    , Control.Monad.Operational.Class
+    , Control.Monad.Operational.TH
+  -- other-modules:
+  build-depends:       base ==4.*, transformers >= 0.2.0 && <0.6, template-haskell, containers, elevator >= 0.2 && <0.3, extensible >= 0.2.6 && <3, mtl >= 2.0