each (empty) → 0.1.0.0

raw patch · 8 files changed

+356/−0 lines, 8 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, each, hspec, mtl, template-haskell

Files

• LICENSE +30/−0
• README.md +45/−0
• Setup.hs +2/−0
• each.cabal +47/−0
• src/Each.hs +89/−0
• src/Each/Invoke.hs +27/−0
• src/Each/Transform.hs +115/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright dramforever (c) 2017++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 dramforever 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,45 @@+# each++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:++    ghci> $(each [| "Hello, " ++ (~! getLine) |])+    World              <--[keyboard input]+    "Hello, World"++In this case, the code is translated into `fmap ((++) "Hello, ") getLine`++We currently have support for++* Normal function application like `f x y`+* Infix operator application like `x + y`, including sections like `(+ y)`+* Type signatures like `x :: t`++Support for more constructs is coming.++## More demos++A more detailed demo:++    ghci> :{+        | $(each [|+        |   "Hey it works"+        |   ++ show (length $+        |     "something"+        |     ++ (~! readFile "/etc/issue")+        |     ++ (~! readFile "/etc/issue.net"))+        | |])+        | :}+    "Hey it works64"++Nested binds also work as expected.++    ghci> prompt str = putStrLn str *> getLine+    ghci> $(each [| "Nah just " ++ (~! prompt ("What's " ++ bind getLine ++ "?")) |])+    something          <--[keyboard input]+    What's something?+    nothing            <--[keyboard input]+    "Nah just nothing"

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

@@ -0,0 +1,47 @@+name: each+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (C) dramforever <dramforever@live.com>+maintainer: dramforever@live.com+homepage: https://github.com/dramforever/each#readme+synopsis: Template Haskell library for writing monadic expressions more easily+description:+    See README at the bottom.+    .+    /Getting started/: See "Each".+category: Language+author: dramforever+extra-source-files:+    README.md++source-repository head+    type: git+    location: https://github.com/dramforever/each++library+    exposed-modules:+        Each+        Each.Invoke+        Each.Transform+    build-depends:+        base >=4.9 && <5,+        template-haskell >=2.11.0.0,+        mtl >=2.2.1,+        containers >=0.5.7.1+    default-language: Haskell2010+    hs-source-dirs: src++test-suite each-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base >=4.9.0.0,+        each >=0.1.0.0,+        hspec >=2.2.4,+        QuickCheck >=2.8.2+    default-language: Haskell2010+    hs-source-dirs: test+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O

@@ -0,0 +1,89 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Each+-- Copyright   :  (c) dramforever 2017+-- License     :  BSD3+--+-- Maintainer  :  dramforever+-- 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'.+-----------------------------------------------------------------------------++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)

@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Each.Invoke+-- Copyright   :  (c) dramforever 2017+-- License     :  BSD3+--+-- Maintainer  :  dramforever+-- Stability   :  experimental+-- Portability :  non-portable (Template Haskell)+--+-- Names that are used to bind things in 'each' blocks are defined here.+-----------------------------------------------------------------------------++module Each.Invoke+    ( bind+    , (~!)+    ) where++-- | Do not use this outside of an each block. Only its name is used, and its+-- value itself does not make sense.+bind :: ()+bind = error "Do not use this outside of an each block"++-- | Do not use this outside of an each block. Only its name is used, and its+-- value itself does not make sense.+(~!) :: ()+(~!) = error "Do not use this outside of an each block"

@@ -0,0 +1,115 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Each.Transform+-- Copyright   :  (c) dramforever 2017+-- License     :  BSD3+--+-- Maintainer  :  dramforever+-- Stability   :  experimental+-- Portability :  non-portable (Template Haskell)+--+-- An internal module where most of the real transformation goes on.+-----------------------------------------------------------------------------++module Each.Transform+    ( transform+    , Env (..)+    , Result (..)+    ) where++import Control.Applicative+import Control.Monad.Reader+import Data.Monoid+import Language.Haskell.TH+++-- The following modules are imported for use in splices+import qualified Control.Monad+import qualified Data.Functor++import qualified Each.Invoke++data Result+    = Pure ExpQ -- ^ This subexpression does not invoke bind, i.e. is pure+    | Bind ExpQ -- ^ This subexpression contains invocations of bind++data Env+    = Env+    { envType :: Maybe TypeQ+    --, envLocals :: M.Map Name Result+    }++type M = ReaderT Env Q++transform :: Exp -> Env -> Q Result+transform ex env = runReaderT (transform' ex) env++transform' :: Exp -> M Result+-- Detecting and processing invocations of bind+transform' (InfixE Nothing (VarE v) (Just x))+    | v == '(Each.Invoke.~!) = impurify x+transform' (AppE (VarE v) x)+    | v == 'Each.Invoke.bind = impurify 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' (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' (InfixE Nothing op Nothing) =+    transform' op++transform' (InfixE (Just lhs) op Nothing) =+    transform' (AppE op lhs)++transform' (InfixE Nothing op (Just rhs)) =+    lift [| Prelude.flip $(pure op) $(pure rhs) |] >>= transform'++transform' (InfixE (Just lhs) op (Just rhs)) =+    transform' (AppE (AppE op lhs) rhs)++transform' (SigE x ty) = transform' x >>= \tx -> case tx of+    Pure ex -> pure $ Pure [| $(ex) :: $(pure ty) |]++    Bind ex -> do+        Env { envType = mety } <- ask+        case mety of+            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) |]++transform' x = fail (errUnsupportedSyntax x)++impurify :: Exp -> M Result+impurify x =+        go <$> transform' x+    where+        go (Pure e) = Bind e+        go (Bind e) = Bind [| Control.Monad.join $(e) |]++errUnsupportedSyntax :: Exp -> String+errUnsupportedSyntax x = "each: Unsupported syntax in " <> pprint x++errSig :: String+errSig =+    "each: Using type signatures on expressions containing 'bind' requires \+    \specifying the context type using 'eachWith', or enabling \+    \-XPartialTypeSignatures."

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}