minioperational 0.4.6 → 0.4.7

raw patch · 5 files changed

+36/−80 lines, 5 filesdep +clean-unionsdep +elevator

Dependencies added: clean-unions, elevator

Files

• Control/Monad/Operational/Class.hs +7/−63
• Control/Monad/Operational/Mini.hs +11/−7
• Control/Monad/Operational/TH.hs +3/−3
• Control/Monad/Trans/Operational/Mini.hs +13/−5
• minioperational.cabal +2/−2

@@ -3,7 +3,7 @@ {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Operational.Class
@@ -14,69 +14,13 @@ -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- A class for operational monads
+-- Just for compatibility
 ----------------------------------------------------------------------------
-module Control.Monad.Operational.Class ((:!)(..)) 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
-#if MIN_VERSION_transformers(0,4,0)
-import Control.Monad.Trans.Except
-#endif
-import Control.Monad.Trans.Identity
-import Control.Monad.Trans.Class
-import Data.Monoid
-
-class Monad m => t :! m | m -> t where
-  -- | Construct an operational action from a single imperative.
-  singleton :: t a -> m a
-
-instance (t :! m) => t :! ReaderT e m where
-  singleton = lift . singleton
-
-instance (t :! m) => t :! Lazy.StateT s m where
-  singleton = lift . singleton
-
-instance (t :! m) => t :! Strict.StateT s m where
-  singleton = lift . singleton
-
-instance (t :! m) => t :! ContT r m where
-  singleton = lift . singleton
-
-instance (t :! m, Monoid w) => t :! Lazy.WriterT w m where
-  singleton = lift . singleton
-
-instance (t :! m, Monoid w) => t :! Strict.WriterT w m where
-  singleton = lift . singleton
-
-instance (t :! m, Monoid w) => t :! Strict.RWST r w s m where
-  singleton = lift . singleton
-
-instance (t :! m, Monoid w) => t :! Lazy.RWST r w s m where
-  singleton = lift . singleton
-
-instance (t :! m) => t :! MaybeT m where
-  singleton = lift . singleton
-
-instance (t :! m) => t :! IdentityT m where
-  singleton = lift . singleton
+module Control.Monad.Operational.Class ((:!), singleton) where
 
-instance (t :! m) => t :! ListT m where
-  singleton = lift . singleton
+import Control.Elevator
 
-instance (t :! m, Error e) => t :! ErrorT e m where
-  singleton = lift . singleton
+type t :! m = Elevate t m
 
-#if MIN_VERSION_transformers(0,4,0)
-instance (t :! m) => t :! ExceptT e m where
-  singleton = lift . singleton
-#endif+singleton :: Elevate f g => f a -> g a
+singleton = elevate

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators #-}
+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators, DataKinds, TypeFamilies, ConstraintKinds, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Operational.Mini
@@ -22,6 +22,8 @@ import Control.Monad.Operational.Class
 import Control.Monad.Operational.TH
 import Control.Applicative
+import Data.OpenUnion1.Clean
+import Control.Elevator
 
 infixl 1 :>>=
 
@@ -44,11 +46,12 @@ interpret :: Monad m => (forall x. t x -> m x) -> Program t a -> m a
 interpret e (Program m) = m return (\t f -> e t >>= f)
 
-cloneProgram :: (t :! m) => Program t a -> m a
-cloneProgram (Program m) = m return (\t c -> singleton t >>= c)
+cloneProgram :: (Monad m, Elevate t m) => Program t a -> m a
+cloneProgram (Program m) = m return ((>>=) . elevate)
 
-instance t :! Program t where
-    singleton t = Program $ \p i -> i t p
+instance Tower (Program t) where
+    type Floors (Program t) = t :> Empty
+    toLoft = simply $ \t -> Program $ \p i -> i t p
 
 -- | Reified version of 'Program'. It is useful for testing.
 data ReifiedProgram t a where
@@ -78,5 +81,6 @@     Return a >>= f = f a
     (t :>>= m) >>= k = t :>>= (>>= k) . m
 
-instance t :! ReifiedProgram t where
-    singleton t = t :>>= Return+instance Tower (ReifiedProgram t) where
+    type Floors (ReifiedProgram t) = t :> Empty
+    toLoft = simply (:>>= Return)

@@ -2,11 +2,11 @@ module Control.Monad.Operational.TH (makeSingletons) where
 import Prelude hiding (mapM)
 import Language.Haskell.TH
-import Control.Monad.Operational.Class
 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
@@ -52,12 +52,12 @@             let vars = map PlainTV $ (m :) $ nub
                     $ tyVars instr ++ tyVars resultType' ++ concatMap tyVars argTypes'
 
-            let sig = SigD bodyName $ ForallT vars [ClassP ''(:!) [instr, VarT m]]
+            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 'singleton) $ foldl AppE (ConE conName) (map VarE ps)
+            let body = AppE (VarE 'elevate) $ foldl AppE (ConE conName) (map VarE ps)
 
             return [sig, FunD bodyName [Clause (map VarP ps) (NormalB body) []]]  
 

@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, GADTs #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses,KindSignatures #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,KindSignatures, DataKinds, TypeFamilies, ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Trans.Operational.Mini@@ -16,6 +16,7 @@ module Control.Monad.Trans.Operational.Mini (   ProgramT(..)   , unProgram+  , cloneProgramT   , interpret   , ReifiedProgramT(..)   , fromReifiedT@@ -30,10 +31,15 @@ import Control.Monad.Operational.TH import Control.Applicative import Control.Monad.Trans.Class+import Control.Elevator+import Data.OpenUnion1.Clean  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 @@ -52,8 +58,9 @@ 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 t :! ProgramT t m where-    singleton t = ProgramT $ \p _ i -> i t p+instance (Monad m, Tower m) => Tower (ProgramT t m) where+    type Floors (ProgramT t m) = t :> Floors1 m+    toLoft = (\t -> ProgramT $ \p _ i -> i t p) ||> lift . toLoft1  instance MonadTrans (ProgramT t) where     lift m = ProgramT $ \p l _ -> l (liftM p m)@@ -102,7 +109,8 @@     (t :>>= m) >>= k = t :>>= (>>= k) . m     Lift a c >>= f = Lift a (c >=> f) -instance Monad m => t :! ReifiedProgramT t m where-    singleton t = t :>>= Return+instance (Monad m, Tower m) => Tower (ReifiedProgramT t m) where+    type Floors (ReifiedProgramT t m) = t :> Floors1 m+    toLoft = (:>>= Return) ||> lift . toLoft1  instance MonadTrans (ReifiedProgramT t) where lift = flip Lift Return

@@ -1,5 +1,5 @@ name:                minioperational
-version:             0.4.6
+version:             0.4.7
 synopsis:            fast and simple operational monad
 description:         This package provides tiny implementation of operational monad.
 homepage:            https://github.com/fumieval/minioperational
@@ -24,4 +24,4 @@     , Control.Monad.Operational.Class
     , Control.Monad.Operational.TH
   -- other-modules:       
-  build-depends:       base ==4.*, transformers >= 0.2.0 && <0.6, template-haskell, containers+  build-depends:       base ==4.*, transformers >= 0.2.0 && <0.6, template-haskell, containers, elevator, clean-unions