mirror of
https://github.com/haskell-effectful/effectful.git
synced 2024-11-22 22:14:21 +03:00
Add effectful-th based on the code from cleff (#60)
This commit is contained in:
Andrzej Rybczak
GitHub
parent
cfd958d0dc
commit
b77e9c3d65
36
.github/workflows/haskell-ci.yml
vendored
36
.github/workflows/haskell-ci.yml
vendored
@ -8,9 +8,9 @@
|
||||
#
|
||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||
#
|
||||
# version: 0.14
|
||||
# version: 0.14.1
|
||||
#
|
||||
# REGENDATA ("0.14",["github","--config=cabal.haskell-ci","cabal.project"])
|
||||
# REGENDATA ("0.14.1",["github","--config=cabal.haskell-ci","cabal.project"])
|
||||
#
|
||||
name: Haskell-CI
|
||||
on:
|
||||
@ -169,8 +169,9 @@ jobs:
|
||||
- name: initial cabal.project for sdist
|
||||
run: |
|
||||
touch cabal.project
|
||||
echo "packages: $GITHUB_WORKSPACE/source/effectful" >> cabal.project
|
||||
echo "packages: $GITHUB_WORKSPACE/source/effectful-core" >> cabal.project
|
||||
echo "packages: $GITHUB_WORKSPACE/source/effectful-th" >> cabal.project
|
||||
echo "packages: $GITHUB_WORKSPACE/source/effectful" >> cabal.project
|
||||
cat cabal.project
|
||||
- name: sdist
|
||||
run: |
|
||||
@ -182,24 +183,29 @@ jobs:
|
||||
find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
|
||||
- name: generate cabal.project
|
||||
run: |
|
||||
PKGDIR_effectful="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-[0-9.]*')"
|
||||
echo "PKGDIR_effectful=${PKGDIR_effectful}" >> "$GITHUB_ENV"
|
||||
PKGDIR_effectful_core="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-core-[0-9.]*')"
|
||||
echo "PKGDIR_effectful_core=${PKGDIR_effectful_core}" >> "$GITHUB_ENV"
|
||||
PKGDIR_effectful_th="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-th-[0-9.]*')"
|
||||
echo "PKGDIR_effectful_th=${PKGDIR_effectful_th}" >> "$GITHUB_ENV"
|
||||
PKGDIR_effectful="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-[0-9.]*')"
|
||||
echo "PKGDIR_effectful=${PKGDIR_effectful}" >> "$GITHUB_ENV"
|
||||
rm -f cabal.project cabal.project.local
|
||||
touch cabal.project
|
||||
touch cabal.project.local
|
||||
echo "packages: ${PKGDIR_effectful}" >> cabal.project
|
||||
echo "packages: ${PKGDIR_effectful_core}" >> cabal.project
|
||||
echo "package effectful" >> cabal.project
|
||||
echo " ghc-options: -Werror=missing-methods" >> cabal.project
|
||||
echo "packages: ${PKGDIR_effectful_th}" >> cabal.project
|
||||
echo "packages: ${PKGDIR_effectful}" >> cabal.project
|
||||
echo "package effectful-core" >> cabal.project
|
||||
echo " ghc-options: -Werror=missing-methods" >> cabal.project
|
||||
echo "package effectful-th" >> cabal.project
|
||||
echo " ghc-options: -Werror=missing-methods" >> cabal.project
|
||||
echo "package effectful" >> cabal.project
|
||||
echo " ghc-options: -Werror=missing-methods" >> cabal.project
|
||||
cat >> cabal.project <<EOF
|
||||
package effectful
|
||||
flags: +benchmark-foreign-libraries
|
||||
EOF
|
||||
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core)$/; }' >> cabal.project.local
|
||||
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core|effectful-th)$/; }' >> cabal.project.local
|
||||
cat cabal.project
|
||||
cat cabal.project.local
|
||||
- name: dump install plan
|
||||
@ -227,18 +233,22 @@ jobs:
|
||||
$CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
|
||||
- name: doctest
|
||||
run: |
|
||||
cd ${PKGDIR_effectful} || false
|
||||
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
|
||||
cd ${PKGDIR_effectful_core} || false
|
||||
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
|
||||
cd ${PKGDIR_effectful_core} || false
|
||||
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils
|
||||
cd ${PKGDIR_effectful_th} || false
|
||||
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
|
||||
cd ${PKGDIR_effectful} || false
|
||||
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
|
||||
- name: cabal check
|
||||
run: |
|
||||
cd ${PKGDIR_effectful} || false
|
||||
${CABAL} -vnormal check
|
||||
cd ${PKGDIR_effectful_core} || false
|
||||
${CABAL} -vnormal check
|
||||
cd ${PKGDIR_effectful_th} || false
|
||||
${CABAL} -vnormal check
|
||||
cd ${PKGDIR_effectful} || false
|
||||
${CABAL} -vnormal check
|
||||
- name: haddock
|
||||
run: |
|
||||
$CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
packages:
|
||||
effectful/effectful.cabal
|
||||
effectful-core/effectful-core.cabal
|
||||
effectful-core/*.cabal
|
||||
effectful-th/*.cabal
|
||||
effectful/*.cabal
|
||||
|
||||
@ -39,4 +39,5 @@ run_doctest() {
|
||||
}
|
||||
|
||||
run_doctest effectful-core src
|
||||
run_doctest effectful-th src
|
||||
run_doctest effectful src
|
||||
|
||||
2
effectful-th/CHANGELOG.md
Normal file
2
effectful-th/CHANGELOG.md
Normal file
@ -0,0 +1,2 @@
|
||||
# effectful-th-0.1 (2022-??-??)
|
||||
* Initial release.
|
||||
64
effectful-th/LICENSE
Normal file
64
effectful-th/LICENSE
Normal file
@ -0,0 +1,64 @@
|
||||
Copyright (c) 2021-2022, Andrzej Rybczak
|
||||
|
||||
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 Andrzej Rybczak 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.
|
||||
|
||||
This software incorporates code from the cleff package (available from
|
||||
https://hackage.haskell.org/package/cleff) under the following license:
|
||||
|
||||
Copyright Xy Ren (c) 2021
|
||||
|
||||
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 Xy Ren 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.
|
||||
75
effectful-th/effectful-th.cabal
Normal file
75
effectful-th/effectful-th.cabal
Normal file
@ -0,0 +1,75 @@
|
||||
cabal-version: 2.4
|
||||
build-type: Simple
|
||||
name: effectful-th
|
||||
version: 0.1
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
category: Control
|
||||
maintainer: andrzej@rybczak.net
|
||||
author: Andrzej Rybczak
|
||||
synopsis: Template Haskell utilities for the effectful library.
|
||||
|
||||
description: Generate functions for performing operations of dynamically
|
||||
dispatched effects via Template Haskell.
|
||||
|
||||
extra-source-files: CHANGELOG.md
|
||||
|
||||
tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.1
|
||||
|
||||
bug-reports: https://github.com/arybczak/effectful/issues
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/arybczak/effectful.git
|
||||
|
||||
common language
|
||||
ghc-options: -Wall -Wcompat
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions: BangPatterns
|
||||
ConstraintKinds
|
||||
DataKinds
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NoStarIsType
|
||||
RankNTypes
|
||||
RecordWildCards
|
||||
RoleAnnotations
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TupleSections
|
||||
TypeApplications
|
||||
TypeFamilies
|
||||
TypeOperators
|
||||
|
||||
library
|
||||
import: language
|
||||
|
||||
build-depends: base >= 4.13 && < 5
|
||||
, containers >= 0.6
|
||||
, effectful >= 0.1 && < 0.1.1
|
||||
, exceptions >= 0.10.4
|
||||
, template-haskell >= 2.15 && < 2.19
|
||||
, th-abstraction >= 0.4
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
exposed-modules: Effectful.TH
|
||||
|
||||
test-suite th-tests
|
||||
import: language
|
||||
|
||||
build-depends: base
|
||||
, effectful
|
||||
, effectful-th
|
||||
|
||||
hs-source-dirs: tests
|
||||
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: ThTests.hs
|
||||
265
effectful-th/src/Effectful/TH.hs
Normal file
265
effectful-th/src/Effectful/TH.hs
Normal file
@ -0,0 +1,265 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
-- | Generate functions for performing operations of dynamically dispatched
|
||||
-- effects via Template Haskell.
|
||||
module Effectful.TH
|
||||
( makeEffect
|
||||
, makeEffect_
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Char (toLower)
|
||||
import Data.Foldable (foldl')
|
||||
import Data.Maybe
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Language.Haskell.TH.Datatype.TyVarBndr
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Dynamic
|
||||
|
||||
-- | For an effect data type @E@, @'makeEffect' E@ generates the appropriate
|
||||
-- instance of 'DispatchOf' as well as functions for performing operations of
|
||||
-- @E@ by 'send'ing them to the effect handler.
|
||||
--
|
||||
-- >>> :{
|
||||
-- data E :: Effect where
|
||||
-- Op1 :: Int -> m a -> E m a
|
||||
-- Op2 :: IOE :> es => Int -> E (Eff es) ()
|
||||
-- Op3 :: (forall r. m r -> m r) -> E m Int
|
||||
-- makeEffect ''E
|
||||
-- :}
|
||||
--
|
||||
-- >>> :kind! DispatchOf E
|
||||
-- DispatchOf E :: Dispatch
|
||||
-- = 'Dynamic
|
||||
--
|
||||
-- >>> :t op1
|
||||
-- op1 :: (E :> es) => Int -> Eff es a -> Eff es a
|
||||
--
|
||||
-- >>> :t op2
|
||||
-- op2 :: (E :> es, IOE :> es) => Int -> Eff es ()
|
||||
--
|
||||
-- >>> :t op3
|
||||
-- op3 :: (E :> es) => (forall r. Eff es r -> Eff es r) -> Eff es Int
|
||||
--
|
||||
-- The naming rule changes the first uppercase letter in the constructor name to
|
||||
-- lowercase or removes the @:@ symbol in case of operators. Any fixity
|
||||
-- annotations defined for the constructors are preserved for the corresponding
|
||||
-- definitions.
|
||||
makeEffect :: Name -> Q [Dec]
|
||||
makeEffect = makeEffectImpl True
|
||||
|
||||
-- | Like 'makeEffect', but doesn't generate type signatures. This is useful
|
||||
-- when you want to attach Haddock documentation to function signatures:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Noop :: Effect where
|
||||
-- Noop :: Noop m ()
|
||||
-- makeEffect_ ''Noop
|
||||
-- -- | Perform nothing at all.
|
||||
-- noop :: Noop :> es => Eff es ()
|
||||
-- :}
|
||||
--
|
||||
-- /Note:/ function signatures must be added /after/ the call to 'makeEffect_'.
|
||||
makeEffect_ :: Name -> Q [Dec]
|
||||
makeEffect_ = makeEffectImpl False
|
||||
|
||||
makeEffectImpl :: Bool -> Name -> Q [Dec]
|
||||
makeEffectImpl makeSig effName = do
|
||||
checkRequiredExtensions
|
||||
info <- reifyDatatype effName
|
||||
dispatch <- do
|
||||
e <- getEff (ConT $ datatypeName info) (datatypeInstTypes info)
|
||||
let dispatchE = ConT ''DispatchOf `AppT` e
|
||||
dynamic = PromotedT 'Dynamic
|
||||
pure . TySynInstD $ TySynEqn Nothing dispatchE dynamic
|
||||
ops <- traverse (makeCon makeSig) (constructorName <$> datatypeCons info)
|
||||
pure $ dispatch : concat (reverse ops)
|
||||
where
|
||||
getEff :: Type -> [Type] -> Q Type
|
||||
getEff e = \case
|
||||
[m, r] -> do
|
||||
checkKind "the next to last" (ArrowT `AppT` StarT `AppT` StarT) m
|
||||
checkKind "the last" StarT r
|
||||
pure e
|
||||
(v : vs) -> getEff (e `AppT` forgetKind v) vs
|
||||
_ -> fail "The effect data type needs at least 2 type parameters"
|
||||
where
|
||||
forgetKind = \case
|
||||
SigT v _ -> v
|
||||
ty -> ty
|
||||
|
||||
checkKind which expected = \case
|
||||
SigT (VarT _) k
|
||||
| k == expected -> pure ()
|
||||
| otherwise -> fail
|
||||
$ "Expected " ++ which ++ " type parameter to have a kind "
|
||||
++ pprint expected ++ ", got " ++ pprint k
|
||||
-- Weird type, let it through and see what happens.
|
||||
_ -> pure ()
|
||||
|
||||
-- | Generate a single definition of an effect operation.
|
||||
makeCon :: Bool -> Name -> Q [Dec]
|
||||
makeCon makeSig name = do
|
||||
fixity <- reifyFixity name
|
||||
typ <- reify name >>= \case
|
||||
DataConI _ typ _ -> pure typ
|
||||
_ -> fail $ "Not a data constructor: " ++ nameBase name
|
||||
|
||||
(actionParams, (effTy, ename, resTy)) <- extractParams typ
|
||||
|
||||
-- The 'ename' can be either:
|
||||
--
|
||||
-- - A variable for the monad, in which case we need to generate the @es@
|
||||
-- variable and substitute it later for 'Eff es'.
|
||||
--
|
||||
-- - A variable 'es' for the local 'Eff es' if the monad parameter was locally
|
||||
-- substituted in the contructor.
|
||||
--
|
||||
-- For example in the following effect:
|
||||
--
|
||||
-- data E :: Effect where
|
||||
-- E1 :: Int -> E m ()
|
||||
-- E2 :: IOE :> es => E (Eff es) ()
|
||||
--
|
||||
-- Processing 'E1' will yield 'Right m', but 'E2' will yield 'Left es'.
|
||||
--
|
||||
-- In the first case we need to substitute the variable ourselves in a few
|
||||
-- places, but in the second we're good since it was already substituted.
|
||||
(esName, maybeMonadName) <- case ename of
|
||||
Left esName -> pure (esName, Nothing)
|
||||
Right monadName -> (, Just monadName) <$> newName "es"
|
||||
|
||||
let fnName = mkName . toSmartConName $ nameBase name
|
||||
fnArgs <- traverse (const $ newName "x") actionParams
|
||||
|
||||
let esVar = VarT esName
|
||||
|
||||
substM :: Type -> Type
|
||||
substM = case maybeMonadName of
|
||||
Just m -> applySubstitution . Map.singleton m $ ConT ''Eff `AppT` esVar
|
||||
Nothing -> id
|
||||
|
||||
(origActionVars, actionCtx) = extractCtx typ
|
||||
actionVars = case maybeMonadName of
|
||||
Just m -> filter ((m /=) . tvName) origActionVars
|
||||
++ [kindedTVSpecified esName $ ListT `AppT` ConT ''Effect]
|
||||
Nothing -> origActionVars
|
||||
|
||||
#if MIN_VERSION_template_haskell(2,17,0)
|
||||
-- In GHC >= 9.0 it's possible to generate the following body:
|
||||
--
|
||||
-- e x1 .. xN = send (E @ty1 .. @tyN x1 .. xN)
|
||||
--
|
||||
-- because specificities of constructor variables are exposed.
|
||||
--
|
||||
-- This allows to generate functions for such effects:
|
||||
--
|
||||
-- type family F ty :: Type
|
||||
-- data AmbEff :: Effect where
|
||||
-- AmbEff :: Int -> AmbEff m (F ty)
|
||||
--
|
||||
-- Sadly the version for GHC < 9 will not compile due to ambiguity error.
|
||||
let fnBody =
|
||||
let tvFlag = \case
|
||||
PlainTV _ flag -> flag
|
||||
KindedTV _ flag _ -> flag
|
||||
|
||||
tyApps = (`mapMaybe` origActionVars) $ \v -> case tvFlag v of
|
||||
InferredSpec -> Nothing
|
||||
SpecifiedSpec -> Just $ if maybeMonadName == Just (tvName v)
|
||||
then ConT ''Eff `AppT` esVar
|
||||
else VarT (tvName v)
|
||||
|
||||
effCon = if makeSig
|
||||
then foldl' AppTypeE (ConE name) tyApps
|
||||
else ConE name
|
||||
in VarE 'send `AppE` foldl' (\f -> AppE f . VarE) effCon fnArgs
|
||||
#else
|
||||
-- In GHC < 9.0, generate the following body:
|
||||
--
|
||||
-- e :: E v1 .. vN :> es => x1 -> .. -> xK -> E v1 .. vN (Eff es) r
|
||||
-- e x1 .. xK = send (E x1 .. xN :: E v1 .. vK (Eff es) r)
|
||||
let fnBody =
|
||||
let effOp = foldl' (\f -> AppE f . VarE) (ConE name) fnArgs
|
||||
effSig = effTy `AppT` (ConT ''Eff `AppT` esVar) `AppT` substM resTy
|
||||
in if makeSig
|
||||
then VarE 'send `AppE` SigE effOp effSig
|
||||
else VarE 'send `AppE` effOp
|
||||
#endif
|
||||
let fnSig = ForallT actionVars
|
||||
(UInfixT effTy ''(:>) esVar : actionCtx)
|
||||
(makeTyp esVar substM resTy actionParams)
|
||||
|
||||
let rest = FunD fnName [Clause (VarP <$> fnArgs) (NormalB fnBody) []]
|
||||
: maybeToList ((`InfixD` name) <$> fixity)
|
||||
(++ rest) <$> withHaddock name [SigD fnName fnSig | makeSig]
|
||||
|
||||
----------------------------------------
|
||||
-- Helpers
|
||||
|
||||
toSmartConName :: String -> String
|
||||
toSmartConName = \case
|
||||
(':' : xs) -> xs
|
||||
(x : xs) -> toLower x : xs
|
||||
_ -> error "empty constructor name"
|
||||
|
||||
extractCtx :: Type -> ([TyVarBndrSpec], Cxt)
|
||||
extractCtx = \case
|
||||
ForallT vars ctx _ -> (vars, ctx)
|
||||
ty -> error $ "unexpected type: " ++ show ty
|
||||
|
||||
extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type))
|
||||
extractParams = \case
|
||||
ForallT _ _ ty -> extractParams ty
|
||||
SigT ty _ -> extractParams ty
|
||||
ParensT ty -> extractParams ty
|
||||
ArrowT `AppT` a `AppT` ty -> do
|
||||
(args, ret) <- extractParams ty
|
||||
pure (a : args, ret)
|
||||
#if MIN_VERSION_template_haskell(2,17,0)
|
||||
MulArrowT `AppT` _ `AppT` a `AppT` ty -> do
|
||||
(args, ret) <- extractParams ty
|
||||
pure (a : args, ret)
|
||||
#endif
|
||||
effTy `AppT` monadTy `AppT` resTy -> case monadTy of
|
||||
VarT monadName -> pure ([], (effTy, Right monadName, resTy))
|
||||
ConT eff `AppT` VarT esName
|
||||
| eff == ''Eff -> pure ([], (effTy, Left esName, resTy))
|
||||
ty -> fail $ "Invalid instantiation of the monad parameter: " ++ pprint ty
|
||||
ty -> fail $ "Unexpected type: " ++ pprint ty
|
||||
|
||||
makeTyp :: Type -> (Type -> Type) -> Type -> [Type] -> Type
|
||||
makeTyp esVar substM resTy = \case
|
||||
[] -> ConT ''Eff `AppT` esVar `AppT` substM resTy
|
||||
(p : ps) -> ArrowT `AppT` substM p `AppT` makeTyp esVar substM resTy ps
|
||||
|
||||
withHaddock :: Name -> [Dec] -> Q [Dec]
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
withHaddock name dec = withDecsDoc
|
||||
("Perform the operation '" ++ nameBase name ++ "'.") (pure dec)
|
||||
#else
|
||||
withHaddock _ dec = pure dec
|
||||
#endif
|
||||
|
||||
checkRequiredExtensions :: Q ()
|
||||
checkRequiredExtensions = do
|
||||
missing <- filterM (fmap not . isExtEnabled) exts
|
||||
let ppMissing = map (\ext -> "{-# LANGUAGE " <> show ext <> " #-}") missing
|
||||
unless (null missing) . fail . unlines $
|
||||
[ "Generating functions requires additional language extensions.\n"
|
||||
, "You can enable them by adding them to the 'default-extensions'"
|
||||
, "field in the .cabal file or the following pragmas to the beginning"
|
||||
, "of the source file:\n"
|
||||
] ++ ppMissing
|
||||
where
|
||||
exts = [ FlexibleContexts
|
||||
, ScopedTypeVariables
|
||||
#if MIN_VERSION_template_haskell(2,17,0)
|
||||
, TypeApplications
|
||||
#endif
|
||||
, TypeFamilies
|
||||
, TypeOperators
|
||||
]
|
||||
143
effectful-th/tests/ThTests.hs
Normal file
143
effectful-th/tests/ThTests.hs
Normal file
@ -0,0 +1,143 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Main where
|
||||
|
||||
import Data.Kind (Type)
|
||||
import GHC.TypeLits
|
||||
|
||||
import Effectful
|
||||
import Effectful.TH
|
||||
|
||||
main :: IO ()
|
||||
main = pure () -- only compilation tests
|
||||
|
||||
data SimpleADT (m :: Type -> Type) (a :: Type)
|
||||
= SimpleADTC1 Int
|
||||
| SimpleADTC2 String
|
||||
|
||||
makeEffect ''SimpleADT
|
||||
|
||||
data ADTSyntax1 (m :: Type -> Type) (a :: Type)
|
||||
= a ~ Int => ADTSyntax1C String
|
||||
|
||||
makeEffect ''ADTSyntax1
|
||||
|
||||
data ADTSyntax2 (m :: Type -> Type) (a :: Type)
|
||||
= a ~ Int => ADTSyntax2C1 Int
|
||||
| a ~ String => ADTSyntax2C2 String
|
||||
|
||||
makeEffect ''ADTSyntax2
|
||||
|
||||
data ADTSyntax3 (m :: Type -> Type) (a :: Type)
|
||||
= Show a => ADTSyntax3C a
|
||||
|
||||
makeEffect ''ADTSyntax3
|
||||
|
||||
data GADTSyntax :: Effect where
|
||||
GADTSyntaxC1 :: Int -> GADTSyntax m Int
|
||||
GADTSyntaxC2 :: String -> GADTSyntax m String
|
||||
GADTSyntaxC3 :: IOE :> es => Bool -> GADTSyntax (Eff es) a
|
||||
|
||||
makeEffect ''GADTSyntax
|
||||
|
||||
data Fields (m :: Type -> Type) (a :: Type)
|
||||
= FieldsC { fieldsCF1 :: Int, fieldsCF2 :: String }
|
||||
|
||||
makeEffect ''Fields
|
||||
|
||||
newtype Newtype1 (m :: Type -> Type) (a :: Type)
|
||||
= Newtype1C Int
|
||||
|
||||
makeEffect ''Newtype1
|
||||
|
||||
newtype Newtype2 :: Effect where
|
||||
Newtype2C :: String -> Newtype2 m a
|
||||
|
||||
makeEffect ''Newtype2
|
||||
|
||||
data Instance = ADTI | GADTI | NTI | MMI
|
||||
|
||||
data family Family (s :: Instance) (m :: Type -> Type) a
|
||||
|
||||
data instance Family 'ADTI _ _ = ADTIC1 Int | ADTIC2 String
|
||||
makeEffect 'ADTIC1
|
||||
|
||||
data instance Family 'GADTI _ _ where
|
||||
GADTIC1 :: Int -> Family 'GADTI m Int
|
||||
GADTIC2 :: String -> Family 'GADTI m String
|
||||
makeEffect 'GADTIC1
|
||||
|
||||
newtype instance Family 'NTI _ _ = NTIC Int
|
||||
makeEffect 'NTIC
|
||||
|
||||
data instance Family 'MMI m (_ m) where
|
||||
MMIC1 :: f m -> Family 'MMI m (f m)
|
||||
MMIC2 :: (forall x. m x -> m (f m)) -> Family 'MMI m (f m)
|
||||
|
||||
makeEffect 'MMIC1
|
||||
|
||||
data Complex :: Effect where
|
||||
Mono :: Int -> Complex m Bool
|
||||
Poly :: a -> Complex m a
|
||||
PolyIn :: a -> Complex m Bool
|
||||
PolyOut :: Int -> Complex m a
|
||||
Lots :: a -> b -> c -> d -> e -> f -> Complex m ()
|
||||
Nested :: Maybe b -> Complex m (Maybe a)
|
||||
MultiNested :: (Maybe a, [b]) -> Complex m (Maybe a, [b])
|
||||
Existential :: (forall e. e -> Maybe e) -> Complex m a
|
||||
LotsNested :: Maybe a -> [b] -> (c, c) -> Complex m (a, b, c)
|
||||
Dict :: Ord a => a -> Complex m a
|
||||
MultiDict :: (Eq a, Ord b, Enum a, Num c)
|
||||
=> a -> b -> c -> Complex m ()
|
||||
IndexedMono :: f 0 -> Complex m Int
|
||||
IndexedPoly :: forall f (n :: Nat) m . f n -> Complex m (f (n + 1))
|
||||
IndexedPolyDict :: KnownNat n => f n -> Complex m Int
|
||||
|
||||
makeEffect ''Complex
|
||||
|
||||
data HOEff :: Effect where
|
||||
EffArgMono :: m () -> HOEff m ()
|
||||
EffArgPoly :: m a -> HOEff m a
|
||||
EffArgComb :: m a -> (m a -> m b) -> HOEff m b
|
||||
EffRank2 :: (forall x. m x -> m (Maybe x)) -> HOEff m a
|
||||
|
||||
makeEffect ''HOEff
|
||||
|
||||
data ComplexEffArgs b c :: Effect where
|
||||
EffMono :: Int -> ComplexEffArgs Int String m Bool
|
||||
EffPoly1 :: a -> ComplexEffArgs a b m a
|
||||
EffPoly2 :: a -> ComplexEffArgs a (Maybe a) m Bool
|
||||
EffPolyFree :: String -> ComplexEffArgs a b m Int
|
||||
EffSame1 :: ComplexEffArgs a a m a
|
||||
EffSame2 :: ComplexEffArgs b b m a
|
||||
EffHO :: m b -> ComplexEffArgs b Int m String
|
||||
|
||||
makeEffect ''ComplexEffArgs
|
||||
|
||||
data HKEffArgs f g :: Effect where
|
||||
HKRank2 :: (forall x . f x -> g x) -> HKEffArgs f g m a
|
||||
|
||||
makeEffect ''HKEffArgs
|
||||
|
||||
data ByCon :: Effect where
|
||||
ByConA :: Int -> ByCon m String
|
||||
ByConB :: Int -> ByCon m String
|
||||
|
||||
makeEffect 'ByConA
|
||||
|
||||
data ByField :: Effect where
|
||||
ByFieldA :: { byFieldAf :: Int } -> ByField m Int
|
||||
ByFieldB :: { byFieldBf :: Int } -> ByField m Int
|
||||
|
||||
makeEffect 'byFieldAf
|
||||
|
||||
type family F ty
|
||||
data AmbEff :: Effect where
|
||||
AmbEff :: Int -> AmbEff m (F ty)
|
||||
|
||||
-- This only works in GHC >= 9, otherwise the 'ty' variable is ambiguous.
|
||||
#if __GLASGOW_HASKELL__ >= 900
|
||||
makeEffect 'AmbEff
|
||||
#endif
|
||||
Loading…
Reference in New Issue
Block a user