minioperational 0.4 → 0.4.1

raw patch · 3 files changed

+44/−31 lines, 3 files

Files

• Control/Monad/Operational/TH.hs +40/−29
• Control/Monad/Trans/Operational/Mini.hs +3/−1
• minioperational.cabal +1/−1

@@ -1,25 +1,24 @@ {-# LANGUAGE TemplateHaskell #-}
 module Control.Monad.Operational.TH (makeSingletons) where
-
+import Prelude hiding (mapM)
 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)
+import qualified Data.Map as Map
+import Control.Lens
+import Data.List (nub)
+import Data.Traversable
 
-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
+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]
@@ -33,29 +32,41 @@         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
+        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..] 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 ''(:!) [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)
 
             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 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

@@ -15,11 +15,13 @@ ---------------------------------------------------------------------------- module Control.Monad.Trans.Operational.Mini (   ProgramT(..), interpret,  ReifiedProgramT(..), fromReifiedT,-  module Control.Monad.Operational.Class+  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 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                minioperational
-version:             0.4
+version:             0.4.1
 synopsis:            fast and simple operational monad
 description:         This package provides tiny implementation of operational monad.
 homepage:            https://github.com/fumieval/minioperational