fused-effects-th 0.1.0.1 → 0.1.0.2
raw patch · 4 files changed
+84/−52 lines, 4 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−2
- fused-effects-th.cabal +8/−6
- src/Control/Effect/TH.hs +58/−44
- test/Spec.hs +12/−0
CHANGELOG.md view
@@ -3,6 +3,10 @@ `fused-effects-th` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.1.0.2++* Fix a bug where typeclass constraints on GADT constructors were being ignored.+ ## 0.1.0.1 * Fix a bug where explicit kind signatures around a monad type variable@@ -10,7 +14,7 @@ ## 0.1.0.0 -* Initially created.+* Initial release. [1]: https://pvp.haskell.org-[2]: https://github.com/patrickt/fused-effects-th/releases+[2]: https://github.com/fused-effects/fused-effects-th/releases
fused-effects-th.cabal view
@@ -1,10 +1,10 @@ cabal-version: 2.4 name: fused-effects-th-version: 0.1.0.1+version: 0.1.0.2 synopsis: Template Haskell helpers for fused-effects. description: This package provides Template Haskell splices that wrap the smart constructors needed for declaring new effects when using the fused-effects effect system.-homepage: https://github.com/patrickt/fused-effects-th-bug-reports: https://github.com/patrickt/fused-effects-th/issues+homepage: https://github.com/fused-effects/fused-effects-th+bug-reports: https://github.com/fused-effects/fused-effects-th/issues license: BSD-3-Clause license-file: LICENSE author: Patrick Thomson@@ -14,14 +14,16 @@ build-type: Simple extra-doc-files: README.md CHANGELOG.md-tested-with: GHC == 8.8.3+tested-with: GHC == 8.6.5+ GHC == 8.8.3+ GHC == 8.10.2 source-repository head type: git- location: https://github.com/patrickt/fused-effects-th.git+ location: https://github.com/fused-effects/fused-effects-th.git common common-options- build-depends: base >= 4.9 && < 4.15+ build-depends: base >= 4.12 && < 4.15 , fused-effects ^>= 1.1 , template-haskell >= 2.12 && < 2.17
src/Control/Effect/TH.hs view
@@ -13,23 +13,25 @@ import Control.Monad (join) import Data.Char (toLower) import Data.Foldable+import Data.Monoid (Ap (..)) import Data.Traversable-import Language.Haskell.TH as TH+import Language.Haskell.TH (appT, arrowT, mkName, varT)+import qualified Language.Haskell.TH as TH data PerEffect = PerEffect- { typeName :: TH.Name,- effectTypeVars :: [TH.TyVarBndr],- monadTypeVar :: TH.TyVarBndr,+ { effectType :: TH.TypeQ,+ effectTyVarCount :: Int, forallConstructor :: TH.Con } data PerDecl = PerDecl- { ctorName :: TH.Name,+ { ctorArgs :: [TH.TypeQ],+ ctorConstraints :: [TH.TypeQ],+ ctorName :: TH.Name,+ ctorTyVars :: [TH.TyVarBndr], functionName :: TH.Name,- ctorArgs :: [TH.Type],- returnType :: TH.Type,- perEffect :: PerEffect,- extraTyVars :: [TyVarBndr]+ gadtReturnType :: TH.TypeQ,+ perEffect :: PerEffect } -- | Given an effect type, this splice generates functions that create per-constructor request functions.@@ -62,36 +64,41 @@ -- -- 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 :: TH.Name -> TH.DecsQ makeSmartConstructors typ =+ -- Lookup the provided type name. 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)+ -- If it's a type constructor, record its type name.+ TH.TyConI (TH.DataD _ctx tn tvs _kind constructors _derive) ->+ let perEffect = PerEffect (TH.conT tn) (length tvs)+ in getAp (foldMap (Ap . makeDeclaration . perEffect) constructors)+ -- Die otherwise.+ other ->+ fail ("Can't generate definitions for a non-data-constructor: " <> TH.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)+ -- Start by extracting the relevant parts of this particular constructor.+ (names, ctorArgs, constraints, returnType, ctorTyVars) <- case forallConstructor of+ TH.ForallC vars ctx (TH.GadtC names bangtypes (TH.AppT _ final)) ->+ pure (names, fmap snd bangtypes, ctx, final, 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)+ -- Then iterate over the names of the constructors, emitting an injected+ -- method per name. fmap join . for names $ \ctorName -> do- let downcase = \case- x : xs -> toLower x : xs- [] -> []- functionName = TH.mkName . downcase . TH.nameBase $ ctorName- let decl = PerDecl {..}+ let downcase (x : xs) = mkName (toLower x : xs)+ downcase [] = error "attempted to downcase empty name"+ decl =+ PerDecl+ { ctorName = ctorName,+ functionName = downcase . TH.nameBase $ ctorName,+ ctorArgs = fmap pure ctorArgs,+ gadtReturnType = pure returnType,+ perEffect = perEffect,+ ctorTyVars = ctorTyVars,+ ctorConstraints = fmap pure constraints+ } sign <- makeSignature decl func <- makeFunction decl prag <- makePragma decl@@ -101,27 +108,34 @@ makePragma PerDecl {..} = TH.pragInlD functionName TH.Inlinable TH.FunLike TH.AllPhases -makeFunction :: PerDecl -> Q Dec+makeFunction :: PerDecl -> TH.DecQ makeFunction d = TH.funD (functionName d) [makeClause d] -makeClause :: PerDecl -> ClauseQ+makeClause :: PerDecl -> TH.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+ -- Glue together the parameter to 'send', fully applied+ applies = foldl' (\e n -> e `TH.appE` TH.varE n) (TH.conE ctorName) names+ -- A source of a, b, c... names for function parameters. 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 (rest ++ [monadTypeVar, sigVar]) (TH.cxt [hasConstraint]) folded)+ let sigVar = mkName "sig"+ (rest, monadTV) = (init ctorTyVars, last ctorTyVars)+ getTyVar =+ varT . \case+ TH.PlainTV n -> n+ TH.KindedTV n _ -> n+ monadName = getTyVar monadTV+ -- Build the parameter to Has by consulting the number of required type parameters.+ invocation = foldl' appT effectType (fmap getTyVar (take (effectTyVarCount - 2) rest))+ hasConstraint = [t|Has ($(invocation)) $(varT sigVar) $(monadName)|]+ -- Build the type signature by folding with (->) over the function arguments as needed.+ foldedSig = foldr (\a b -> arrowT `appT` a `appT` b) (monadName `appT` gadtReturnType) ctorArgs+ -- Glue together the Has and the per-constructor constraints.+ allConstraints = TH.cxt (hasConstraint : ctorConstraints)+ in TH.sigD functionName (TH.forallT (rest ++ [monadTV, TH.plainTV sigVar]) allConstraints foldedSig)
test/Spec.hs view
@@ -27,8 +27,20 @@ data Go (m :: Type -> Type) k where App :: String -> Go m () +data Same (m :: Type -> Type) k where+ Same :: Same m ()++data Kinded (s :: Type) (m :: Type -> Type) k where+ Kinded :: s -> Kinded s m ()++data Constrained (m :: Type -> Type) k where+ Shown :: Show a => a -> Constrained m a+ makeSmartConstructors ''Go makeSmartConstructors ''State+makeSmartConstructors ''Same+makeSmartConstructors ''Kinded+makeSmartConstructors ''Constrained -- Need to ensure that if a constructor introduces a new type variable, -- that it is introduced in the corresponding invocation. The question is