From b77e9c3d65dbd4df4ff02fdd326c0b843dbf684e Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Tue, 22 Feb 2022 21:39:14 +0100 Subject: [PATCH] Add effectful-th based on the code from cleff (#60) --- .github/workflows/haskell-ci.yml | 36 +++-- cabal.project | 5 +- doctest.sh | 1 + effectful-th/CHANGELOG.md | 2 + effectful-th/LICENSE | 64 ++++++++ effectful-th/effectful-th.cabal | 75 +++++++++ effectful-th/src/Effectful/TH.hs | 265 +++++++++++++++++++++++++++++++ effectful-th/tests/ThTests.hs | 143 +++++++++++++++++ 8 files changed, 576 insertions(+), 15 deletions(-) create mode 100644 effectful-th/CHANGELOG.md create mode 100644 effectful-th/LICENSE create mode 100644 effectful-th/effectful-th.cabal create mode 100644 effectful-th/src/Effectful/TH.hs create mode 100644 effectful-th/tests/ThTests.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 3a65452..9525f95 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -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 <> 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 diff --git a/cabal.project b/cabal.project index 8d38526..4e44357 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,4 @@ packages: - effectful/effectful.cabal - effectful-core/effectful-core.cabal + effectful-core/*.cabal + effectful-th/*.cabal + effectful/*.cabal diff --git a/doctest.sh b/doctest.sh index 55d2bbb..fd9c640 100755 --- a/doctest.sh +++ b/doctest.sh @@ -39,4 +39,5 @@ run_doctest() { } run_doctest effectful-core src +run_doctest effectful-th src run_doctest effectful src diff --git a/effectful-th/CHANGELOG.md b/effectful-th/CHANGELOG.md new file mode 100644 index 0000000..a413664 --- /dev/null +++ b/effectful-th/CHANGELOG.md @@ -0,0 +1,2 @@ +# effectful-th-0.1 (2022-??-??) +* Initial release. diff --git a/effectful-th/LICENSE b/effectful-th/LICENSE new file mode 100644 index 0000000..141acbc --- /dev/null +++ b/effectful-th/LICENSE @@ -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. diff --git a/effectful-th/effectful-th.cabal b/effectful-th/effectful-th.cabal new file mode 100644 index 0000000..324f527 --- /dev/null +++ b/effectful-th/effectful-th.cabal @@ -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 diff --git a/effectful-th/src/Effectful/TH.hs b/effectful-th/src/Effectful/TH.hs new file mode 100644 index 0000000..d821837 --- /dev/null +++ b/effectful-th/src/Effectful/TH.hs @@ -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 + ] diff --git a/effectful-th/tests/ThTests.hs b/effectful-th/tests/ThTests.hs new file mode 100644 index 0000000..cbce727 --- /dev/null +++ b/effectful-th/tests/ThTests.hs @@ -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