packages feed

monad-skeleton 0.1.3.2 → 0.1.4

raw patch · 6 files changed

+71/−41 lines, 6 files

Files

README.md view
@@ -23,7 +23,7 @@  ```haskell data Interaction x where-  Get :: Interacton String+  Get :: Interaction String   Put :: String -> Interaction ()  echo :: Skeleton Interaction ()
monad-skeleton.cabal view
@@ -1,5 +1,5 @@ name:                monad-skeleton-version:             0.1.3.2+version:             0.1.4 synopsis:            Monads of program skeleta description:         Fast operational monad library homepage:            https://github.com/fumieval/monad-skeleton@@ -26,6 +26,7 @@   exposed-modules:     Control.Monad.Skeleton     , Control.Monad.Skeleton.Internal     , Control.Monad.Zombie+    , Control.Monad.Zombie.Internal   build-depends:       base == 4.*   hs-source-dirs: src   ghc-options: -Wall
src/Control/Monad/Skeleton.hs view
@@ -8,9 +8,6 @@   , unbone   , boned   , hoistSkeleton-  -- * internal-  , Spine(..)-  , graftSpine   ) where import Control.Arrow import Control.Applicative@@ -21,16 +18,18 @@  -- | Re-add a bone. boned :: MonadView t (Skeleton t) a -> Skeleton t a-boned t = Skeleton (Spine t id)+boned (Return a) = ReturnS a+boned (t :>>= k) = BindS t $ Leaf $ Kleisli k {-# INLINE boned #-}  -- | Pick a bone from a 'Skeleton'. debone :: Skeleton t a -> MonadView t (Skeleton t) a-debone (Skeleton (Spine v c)) = case v of-  Return a -> viewL c (Return a) $ \(Kleisli k) c' -> case k a of-    Skeleton s -> debone $ Skeleton $ graftSpine c' s-  t :>>= k -> t :>>= \a -> case k a of-    Skeleton s -> Skeleton (graftSpine c s)+debone (ReturnS a) = Return a+debone (BindS t c0) = t :>>= go c0 where+  go :: Cat (Kleisli (Skeleton t)) a b -> a -> Skeleton t b+  go c a = viewL c (\(Kleisli k) -> k a) $ \(Kleisli k) c' -> case k a of+    ReturnS b -> go c' b+    BindS t' c'' -> BindS t' (Tree c'' c')  -- | Uncommon synonym for 'debone'. unbone :: Skeleton t a -> MonadView t (Skeleton t) a@@ -40,15 +39,15 @@  -- | A skeleton that has only one bone. bone :: t a -> Skeleton t a-bone t = Skeleton (Spine (t :>>= return) id)+bone t = BindS t $ Leaf $ Kleisli ReturnS {-# INLINABLE bone #-}  -- | Lift a transformation between bones into transformation between skeletons. hoistSkeleton :: forall s t a. (forall x. s x -> t x) -> Skeleton s a -> Skeleton t a hoistSkeleton f = go where   go :: forall x. Skeleton s x -> Skeleton t x-  go (Skeleton (Spine v c)) = Skeleton $ Spine (hoistMV f go v)-    (transCat (transKleisli go) c)+  go (ReturnS a) = ReturnS a+  go (BindS t c) = BindS (f t) $ transCat (transKleisli go) c {-# INLINE hoistSkeleton #-}  -- | A deconstructed action@@ -76,19 +75,12 @@     Return a -> return a {-# INLINE iterMV #-} --- | The spine of skeleta.-data Spine t m a where-  Spine :: MonadView t m a -> Cat (Kleisli m) a b -> Spine t m b---- | Extend a spine.-graftSpine :: Cat (Kleisli m) a b -> Spine t m a -> Spine t m b-graftSpine c (Spine v d) = Spine v (c . d)-{-# INLINE graftSpine #-}- -- | @'Skeleton' t@ is a monadic skeleton (operational monad) made out of 't'. -- Skeletons can be fleshed out by getting transformed to other monads. -- It provides O(1) ('>>=') and 'debone', the monadic reflection.-newtype Skeleton t a = Skeleton { unSkeleton :: Spine t (Skeleton t) a }+data Skeleton t a where+  ReturnS :: a -> Skeleton t a+  BindS :: t a -> Cat (Kleisli (Skeleton t)) a b -> Skeleton t b  instance Functor (Skeleton t) where   fmap = liftM@@ -104,5 +96,6 @@   a <* b = a >>= \x -> b >> return x  instance Monad (Skeleton t) where-  return a = Skeleton $ Spine (Return a) id-  Skeleton (Spine t c) >>= k = Skeleton $ Spine t (c |> Kleisli k)+  return = ReturnS+  ReturnS a >>= k = k a+  BindS t c >>= k = BindS t (c |> Kleisli k)
src/Control/Monad/Skeleton/Internal.hs view
@@ -2,18 +2,15 @@ module Control.Monad.Skeleton.Internal (Cat(..), transCat, (|>), viewL, transKleisli) where  import Control.Arrow-import Control.Category import Unsafe.Coerce  data Cat k a b where-  Empty :: Cat k a a   Leaf :: k a b -> Cat k a b   Tree :: Cat k a b -> Cat k b c -> Cat k a c  transCat :: (forall x y. j x y -> k x y) -> Cat j a b -> Cat k a b transCat f (Tree a b) = transCat f a `Tree` transCat f b transCat f (Leaf k) = Leaf (f k)-transCat _ Empty = Empty {-# INLINE transCat #-}  (|>) :: Cat k a b -> k b c -> Cat k a c@@ -21,22 +18,14 @@ {-# INLINE (|>) #-}  viewL :: forall k a b r. Cat k a b-  -> ((a ~ b) => r)+  -> (k a b -> r)   -> (forall x. k a x -> Cat k x b -> r)   -> r-viewL Empty e _ = e-viewL (Leaf k) _ r = k `r` Empty+viewL (Leaf k) e _ = e k viewL (Tree a b) e r = go a b where   go :: Cat k a x -> Cat k x b -> r-  go Empty t = viewL t e r   go (Leaf k) t = r k t   go (Tree c d) t = go c (Tree d t)--instance Category (Cat k) where-  id = Empty-  {-# INLINE id #-}-  (.) = flip Tree-  {-# INLINE (.) #-}  transKleisli :: (m b -> n b) -> Kleisli m a b -> Kleisli n a b transKleisli f = unsafeCoerce (f Prelude..)
src/Control/Monad/Zombie.hs view
@@ -1,12 +1,22 @@-{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types, ScopedTypeVariables, GADTs #-} module Control.Monad.Zombie where import Control.Applicative import Control.Arrow import Control.Category import Control.Monad import Control.Monad.Skeleton-import Control.Monad.Skeleton.Internal+import Control.Monad.Skeleton.Internal (transKleisli)+import Control.Monad.Zombie.Internal import Prelude hiding (id, (.))++-- | The spine of skeleta.+data Spine t m a where+  Spine :: MonadView t m a -> Cat (Kleisli m) a b -> Spine t m b++-- | Extend a spine.+graftSpine :: Cat (Kleisli m) a b -> Spine t m a -> Spine t m b+graftSpine c (Spine v d) = Spine v (Tree d c)+{-# INLINE graftSpine #-}  -- | 'Zombie' is a variant of 'Skeleton' which has an 'Alternative' instance. newtype Zombie t a = Zombie { unZombie :: [Spine t (Zombie t) a] }
+ src/Control/Monad/Zombie/Internal.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PolyKinds, GADTs, Rank2Types, ScopedTypeVariables, Trustworthy #-}+module Control.Monad.Zombie.Internal (Cat(..), transCat, (|>), viewL) where++import Control.Category++data Cat k a b where+  Empty :: Cat k a a+  Leaf :: k a b -> Cat k a b+  Tree :: Cat k a b -> Cat k b c -> Cat k a c++transCat :: (forall x y. j x y -> k x y) -> Cat j a b -> Cat k a b+transCat f (Tree a b) = transCat f a `Tree` transCat f b+transCat f (Leaf k) = Leaf (f k)+transCat _ Empty = Empty+{-# INLINE transCat #-}++(|>) :: Cat k a b -> k b c -> Cat k a c+s |> k = Tree s (Leaf k)+{-# INLINE (|>) #-}++viewL :: forall k a b r. Cat k a b+  -> ((a ~ b) => r)+  -> (forall x. k a x -> Cat k x b -> r)+  -> r+viewL Empty e _ = e+viewL (Leaf k) _ r = k `r` Empty+viewL (Tree a b) e r = go a b where+  go :: Cat k a x -> Cat k x b -> r+  go Empty t = viewL t e r+  go (Leaf k) t = r k t+  go (Tree c d) t = go c (Tree d t)++instance Category (Cat k) where+  id = Empty+  {-# INLINE id #-}+  (.) = flip Tree+  {-# INLINE (.) #-}