explicit-sharing 0.5.1.2 → 0.6

raw patch · 4 files changed

+489/−7 lines, 4 filesdep +derivedep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: derive, template-haskell

API changes (from Hackage documentation)

Files

• Control/Monad/Sharing/Classes.hs +13/−3
• Control/Monad/Sharing/Implementation/CPS.hs +1/−1
• Data/Monadic/Derive.hs +469/−0
• explicit-sharing.cabal +6/−3

@@ -19,8 +19,10 @@ -- sharing. module Control.Monad.Sharing.Classes ( -  Sharing(..), Shareable(..), Convertible(..), convert+  Sharing(..), Shareable(..), Convertible(..), convert, +  MInt, MChar, MBool+  ) where  -- | Interface of monads that support explicit sharing.@@ -44,9 +46,13 @@ -- could be applied. class Shareable m a  where-  shareArgs :: Monad n -            => (forall b . Shareable m b => m b -> n (m b)) -> a -> n a+  shareArgs :: Monad n => +               (forall b . Shareable m b => m b -> n (m b)) -> a -> n a +type MInt  m = Int+type MChar m = Char+type MBool m = Bool+ instance Monad m => Shareable m Bool  where   shareArgs _ = return@@ -68,6 +74,10 @@   shareArgs _ = return  instance Monad m => Shareable m [Char]+ where+  shareArgs _ = return++instance Monad m => Shareable m (a -> b)  where   shareArgs _ = return 

@@ -104,7 +104,7 @@ -- 'Lazy' is a monad transformer. instance MonadTrans Lazy  where-  lift a = Lazy (\c s -> a >>= \x -> c x s)+  lift a = Lazy (\c s -> a >>= flip c s)  -- If the underlying monad supports IO we can lift this functionality. instance MonadIO m => MonadIO (Lazy m)

