mzv 0.1.0.1 → 0.1.0.2

raw patch · 4 files changed

+396/−1 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• mzv.cabal +4/−1
• src/Control/Monad/Mask.hs +176/−0
• src/Control/Monad/Views.hs +126/−0
• src/Control/Monad/Zipper.hs +90/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                mzv-version:             0.1.0.1+version:             0.1.0.2 synopsis:            Implementation of the "Monads, Zippers and Views" (Schrijvers and Oliveira, ICFP'11) description:         Implementation of the "Monads, Zippers and Views" (Schrijvers and Oliveira, ICFP'11) homepage:     	     http://github.com/ifigueroap/mzv@@ -24,6 +24,9 @@  Library   exposed-modules:+    Control.Monad.Views+    Control.Monad.Mask+    Control.Monad.Zipper     Control.Monad.Cont     Control.Monad.Cont.Class     Control.Monad.Error

@@ -0,0 +1,176 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}++module Control.Monad.Mask where++import Control.Monad.Identity+import Control.Monad.Zipper+import Control.Monad.State.Lazy+import Control.Monad.Error+import Control.Monad.Views (MonadMorphism (..), View (..), (:><:) (..), i, o, vcomp)+++-- ========================= Nominal Masks =========================++newtype Tagged tag m a = Tag { unTag :: m a }++instance MonadTrans (Tagged tag) where+  lift       = Tag+  mt         = MT+  unlift   k = Tag $ k (\tm -> unTag tm >>= return . Identity) >>= return . runIdentity++instance Monad m => Monad (Tagged tag m) where+  return   = Tag . return+  m >>= f  = Tag $ unTag m >>= unTag . f++instance MonadState s m => MonadState s (Tagged t m) where+  get = lift get+  put = lift . put++-- Standard Tagged Transformers++type TStateT tag s m = Tagged tag (StateT s m)++runTStateT :: Monad m => s -> TStateT tag s m a -> m (a,s)+runTStateT s m = runStateT (unTag m) s++evalTStateT :: Monad m => s -> TStateT tag s m a -> m a+evalTStateT s m = evalStateT (unTag m) s++type TErrorT tag error m = Tagged tag (ErrorT error m)++runTErrorT :: Monad m => TErrorT tag e m a -> m (Either e a)+runTErrorT m = runErrorT (unTag m)++class (Monad m, Monad n) => TWith tag n m where+   structure :: View g => tag -> (n `g` m)++use     :: TWith tag n m => n a -> tag -> m a+c `use` name     = bifrom (structure name) c++expose  :: TWith tag n m => m a -> tag -> n a+c `expose` name  = bito (structure name) c++  -- [1] tag at the top+instance (Monad m, m ~ n) => TWith tag n (Tagged tag m) where+   structure _  = t -- idv++  -- auxiliary clause, to resolve overlap between [1] and [3]+instance (Monad m, m ~ t n, MonadTrans t) => TWith tag m (Tagged tag (t n)) where+   structure _  = t++  -- [2] tag in focus+instance (Monad m, Monad n, MonadTrans t, m ~ t n) => TWith tag m ((t :> Tagged tag) n) where+   structure _  = case (mt :: Transformation t (Tagged tag n)) of+                    MT -> inverse_o `hcomp` hmap t++  -- auxiliary clause, to resolve overlap between [2] and [3]+instance (Monad (t' n), Monad m, Monad n, MonadTrans t, m ~ (((t :> Tagged tag) :> t') n), MonadTrans t') => TWith tag m ((t :> Tagged tag) (t' n)) where+   structure _  = case (mt :: Transformation t' n) of+                   MT -> o++  -- [3] shift focus down+instance (Monad (t0 (t1 n)), Monad m, Monad n, TWith tag m ((t0 :> t1) n), MonadTrans t0, MonadTrans t1) => TWith tag m (t0 (t1 n)) where+   structure tag  =  case (mt :: Transformation t1 n) of+                       MT -> case (mt :: Transformation t0 (t1 n)) of+                               MT -> o `hcomp` structure tag++t :: View g => m `g` Tagged tag m+t = view Tag unTag++unt :: View g => Tagged tag m `g` m+unt = view unTag Tag++inverse_o  = view rightL leftL++data Log1 = Log1+data Log2 = Log2++ifpos1 :: MonadState Int m => m () -> m ()+ifpos1 c = do  x <- get+               if x > 0 then c else return ()++-- x98 = runIdentity $ runTStateT Counter2 5 $ runTStateT Counter1 0 $ c+-- x99 = runIdentity $ runTStateT Counter1 0 $ runTStateT Counter2 5 $ c++luse     :: LWith taglist n m => n a -> taglist -> m a+c `luse` namelist     = bifrom (lstructure namelist) c++data e :&: l = e :&: l++data HTrue  = HTrue+data HFalse = HFalse++class HMember e l b where+  hmember :: e -> l -> b++instance b ~ HTrue => HMember e e b where+  hmember _ _ = HTrue+instance b ~ HFalse => HMember e f b where+  hmember _ _ = HFalse+instance b ~ HTrue => HMember e (e :&: l) b where+  hmember _ _ = HTrue+instance HMember e l b => HMember e (f :&: l) b where+  hmember e (_ :&: l) = hmember e l++class LWith list (n :: * -> *) (m :: * -> *) where+  lstructure :: View g => list -> (n `g` m)++class LWith1 list b (n :: * -> *) (m :: * -> *) where+  lstructure1 :: View g => list -> b -> (n `g` m)++class LWith2 list b (n :: * -> *) (m :: * -> *) where+  lstructure2 :: View g => list -> b -> (n `g` m)++instance (HMember t l b, LWith1 l b n (Tagged t m), Monad m, Monad n) => LWith l n (Tagged t m) where+  lstructure list = lstructure1 list (hmember e list :: b)+    where e = undefined :: t++instance (HMember t l b, LWith2 l b n ((t0 :> Tagged t) m), Monad m, Monad n) => LWith l n ((t0 :> Tagged t) m) where+  lstructure list = lstructure2 list (hmember e list :: b)+    where e = undefined :: t++instance (m ~ n, Monad m, Monad n) => LWith l n m where+  lstructure list = idv++instance (Monad m, n ~ t n', Monad n', LWith list n' m, MonadTrans t) => LWith1 list HTrue n (Tagged e (t m)) where+  lstructure1 list _ = f list+    where f :: forall list m n n' t g e.+               (Monad m, n ~ t n', Monad n', LWith list n' m, MonadTrans t, View g) =>+               list -> n `g` (Tagged e (t m))+          f list =     case (mt :: Transformation t m) of+                         MT -> case (mt :: Transformation t n') of+                                 MT -> t `hcomp` (hmap (lstructure list :: n' `g` m))++instance (LWith list n ((:>) t t' m), Monad n, Monad m, MonadTrans t, MonadTrans t') => LWith1 list HFalse n (Tagged e (t (t' m))) where+  lstructure1 list _ = case (mt :: Transformation t' m) of+                        MT -> case (mt :: Transformation t (t' m)) of+                                MT -> t `hcomp` o `hcomp` lstructure list++instance (Monad m, n ~ (t0 :> t) n', Monad n', LWith list n' m, MonadTrans t, MonadTrans t0) => LWith2 list HTrue n ((t0 :> Tagged e) (t m)) where+  lstructure2 list _ = f list+    where f :: forall list m n t0 t n' e g.+               (Monad m, n ~ (t0 :> t) n', Monad n', LWith list n' m, MonadTrans t, MonadTrans t0, View g) =>+               list -> n `g` ((t0 :> Tagged e) (t m))+          f list =     case (mt :: Transformation t m) of+                         MT -> case (mt :: Transformation t0 (t m)) of+                                 MT -> case (mt :: Transformation t0 (Tagged e (t m))) of+                                         MT -> inverse_o `hcomp` hmap t `hcomp` o `hcomp` hmap (lstructure list :: n' `g` m)++instance (Monad m, Monad n, LWith list n ((t0 :> t1 :> t2) m), MonadTrans t2, MonadTrans t1, MonadTrans t0) => LWith2 list HFalse n ((t0 :> Tagged e) (t1 (t2 m))) where+  lstructure2 list _ = case (mt :: Transformation t2 m) of+                         MT -> case (mt :: Transformation t1 (t2 m)) of+                                 MT -> case (mt :: Transformation t0 (t1 (t2 m))) of+                                         MT -> case (mt :: Transformation t0 (Tagged e (t1 (t2 m)))) of+                                                 MT -> inverse_o `hcomp` hmap t `hcomp` o `hcomp` o `hcomp` (lstructure list)++getv v  = from v $ get+putv v  = from v . put

@@ -0,0 +1,126 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Control.Monad.Views where++import Control.Monad.Zipper+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer++class MonadMorphism g where+  idv        ::  (Monad m) =>  m `g` m+  hcomp      ::  (Monad l, Monad m, Monad n) +             =>  (m `g` n) -> (l `g` m) -> (l `g` n)+  hmap       ::  (Monad m, Monad n, MonadTrans t) +             =>  (m `g` n) -> (t m `g` t n)+  from       ::  (Monad m, Monad n) =>  (n `g` m) -> n a -> m a++htmap :: (Monad (t1 n), Monad (t2 n), Monad m, Monad n, Monad (t1 m),+          MonadTrans t1, MonadMorphism g) =>+         (forall m . Monad m => t1 m `g` t2 m) -> (m `g` n) -> t1 m `g` t2 n+htmap t f = t `hcomp` hmap f++newtype n :-> m = Uni (forall a. n a -> m a)++instance MonadMorphism (:->) where+  idv            = Uni id+  v2 `hcomp` v1  = Uni $ from v2 .from v1+  hmap v         = Uni $ tmap (from v)+  from (Uni v)   = v++liftv :: (MonadTrans t, Monad m) => m :-> t m+liftv = Uni lift++r1 :: (MonadTrans t, Monad m, MonadState s (t m)) => ReaderT s m :-> t m+r1 = Uni $ \n ->  do  s <- get +                      lift $ runReaderT n s++ra = Uni (\n ->  do  s <- get+                     lift $ runReaderT n s )++data n :><: m = Bi  { bifrom  :: forall a. n a -> m a+                    , bito    :: forall a. m a -> n a}++instance MonadMorphism (:><:) where+  idv            = Bi  { bifrom  = id+                       , bito    = id }+  v2 `hcomp` v1  = Bi  { bifrom  = bifrom v2 . bifrom v1+                       , bito    = bito v1 . bito v2     }+  hmap v         = Bi  { bifrom  = tmap (from v)+                       , bito    = tmap (to v)  }+  from v         = bifrom v++to :: (Monad n, Monad m) => n :><: m -> m a -> n a+to = bito++inverse ::  (Monad n, Monad m) =>  n :><: m -> m :><: n+inverse (Bi from to) = Bi to from++class MonadMorphism g => View g where+  view :: (forall a. n a -> m a) -> (forall a. m a -> n a) -> n `g` m++instance View (:->)  where view f fm1 = Uni f++instance View (:><:) where view f fm1 = Bi f fm1++stateIso  :: (Monad m, View g) +          => (s2 -> s1) -> (s1 -> s2) -> StateT s2 m `g` StateT s1 m+stateIso f fm1 = view (iso f fm1) (iso fm1 f) where+  iso g h m = StateT $ \s2 -> do  (a, s1) <- runStateT m (h s2)+                                  return (a, g s1)++newtype MonadStateReaderT s m a = MonadStateReaderT { runMonadStateReaderT :: m a }++instance MonadState s m => MonadReader s (MonadStateReaderT s m) where+  ask   = MonadStateReaderT get+  local f m = MonadStateReaderT $ +    do s <- get+       put (f s)+       r <- runMonadStateReaderT m+       put s+       return r++instance MonadWriter w m => MonadWriter w (MonadStateReaderT s m) where+    tell     = lift . tell+    listen m = MonadStateReaderT $ do (ma, w) <- listen (runMonadStateReaderT m)+                                      return (ma, w)+    pass m   = MonadStateReaderT $ pass $ do+                                   (ma, w) <- runMonadStateReaderT m+                                   return (ma, w)++instance MonadTrans (MonadStateReaderT s)+ where+  lift      = MonadStateReaderT+  mt        = MT+  unlift f  = MonadStateReaderT $ liftM runIdentity $ f (\tmx -> liftM Identity $ runMonadStateReaderT tmx)++r2 :: (MonadState s m, View g) => MonadStateReaderT s m `g` m+r2 = view runMonadStateReaderT MonadStateReaderT++instance Monad m => Monad (MonadStateReaderT s m) where+  return   = MonadStateReaderT . return+  x >>= f  = MonadStateReaderT $ runMonadStateReaderT x >>= runMonadStateReaderT . f++-- ========================= Structural Masks =========================++infixl 5 `vcomp`++i  ::  (Monad m, View g) =>  m `g` m+i = idv++o  ::  (MonadTrans t1, MonadTrans t2, Monad m, View g) +   =>  (t1 :> t2) m `g` t1 (t2 m) +o  = view leftL rightL ++v1 `vcomp` v2  = v1 `hcomp` hmap v2

@@ -0,0 +1,90 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Control.Monad.Zipper where++import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Error.Class+import Control.Monad.Writer++newtype (t1 :> (t2 :: (* -> *) -> * -> *))  m a = Z { runZ :: t1 (t2 m) a }++leftL   = runZ+rightL  = Z++instance (MonadTrans t1, MonadTrans t2, Monad m) => Monad ((t1 :> t2) m) where+  return x  = returnZ x+  m >>= f   = m `bindZ` f++returnZ :: forall a t1 t2 m. (MonadTrans t1, MonadTrans t2, Monad m) => a -> (t1 :> t2) m a+returnZ x = case (mt :: Transformation t2 m) of+              MT -> case (mt :: Transformation t1 (t2 m)) of+                      MT -> Z $ return x++bindZ :: forall a b t1 t2 m. (MonadTrans t1, MonadTrans t2, Monad m)+      => (t1 :> t2) m a -> (a -> (t1 :> t2) m b) -> (t1 :> t2) m b+m `bindZ` f = case (mt :: Transformation t2 m) of+                MT -> case (mt :: Transformation t1 (t2 m)) of+                        MT -> Z $ runZ m >>= runZ . f++instance (MonadTrans t1, MonadTrans t2) => MonadTrans (t1 :> t2) where+  lift m  = liftZ m+  mt      = MT+  unlift  = unliftZ++liftZ :: forall a t1 t2 m. (MonadTrans t1, MonadTrans t2, Monad m) => m a -> (t1 :> t2) m a+liftZ m = case (mt :: Transformation t2 m) of+            MT -> Z $ lift $ lift $ m++unliftZ :: forall m n a t1 t2. (Monad m, Monad n, MonadTrans t1, MonadTrans t2)+        => (forall f. Functor f => (forall x. (t1 :> t2) m x -> m (f x)) -> n (f a)) -> (t1 :> t2) n a+unliftZ f = case (mt :: Transformation t2 m) of+              MT -> case (mt :: Transformation t2 n) of+                      MT -> Z $ unlift $ \ul1 -> unlift $ \ul2 -> liftM runFComp $ f $ \m -> liftM FComp $ ul2 $ ul1 $ runZ $ m++newtype FComp f1 f2 a = FComp { runFComp :: f1 (f2 a) }+instance (Functor f1, Functor f2) => Functor (FComp f1 f2) where+  fmap f = FComp . fmap (fmap f) . runFComp+++{-+tmixmapZ :: forall c t1 t2 m n. (MonadTrans t1, MonadTrans t2, Monad m, Monad n) =>+              (forall a. m a -> n a) -> (forall b. n b -> m b) -> Z t1 t2 m c -> Z t1 t2 n c+tmixmapZ f g m = case (mt :: Transformation t2 m) of+                   MT -> case (mt :: Transformation t2 n) of+                           MT -> Z $ tmixmap (tmixmap f g) (tmixmap g f) $ runZ m+-}++-- #############################################################################++instance (MonadTrans t1, MonadTrans t2, Monad m, MonadState s (t2 m))+      => MonadState s ((t1 :> t2) m) where+  get   = Z $ lift $ get+  put s = Z $ lift $ put s+++instance (MonadTrans t1, MonadTrans t2, Monad m, MonadError e (t2 m))+      => MonadError e ((t1 :> t2) m) where+  throwError e   = Z $ lift $ throwError e+  catchError m h = Z $ unlift (\ul -> ul (runZ m) `catchError` (ul . runZ . h))++instance (MonadTrans t1, MonadTrans t2, Monad m, MonadReader e (t2 m))+     => MonadReader e ((t1 :> t2) m) where+  ask        = Z $ lift $ ask+  local f m  = Z $ unlift (\ul -> local f (ul $ runZ m))+++instance (MonadTrans t1, MonadTrans t2, Monad m, MonadWriter w (t2 m))+     => MonadWriter w ((t1 :> t2) m) where+  tell c    = Z $ lift $ tell c+  -- listen = ??+  -- pass   = ??