each 0.1.0.0 → 1.1.0.0

raw patch · 4 files changed

+203/−149 lines, 4 filesdep +dlistdep −containersdep −mtldep ~eachPVP ok

version bump matches the API change (PVP)

Dependencies added: dlist

Dependencies removed: containers, mtl

Dependency ranges changed: each

API changes (from Hackage documentation)

Files

• README.md +51/−9
• each.cabal +3/−4
• src/Each.hs +1/−66
• src/Each/Transform.hs +148/−70

@@ -2,23 +2,65 @@  Inspired by [the Scala library of the same name](https://github.com/ThoughtWorksInc/each), each is a Template Haskell library that transforms expressions containing-invocations of impure subexpressions into calls to `fmap`, `<*>`, `join`,-etc. Just mark your impure subexpressions with `bind` or `~!` and they will be-called appropriately, as in this small demo:+invocations of impure subexpressions into do-notation. Just mark your impure+subexpressions with `bind` or `~!` and they will be called appropriately,+as in this small demo:      ghci> $(each [| "Hello, " ++ (~! getLine) |])     World              <--[keyboard input]     "Hello, World" -In this case, the code is translated into `fmap ((++) "Hello, ") getLine`+With the `ApplicativeDo` GHC extension, calls to `fmap` and `<*>` will be+arranged so that you don't need to worry if you use, say, Haxl and needs+`Applicative` for parallelism. -We currently have support for+Most constructs where this would make things much more simpler are already+supported. In particular, these are okay: -* Normal function application like `f x y`-* Infix operator application like `x + y`, including sections like `(+ y)`-* Type signatures like `x :: t`+- Nested `bind`s.+- Branching constructs, even if the branches themselves uses `bind`. The+generated `do`-notation will generally match imperative intuition. -Support for more constructs is coming.+These are some quirks:++- `let` expressions are evaluated sequentially. `each` currently lacks support+for detecting pure `let` expressions.+- `where` is not implemented.+- Parameters to lambda functions may not be used impurely. This is acceptable,+but the error message may be confusing:++        ghci> $(each [| (\x -> bind x) |])++        <interactive>:25:3: error:+        • The exact Name ‘x_acBv’ is not in scope+        Probable cause: you used a unique Template Haskell name (NameU),+        perhaps via newName, but did not bind it+        If that's it, then -ddump-splices might be useful+        • In the untyped splice: $(each [| (\ x -> bind x) |])++  Also, `bind`s in the lambda will be run when the lambda is *constructed*,+not when it's called.+- `PatternGuard`, `LambdaCase` and a few other extensions (uncertain) are not+yet implemented.++If you find something wrong, or really want some feature, feel free to leave an+issue.++## How it works++The basic structure of an `each` block is this:++    $(each [| ... |])++Inside of this block, three (interchangable) ways are used to mark impure+subexpressions:++- `bind expr`+- `bind $ expr`+- `(~! expr)`++`do`-notation is generated according to left-to-right order, and branching is+handled.  ## More demos 

@@ -1,5 +1,5 @@ name: each-version: 0.1.0.0+version: 1.1.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -29,8 +29,7 @@     build-depends:         base >=4.9 && <5,         template-haskell >=2.11.0.0,-        mtl >=2.2.1,-        containers >=0.5.7.1+        dlist >=0.8.0.2     default-language: Haskell2010     hs-source-dirs: src @@ -39,7 +38,7 @@     main-is: Spec.hs     build-depends:         base >=4.9.0.0,-        each >=0.1.0.0,+        each >=1.1.0.0,         hspec >=2.2.4,         QuickCheck >=2.8.2     default-language: Haskell2010

@@ -11,79 +11,14 @@ -- Stability   :  experimental -- Portability :  non-portable (Template Haskell) ----- The basic structure of an 'each' block is this:------ > $(each [| ... |])------ Inside of this block, three (interchangable) ways are used to mark impure--- subexpressions:------ * @bind expr@--- * @bind $ expr@--- * @(~! expr)@------ When 'each' encounters such a subexpression, appropriate calls to 'fmap',--- '<*>' and 'join' are generated so that the results generally match what you--- would expect. In particular, The impure actions are evaluated from left to--- right, so that:------ > $(each [| bind getLine ++ bind getLine ])------ means------ > (++) `fmap` getLine <*> getLine------ = Type signatures------ Type signatures like @(x :: t)@, when used on expressions containing 'bind',--- i.e. impure subexpressions, are transformed in one of the following ways:------ * With @PartialTypeSignatures@, the generated context type will be a--- wildcard, requiring GHC to infer the context. In this case @(z :: t)@ where--- contains an impure subexpression, is transfomed into @(z' :: _ t)@, where--- @z'@ is the transformed form of @z@.--- * With 'eachWith', the context type is as supplied. For examples see--- 'eachWith'.+-- Users of @each@ should import this module. For more usage info see README -----------------------------------------------------------------------------  module Each     ( each-    , eachWith     , bind     , (~!)     ) where -import Language.Haskell.TH--import qualified Control.Applicative- import Each.Invoke import Each.Transform--each' :: Maybe TypeQ -> ExpQ -> ExpQ-each' ety x = do-    ex <- x-    transform ex env >>= \case-            Pure z -> [| Control.Applicative.pure $(z) |]-            Bind z -> z-    where-        env = Env { envType = ety }---- | Invoke an 'each' block. Intended to be used as------ > $(each [| ... |])-each :: ExpQ -> ExpQ-each = each' Nothing---- | Invoke an 'each' block while specifying the context type, so that type--- annotations may be processed appropriately.------ > $(eachWith [t| IO |] [| "Hello, " ++ (bind getLine :: String) |])------ means------ > ("Hello, " ++) `fmap` (getLine :: IO String)------ using the 'IO' type which is supplied to 'eachWith'.-eachWith :: TypeQ -> ExpQ -> ExpQ-eachWith ety = each' (Just ety)

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE LambdaCase #-}  -----------------------------------------------------------------------------@@ -14,102 +14,180 @@ -- An internal module where most of the real transformation goes on. ----------------------------------------------------------------------------- -module Each.Transform-    ( transform-    , Env (..)-    , Result (..)-    ) where+module Each.Transform where  import Control.Applicative-import Control.Monad.Reader+import Control.Monad+import Data.DList (DList, singleton, toList) import Data.Monoid+ import Language.Haskell.TH +import qualified Each.Invoke --- The following modules are imported for use in splices-import qualified Control.Monad-import qualified Data.Functor+-- | A writer monad where the empty case is distinguished.+data Result a+    = Impure (DList Stmt) a -- ^ Invariant: the bind list is not empty+    | Pure a -import qualified Each.Invoke+instance Functor Result where+    f `fmap` Impure bs x = Impure bs (f x)+    f `fmap` Pure a = Pure (f a) -data Result-    = Pure ExpQ -- ^ This subexpression does not invoke bind, i.e. is pure-    | Bind ExpQ -- ^ This subexpression contains invocations of bind+instance Applicative Result where+    pure = Pure+    Pure f <*> Pure x = Pure (f x)+    Pure f <*> Impure xbs x = Impure xbs (f x)+    Impure fbs f <*> Pure x = Impure fbs (f x)+    Impure fbs f <*> Impure xbs x = Impure (fbs <> xbs) (f x) -data Env-    = Env-    { envType :: Maybe TypeQ-    --, envLocals :: M.Map Name Result-    }+instance Monad Result where+    Impure bs x >>= k = case k x of+        Impure ks r -> Impure (bs <> ks) r+        Pure r -> Impure bs r+    Pure x >>= k = k x -type M = ReaderT Env Q+addBind :: Name -> Exp -> Result ()+addBind n e = Impure (singleton (BindS (VarP n) e)) () -transform :: Exp -> Env -> Q Result-transform ex env = runReaderT (transform' ex) env+-- | Invoke an 'each' block+each :: ExpQ -> ExpQ+each inp = generate <$> (inp >>= transform) -transform' :: Exp -> M Result+generate :: Result Exp -> Exp+generate (Pure x) = AppE (VarE 'Control.Applicative.pure) x+generate (Impure xs x) = DoE $ toList (xs <> singleton (+    NoBindS (AppE (VarE 'Control.Monad.return) x)))++transform :: Exp -> Q (Result Exp) -- Detecting and processing invocations of bind-transform' (InfixE Nothing (VarE v) (Just x))+transform (InfixE Nothing (VarE v) (Just x))     | v == '(Each.Invoke.~!) = impurify x-transform' (AppE (VarE v) x)+transform (AppE (VarE v) x)     | v == 'Each.Invoke.bind = impurify x-transform' (InfixE (Just (VarE vf)) (VarE vo) (Just x))+transform (InfixE (Just (VarE vf)) (VarE vo) (Just x))     | vf == 'Each.Invoke.bind && vo == '(Prelude.$) = impurify x -transform' (VarE vn) = pure $ Pure (varE vn)-transform' (ConE cn) = pure $ Pure (conE cn)-transform' (LitE lit) = pure $ Pure (litE lit)+transform (VarE n) = pure $ pure (VarE n)+transform (ConE n) = pure $ pure (ConE n)+transform (LitE l) = pure $ pure (LitE l) -transform' (AppE f x) =-        liftA2 go (transform' f) (transform' x)-    where-        go (Pure ef) (Pure ex) = Pure [| $(ef) $(ex) |]-        go (Pure ef) (Bind ex) = Bind [| Data.Functor.fmap $(ef) $(ex) |]-        go (Bind ef) (Pure ex) = Bind [| Data.Functor.fmap ($ $(ex)) $(ef) |]-        go (Bind ef) (Bind ex) = Bind [| (Control.Applicative.<*>) $(ef) $(ex) |]+transform (AppE f x) =+    liftA2 (liftA2 AppE) (transform f) (transform x) -transform' (InfixE Nothing op Nothing) =-    transform' op+transform (InfixE lhs mid rhs) = do+    tl <- traverse transform lhs+    tm <- transform mid+    tr <- traverse transform rhs+    pure (liftA3 InfixE (sequence tl) tm (sequence tr)) -transform' (InfixE (Just lhs) op Nothing) =-    transform' (AppE op lhs)+-- TODO Maybe add checks to ensure that the arguments aren't used impurely?+transform (LamE ps x) = fmap (LamE ps) <$> transform x -transform' (InfixE Nothing op (Just rhs)) =-    lift [| Prelude.flip $(pure op) $(pure rhs) |] >>= transform'+transform (TupE ps) = fmap TupE . sequence <$> (traverse transform ps) -transform' (InfixE (Just lhs) op (Just rhs)) =-    transform' (AppE (AppE op lhs) rhs)+transform (CondE c t f) = do+    tc <- transform c+    tt <- transform t+    tf <- transform f+    case liftA2 (,) tt tf of+        Pure (et, ef) -> pure $ (\z -> CondE z et ef) <$> tc+        res -> do+            var <- newName "bind"+            pure $ do+                ec <- tc+                addBind var (CondE ec (generate tt) (generate tf))+                pure (VarE var) -transform' (SigE x ty) = transform' x >>= \tx -> case tx of-    Pure ex -> pure $ Pure [| $(ex) :: $(pure ty) |]+transform (MultiIfE bs) = case desugarMultiIf bs of+        Right x -> transform x+        Left err -> fail err+    where+        desugarMultiIf :: [(Guard, Exp)] -> Either String Exp+        desugarMultiIf [] = pure (AppE+            (VarE 'Prelude.error)+            (LitE $ StringL errNonExhaustiveGuard))+        desugarMultiIf ((NormalG c, t) : bs) = go <$> desugarMultiIf bs+            where go f = CondE c t f+        desugarMultiIf ((PatG _, _) : _) =+            Left errPatternGuard -    Bind ex -> do-        Env { envType = mety } <- ask-        case mety of+transform (LetE [] e) = transform e+transform (LetE (ValD p v [] : ds) e) =+    transform (CaseE (bodyToExp v) [Match p (NormalB $ LetE ds e) []])++transform (LetE (ValD _ _ _ : _) _) = fail errWhere+transform (LetE _ _) = fail errComplexLet++transform (CaseE s ma) = do+        ts <- transform s+        tm <- traverse transformMatch ma+        case traverse getPureMatch tm of+            Just pes -> pure $ (\z -> CaseE z (toMatch <$> pes)) <$> ts             Nothing -> do-                ok <- lift $ isExtEnabled PartialTypeSignatures-                if ok-                    -- Try PartialTypeSignatures-                    then pure $ Bind [| $(ex) :: $(pure WildCardT) $(pure ty) |]-                    else fail errSig-            Just ety ->-                -- Use the supplied context type-                pure $ Bind [| $(ex) :: $(ety) $(pure ty) |]+                var <- newName "bind"+                pure $ do+                    es <- ts+                    addBind var (CaseE es (generateMatch <$> tm))+                    pure (VarE var)+    where+        generateMatch :: (Pat, Result Exp) -> Match+        generateMatch (p, e) = toMatch (p, generate e) -transform' x = fail (errUnsupportedSyntax x)+        toMatch :: (Pat, Exp) -> Match+        toMatch (p, e) = Match p (NormalB e) [] -impurify :: Exp -> M Result-impurify x =-        go <$> transform' x+        getPureMatch :: (Pat, Result Exp) -> Maybe (Pat, Exp)+        getPureMatch (pat, Pure e) = Just (pat, e)+        getPureMatch _ = Nothing++        transformMatch :: Match -> Q (Pat, Result Exp)+        transformMatch (Match pat body []) =+            (\x -> (pat, x)) <$> transform (bodyToExp body)+        transformMatch _ = fail errWhere++transform (ArithSeqE z) =+    fmap ArithSeqE <$> case z of+        FromR a -> fmap FromR <$> transform a+        FromThenR a b -> liftA2 (liftA2 FromThenR) (transform a) (transform b)+        FromToR a b -> liftA2 (liftA2 FromToR) (transform a) (transform b)+        FromThenToR a b c -> liftA3 (liftA3 FromThenToR)+            (transform a) (transform b) (transform c)++transform (ListE xs) = fmap ListE . sequence <$> (traverse transform xs)++transform (SigE e t) = fmap (\te -> SigE te t) <$> transform e++transform (RecConE name fes) =+    fmap (RecConE name) . sequence+    <$> (traverse transformFieldExp fes)++transform (RecUpdE x fes) =+    liftA2 (liftA2 RecUpdE)+    (transform x)+    (sequence <$> traverse transformFieldExp fes)++transform (UnboundVarE n) = pure $ pure (UnboundVarE n)++transform x = fail (errUnsupported <> pprint x)++bodyToExp :: Body -> Exp+bodyToExp (NormalB x) = x+bodyToExp (GuardedB x) = MultiIfE x++transformFieldExp :: FieldExp -> Q (Result FieldExp)+transformFieldExp (nm, e) = fmap (\x -> (nm, x)) <$> transform e++impurify :: Exp -> Q (Result Exp)+impurify e = liftA2 go (transform e) (newName "bind")     where-        go (Pure e) = Bind e-        go (Bind e) = Bind [| Control.Monad.join $(e) |]+        go te nm = te >>= \z -> VarE nm <$ addBind nm z -errUnsupportedSyntax :: Exp -> String-errUnsupportedSyntax x = "each: Unsupported syntax in " <> pprint x+errNonExhaustiveGuard, errUnsupported,+    errPatternGuard, errWhere, errComplexLet :: String -errSig :: String-errSig =-    "each: Using type signatures on expressions containing 'bind' requires \-    \specifying the context type using 'eachWith', or enabling \-    \-XPartialTypeSignatures."+errNonExhaustiveGuard = "Non-exhaustive guard"+errUnsupported = "Unsupported syntax in: "+errPatternGuard = "Pattern guards are not supported"+errWhere = "'where' is not supported"+errComplexLet = "Only declarations like 'pattern = value' are supported in let"