packages feed

elevator 0.1.3 → 0.2

raw patch · 3 files changed

+113/−89 lines, 3 filesdep +extensibledep −clean-unions

Dependencies added: extensible

Dependencies removed: clean-unions

Files

.travis.yml view
@@ -1,1 +1,10 @@-language: haskell+language: haskell
+
+env:
+  - GHCVER=7.8.3
+
+before_install:
+  - sudo add-apt-repository -y ppa:hvr/ghc
+  - sudo apt-get update
+  - sudo apt-get install -y -qq cabal-install-1.20 ghc-$GHCVER
+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
elevator.cabal view
@@ -1,5 +1,5 @@ name:                elevator
-version:             0.1.3
+version:             0.2
 synopsis:            Immediately lifts to a desired level
 description:         This package provides 'elevate' function which composes 'lift'-like transformations automatically.
 homepage:            https://github.com/fumieval/elevator
@@ -22,8 +22,8 @@ 
 library
   exposed-modules:     Control.Elevator
-  -- other-modules:       
+  -- other-modules:
   other-extensions:    TypeOperators, FlexibleContexts, FlexibleInstances, ConstraintKinds, TypeFamilies, DataKinds
-  build-depends:       base == 4.*, transformers >= 0.3, clean-unions
+  build-depends:       base == 4.*, transformers >= 0.3, extensible >= 0.2.6 && <0.3
   hs-source-dirs:      src
