fused-effects-th (empty) → 0.1.0.0

raw patch · 6 files changed

+326/−0 lines, 6 filesdep +basedep +fused-effectsdep +fused-effects-th

Dependencies added: base, fused-effects, fused-effects-th, tasty, tasty-hunit, template-haskell

Files

CHANGELOG.md +11/−0
LICENSE +29/−0
README.md +33/−0
fused-effects-th.cabal +60/−0
src/Control/Effect/TH.hs +127/−0
test/Spec.hs +66/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog++`fused-effects-th` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.0.0.0++* Initially created.++[1]: https://pvp.haskell.org+[2]: https://github.com/patrickt/fused-effects-th/releases

+ LICENSE view

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, Patrick Thomson+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.

+ README.md view

@@ -0,0 +1,33 @@+# fused-effects-th++[![GitHub CI](https://github.com/fused-effects/fused-effects-th/workflows/CI/badge.svg)](https://github.com/fused-effects/fused-effects-th/actions)+[![Hackage](https://img.shields.io/hackage/v/fused-effects-th.svg?logo=haskell)](https://hackage.haskell.org/package/fused-effects-th)+[![BSD-3-Clause license](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](LICENSE)++This package provides Template Haskell helpers for fused-effects. The `makeSmartConstructors` splice, given the name of a GADT defining an effect, iterates through the possible constructors and generates functions that construct effects using `send`. That is to say, given the standard `State` type:++``` haskell+data State s m k where+  Get :: State s m s+  Put :: s -> State s m ()+```++calling `makeSmartConstructors ''State` generates the following code (cleaned up a little from the native Template Haskell output):++``` haskell+get ::+  forall s sig m+  Has (State s) sig m =>+  m s+get = send Get+{-# INLINEABLE get #-}+ put ::+  forall s sig m.+  Has (State s) sig m =>+  s ->+  m ()+put a = send (Put a)+{-# INLINEABLE put #-}+```++Bug reports are welcome on the [issue tracker](https://github.com/fused-effects/fused-effects-th/issues).

+ fused-effects-th.cabal view

@@ -0,0 +1,60 @@+cabal-version:       2.4+name:                fused-effects-th+version:             0.1.0.0+synopsis:            Template Haskell helpers for fused-effects.+description:         Template Haskell helpers for fused-effects.+homepage:            https://github.com/patrickt/fused-effects-th+bug-reports:         https://github.com/patrickt/fused-effects-th/issues+license:             BSD-3-Clause+license-file:        LICENSE+author:              Patrick Thomson+maintainer:          Patrick Thomson <patrickt@github.com>+copyright:           2020 Patrick Thomson+category:            Control+build-type:          Simple+extra-doc-files:     README.md+                     CHANGELOG.md+tested-with:         GHC == 8.8.3++source-repository head+  type:                git+  location:            https://github.com/patrickt/fused-effects-th.git++common common-options+  build-depends:       base >= 4.9 && < 4.15+                     , fused-effects ^>= 1.1+                     , template-haskell >= 2.12 && < 2.17++  ghc-options:         -Wall+                       -Wcompat+                       -Widentities+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+  if impl(ghc >= 8.0)+    ghc-options:       -Wredundant-constraints+  if impl(ghc >= 8.2)+    ghc-options:       -fhide-source-paths+  if impl(ghc >= 8.4)+    ghc-options:       -Wmissing-export-lists+                       -Wpartial-fields+  if impl(ghc >= 8.8)+    ghc-options:       -Wmissing-deriving-strategies++  default-language:    Haskell2010++library+  import:              common-options+  hs-source-dirs:      src+  exposed-modules:     Control.Effect.TH++test-suite fused-effects-th-test+  import:              common-options+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       fused-effects-th+                     , tasty ^>= 1.3+                     , tasty-hunit >= 0.10+  ghc-options:         -threaded+                       -rtsopts+                       -with-rtsopts=-N

+ src/Control/Effect/TH.hs view

