THEff (empty) → 0.1.0.1

raw patch · 21 files changed

+1514/−0 lines, 21 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• THEff.cabal +81/−0
• samples/SampleAll.hs +58/−0
• samples/SampleCatch.hs +23/−0
• samples/SampleException.hs +24/−0
• samples/SampleFresh.hs +17/−0
• samples/SampleReader.hs +18/−0
• samples/SampleState.hs +21/−0
• samples/SampleStateWithout.hs +16/−0
• samples/SampleValidator.hs +26/−0
• samples/SampleWriter.hs +26/−0
• src/Control/THEff.hs +147/−0
• src/Control/THEff/Catch.hs +98/−0
• src/Control/THEff/Exception.hs +95/−0
• src/Control/THEff/Fresh.hs +89/−0
• src/Control/THEff/Reader.hs +92/−0
• src/Control/THEff/State.hs +118/−0
• src/Control/THEff/TH/Internal.hs +296/−0
• src/Control/THEff/Validator.hs +140/−0
• src/Control/THEff/Writer.hs +97/−0

@@ -0,0 +1,30 @@+Copyright (c) 2015, Kolodezny Diver++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 Kolodezny Diver 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.

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

@@ -0,0 +1,81 @@+name:                THEff
+version:             0.1.0.1
+synopsis:            TH implementation of effects. 
+license:             BSD3
+license-file:        LICENSE
+author:              Kolodezny Diver
+maintainer:          kolodeznydiver@gmail.com
+category:            Control, Effect, TH 
+build-type:          Simple
+cabal-version:       >=1.10
+description:    
+  This package implements effects, as alternative to monad
+  transformers. Actually, the effects themselves are created without 
+  the use of TH, but the binding of nested effects described by 
+  mkEff splice. For example.
+  .
+  > mkEff "MyReader"    ''Reader    ''Int       ''Lift
+  > mkEff "SomeState"   ''State     ''Bool      ''MyReader
+  > mkEff "OtherRdr"    ''Reader    ''Float     ''SomeState
+  > 
+  > main:: IO ()
+  > main = do
+  >     r <- runMyReader  100 
+  >        $ runSomeState False
+  >        $ runOtherRdr  pi  $ do
+  >             i :: Int   <- ask                    -- MyReader 
+  >             f :: Float <- ask                    -- OtherRdr
+  >             b <- get                             -- SomeState
+  >             put $ not b                          -- SomeState 
+  >             lift $ putStrLn "print from effect!" -- Lift  
+  >             return $ show $ fromIntegral i * f 
+  >     print r
+  .
+  For more information about extensible effects , see the original paper at
+  <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>.
+  But, this package is significantly different from the original.
+  It uses a chains of ordinary GADTs created by TH. 
+  No Typeable, unsafe... , ExistentialQuantification ...
+
+extra-source-files:    samples/*.hs
+  
+Source-repository head
+    type:               git
+    location:           https://github.com/KolodeznyDiver/THEff.git
+    
+library
+  ghc-options:         -Wall 
+  exposed-modules:     Control.THEff
+                       Control.THEff.Reader
+                       Control.THEff.State
+                       Control.THEff.Exception
+                       Control.THEff.Catch
+                       Control.THEff.Writer
+                       Control.THEff.Fresh
+                       Control.THEff.Validator
+  
+  -- Modules included in this library but not exported.
+  other-modules:       Control.THEff.TH.Internal
+  
+  -- LANGUAGE extensions used by modules in this package.
+  other-extensions:    KindSignatures
+                       , FlexibleInstances
+                       , FlexibleContexts
+                       , MultiParamTypeClasses
+                       , TemplateHaskell
+                       , ViewPatterns
+                       , RecordWildCards
+                       , ScopedTypeVariables
+                       , RankNTypes
+                       , GADTs
+  
+  -- Other library packages from which modules are imported.
+  build-depends:       base >=4.8 && <4.9
+                      ,template-haskell >=2.4 && <2.11
+  
+  -- Directories containing source files.
+  hs-source-dirs:      src
+  
+  -- Base language which the package is written in.
+  default-language:    Haskell2010
+  

@@ -0,0 +1,58 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.Reader+import Control.THEff.State+import Control.THEff.Exception+import Control.THEff.Catch+import Control.THEff.Writer+import Control.THEff.Fresh+import Control.THEff.Validator+import System.Environment (getProgName)+import Control.Monad +import Data.Either+import GHC.Float ++mkEff "MyReader"    ''Reader    ''Int       ''Lift+mkEff "SomeState"   ''State     ''Bool      ''MyReader+mkEff "OtherRdr"    ''Reader    ''Float     ''SomeState+mkEff "MyWriter"     ''Writer   ''String    ''OtherRdr+mkEff "MyException" ''Except    ''String   ''MyWriter+mkEff "MyCatch"     ''Catch     ''Int       ''MyException+mkEff "UnicalChar"  ''Fresh     ''Char      ''MyCatch+mkEff "MyVldtr"     ''Validator ''Float     ''UnicalChar++main:: IO ()+main = do+    r <- runMyReader 100 +       $ runSomeState False+       $ runOtherRdr pi +       $ runMyWriter +       $ runMyException id +       $ runMyCatch (("Error code : " ++).show) +       $ runUnicalChar 'A' $ do+            i :: Int <- asks (*2)                    -- MyReader +            f :: Float <- ask                        -- OtherRdr+            tell "ProgName="                         -- MyWriter+            b <- get                                 -- SomeState+            put $ not b                              -- SomeState +            when b $ throwExc "Throw!"               -- MyException +--            unless b $ throwCtch (123::Int)        -- MyCatch +            lift $ putStrLn "print from effect!"     -- Lift  +            c1 <- fresh                              -- UnicalChar+            lift $ putStrLn $ "c1=" ++ [c1]          -- Lift  +            c2 <- fresh                              -- UnicalChar +            lift $ putStrLn $ "c2=" ++ [c2]          -- Lift  +            r <- runMyVldtr (validator (<1000)) $ do+                s <- lift getProgName                 -- Lift+                tell s                                -- MyWriter+                lift $ putStrLn $ "ProgName is " ++ s -- Lift +                x <- chk $ fromIntegral i * f         -- MyVldtr  +                return $ float2Double x+            return $ either ((++ " is out of range") . show) show r+    print r

@@ -0,0 +1,23 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.THEff+import Control.THEff.Catch++mkEff "MyCatch"     ''Catch     ''Float       ''NoEff++foo:: Float -> Eff (MyCatch m String) String+foo x = do+    throwCtchIf  x (==0)+    return $ "1/" ++ show x ++ " = " ++ (show $ 1 / x)+    +hndlr :: Float -> String+hndlr x = "Error : x=" ++ show x++main:: IO ()+main = do+    print $ runMyCatch hndlr $ foo 4+    print $ runMyCatch hndlr $ foo 0

@@ -0,0 +1,24 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# # LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.Exception+--import Control.Monad(when)+ +mkEff "MyException" ''Except    ''String   ''NoEff++safeSqrt :: Float -> Eff (MyException m Float) Float+safeSqrt x =  do+    throwIf (x<0) "The argument must be non-negative."+--    when (x<0) $+--        throwExc "The argument must be non-negative."+    return $ sqrt x +  +main:: IO ()+main = do+    print $ runMyException id $ safeSqrt 4+    print $ runMyException id $ safeSqrt (-1)

@@ -0,0 +1,17 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.THEff+import Control.THEff.Fresh++mkEff "UnicalChar"  ''Fresh     ''Char      ''NoEff++main:: IO ()+main = putStrLn $ runUnicalChar 'A' $ do+            a <- fresh+            b <- fresh+            c <- fresh+            return $ a:b:[c]

@@ -0,0 +1,18 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# # LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.Reader++mkEff "CharReader"   ''Reader    ''Char       ''NoEff+mkEff "StrReader"    ''Reader    ''String     ''CharReader++main:: IO ()+main = putStrLn $ runCharReader 'T' $ runStrReader "est" $ do+            c <- ask+            s <- ask+            return $ c:s

@@ -0,0 +1,21 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-} +module Main where+++import Control.THEff+import Control.THEff.State++mkEff "Example1"   ''State     ''Int      ''NoEff+mkEff "Example2"   ''State     ''Float    ''Example1++main:: IO ()+main = print $ runExample1 123 +             $ runExample2 pi $ do+                    i <- get+                    modify ((1 :: Int) +)+                    put $ i * (2 :: Float)+                    return $ show i 

@@ -0,0 +1,16 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.State++mkEff "Example1"   ''State     ''Int      ''NoEff++main:: IO ()+main = print $ withoutState runExample1 123 $ do+                    modify ((1 :: Int) +)+                    return "Test"

@@ -0,0 +1,26 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# # LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.Validator++mkEff "MyVldtr"   ''Validator   ''Float     ''NoEff++test1 :: Int -> Either Float Float -- return Left if out of range +test1 i = runMyVldtr (validator (<30)) $+                    chk $ pi ^ i++test2 :: Int -> Float -- If value is out of range, it is set on the border of the range. +-- test2 i = right $ runMyVldtr (range 0 30) $ chk $ pi ^ i+test2 i = withRange runMyVldtr 0 30 $ chk $ pi ^ i+          +main:: IO ()+main = do+    print $ test1 2+    print $ test1 3+    print $ test2 2+    print $ test2 3

@@ -0,0 +1,26 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# # LANGUAGE ScopedTypeVariables #-} +module Main where++import Control.THEff+import Control.THEff.Writer+import Control.Monad(forM_) +import Data.Monoid++type IntAccum = Sum Int++mkEff "StrWriter"   ''Writer   ''String    ''NoEff+mkEff "IntWriter"   ''Writer   ''IntAccum  ''StrWriter++main:: IO ()+main = putStrLn $ uncurry (flip (++)) $ runStrWriter $ do+            tell "Result"+            (r, Sum v) <- runIntWriter $ do+                tell "="+                forM_ [1::Int .. 10]+                    (tell . Sum)+                return (pi :: Float)+            return $ show $ r * fromIntegral v

@@ -0,0 +1,147 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module      : Control.THEff+Description : Main module of TH Eff package. +Copyright   : (c) Kolodezny Diver, 2015+License     : GPL-3+Maintainer  : kolodeznydiver@gmail.com+Stability   : experimental+Portability : Portable+-}++module Control.THEff (+                      -- * Overview +-- |+--   This package implements effects, as alternative to monad+--   transformers. Actually, the effects themselves are created without +--   the use of TH, but the binding of nested effects described by +--   mkEff splice. For example.+--   +-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {-# LANGUAGE ScopedTypeVariables #-} +-- > +-- > import Control.THEff+-- > import Control.THEff.Reader+-- > import Control.THEff.State+-- >+-- > mkEff "MyReader"    ''Reader    ''Int       ''Lift+-- > mkEff "SomeState"   ''State     ''Bool      ''MyReader+-- > mkEff "OtherRdr"    ''Reader    ''Float     ''SomeState+-- > +-- > main:: IO ()+-- > main = do+-- >     r <- runMyReader  100 +-- >        $ runSomeState False+-- >        $ runOtherRdr  pi  $ do+-- >             i :: Int   <- ask                    -- MyReader +-- >             f :: Float <- ask                    -- OtherRdr+-- >             b <- get                             -- SomeState+-- >             put $ not b                          -- SomeState +-- >             lift $ putStrLn "print from effect!" -- Lift  +-- >             return $ show $ fromIntegral i * f +-- >     print r+--  +--  For more information about extensible effects , see the original paper at+--  <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>.+--  But, this package is significantly different from the original.+--  It uses a chains of ordinary GADTs created by TH. +--  No Typeable, unsafe... , ExistentialQuantification ...+--  +--  Note. Further, wherever referred to  __/runEEEE/__ is meant `mkEff' generated function, e.g.+--  runMyReader, runSomeState, runOtherRdr .+-- +--  See more in samples/*.hs++                      -- * Base THEff support+                      mkEff+                    , Eff(..)+                    , EffClass(..)+                      -- * No monadic start effect +                    , NoEff(..)+                    , effNoEff+                    , runNoEff+                      -- * Monadic start effect+                    , Lift'(..)+                    , EffClassM(..)+                    , lift+                    , Lift(..)+                    , runLift+                     )  where++import Control.THEff.TH.Internal(mkEff)++-- | The Monad of effects+newtype Eff w a = Eff {runEff :: (a -> w) -> w}++instance Functor (Eff w) where+      fmap f (Eff g) = Eff $ \k -> g (k . f)++instance Applicative (Eff w) where+    pure = return+    Eff f <*> Eff g = Eff $ \k -> f (\v -> g (k . v))+      +instance Monad (Eff w) where+    return x = Eff $ \k -> k x+    m >>= f =  Eff $ \k -> runEff m (\v -> runEff (f v) k)++-- | Helper class to transfer the action effects by chain. +--   Instances of this class are created in @mkEff@.+class EffClass w v e where+    effAction:: ((r -> e) -> w v e) -> Eff e r +    effAction f = Eff $ \k -> toEff $ f k+    toEff:: w v e -> e++-- | The first effect in a chain of effects not use monads.+--   The chain of effects should start or that type, or @Lift@ (See below.)+newtype NoEff (m:: * -> *) a = NoEff { unNoEff :: a}++-- | This function is used in the 'mkEff' generated runEEEE... functions. +-- > @effNoEff _ = error "THEff: Attempting to call the effect NoEff that does not have any actions!"@+effNoEff :: a -> b+effNoEff _ = error "THEff: Attempting to call the effect NoEff that does not have any actions!"++-- | This function is used in the 'mkEff' generated runEEEE... functions. +--   Do not use it alone.+runNoEff :: Eff (NoEff m a) a -> a+runNoEff m = unNoEff $ runEff m NoEff++-- | Helper data type for transfer the monadic action effects by chain. +data Lift' m v = forall a. Lift' (m a) (a -> v)++-- | Helper class to transfer the monadic action effects by chain. +--   Instances of this class are created in @mkEff@.+class EffClassM m e where+    effLift:: Lift' m r -> Eff e r+    effLift (Lift' m g) = Eff $ \k -> toEffM $ Lift' m (k . g)+    -- | +    toEffM:: Lift' m e -> e++-- | Lift a Monad to an Effect.+lift:: (Monad m, EffClassM m e) => m a -> Eff e a+lift m = effLift $ Lift' m id++-- | The first effect in a chain of monadic effects.+--   The chain of effects should start or that type, or @NoEff@.+data Lift m a = Lift_ (Lift' m (Lift m a))+              | LiftResult a++instance EffClassM m (Lift m a) where+    toEffM = Lift_++-- | This function is used in the @mkEff@ generated runEEEE... functions. +--   Do not use it alone.+runLift :: Monad m => Eff (Lift m a) a -> m a+runLift e = loop $ runEff e LiftResult+    where+        loop (Lift_ (Lift' m g)) = m >>= loop . g +        loop (LiftResult r) = return r

@@ -0,0 +1,98 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Catch (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.Catch+-- > +-- > mkEff "MyCatch"     ''Catch     ''Float       ''NoEff+-- > +-- > foo:: Float -> Eff (MyCatch m String) String+-- > foo x = do+-- >     throwCtchIf  x (==0)+-- >     return $ "1/" ++ show x ++ " = " ++ (show $ 1 / x)+-- >     +-- > hndlr :: Float -> String+-- > hndlr x = "Error : x=" ++ show x+--    +-- >>> runMyCatch hndlr $ foo 4+-- "1/4.0 = 0.25"+--+-- >>> runMyCatch hndlr $ foo 0+-- "Error : x=0.0" ++                      -- * Types and functions used in mkEff+                            Catch'+                          , Catch(..) +                          , CatchArgT+                          , CatchResT+                          , effCatch+                          , runEffCatch +                      -- * Functions that use this effect                         +                          , throwCtch+                          ,throwCtchIf+                          ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+newtype Catch' v e = Catch' v++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE function.+data Catch (m:: * -> *) e o v a = CatchOuter (o m e)+                                | CatchAction (Catch' v e)    +                                | CatchResult a++-- | Type of fourth argument of runEffCatch and first argument of runEEEE. +type CatchArgT v r = (v -> r)++-- | Result type of runEEEE.  +type CatchResT r = r++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effCatch:: EffClass Catch' v e => Catch' v r -> Eff e r+effCatch (Catch' v) = effAction $ \_ -> Catch' v+    +-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffCatch :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. Monad m =>+    (u t r -> (r -> m (CatchResT z)) -> m (CatchResT z)) -- ^ The outer effect function+ -> (Catch m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Catch t r u v z)  -- ^ The chain of effects link unwrapper.+ -> CatchArgT v z -- ^ The argument of effect. Checking and/or correction function. + -> Eff r a+ -> m  (CatchResT z)+runEffCatch outer to un f m = loop $ runEff m (to . CatchResult)+  where +    loop = select . un where+        select (CatchOuter g)  = outer g loop+        select (CatchAction (Catch' v)) = return $ f v+        select (CatchResult r) = return r++-- | Throw effect specific exception.+throwCtch :: EffClass Catch' v e => v -> Eff e ()+throwCtch = effCatch . Catch' ++-- | Throw effect specific exception if first argument is True.+throwCtchIf :: EffClass Catch' v e => v -> (v -> Bool) -> Eff e ()+throwCtchIf v f | f v = throwCtch v+                | otherwise = return ()

@@ -0,0 +1,95 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Exception (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.Exception+-- >  +-- > mkEff "MyException" ''Except    ''String   ''NoEff+-- > +-- > safeSqrt :: Float -> Eff (MyException m Float) Float+-- > safeSqrt x =  do+-- >     throwIf (x<0) "The argument must be non-negative."+-- >     return $ sqrt x +--    +-- >>> runMyException id $ safeSqrt 4+-- Right 2.0+--+-- >>> runMyException id $ safeSqrt (-1)+-- Left "The argument must be non-negative." ++                      -- * Types and functions used in mkEff+                            Except'+                          , Except(..) +                          , ExceptArgT+                          , ExceptResT+                          , effExcept+                          , runEffExcept +                      -- * Functions that use this effect                         +                          , throwExc+                          , throwIf+                          ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+newtype Except' v e = Except' v++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data Except (m:: * -> *) e o v a = ExceptOuter (o m e)+                                 | ExceptAction (Except' v e)    +                                 | ExceptResult a++-- | Type of fourth argument of runEffExcept and first argument of runEEEE. +type ExceptArgT v = (v -> v)++-- | Result type of runEEEE.  +type ExceptResT r v = Either v r++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effExcept:: EffClass Except' v e => Except' v r -> Eff e r+effExcept (Except' v) = effAction $ \_ -> Except' v+    +-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffExcept :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. Monad m =>+    (u t r -> (r -> m (ExceptResT z v)) -> m (ExceptResT z v)) -- ^ The outer effect function+ -> (Except m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Except t r u v z)  -- ^ The chain of effects link unwrapper.+ -> ExceptArgT v -- ^ The argument of effect. Except value map. Usualy __/id/__.+ -> Eff r a+ -> m  (ExceptResT z v)+runEffExcept outer to un f m = loop $ runEff m (to . ExceptResult)+  where +    loop = select . un where+        select (ExceptOuter g)  = outer g loop+        select (ExceptAction (Except' v)) = return $ Left $ f v+        select (ExceptResult r) = return $ Right r++-- | Throw effect specific exception.+throwExc :: EffClass Except' v e => v -> Eff e ()+throwExc = effExcept . Except' ++-- | Throw effect specific exception if first argument is True.+throwIf :: EffClass Except' v e => Bool -> v -> Eff e ()+throwIf True  s = throwExc s+throwIf False _ = return ()    

@@ -0,0 +1,89 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Fresh (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {- # LANGUAGE ScopedTypeVariables #-} +-- > module Main where+-- > +-- > import Control.THEff+-- > import Control.THEff.Fresh+-- > +-- > mkEff "UnicalChar"  ''Fresh     ''Char      ''NoEff+-- > +-- > main:: IO ()+-- > main = putStrLn $ runUnicalChar 'A' $ do+-- >             a <- fresh+-- >             b <- fresh+-- >             c <- fresh+-- >             return $ a:b:[c]+-- +-- __/Output :/__ ABC++                      -- * Types and functions used in mkEff+                            Fresh'+                          , Fresh(..) +                          , FreshArgT+                          , FreshResT+                          , effFresh+                          , runEffFresh +                      -- * Functions that use this effect                         +                          , fresh+                          ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+data Fresh' v e = Fresh' (v -> e)  ++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data Fresh (m:: * -> *) e o v a = FreshOuter (o m e)+                                | FreshAction (Fresh' v e)    +                                | FreshResult a++-- | Type of fourth argument of runEffFresh and first argument of runEEEE. +type FreshArgT v = v+ +-- | Result type of runEEEE.  +type FreshResT r = r++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effFresh:: EffClass Fresh' v e => Fresh' v r -> Eff e r+effFresh (Fresh' g) = effAction $ \k -> Fresh' (k . g)+    +-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffFresh :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. (Monad m, Enum v) =>+    (u t r -> (r -> m (FreshResT z)) -> m (FreshResT z)) -- ^ The outer effect function+ -> (Fresh m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Fresh t r u v z)  -- ^ The chain of effects link unwrapper.+ -> FreshArgT v -- ^ The initial value of argument of effect.+ -> Eff r a+ -> m  (FreshResT z)+runEffFresh outer to un v m = loop v $ runEff m (to . FreshResult)+  where +    loop s = select . un where+        select (FreshOuter g)  = outer g (loop s)+        select (FreshAction (Fresh' k)) = (loop $! succ s) (k s)+        select (FreshResult r) = return r++-- | Get a unique value.+fresh :: EffClass Fresh' v e => Eff e v+fresh = effFresh $ Fresh' id

@@ -0,0 +1,92 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Reader (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.Reader+-- > +-- > mkEff "CharReader"   ''Reader    ''Char       ''NoEff+-- > mkEff "StrReader"    ''Reader    ''String     ''CharReader+-- > +-- > main:: IO ()+-- > main = putStrLn $ runCharReader 'T' $ runStrReader "est" $ do+-- >             c <- ask+-- >             s <- ask+-- >             return $ c:s+-- +-- __/Output :/__ "Test"++                      -- * Types and functions used in mkEff+                              Reader' +                            , Reader(..)+                            , ReaderArgT+                            , ReaderResT+                            , effReader+                            , runEffReader+                      -- * Functions that use this effect                         +                            , ask+                            , asks+                            ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+newtype Reader' v e = Reader' (v -> e)++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data Reader (m:: * -> *) e o v a = ReaderOuter (o m e)+                                 | ReaderAction (Reader' v e)+                                 | ReaderResult a ++-- | Type of fourth argument of runEffReader and first argument of runEEEE. +type ReaderArgT v = v++-- | Result type of runEEEE.  +type ReaderResT r = r++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effReader:: EffClass Reader' v e => Reader' v r -> Eff e r+effReader (Reader' g) = effAction $ \k -> Reader' (k . g)++-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffReader :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) a v +            (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a1 r. Monad m =>+    (u t r -> (r -> m (ReaderResT a)) -> m (ReaderResT a)) -- ^ The outer effect function+ -> (Reader m1 e o w a1 -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Reader t r u v a)  -- ^ The chain of effects link unwrapper.+ -> ReaderArgT v -- ^ The initial value of argument of effect.+ -> Eff r a1+ -> m (ReaderResT a)+runEffReader outer to un v m = loop $ runEff m (to . ReaderResult)+    where+        loop = select . un+        select (ReaderOuter f)  = outer f loop+        select (ReaderAction (Reader' g)) = loop $ g v+        select (ReaderResult r) = return r++-- | Get reader value+ask :: EffClass Reader' v e => Eff e v+ask = effReader $ Reader' id++-- | Get and convert the value of the reader+asks :: EffClass Reader' r e => (r -> v) -> Eff e v+asks f = effReader $ Reader' f

@@ -0,0 +1,118 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.State (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.State+-- > +-- > mkEff "Example1"   ''State     ''Int      ''NoEff+-- > mkEff "Example2"   ''State     ''Float    ''Example1+-- > +-- > main:: IO ()+-- > main = print $ runExample1 123 +-- >              $ runExample2 pi $ do+-- >                     i <- get+-- >                     modify ((1 :: Int) +)+-- >                     put $ i * (2 :: Float)+-- >                     return  $ show i +-- +-- __/Output :/__ (("3.1415927",6.2831855),124)++                      -- * Types and functions used in mkEff+                            State'+                          , State(..) +                          , StateArgT+                          , StateResT+                          , effState+                          , runEffState +                      -- * Functions that use this effect                         +                          , get+                          , put+                          , modify+                      -- * Helper functions+                          , stateOnly+                          , withoutState+                          ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+data State' v e = State' (v -> v) (v -> e)  ++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data State (m:: * -> *) e o v a = StateOuter (o m e)+                                | StateAction (State' v e)    +                                | StateResult a++-- | Type of fourth argument of runEffState and first argument of runEEEE. +type StateArgT v = v++-- | Result type of runEEEE.  +type StateResT r v = (r, v)++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effState:: EffClass State' v e => State' v r -> Eff e r+effState (State' f g) = effAction $ \k -> State' f (k . g)++-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffState :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. Monad m =>+    (u t r -> (r -> m (StateResT z v)) -> m (StateResT z v)) -- ^ The outer effect function+ -> (State m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> State t r u v z)  -- ^ The chain of effects link unwrapper.+ -> StateArgT v -- ^ The initial value of argument of effect.+ -> Eff r a+ -> m  (StateResT z v)+runEffState outer to un v m = loop v $ runEff m (to . StateResult)+  where +    loop s = select . un where+        select (StateOuter f)  = outer f (loop s)+        select (StateAction (State' t k)) = let s' = t s in loop s' (k s')+        select (StateResult r) = return (r,s)++-- | Get state value+get :: EffClass State' v e => Eff e v+get = effState $ State' id id+    +-- | Put state value+put :: EffClass State' v e => v -> Eff e ()+put = modify . const+    +-- | Modify state value+modify :: EffClass State' v e => (v -> v) -> Eff e ()+modify f = effState $ State' f (const ())+ +-- | @ stateOnly runExample1 123 === snd (runExample1 123) @+stateOnly :: forall v e r t. +    (t -> e -> (r, v)) -- ^ State effect runEEEE function+ -> t -- ^ The initial value of argument of effect. + -> e -- ^ Eff (MyState m ...) ... + -> v+stateOnly f v = snd . (f v)++-- | @ withoutState runExample1 123 === fst (runExample1 123) @+withoutState :: forall v e r t. +    (t -> e -> (r, v)) -- ^ State effect runEEEE function+ -> t -- ^ The initial value of argument of effect. + -> e -- ^ Eff (MyState m ...) ... + -> r+withoutState f v = fst . (f v)

@@ -0,0 +1,296 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE  TemplateHaskell, ViewPatterns, RecordWildCards #-}+module Control.THEff.TH.Internal(mkEff) where++import Language.Haskell.TH+import Data.List+import Data.Either+import Data.Maybe++data DescrEff = DescrEff {  dModule :: String +                         ,  dName :: String+                         ,  dEffModule :: String +                         ,  dEffName :: String+                         ,  dType :: Maybe Type +                         } deriving Show++splitLast:: Char -> String -> (String,String)+splitLast c s = case findIndices (c ==) s of+                    [] -> ("",s)+                    ixs -> splitAt (last ixs +1) s++getModuleAndName :: Name -> (String,String)+getModuleAndName = splitLast '.' . show+                    +parseCon :: Con -> Either String DescrEff+parseCon (NormalC n [(NotStrict, AppT t@(AppT (ConT e) _) _ )]) = +        if not (null en) && last en == '\'' then+             Right $ DescrEff nm nn' em (init en) (if en == "Lift'" then Nothing else Just t)+        else Left  $ "Incorrect type name : " ++ en+    where (nm,nn) = getModuleAndName n+          (_,nn') = splitLast '_' nn+          (em,en) = getModuleAndName e +parseCon _ = Left "Incorrect subtype"++mkN_E :: String -> String -> Name+mkN_E prfx eff = mkName $ concat [ prfx, "_", eff]++mkEffName' :: DescrEff -> Name  +mkEffName' DescrEff{..} = mkName $ concat [ dEffModule, dEffName, "'"]++mkPrimName :: String -> Name+mkPrimName = mkName . (++ "'")++mkTypePrim :: String -> [DescrEff] -> Q Dec+mkTypePrim newType lst = do+    m <- newName "m"+    e <- newName "e"+    let kinds = [KindedTV m (AppT (AppT ArrowT StarT) StarT), KindedTV e StarT]+    let n = mkPrimName newType+    let mkc = mkCon (VarT m) (VarT e) newType+    return $ +        case lst of+            [d] -> NewtypeD [] n kinds (mkc d) []+            _ -> DataD [] n kinds (map mkc lst) []+            +        +mkCon :: Type -> Type -> String -> DescrEff -> Con+mkCon m e newType d@DescrEff{..} = +    NormalC (mkN_E newType dName) [(NotStrict, AppT +      ( case dType of+            (Just t) -> t+            _ -> AppT (ConT $ mkEffName' d) m+      ) e )]++mkTypeMain :: String ->  String -> Name -> Name -> Type -> Q Dec +mkTypeMain thisMdl newType newTypeName effName argT = do+    m <- newName "m"+    a <- newName "a"+    let n = mkName newType+    let t' = mkPrimName $ thisMdl ++ newType+    let u = mkName $ "un" ++ newType+    return $+        NewtypeD [] n [KindedTV m (AppT (AppT ArrowT StarT) StarT),+                                    KindedTV a StarT]+                (RecC n +                    [(u,NotStrict,+                        AppT (AppT (AppT (AppT +                          (AppT (ConT effName) (VarT m))+                          (AppT (AppT (ConT newTypeName) (VarT m))+                             (VarT a))+                                          )+                                          (ConT t')+                                   )+                                   argT+                              )+                              (VarT a)+                      )]) []    ++lookEff :: (String -> Q (Maybe Name)) -> String -> Q Name+lookEff f n = do+    m <- f n+    case m of+        (Just x) -> return x+        _ -> fail $ concat ["mkEff: ", n, " not found"] + +lookEffType :: String -> Q Name+lookEffType = lookEff lookupTypeName++lookEffValue :: String -> Q Name+lookEffValue = lookEff lookupValueName+ +lookEffFn :: String -> String -> Q Name +lookEffFn mdl eff = lookEffValue $ concat [mdl, "eff", eff]+ +data InstnType = InstnAction | InstnOuter++mkInstn :: String -> String -> Name -> Name -> InstnType -> DescrEff -> Q Dec+mkInstn thisMdl newType newTypeName thisEffName it DescrEff{..} = do+    let thisEff = show thisEffName+    c <- lookEffType (if isJust dType then "EffClass" else "EffClassM") +    m <- newName "m"+    a <- newName "a"+    x <- newName "x"+    let fullNewType = thisMdl ++ newType+    return $ InstanceD [] (AppT  +        (case dType of+            (Just (AppT effT argT)) -> AppT (AppT (ConT c) effT) argT+            _ -> AppT (ConT c) (VarT m)+        )+        (AppT (AppT (ConT newTypeName) (VarT m)) (VarT a))) +        [FunD (mkName (if isJust dType then "toEff" else "toEffM")) +            [Clause [VarP x] (NormalB (AppE (ConE newTypeName) +                (case it of+                    InstnAction -> AppE (ConE (mkName $ concat [thisEff,"Action"])) +                                    (VarE x)+                    InstnOuter  -> AppE (ConE (mkName $ concat [thisEff,"Outer"])) +                                    (AppE (ConE (mkN_E fullNewType dName)) (VarE x))+                ))) []]]++is2ar :: Name -> Q Bool+is2ar t = do+    (TyConI d) <- reify t+    return (case d of+                (TySynD _ [_,_] _) -> True+                (NewtypeD [] _ [_,_] _ _) -> True+                (DataD _ _ [_,_] _ _) -> True+                _ -> False+            )+            +mkRunFun :: String -> String -> Name -> Name -> Type -> Name -> [DescrEff] -> DecsQ+mkRunFun thisMdl newType newTypeName thisEffName argT outerName ds = do+    mf <- lookEffValue ">>="+    eff <- lookEffType "Eff" +    let (tm,tn) = getModuleAndName thisEffName+    runEffThisEffName <- lookEffValue $ concat [tm,"runEff",tn]+    ri <- reify runEffThisEffName+    let useArg = case ri of+                    (VarI _ (ForallT _ _ +                        (AppT _ -- arg 1 +                        (AppT  _ -- arg 2+                        (AppT  _ -- arg 3+                        (AppT +                        (AppT ArrowT _) -- arg 4  (if exist)+                        (AppT -- arg 5 +                            (AppT ArrowT (AppT (AppT (ConT _) (VarT _)) (VarT _))) +                            (AppT (VarT _) _+                        ))))))) _ _ ) -> True+                    _ -> False+    resTName <- lookEffType $ concat [tm,tn,"ResT"] +    m <- newName "m"+    a <- newName "a"+    b <- newName "b"+    h <- newName "h"+    twoArgResT <- is2ar resTName+    let fullNewType = thisMdl ++ newType+        fnName = mkName $ "run" ++ newType+        uTypeName = mkName $ concat [thisMdl,"un",newType]+        resT = AppT (ConT resTName) (VarT a)+        resT2 = if twoArgResT then AppT resT argT else resT+        t = AppT (AppT ArrowT (AppT (AppT (ConT eff) (AppT (AppT (ConT newTypeName) +          (VarT m)) (VarT a))) (VarT a)))+          (case on of+            "Lift"  -> AppT (VarT m) resT2+            "NoEff" -> resT2+            _ -> (AppT (AppT (ConT eff) (AppT (AppT (ConT outerName) (VarT m)) (VarT b))) +                   resT2)  )+    argsAndResT <- if useArg then do+                        argTName <- lookEffType $ concat [tm,tn,"ArgT"] +                        twoArgT <- is2ar argTName+                        let a1T = AppT (ConT argTName) argT+                            aT = if twoArgT then AppT a1T (VarT a) else a1T+                        return $ AppT (AppT ArrowT aT) t +                   else return t+    case ds of+        [] -> do+            let isLift = on == "Lift"+            g <- newName "g"+            e <- lookEffFn om on+            cx <- if isLift then do+                       mnd <- lookEffType "Monad"+                       return [AppT (ConT mnd) (VarT m)]+                  else return []+            let outer = if isLift then+                            (LamE [ConP (mkN_E fullNewType on) [VarP h]] (AppE (VarE mf) +                                (AppE (VarE e) (VarE h))))+                        else VarE e+                cls = if useArg then [VarP b,VarP g] else [VarP g]+                runeff = AppE (AppE (AppE (VarE runEffThisEffName) outer) (ConE newTypeName))+                            (VarE uTypeName)+                mainBd = if useArg then AppE (AppE runeff (VarE b)) (VarE g)+                         else AppE runeff (VarE g)+            runOuterEffName <- lookEffValue $ concat [om,"run",on]+            return $ [SigD fnName (ForallT [PlainTV m,PlainTV a] cx argsAndResT),+              FunD fnName [Clause cls (NormalB (AppE (VarE runOuterEffName) mainBd)) []]]+        _ -> do+            let mkMatch DescrEff{..} = do+                    g <- newName "g"+                    e <- lookEffFn dEffModule dEffName+                    return $ Match (ConP (mkN_E fullNewType dName) [VarP g]) +                        (NormalB (AppE (VarE e) (VarE g))) []+            ms <- mapM mkMatch ds+            return [SigD fnName (ForallT [PlainTV m,PlainTV a,PlainTV b] [] argsAndResT ),+                    ValD (VarP fnName) (NormalB (AppE (AppE (AppE (VarE runEffThisEffName) +                    (LamE [VarP h] (AppE (VarE mf) (CaseE (VarE h) ms)))) (ConE newTypeName)) +                    (VarE uTypeName))) []]+             +    where (om,on) = getModuleAndName outerName  +             ++-- | TH function for building types and functions to ensure the functioning of +--   the chain enclosed in each other's effects+mkEff :: String -- ^ The name of the new type - the element chain effects. +                -- Based on this name mkEff will create new names with prefixes and suffixes.+      -> Name   -- ^ The type of effect. e.g. `State' or `Reader'. +      -> Name   -- ^ The type used in the first argument runEEEE and / or in +                -- the result of runEEEE. For example, for `State' effect,  of items  this type+                -- used in `get', `put', `modify'.+      -> Name   -- ^ The name of previous (outer) element chain effects.+      -> DecsQ+mkEff newType effName effArg outt = do+    loc <- location+    let thisMdl = loc_module loc ++ "."+        fullNewType = thisMdl ++ newType+        newTypeName = mkName fullNewType+        argT = ConT effArg+    if on `elem` ["Lift","NoEff"] +        then do+            let isLift = on == "Lift"+                o = DescrEff "" on om on Nothing+            dPrim <- mkTypePrim newType (if isLift then [o] else [])+            dMain <- mkTypeMain thisMdl newType newTypeName effName argT+            dMainInst <- mkInstn thisMdl newType newTypeName effName +                InstnAction $ mkDescrEff "" "" "" "" effName argT +            dOuterInst <- mkInstn thisMdl newType newTypeName effName InstnOuter o+            dRun <- mkRunFun thisMdl newType newTypeName effName argT outt [] +            let r = if isLift then dOuterInst:dRun else dRun+            return $ dPrim:dMain:dMainInst:r+        else do+            oi <- reify outt+            case oi of+                TyConI (NewtypeD [] _ [_,_] (RecC (ocmp -> True)+                    [(_,NotStrict,+                        AppT (AppT (AppT (AppT +                          (AppT (ConT te) _ ) _+                                          )+                                          (ConT tep)+                                   )+                                   argt+                              )+                              _+                      )]) []) -> do+                        opi <- reify tep+                        let ~(TyConI dec) = opi+                        let lst = case dec of+                                    (NewtypeD [] _ [_,_] c  []) -> [parseCon c]+                                    (DataD    [] _ [_,_] cl []) -> map parseCon cl+                                    _ -> [Left $ "Incorrect type " ++ show tep]+                                  +                        case lefts lst of+                            (e:_) -> fail $ "mkEff: " ++ e+                            [] -> let l = rights lst+                                      (tm,tn) = getModuleAndName te+                                      o = mkDescrEff om on tm tn te argt+                                      l1 = o:l+                                  in do+                                    dPrim <- mkTypePrim newType l1+                                    dMain <- mkTypeMain thisMdl newType newTypeName effName argT+                                    dMainInst <- mkInstn thisMdl newType newTypeName effName +                                        InstnAction $ mkDescrEff "" "" "" "" effName argT +                                    dOuterInsts <- mapM +                                        (mkInstn thisMdl newType newTypeName effName InstnOuter) +                                        l1+                                    dRun <- mkRunFun thisMdl newType newTypeName effName +                                        argT outt l1 +                                    return $ dPrim:dMain:dMainInst:(dOuterInsts ++ dRun) +                _ -> fail "mkEff: Expected newtype in forth argument or ''Lift or ''NoEff"+                +    where (om,on) = getModuleAndName outt+          soutt = show outt+          ocmp = (soutt ==) . show+          mkDescrEff oM oN tM tN tE aT = DescrEff oM oN tM tN (Just $ AppT (ConT +                                            (mkName $ show tE ++ "'")) aT)+

@@ -0,0 +1,140 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Validator (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.Validator+-- > +-- > mkEff "MyVldtr"   ''Validator   ''Float     ''NoEff+-- > +-- > test1 :: Int -> Either Float Float -- return Left if out of range+-- > test1 i = runMyVldtr (validator (<30)) $+-- >                     chk $ pi ^ i+-- > +-- > test2 :: Int -> Float -- If value is out of range, it is set on the border of the range.+-- > test2 i = withRange runMyVldtr 0 30 $ chk $ pi ^ i+--    +-- >>> test1 2+-- Right 9.869605+--+-- >>> test1 3+-- Left 31.006279+-- +-- >>> test2 2+-- 9.869605+-- +-- >>> test2 3+-- 30.0++                      -- * Types and functions used in mkEff+                            Validator'+                          , Validator(..) +                          , ValidatorArgT+                          , ValidatorResT+                          , effValidator+                          , runEffValidator +                      -- * Functions that use this effect                         +                          , chk+                      -- ** Functions for substitution in the first argument runEEEEE....+                          , validator+                          , range+                      -- * Helper functions+                          , right+                          , withRange+                          ) where++import Control.THEff++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+data Validator' v e = Validator' v (v -> e)  ++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data Validator (m:: * -> *) e o v a = ValidatorOuter (o m e)+                                    | ValidatorAction (Validator' v e)    +                                    | ValidatorResult a++-- | Type of fourth argument of runEffValidator and first argument of runEEEE. +type ValidatorArgT v r = (v -> Either v v)++-- | Result type of runEEEE.  +type ValidatorResT r v = Either v r++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effValidator:: EffClass Validator' v e => Validator' v r -> Eff e r+effValidator (Validator' v g) = effAction $ \k -> Validator' v (k . g)++                    +-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffValidator :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. Monad m =>+    (u t r -> (r -> m (ValidatorResT z v)) -> m (ValidatorResT z v)) -- ^ The outer effect function+ -> (Validator m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Validator t r u v z)  -- ^ The chain of effects link unwrapper.+ -> ValidatorArgT v z -- ^ The argument of effect. A value validator function. + -> Eff r a+ -> m  (ValidatorResT z v)+runEffValidator outer to un f m = loop $ runEff m (to . ValidatorResult)+  where +    loop = select . un where+        select (ValidatorOuter g)  = outer g loop+        select (ValidatorAction (Validator' v k)) = +                case f v of+                    (Left x)  -> return $ Left x+                    (Right x) -> loop (k x)+        select (ValidatorResult r) = return $ Right r++-- | Check the conditions specified by the first argument of runEEEE+chk :: EffClass Validator' v e => v -> Eff e v+chk v = effValidator $ Validator' v id++-- | validator returns __/Right v/__ if the predicate returns True and __/Left v/__ else.+validator :: Ord v => +    (v -> Bool) -- ^ predicate+ -> v           -- ^ value+ -> Either v v  +validator f v | f v = Right v+              | otherwise = Left v+  +-- | If the value is outside this range, `range' sets the value of the range. +-- Always returns __/Right/__. +range :: Ord v => +    v -- ^ The lower limit of the range.+ -> v -- ^ The upper limit of the range+ -> v -- ^ The value+ -> Either v v+range vmin vmax v | vmin>v = Right vmin+                  | v>vmax = Right vmax +                  | otherwise = Right v+++-- | right ~(Right v) = v+right :: Either a b -> b +right ~(Right v) = v++-- | If the runEEEE return value is out of range, it is set on the border of the range.+withRange :: forall r e l v. Ord v =>+    ((v -> Either v v) -> e -> Either l r) -- ^ Validator effect runEEEE function+ -> v -- ^ The lower limit of the range.+ -> v -- ^ The upper limit of the range.+ -> e -- ^ Eff (MyValidator m ...) ... + -> r+withRange f vmin vmax = right . (f (range vmin vmax))

@@ -0,0 +1,97 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Control.THEff.Writer (+                      -- * Overview +-- |+-- > {-# LANGUAGE KindSignatures #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Control.THEff+-- > import Control.THEff.Writer+-- > import Control.Monad(forM_) +-- > import Data.Monoid+-- > +-- > type IntAccum = Sum Int+-- > +-- > mkEff "StrWriter"   ''Writer   ''String    ''NoEff+-- > mkEff "IntWriter"   ''Writer   ''IntAccum  ''StrWriter+-- > +-- > main:: IO ()+-- > main = putStrLn $ uncurry (flip (++)) $ runStrWriter $ do+-- >             tell "Result"+-- >             (r, Sum v) <- runIntWriter $ do+-- >                 tell "="+-- >                 forM_ [1::Int .. 10]+-- >                     (tell . Sum)+-- >                 return (pi :: Float)+-- >             return $ show $ r * fromIntegral v+-- +-- __/Output :/__ Result=172.7876+--+-- Note that for the effect `Writer' `mkEff' generates unary function runEEEE. `mkEff' chooses +-- generation unary or binary function runEEEE based on number of arguments of  effect function. +-- E.g. runEffWriter.++                      -- * Types and functions used in mkEff+                            Writer'+                          , Writer(..) +                          , WriterResT+                          , effWriter+                          , runEffWriter +                      -- * Functions that use this effect                         +                          , tell+                          ) where++import Control.THEff+import Data.Monoid++-- | Actually, the effect type+--  - __/v/__ - Type - the parameter of the effect.+--  - __/e/__ - mkEff generated type.+data Writer' v e = Writer' v (() -> e)  ++-- | Type implements link in the chain of effects.+--   Constructors must be named __/{EffectName}{Outer|WriterAction|WriterResult}/__+--   and have a specified types of fields.+-- - __/m/__ - Or Monad (if use the 'Lift') or phantom type - stub (if used 'NoEff').+-- - __/o/__ - Type of outer effect.+-- - __/a/__ - The result of mkEff generated runEEEE... function.+data Writer (m:: * -> *) e o v a = WriterOuter (o m e)+                                 | WriterAction (Writer' v e)    +                                 | WriterResult a++-- | Result type of runEEEE.  +type WriterResT r v = (r, v)++-- | This function is used in the 'mkEff' generated runEEEE functions and typically +-- in effect action functions. Calling the effect action.+effWriter:: EffClass Writer' v e => Writer' v r -> Eff e r+effWriter (Writer' v g) = effAction $ \k -> Writer' v (k . g)+ +-- | The main function of the effect implementing. +-- This function is used in the 'mkEff' generated runEEEE functions. +runEffWriter :: forall (t :: * -> *) (u :: (* -> *) -> * -> *) (m :: * -> *) +             z v (m1 :: * -> *) e (o :: (* -> *) -> * -> *) w a r. (Monad m, Monoid v) =>+    (u t r -> (r -> m (WriterResT z v)) -> m (WriterResT z v)) -- ^ The outer effect function+ -> (Writer m1 e o w a -> r) -- ^ The chain of effects link wrapper.+ -> (r -> Writer t r u v z)  -- ^ The chain of effects link unwrapper.+--             -> WriterArgT v  -- unused argument!+ -> Eff r a+ -> m  (WriterResT z v)+runEffWriter outer to un m = loop mempty $ runEff m (to . WriterResult)+  where +    loop s = select . un where+        select (WriterOuter g)  = outer g (loop s)+        select (WriterAction (Writer' v k)) = let s' = s `mappend` v -- (f v)+                                              in loop s' (k ())+        select (WriterResult r) = return (r,s)++-- | Add value to monoid. +tell :: EffClass Writer' v e => v -> Eff e ()+tell v = effWriter $ Writer' v (const ())