@@ -0,0 +1,469 @@+-- | +-- Module      : Data.Monadic.Derive+-- Copyright   : Sebastian Fischer+-- License     : PublicDomain+-- Maintainer  : Sebastian Fischer <mailto:sebf@informatik.uni-kiel.de>+-- Stability   : experimental+-- +-- Automatic deriving of monadic data types and corresponding instances.+module Data.Monadic.Derive (++  monadic, makeMData, makeShareable, makeConvertible++  ) where++import Language.Haskell+import Data.Derive.Internal.Derivation++import Control.Monad.Error+import Control.Applicative+import Control.Arrow++typeParamName, branchResName, funArgName :: String+typeParamName = "m"; branchResName = "a"; funArgName = "fun"++-- | Derives monadic datatypes and instances for explicit sharing as+--   well as conversion. Combines the other three derivations which+--   provide the same functionality split into different parts.+-- +--   You usually need the following preamble when deriving monadic code:+-- +-- > {-# LANGUAGE TemplateHaskell+-- >   , KindSignatures+-- >   , MultiParamTypeClasses+-- >   , FlexibleInstances+-- >   #-}+-- > import Control.Monad.Sharing+-- > import Data.Monadic.Derive+-- > import Data.DeriveTH+-- +--   If your types contain lists, you also need to+-- +-- > import Data.Monadic.List+-- +-- With this prerequisites, you can derive a monadic 'Maybe' type by+-- +-- > $(derive monadic ''Maybe)+-- +monadic :: Derivation+monadic = derivationCustom "Monadic"+            (\ (_,d) -> concat <$> mapM ($d) [convData,shareableInst,convInsts])++-- | Generates a monadic datatype and corresponding con- and+--   destructor functions from a Haskell datatype.+-- +--   For example, the datatype+-- +-- > data Maybe a = Nothing | Just a+-- +--   can be translated into its monadic counterpart by typing+-- +-- > $(derive makeMData ''Maybe)+-- +--   This call generates the following datatype+-- +-- > data MMaybe m a = MNothing | MJust (m a)+-- +--   and the following auxiliary functions for constructing and+--   matching monadic values:+-- +-- > mNothing :: Monad m => m (MMaybe m a)+-- > mNothing = return MNothing+-- +-- > mJust :: Monad m => m a -> m (MMaybe m a)+-- > mJust a = return (MJust a)+-- +-- > matchMMaybe :: Monad m => m (MMaybe m a) -> m b -> (m a -> m b) -> m b+-- > matchMMaybe x n j = x >>= \x -> case x of { MNothing -> n; MJust a -> j a }+-- +makeMData :: Derivation+makeMData = derivationCustom "MData" (convData . snd)++-- | Generates a 'Shareable' instance for a monadic datatype.+-- +--   For example the call+-- +-- > $(derive makeShareable ''Maybe)+-- +--   generates the following instance:+-- +-- > instance (Monad m, Shareable m a) => Shareable (Maybe m a) where+-- >   shareArgs fun MNothing  = return MNothing+-- >   shareArgs fun (MJust a) = fun a >>= \a -> mJust a+-- +makeShareable :: Derivation+makeShareable = derivationCustom "Shareable" (shareableInst . snd)++-- | Generates 'Convertible' instances to convert between monadic and+--   non-monadic datatypes.+-- +--   For example, the call+-- +-- > $(derive makeConvertible ''Maybe)+-- +--   generates the following instances:+-- +-- > instance (Monad m, Convertible m a a')+-- >       => Convertible m (Maybe a) (MMaybe m a') where+-- >   convArgs fun Nothing  = mNothing+-- >   convArgs fun (Just a) = mJust (fun a)+-- > +-- > instance (Monad m, Convertible m a' a)+-- >       => Convertible m (MMaybe m a') (Maybe a) where+-- >   convArgs fun MNothing  = return Nothing+-- >   convArgs fun (MJust a) = (a >>= fun) >>= \a -> return (Just a)+-- +makeConvertible :: Derivation+makeConvertible = derivationCustom "Convertible" (convInsts . snd)++-- printDecls (Left s) = Left s+-- printDecls (Right ds) = trace (unlines . map prettyPrint $ ds) (Right ds)++type Conv a = Either String a++convData :: Decl -> Conv [Decl]+convData (DataDecl _ dataOrNew ctx name args cs _) = +  do cs' <- mapM convQCons cs+     let decl = DataDecl sl dataOrNew ctx (convName True name) (m:args) cs' []+     cfuns <- concat <$> mapM (makeCFunT name args) cs+     mfun <- makeMatchFunT name args cs+     return (decl:cfuns++mfun)+ where m = KindedVar (Ident typeParamName) (KindStar `KindFn` KindStar)++convData _ = fail "Data.Monadic.Derive: no data declaration"++-- Derive does not create Symbols.+-- Hence, we cannot rely on: Ident => prefix, Symbol => infix+convName :: Bool -> Name -> Name+convName isCons name | all isSymbolChar s && isCons = Symbol (s++"~")+                     | all isSymbolChar s           = Symbol ('~':s)+                     | isCons                       = Ident  ('M':s)+                     | otherwise                    = Ident  ('m':s)+ where s = fromName name++convQCons :: QualConDecl -> Conv QualConDecl+convQCons (QualConDecl sl vs ctx con) = QualConDecl sl vs ctx <$> convCons con++convCons :: ConDecl -> Conv ConDecl++convCons (ConDecl name args) =+  ConDecl (convName True name) <$> mapM convBType args++convCons (InfixConDecl l name r) =+  do [l',r'] <- mapM convBType [l,r]+     return $ InfixConDecl l' (convName True name) r'++convCons (RecDecl name fields) =+  RecDecl (convName True name) <$> mapM convField fields+ where convField (ns,bt) = do bt' <- convBType bt+                              return (map (convName False) ns, bt')++convBType :: BangType -> Conv BangType+convBType (BangedTy   t) = BangedTy <$> convType t+convBType (UnpackedTy t) = UnpackedTy <$> convType t+convBType (UnBangedTy t) = UnBangedTy . TyApp m <$> convType t+ where m = TyVar (Ident typeParamName)++convType :: Type -> Conv Type+convType (TyVar name) = return $ TyVar name+convType (TyParen t) = TyParen <$> convType t+convType (TyApp f x) = liftM2 TyApp (convType f) (convType x)+convType (TyCon (UnQual name)) =+  return $ TyApp (TyCon (UnQual (convName True name))) m+ where m = TyVar (Ident typeParamName)+convType (TyCon (Special ListCon)) =+  return $ TyApp (TyCon (UnQual (Ident "List"))) m+ where m = TyVar (Ident typeParamName)+convType (TyFun a b) =+  liftM2 TyFun (fromBangType <$> convBType (UnBangedTy a))+               (fromBangType <$> convBType (UnBangedTy b))++convType t = fail $ "Data.Monadic.Derive: unsupported type " ++ show t++makeCFunT :: Name -> [TyVarBind] -> QualConDecl -> Conv [Decl]+makeCFunT tname targs (QualConDecl _ _ ctx con) =+  do argts <- mapM (convBType . UnBangedTy . fromBangType) (consArgs con)+     let typ = TyForall Nothing (ClassA (UnQual (Ident "Monad")) [m]:ctx) $+                 foldr (TyFun . fromBangType) (makeType tname targs) argts+     return [TypeSig sl [convName False (consName con)] typ,+             makeCFun (consName con) (consArgs con)]+ where m = TyVar (Ident typeParamName)++makeType :: Name -> [TyVarBind] -> Type+makeType name args =+  TyApp m (foldl TyApp (TyCon (UnQual (convName True name)))+                       (m:map tVar args))+ where m = TyVar (Ident typeParamName)++makeCFun :: Name -> [BangType] -> Decl+makeCFun name [] =+  PatBind sl (PVar (convName False name))+    Nothing (UnGuardedRhs rhs) (BDecls [])+ where+  rhs = App (Var (UnQual (Ident "return"))) $ Con (UnQual (convName True name))++makeCFun name argts =+  FunBind [Match sl (convName False name) (map PVar argvs)+    Nothing (UnGuardedRhs rhs) (BDecls [])]+ where+  argvs = take (length argts) $ map (Ident . (:[])) ['a'..]+  rhs   = foldr bind (App (Var (UnQual (Ident "return")))+                          (foldl App (Con (UnQual (convName True name)))+                                     (map (Var . UnQual) argvs)))+                     (map fst . filter (isBangType . snd) $ zip argvs argts)+  bind a b = InfixApp (Var (UnQual a)) (QVarOp (UnQual (Symbol ">>=")))+                      (Lambda sl [PVar a] b)++makeMatchFunT :: Name -> [TyVarBind] -> [QualConDecl] -> Conv [Decl]+makeMatchFunT (Symbol _) _ _ = return []+makeMatchFunT tname@(Ident s) targs cs =+  do ts <- mapM branchTypeC cs+     let typ = TyForall Nothing [ClassA (UnQual (Ident "Monad")) [m]] $+                 foldr TyFun (TyApp m a) (makeType tname targs:ts)+     return [TypeSig sl [name] typ,+             makeMatchFun name (map conDecl cs)]+ where+  m = TyVar (Ident typeParamName)+  a = TyVar (Ident branchResName)+  name = Ident $ "matchM" ++ s++branchTypeC :: QualConDecl -> Conv Type+branchTypeC (QualConDecl _ _ ctx con) =+  TyForall Nothing ctx <$> branchType (consArgs con)++branchType :: [BangType] -> Conv Type+branchType ts =+  foldr (TyFun . fromBangType) (TyApp m a) <$>+    mapM (convBType . UnBangedTy . fromBangType) ts+ where m = TyVar (Ident typeParamName)+       a = TyVar (Ident branchResName)++makeMatchFun :: Name -> [ConDecl] -> Decl+makeMatchFun name cs =+  FunBind [Match sl name (map PVar args) Nothing (UnGuardedRhs rhs) (BDecls [])]+ where+  args = take (1+length cs) . map (Ident . (:[])) $ ['a'..]+  var = head args+  rhs = InfixApp (Var (UnQual var))+                 (QVarOp (UnQual (Symbol ">>=")))+                 (Lambda sl [PVar var] $+                    Case (Var (UnQual var)) (zipWith makeAlt cs (tail args)))++makeAlt :: ConDecl -> Name -> Alt+makeAlt con fun =+  Alt sl (PApp (UnQual name) (map PVar args)) (UnGuardedAlt rhs) (BDecls [])+ where+  name = convName True (consName con)+  args = map Ident . zipWith (const (:"'")) (consArgs con) $ ['a'..]++  rhs = foldl App (Var (UnQual fun))+      . zipWith arg (consArgs con)+      $ map (Var . UnQual) args++  arg t x | isBangType t = App (Var (UnQual (Ident "return"))) x+          | otherwise    = x++shareableInst :: Decl -> Conv [Decl]+shareableInst (DataDecl _ _ _ name args cs _) =+  do rules <- mapM makeShareArgsRule cs+     return [InstDecl sl ctx (UnQual (Ident "Shareable")) [m,t] $+               [InsDecl $ FunBind rules]]+ where+  m   = TyVar (Ident typeParamName)+  t   = foldl TyApp (TyCon (UnQual (convName True name))) (m:map tVar args)+  ctx = ClassA (UnQual (Ident "Monad")) [m]+        : map (\a -> ClassA (UnQual (Ident "Shareable")) [m,tVar a]) args++shareableInst d = fail $ "Cannot make Shareable instance for " ++ show d++makeShareArgsRule :: QualConDecl -> Conv Match+makeShareArgsRule (QualConDecl _ [] [] con) =+  return $ Match sl (Ident "shareArgs") [PVar fun,cpat] Nothing +             (UnGuardedRhs rhs) (BDecls [])+ where+  name = convName True $ consName con+  args = map (Ident.(:[]).fst) . zip ['a'..] $ consArgs con++  fun  = Ident funArgName+  cpat = UnQual name `PApp` map PVar args+  cexp = foldl App (Con (UnQual name)) $ map (Var . UnQual) args++  rhs  = foldr (\ (x,b) e ->+                 InfixApp (if b then+                             Var (UnQual (Ident "shareArgs"))+                              `App` Var (UnQual fun)+                              `App` Var (UnQual x)+                            else Var (UnQual fun) `App` Var (UnQual x))+                          (QVarOp (UnQual (Symbol ">>=")))+                          (Lambda sl [PVar x] e))+           (Var (UnQual (Ident "return")) `App` cexp)+           (zipWith (curry $ second isBangType) args (consArgs con))++makeShareArgsRule c = fail $ "Cannot make shareArgs rule for " ++ show c++convInsts :: Decl -> Conv [Decl]+convInsts (DataDecl _ _ _ name args cs _) =+  do rules  <- mapM makeConvToM cs+     rules' <- mapM makeConvFromM cs+     return [InstDecl sl (mctx:zipWith convCtx (map tVar args) args')+               cname [m,t,t'] [InsDecl $ FunBind rules],+             InstDecl sl (mctx:zipWith convCtx args' (map tVar args))+               cname [m,t',t] [InsDecl $ FunBind rules']]+ where+  m     = TyVar $ Ident typeParamName+  cname = UnQual $ Ident "Convertible"+  mctx  = ClassA (UnQual (Ident "Monad")) [m]+  args' = map (TyVar . Ident . (:[]) . fst) $ zip ['a'..] args+  t     = foldl TyApp (TyCon (UnQual name)) (map tVar args)+  t'    = foldl TyApp (TyCon (UnQual (convName True name))) (m:args')++  convCtx a b = ClassA cname [m,a,b]++convInsts d = fail $ "Cannot make Convertible instances for " ++ show d++makeConvToM :: QualConDecl -> Conv Match+makeConvToM (QualConDecl _ [] [] con) =+  return $ Match sl (Ident "convArgs") [PVar fun,cpat] Nothing+             (UnGuardedRhs rhs) (BDecls [])+ where+  name = consName con+  args = map (Ident.(:[]).fst) . zip ['a'..] $ consArgs con++  fun  = Ident funArgName+  cpat = UnQual name `PApp` map PVar args++  rhs  = foldl App (Var (UnQual (convName False name))) $+           map (\x -> Var (UnQual fun) `App` Var (UnQual x)) args++makeConvToM c = fail $ "Cannot make convArgs rule for " ++ show c++makeConvFromM :: QualConDecl -> Conv Match+makeConvFromM (QualConDecl _ [] [] con) =+  return $ Match sl (Ident "convArgs") [PVar fun,cpat] Nothing+             (UnGuardedRhs rhs) (BDecls [])+ where+  name = consName con+  args = map (Ident.(:[]).fst) . zip ['a'..] $ consArgs con++  fun  = Ident funArgName+  cpat = UnQual (convName True name) `PApp` map PVar args+  cexp = foldl App (Con (UnQual name)) $ map (Var . UnQual) args++  rhs  = foldr (\ (x,b) e ->+                  InfixApp+                    (if b then Var (UnQual fun) `App` Var (UnQual x)+                      else Paren $ InfixApp+                             (Var (UnQual x))+                             (QVarOp (UnQual (Symbol ">>=")))+                             (Var (UnQual fun)))+                    (QVarOp (UnQual (Symbol ">>=")))+                    (Lambda sl [PVar x] e))+           (Var (UnQual (Ident "return")) `App` cexp)+           (zipWith (curry $ second isBangType) args (consArgs con))++makeConvFromM c = fail $ "Cannot make convArgs rule for " ++ show c++fromName :: Name -> String+fromName (Ident  name) = name+fromName (Symbol name) = name++-- does not recognise unicode symbols+isSymbolChar :: Char -> Bool+isSymbolChar c = c `elem` ":'!#$%&*+./<=>?@\\^|_~"++consName :: ConDecl -> Name+consName (ConDecl name _)        = name+consName (InfixConDecl _ name _) = name+consName (RecDecl name _)        = name++consArgs :: ConDecl -> [BangType]+consArgs (ConDecl _ args)     = args+consArgs (InfixConDecl l _ r) = [l,r]+consArgs (RecDecl _ fs)       = [t | (ns,t) <- fs, _ <- ns]++tVar :: TyVarBind -> Type+tVar (UnkindedVar name) = TyVar name+tVar (KindedVar name kind) = TyKind (TyVar name) kind++isBangType :: BangType -> Bool+isBangType (UnBangedTy _) = False+isBangType _              = True++conDecl :: QualConDecl -> ConDecl+conDecl (QualConDecl _ _ _ con) = con++{- example derivations++data  List               a =  Nil |  Cons    a      (List   a)+data MList (m :: * -> *) a = MNil | MCons (m a) (m (MList m a))++mNil :: Monad m => m (MList m a)+mNil = return MNil++mCons :: Monad m => m a -> m (MList m a) -> m (MList m a)+mCons x xs = return (MCons x xs)++matchMList :: Monad m+           => m (MList m a)+           -> m b -> (m a -> m (MList m a) -> m b)+           -> m b+matchMList list nil cons =+  list >>= \list -> +  case list of+    MNil       -> nil+    MCons x xs -> cons x xs++instance (Monad m, Shareable m a) => Shareable m (List m a)+ where+  shareArgs f MNil = return MNil+  shareArgs f (MCons x xs) =+    f x >>= \x -> f xs >>= \xs -> return (MCons x xs)++instance (Monad m, Convertible m a a') => Convertible m (List a) (MList m a')+ where+  convArgs f Nil = mNil+  convArgs f (Cons x xs) = mCons (f x) (f xs)++instance (Monad m, Convertible m a a') => Convertible m (MList m a) (List a')+ where+  convArgs f MNil = return Nil+  convArgs f (MCons x xs) =+    (x >>= f) >>= \x -> (xs >>= f) >>= \xs -> return (Cons x xs)++data  SList               a =  SNil |  SCons !a     (SList   a)+data MSList (m :: * -> *) a = MSNil | MSCons !a (m (MSList m a))++mSNil :: Monad m => m (MSList m a)+mSNil = return MSNil++mSCons :: Monad m => m a -> m (MSList m a) -> m (MSList m a)+mSCons x xs = x >>= \x -> return (MSCons x xs)++matchMSList :: Monad m+            => m (MSList m a)+            -> m b -> (m a -> m (MSList m a) -> m b)+            -> m b+matchMSList list nil cons =+  list >>= \list -> +  case list of+    MSNil       -> nil+    MSCons x xs -> cons (return x) xs++instance (Monad m, Shareable m a) => Shareable m (MSList m a)+ where+  shareArgs f MSNil = return MSNil+  shareArgs f (MSCons x xs) =+    shareArgs f x >>= \x -> f xs >>= \xs -> return (MSCons x xs)++instance (Monad m, Convertible m a a') => Convertible m (SList a) (MSList m a')+ where+  convArgs f SNil = mSNil+  convArgs f (SCons x xs) = mSCons (f x) (f xs)++instance (Monad m, Convertible m a a') => Convertible m (MSList m a) (SList a')+ where+  convArgs f MSNil = return SNil+  convArgs f (MSCons x xs) =+    f x >>= \x -> (xs >>= f) >>= \xs -> return (Cons x xs)++-}

@@ -1,5 +1,5 @@ Name:          explicit-sharing-Version:       0.5.1.2+Version:       0.6 Cabal-Version: >= 1.6 Synopsis:      Explicit Sharing of Monadic Effects Description:   @@ -20,14 +20,17 @@ Extra-Source-Files: Test.hs  Library-  Build-Depends:    base >= 3 && < 5, containers, mtl+  Build-Depends:    base >= 3 && < 5, containers, mtl,+                    template-haskell >= 2.4 && < 2.5,+                    derive >= 2.3 && < 2.4   Exposed-Modules:  Control.Monad.Sharing,                     Control.Monad.Sharing.Classes,                     Control.Monad.Sharing.FirstOrder,+                    Data.Monadic.Derive,                     Data.Monadic.List   Other-Modules:    Control.Monad.Sharing.Implementation.CPS,                     Control.Monad.Sharing.Implementation.FirstOrder-  Ghc-Options:      -Wall+  Ghc-Options:      -Wall -fno-warn-name-shadowing   Extensions:       ExistentialQuantification,                     MultiParamTypeClasses,                     FlexibleInstances,