@@ -0,0 +1,127 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Defines splices that cut down on boilerplate associated with declaring new effects.+module Control.Effect.TH+  ( makeSmartConstructors,+  )+where++import Control.Algebra+import Control.Monad (join)+import Data.Char (toLower)+import Data.Foldable+import Data.Traversable+import Language.Haskell.TH as TH++data PerEffect = PerEffect+  { typeName :: TH.Name,+    effectTypeVars :: [TH.TyVarBndr],+    monadTypeVar :: TH.TyVarBndr,+    forallConstructor :: TH.Con+  }++data PerDecl = PerDecl+  { ctorName :: TH.Name,+    functionName :: TH.Name,+    ctorArgs :: [TH.Type],+    returnType :: TH.Type,+    perEffect :: PerEffect,+    extraTyVars :: [TyVarBndr]+  }++-- | Given an effect type, this splice generates functions that create per-constructor request functions.+--+-- That is to say, given the standard @State@ type+--+-- @+--   data State s m k where+--     Get :: State s m s+--     Put :: s -> State s m ()+-- @+--+-- an invocation of @makeSmartConstructors ''State@ will generate code that looks like+--+--+-- >   get ::+-- >     forall (s :: Type) sig (m :: Type -> Type).+-- >     Has (State s) sig m =>+-- >     m s+-- >   get = send Get+-- >   {-# INLINEABLE get #-}+-- >    put ::+-- >     forall (s :: Type) sig (m :: Type -> Type).+-- >     Has (State s) sig m =>+-- >     s ->+-- >     m ()+-- >   put a = send (Put a)+-- >   {-# INLINEABLE put #-}+--+--+-- The type variables in each declared function signature will appear in the order+-- they were defined in the effect type.+--+makeSmartConstructors :: Name -> TH.DecsQ+makeSmartConstructors typ =+  TH.reify typ >>= \case+    TH.TyConI (TH.DataD _ctx typeName tyvars _kind cons _derive) -> do+      -- Pick out the `m` argument. We can drop `k` on the floor.+      (effectTypeVarsWithoutSig, monadTypeVar) <- case reverse tyvars of+        _cont : monad : rest -> pure (reverse rest, monad)+        _ -> fail ("Effect types need at least two type arguments: a monad `m` and continuation `k`.")+      -- Continue, recording the various relevant data from the type in question.+      let effectTypeVars = effectTypeVarsWithoutSig ++ [TH.PlainTV (mkName "sig")]+      join <$> traverse (\forallConstructor -> makeDeclaration PerEffect {..}) cons+    other -> fail ("Can't generate definitions for a non-data-constructor: " <> pprint other)++makeDeclaration :: PerEffect -> TH.DecsQ+makeDeclaration perEffect@PerEffect {..} = do+  (names, ctorArgs, returnWithResult, extraTyVars) <- case forallConstructor of+    TH.ForallC vars _ctx (TH.GadtC names bangtypes returnType) ->+      pure (names, fmap snd bangtypes, returnType, vars)+    _ ->+      fail ("BUG: expected forall-qualified constructor, but didn't get one")+  returnType <- case returnWithResult of+    AppT _ final -> pure final+    _ -> fail ("BUG: Couldn't get a return type out of " <> pprint returnWithResult)+  fmap join . for names $ \ctorName -> do+    let downcase = \case+          x : xs -> toLower x : xs+          [] -> []+        functionName = TH.mkName . downcase . TH.nameBase $ ctorName+    let decl = PerDecl {..}+    sign <- makeSignature decl+    func <- makeFunction decl+    prag <- makePragma decl+    pure [sign, func, prag]++makePragma :: PerDecl -> TH.DecQ+makePragma PerDecl {..} =+  TH.pragInlD functionName TH.Inlinable TH.FunLike TH.AllPhases++makeFunction :: PerDecl -> Q Dec+makeFunction d =+  TH.funD (functionName d) [makeClause d]++makeClause :: PerDecl -> ClauseQ+makeClause PerDecl {..} = TH.clause pats body []+  where+    body = TH.normalB [e|send ($(applies))|]+    pats = fmap TH.varP names+    applies = foldl' (\e n -> e `appE` varE n) (conE ctorName) names+    names = fmap (mkName . pure) (take (length ctorArgs) ['a' .. 'z'])++makeSignature :: PerDecl -> TH.DecQ+makeSignature PerDecl {perEffect = PerEffect {..}, ..} =+  let sigVar = last effectTypeVars+      rest = init effectTypeVars+      getTyVar = \case+        TH.PlainTV t -> t+        TH.KindedTV t _ -> t+      monadName = varT (getTyVar monadTypeVar)+      invocation = foldl' appT (conT typeName) (fmap (varT . getTyVar) rest)+      hasConstraint = [t|Has $(parensT invocation) $(varT (mkName "sig")) $(monadName)|]+      folded = foldr (\a b -> arrowT `appT` pure a `appT` b) (monadName `appT` pure returnType) ctorArgs+   in TH.sigD functionName (TH.forallT (extraTyVars ++ [sigVar]) (TH.cxt [hasConstraint]) folded)

+ test/Spec.hs view

@@ -0,0 +1,66 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -ddump-splices #-}+{-# OPTIONS_GHC -Wno-unused-binds #-}++module Main+  ( main,+  )+where++import Control.Carrier.State.Strict (evalState)+import Control.Effect.State hiding (get, put)+import Control.Effect.Reader hiding (ask, local)+import Control.Effect.Writer hiding (tell, listen, censor)+import Control.Effect.TH+import Control.Exception (SomeException, try)+import Data.Either+import Language.Haskell.TH (runQ)+import System.IO+import Test.Tasty+import Test.Tasty.HUnit++makeSmartConstructors ''State+makeSmartConstructors ''Reader+makeSmartConstructors ''Writer++-- Need to ensure that if a constructor introduces a new type variable,+-- that it is introduced in the corresponding invocation. The question is+-- where we can put it. Probably before `sig m`.++assertThrows :: String -> IO a -> Assertion+assertThrows msg go =+  fmap isLeft (try @SomeException go) >>= assertBool msg++testState :: TestTree+testState = testCase "Generated State functions" $ do+  assertEqual "get" (run $ evalState "hello" get) "hello"+  assertEqual "get-put" (run $ evalState "bad" (put "good" *> get)) "good"++data BadGADT where+  BadGADT :: BadGADT++testDataErrors :: TestTree+testDataErrors =+  testCase "Bad data types" $ do+    assertThrows "Bool" (runQ (makeSmartConstructors ''Bool))+    assertThrows "Ill-formed GADT" (runQ (makeSmartConstructors ''BadGADT))++main :: IO ()+main = do+  hClose stderr -- silences TH warnings+  defaultMain $+    testGroup+      "Language.Haskell.TH"+      [ testGroup+          "Behavior"+          [ testState+          ],+        testGroup+          "Template Haskell errors"+          [ testDataErrors+          ]+      ]