elevator (empty) → 0.1

raw patch · 4 files changed

+197/−0 lines, 4 filesdep +basedep +clean-unionsdep +transformerssetup-changed

Dependencies added: base, clean-unions, transformers

Files

LICENSE +30/−0
Setup.hs +2/−0
elevator.cabal +26/−0
src/Control/Elevator.hs +139/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Fumiaki Kinoshita nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ elevator.cabal view

@@ -0,0 +1,26 @@+name:                elevator
+version:             0.1
+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
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+copyright:           Copyright (C) 2014 Fumiaki Kinoshita
+category:            Data
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+source-repository head
+  type: git
+  location: https://github.com/fumieval/elevator.git
+
+library
+  exposed-modules:     Control.Elevator
+  -- other-modules:       
+  other-extensions:    TypeOperators, FlexibleContexts, FlexibleInstances, ConstraintKinds, TypeFamilies, DataKinds
+  build-depends:       base == 4.*, transformers >= 0.3, clean-unions
+  hs-source-dirs:      src
+  default-language:    Haskell2010

+ src/Control/Elevator.hs view

@@ -0,0 +1,139 @@+{-# LANGUAGE CPP, TypeOperators, FlexibleContexts, DefaultSignatures, FlexibleInstances, ConstraintKinds, TypeFamilies, DataKinds #-}
+module Control.Elevator where
+import Control.Monad.Trans.State.Lazy as Lazy
+import Control.Monad.Trans.State.Strict as Strict
+import Control.Monad.Trans.Writer.Lazy as Lazy
+import Control.Monad.Trans.Writer.Strict as Strict
+import Control.Monad.Trans.Identity
+import Data.Functor.Identity
+import Data.OpenUnion1.Clean
+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
+
+#if MIN_VERSION_transformers(0,4,0)
+import Control.Monad.Trans.Except
+#else
+import Control.Monad.Trans.Error
+#endif
+
+class Tower f where
+  type Floors f :: List (* -> *)
+  type Floors f = Empty
+  toLoft :: Union (Floors f) a -> f a
+  default toLoft :: Union Empty a -> f a
+  toLoft = exhaust
+
+type Elevate f g = (Tower g, f ∈ Floors1 g)
+
+type Floors1 g = g :> Floors g
+
+toLoft1 :: Tower f => Union (Floors1 f) a -> f a
+toLoft1 = id ||> toLoft
+
+elevate :: Elevate f g => f a -> g a
+elevate f = (id ||> toLoft) (liftU f)
+{-# INLINE elevate #-}
+
+instance Tower IO where
+  type Floors IO = ST RealWorld :> Empty
+  toLoft = stToIO ||> exhaust
+
+instance Tower Identity
+instance Tower Maybe
+instance Tower (Either e)
+instance Tower ((->) r)
+instance Tower []
+instance Tower (ST s)
+
+instance Tower (Union u) where
+  type Floors (Union u) = u
+  toLoft = id
+
+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
+
+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
+
+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
+
+instance (Monoid w, Monad m, Tower m) => Tower (Lazy.WriterT w m) where
+  type Floors (Lazy.WriterT s m) = Lazy.Writer s
+    :> Strict.Writer s
+    :> Strict.WriterT s m
+    :> Floors1 m
+  toLoft = Lazy.writer . Lazy.runWriter
+    ||> Lazy.writer . Strict.runWriter
+    ||> Lazy.WriterT . Strict.runWriterT
+    ||> lift . toLoft1
+
+instance (Monoid w, Monad m, Tower m) => Tower (Strict.WriterT w m) where
+  type Floors (Strict.WriterT s m) = Lazy.Writer s
+    :> Strict.Writer s
+    :> Lazy.WriterT s 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
+
+instance (Monad m, Tower m) => Tower (MaybeT m) where
+  type Floors (MaybeT m) = Maybe
+    :> Floors1 m
+  toLoft = MaybeT . return
+    ||> lift . toLoft1
+
+instance (Monad m, Tower m) => Tower (ListT m) where
+  type Floors (ListT m) = []
+    :> Floors1 m
+  toLoft = ListT . return
+    ||> lift . toLoft1
+
+#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
+#else
+instance (Error e, Monad m, Tower m) => Tower (ErrorT e m) where
+  type Floors (ExceptT e m) = Either e
+    :> Floors1 m
+  toLoft = ErrorT . return
+    ||> lift . toLoft1
+#endif