minioperational 0.3 → 0.4

raw patch · 5 files changed

+91/−24 lines, 5 filesdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• Control/Monad/Operational/Class.hs +15/−15
• Control/Monad/Operational/Mini.hs +4/−4
• Control/Monad/Operational/TH.hs +63/−0
• Control/Monad/Trans/Operational/Mini.hs +3/−2
• minioperational.cabal +6/−3

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- |@@ -12,7 +12,7 @@ -- -- A class for operational monads -----------------------------------------------------------------------------module Control.Monad.Operational.Class (Operational(..)) where+module Control.Monad.Operational.Class ((:!)(..)) where  import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as Strict@@ -29,42 +29,42 @@ import Control.Monad.Trans.Class import Data.Monoid -class Monad m => Operational t m where -- need fundeps?+class Monad m => t :! m | m -> t where   -- | Construct an operational action from a single imperative.   singleton :: t a -> m a -instance (Operational f m) => Operational f (ReaderT e m) where+instance (t :! m) => t :! ReaderT e m where   singleton = lift . singleton -instance (Operational f m) => Operational f (Lazy.StateT s m) where+instance (t :! m) => t :! Lazy.StateT s m where   singleton = lift . singleton -instance (Operational f m) => Operational f (Strict.StateT s m) where+instance (t :! m) => t :! Strict.StateT s m where   singleton = lift . singleton -instance (Operational f m) => Operational f (ContT r m) where+instance (t :! m) => t :! ContT r m where   singleton = lift . singleton -instance (Operational f m, Monoid w) => Operational f (Lazy.WriterT w m) where+instance (t :! m, Monoid w) => t :! Lazy.WriterT w m where   singleton = lift . singleton -instance (Operational f m, Monoid w) => Operational f (Strict.WriterT w m) where+instance (t :! m, Monoid w) => t :! Strict.WriterT w m where   singleton = lift . singleton -instance (Operational f m, Monoid w) => Operational f (Strict.RWST r w s m) where+instance (t :! m, Monoid w) => t :! 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+instance (t :! m, Monoid w) => t :! Lazy.RWST r w s m where   singleton = lift . singleton -instance (Operational f m) => Operational f (MaybeT m) where+instance (t :! m) => t :! MaybeT m where   singleton = lift . singleton -instance (Operational f m) => Operational f (IdentityT m) where+instance (t :! m) => t :! IdentityT m where   singleton = lift . singleton -instance (Operational f m) => Operational f (ListT m) where+instance (t :! m) => t :! ListT m where   singleton = lift . singleton -instance (Operational f m, Error e) => Operational f (ErrorT e m) where+instance (t :! m, Error e) => t :! ErrorT e m where   singleton = lift . singleton

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, GADTs #-}
+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Operational.Mini
@@ -42,10 +42,10 @@ 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 :: Operational t m => Program t a -> m a
+cloneProgram :: (t :! m) => Program t a -> m a
 cloneProgram (Program m) = m return (\t c -> singleton t >>= c)
 
-instance Operational t (Program t) where
+instance t :! Program t where
     singleton t = Program $ \p i -> i t p
 
 -- | Reified version of 'Program'. It is useful for testing.
@@ -76,5 +76,5 @@     Return a >>= f = f a
     (t :>>= m) >>= k = t :>>= (>>= k) . m
 
-instance Operational t (ReifiedProgram t) where
+instance t :! ReifiedProgram t where
     singleton t = t :>>= Return

@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}
+module Control.Monad.Operational.TH (makeSingletons) where
+
+import Language.Haskell.TH
+import Control.Monad.Operational.Class
+import Data.Char
+
+import Control.Monad.Trans.State
+import Control.Applicative
+import Data.List (union)
+import Data.Maybe (fromJust)
+
+renameType :: [(Name, Name)] -> Type -> State Int Type
+renameType m (VarT n) = case n `lookup` m of
+    Just n' -> return $ VarT n'
+    Nothing -> do
+        i <- get
+        modify (+1)
+        return $ VarT $ mkName $ "a" ++ show i
+renameType m (SigT t k)          = SigT <$> renameType m t <*> pure k
+renameType m (AppT l r)          = AppT <$> renameType m l <*> renameType m r
+renameType _ t                   = pure 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 conName argTypes resultType = do
+            let bodyName = let (b:bs) = nameBase name in mkName (toLower b : bs)
+                ref = [(n, mkName ("p" ++ show i)) | (i, n) <- zip [(0::Int)..] (init vs)]
+                instr = foldl AppT (ConT name) $ map VarT $ map (fromJust . (`lookup`ref)) (init vs)
+                
+                m = mkName "m"
+                
+                ts = evalState (mapM (renameType ref) argTypes) 0
+                result = evalState (renameType ref resultType) 0
+                
+                vars = PlainTV m : map PlainTV (map snd ref `union` tyVars result)
+                
+                sig = SigD bodyName $ ForallT vars [ClassP ''(:!) [instr, VarT m]]
+                    $ foldr (\x y -> AppT ArrowT x `AppT` y) (AppT (VarT m) result) ts
+            
+            ps <- mapM (newName . ("p"++) . show) [0..length argTypes - 1]
+
+            let body = AppE (VarE 'singleton) $ foldl AppE (ConE conName) (map VarE ps)
+
+            return [sig, FunD bodyName [Clause (map VarP ps) (NormalB body) []]]  
+
+        fromCon vs (ForallC _ [EqualP _ t] (NormalC conName ts)) = gen vs conName (map snd ts) t
+        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

@@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes, GADTs #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses,KindSignatures #-} ----------------------------------------------------------------------------- -- |@@ -39,7 +40,7 @@ interpret :: Monad m => (forall x. t x -> m x) -> ProgramT t m a -> m a interpret e (ProgramT m) = m return (\t c -> e t >>= c) -instance Operational t (ProgramT t m) where+instance t :! ProgramT t m where     singleton t = ProgramT $ \p i -> i t p  instance MonadTrans (ProgramT t) where@@ -81,7 +82,7 @@     (t :>>= m) >>= k = t :>>= (>>= k) . m     Lift a c >>= f = Lift a (c >=> f) -instance Monad m => Operational t (ReifiedProgramT t m) where+instance Monad m => t :! ReifiedProgramT t m where     singleton t = t :>>= Return  instance MonadTrans (ReifiedProgramT t) where lift = flip Lift Return

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                minioperational
-version:             0.3
+version:             0.4
 synopsis:            fast and simple operational monad
 description:         This package provides tiny implementation of operational monad.
 homepage:            https://github.com/fumieval/minioperational
@@ -22,6 +22,9 @@ library
   default-language:   Haskell2010
   ghc-options: -Wall -O2
-  exposed-modules:     Control.Monad.Operational.Mini, Control.Monad.Trans.Operational.Mini, Control.Monad.Operational.Class
+  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.4+  build-depends:       base ==4.*, transformers >= 0.2.0 && <0.4, template-haskell