-  default-language:    Haskell2010+  default-language:    Haskell2010
src/Control/Elevator.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeOperators, FlexibleContexts, Rank2Types, DefaultSignatures, FlexibleInstances, ConstraintKinds, TypeFamilies, DataKinds, UndecidableInstances #-}
+{-# LANGUAGE CPP, PolyKinds, TypeOperators, FlexibleContexts, Rank2Types, DefaultSignatures, FlexibleInstances, ConstraintKinds, TypeFamilies, DataKinds, UndecidableInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Elevator
@@ -19,16 +19,20 @@ import Control.Monad.Trans.Writer.Strict as Strict
 import Control.Monad.Trans.Identity
 import Data.Functor.Identity
-import Data.OpenUnion1.Clean
+import Data.Extensible
+import Data.Extensible.Internal
+import Data.Extensible.Union
+import Data.Extensible.League
 import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.List
-import Control.Monad.Trans.Cont
 import Data.Monoid
 import Control.Monad.ST
+import Data.Proxy
+import Unsafe.Coerce
 
 #ifndef MIN_VERSION_transformers
 #define MIN_VERSION_transformers(x,y,z) 1
@@ -40,33 +44,45 @@ import Control.Monad.Trans.Error
 #endif
 
+rung :: (forall x. f x -> g x) -> Gondola g :* fs -> Gondola g :* (f ': fs)
+rung f = (<:) (Gondola f)
+infixr 0 `rung`
+
+newtype Gondola f g = Gondola { runGondola :: forall a. g a -> f a }
+
+-- | A class of types which have bases.
 class Tower f where
-  type Floors (f :: * -> *) :: List (* -> *)
-  type Floors f = Identity :> Empty
-  type Floors1 f :: List (* -> *)
-  type Floors1 f = f :> Floors f
-  toLoft :: Union (Floors f) a -> f a
-  default toLoft :: Applicative f => Union (Identity :> Empty) a -> f a
-  toLoft = pure . runIdentity ||> exhaust
+  type Floors (f :: * -> *) :: [* -> *]
+  type Floors f = '[Identity]
 
-  toLoft1 :: Union (Floors1 f) a -> f a
-  default toLoft1 :: Union (f :> Floors f) a -> f a
-  toLoft1 = id ||> toLoft
+  -- | The product of all ways to lift.
+  stairs :: Gondola f :* Floors f
+  default stairs :: Applicative f => Gondola f :* '[Identity]
+  stairs = pure . runIdentity `rung` Nil
 
+-- | The parents and itself.
+type Floors1 f = f ': Floors f
+
+-- | 'stairs' for 'Floors1'.
+stairs1 :: Tower f => Gondola f :* Floors1 f
+stairs1 = id `rung` stairs
+
+-- | @f@ can be lifted to @g@
 type Elevate f g = (Tower g, f ∈ Floors1 g)
 
+-- | Lift a thing, automatically.
 elevate :: Elevate f g => f a -> g a
-elevate f = toLoft1 (liftU f)
+elevate = runGondola (hlookup membership stairs1)
 {-# RULES "elevate/id" [~2] elevate = id #-}
 {-# INLINE[2] elevate #-}
 
 instance Tower IO where
-  type Floors IO = ST RealWorld :> Identity :> Empty
-  toLoft = stToIO ||> return . runIdentity ||> exhaust
+  type Floors IO = '[ST RealWorld, Identity]
+  stairs = stToIO `rung` return . runIdentity `rung` Nil
 
 instance Tower Identity where
-  type Floors Identity = Empty
-  toLoft = exhaust
+  type Floors Identity = '[]
+  stairs = Nil
 
 instance Tower Maybe
 instance Tower (Either e)
@@ -74,88 +90,87 @@ instance Tower []
 instance Tower (ST s)
 
-instance Tower (Union u) where
-  type Floors (Union u) = u
-  toLoft = id
+instance Generate xs => Tower (Union xs) where
+  type Floors (Union xs) = xs
+  stairs = generate $ \pos -> Gondola $ Union . UnionAt pos . Flux id
 
+instance Forall Functor xs => Tower (League xs) where
+  type Floors (League xs) = xs
+  stairs = generateFor (Proxy :: Proxy Functor) $ \pos -> Gondola $ \f -> League $ UnionAt pos $ Fuse (<$>f)
+
+liftGondolas :: (Monad m, Tower m, MonadTrans t) => Gondola (t m) :* Floors1 m
+liftGondolas = hmap (\(Gondola f) -> Gondola $ lift . f) stairs1
+
 instance (Monad m, Tower m) => Tower (Lazy.StateT s m) where
-  type Floors (Lazy.StateT s m) = Lazy.State s
-    :> Strict.State s
-    :> Strict.StateT s m
-    :> Floors1 m
-  toLoft = Lazy.state . Lazy.runState
-    ||> Lazy.state . Strict.runState
-    ||> Lazy.StateT . Strict.runStateT
-    ||> lift . toLoft1
+  type Floors (Lazy.StateT s m) = Floors1 m
+    ++ Map (Lazy.StateT s) (Floors m)
+    ++ Map (Strict.StateT s) (Floors1 m)
+  stairs = liftGondolas
+    *++* htrans (\(Gondola f) -> Gondola $ Lazy.mapStateT f) stairs
+    *++* htrans (\(Gondola f) -> Gondola $ Lazy.StateT . fmap f . Strict.runStateT) stairs1
 
 instance (Monad m, Tower m) => Tower (Strict.StateT s m) where
-  type Floors (Strict.StateT s m) = Lazy.State s
-    :> Strict.State s
-    :> Lazy.StateT s m
-    :> Floors1 m
-  toLoft = Strict.state . Lazy.runState
-    ||> Strict.state . Strict.runState
-    ||> Strict.StateT . Lazy.runStateT
-    ||> lift . toLoft1
+  type Floors (Strict.StateT s m) = Floors1 m
+    ++ Map (Strict.StateT s) (Floors m)
+    ++ Map (Lazy.StateT s) (Floors1 m)
+  stairs = liftGondolas
+    *++* htrans (\(Gondola f) -> Gondola $ Strict.mapStateT f) stairs
+    *++* htrans (\(Gondola f) -> Gondola $ Strict.StateT . fmap f . Lazy.runStateT) stairs1
 
 instance (Monad m, Tower m) => Tower (ReaderT r m) where
-  type Floors (ReaderT r m) = Reader r
-    :> (->) r
-    :> Floors1 m
-  toLoft = reader . runReader
-    ||> reader
-    ||> lift . toLoft1
+  type Floors (ReaderT r m) = Floors1 m
+    ++ (->) r
+    ': Map (ReaderT r) (Floors1 m)
+  stairs = liftGondolas
+    *++* reader
+    `rung` htrans (\(Gondola f) -> Gondola $ ReaderT . fmap f . runReaderT) stairs1
 
 instance (Monoid w, Monad m, Tower m) => Tower (Lazy.WriterT w m) where
-  type Floors (Lazy.WriterT w m) = Lazy.Writer w
-    :> Strict.Writer w
-    :> Strict.WriterT w m
-    :> Floors1 m
-  toLoft = Lazy.writer . Lazy.runWriter
-    ||> Lazy.writer . Strict.runWriter
-    ||> Lazy.WriterT . Strict.runWriterT
-    ||> lift . toLoft1
+  type Floors (Lazy.WriterT w m) = Floors1 m
+    ++ Map (Lazy.WriterT w) (Floors m)
+    ++ Map (Strict.WriterT w) (Floors1 m)
+  stairs = liftGondolas
+    *++* htrans (\(Gondola f) -> Gondola $ Lazy.mapWriterT f) stairs
+    *++* htrans (\(Gondola f) -> Gondola $ Lazy.WriterT . f . Strict.runWriterT) stairs1
 
 instance (Monoid w, Monad m, Tower m) => Tower (Strict.WriterT w m) where
-  type Floors (Strict.WriterT w m) = Lazy.Writer w
-    :> Strict.Writer w
-    :> Lazy.WriterT w m
-    :> Floors1 m
-  toLoft = Strict.writer . Lazy.runWriter
-    ||> Strict.writer . Strict.runWriter
-    ||> Strict.WriterT . Lazy.runWriterT
-    ||> lift . toLoft1
-
-instance (Monad m, Tower m) => Tower (ContT r m) where
-  type Floors (ContT r m) = Cont (m r)
-    :> Floors1 m
-  toLoft = (\m -> ContT $ \cont -> runCont m cont)
-    ||> lift . toLoft1
+  type Floors (Strict.WriterT w m) = Floors1 m
+    ++ Map (Strict.WriterT w) (Floors m)
+    ++ Map (Lazy.WriterT w) (Floors1 m)
+  stairs = liftGondolas
+    *++* htrans (\(Gondola f) -> Gondola $ Strict.mapWriterT f) stairs
+    *++* htrans (\(Gondola f) -> Gondola $ Strict.WriterT . f . Lazy.runWriterT) stairs1
 
 instance (Monad m, Tower m) => Tower (MaybeT m) where
-  type Floors (MaybeT m) = Maybe
-    :> Floors1 m
-  toLoft = MaybeT . return
-    ||> lift . toLoft1
+  type Floors (MaybeT m) = Floors1 m
+    ++ Maybe
+    ': Map MaybeT (Floors m)
+  stairs = liftGondolas
+    *++* MaybeT . return
+    `rung` htrans (\(Gondola f) -> Gondola $ mapMaybeT f) stairs
 
 instance (Monad m, Tower m) => Tower (ListT m) where
-  type Floors (ListT m) = []
-    :> Floors1 m
-  toLoft = ListT . return
-    ||> lift . toLoft1
+  type Floors (ListT m) = Floors1 m
+    ++ []
+    ': Map ListT (Floors m)
+  stairs = liftGondolas
+    *++* ListT . return
+    `rung` htrans (\(Gondola f) -> Gondola $ mapListT f) stairs
 
 #if MIN_VERSION_transformers(0,4,0)
 instance (Monad m, Tower m) => Tower (ExceptT e m) where
-  type Floors (ExceptT e m) = Either e
-    :> Except e
-    :> Floors1 m
-  toLoft = ExceptT . return
-    ||> ExceptT . return . runExcept
-    ||> lift . toLoft1
+  type Floors (ExceptT e m) = Floors1 m
+    ++ Either e
+    ': Map (ExceptT e) (Floors m)
+  stairs = liftGondolas
+    *++* ExceptT . return
+    `rung` htrans (\(Gondola f) -> Gondola $ mapExceptT f) stairs
 #else
 instance (Error e, Monad m, Tower m) => Tower (ErrorT e m) where
-  type Floors (ErrorT e m) = Either e
-    :> Floors1 m
-  toLoft = ErrorT . return
-    ||> lift . toLoft1
-#endif+  type Floors (ErrorT e m) = Floors1 m
+    ++ Either e
+    ': Map (ErrorT e) (Floors m)
+  stairs = liftGondolas
+    *++* ErrorT . return
+    `rung` htrans (\(Gondola f) -> Gondola $ mapErrorT f) stairs
+#endif