diff --git a/data-effects-th.cabal b/data-effects-th.cabal --- a/data-effects-th.cabal +++ b/data-effects-th.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: data-effects-th -version: 0.4.0.2 +version: 0.4.1.0 -- A short (one-line) description of the package. synopsis: Template Haskell utilities for the data-effects library. @@ -42,7 +42,7 @@ source-repository head type: git location: https://github.com/sayo-hs/data-effects - tag: v0.4.0.2 + tag: v0.4.1.0 subdir: data-effects-th library @@ -67,7 +67,7 @@ lens >= 5.2.3 && < 5.4, mtl >= 2.3 && < 2.4, extra >= 1.7.14 && < 1.9, - containers >= 0.6.5 && < 0.8, + containers >= 0.6.5 && < 0.9, either ^>= 5.0.2, text >= 2.0 && < 2.2, data-default >= 0.7.1 && < 0.9, diff --git a/src/Data/Effect/HFunctor/TH.hs b/src/Data/Effect/HFunctor/TH.hs --- a/src/Data/Effect/HFunctor/TH.hs +++ b/src/Data/Effect/HFunctor/TH.hs @@ -13,12 +13,15 @@ This module provides @TemplateHaskell@ functions to derive an instance of t'Data.Effect.HFunctor.HFunctor'. -} -module Data.Effect.HFunctor.TH where +module Data.Effect.HFunctor.TH ( + module Data.Effect.HFunctor.TH, + Infinite ((:<)), +) where import Data.Effect.HFunctor.TH.Internal (deriveHFunctor) import Data.Effect.TH.Internal (analyzeData) import Data.Functor ((<&>)) -import Data.List.Infinite (Infinite) +import Data.List.Infinite (Infinite ((:<))) import Language.Haskell.TH (Dec, Name, Q, reify) import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Syntax (nameBase) diff --git a/src/Data/Effect/HFunctor/TH/Internal.hs b/src/Data/Effect/HFunctor/TH/Internal.hs --- a/src/Data/Effect/HFunctor/TH/Internal.hs +++ b/src/Data/Effect/HFunctor/TH/Internal.hs @@ -53,6 +53,7 @@ module Data.Effect.HFunctor.TH.Internal where import Control.Monad (replicateM, zipWithM) +import Data.Effect (PolyHFunctor) import Data.Effect.HFunctor (HFunctor, hfmap) import Data.Effect.TH.Internal ( ConInfo (ConInfo), @@ -108,7 +109,7 @@ hfArgNames = map (VarT . tyVarName) hfArgs -- The algorithm is based on: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/derive-functor - hfmapClause :: ConInfo -> Q Clause + hfmapClause :: ConInfo -> Q (Bool, Clause) hfmapClause ConInfo{..} = do let f = case conGadtReturnType of Nothing -> last initArgs @@ -117,24 +118,23 @@ _ `AppT` (VarT n `SigT` _) `AppT` _ -> PlainTV n () _ -> error $ "Encounted unknown structure: " ++ pprint t - hfmapE :: TH.Type -> Exp -> Q Exp + hfmapE :: TH.Type -> Exp -> Q (Bool, Exp) hfmapE tk - | fNotOccurs t = pure + | fNotOccurs t = pure . (True,) | otherwise = \x -> case t of - VarT n `AppT` a | n == tyVarName f && fNotOccurs a -> pure $ mapFn `AppE` x + VarT n `AppT` a | n == tyVarName f && fNotOccurs a -> pure (True, mapFn `AppE` x) ArrowT `AppT` c `AppT` d -> - wrapLam \y -> hfmapE d . (x `AppE`) =<< cohfmapE c y + (False,) <$> wrapLam \y -> fmap snd . hfmapE d . (x `AppE`) =<< cohfmapE c y g `AppT` a | fNotOccurs g -> - ((VarE 'fmap `AppE`) <$> wrapLam (hfmapE a)) <&> (`AppE` x) + (True,) <$> (((VarE 'fmap `AppE`) <$> wrapLam (fmap snd . hfmapE a)) <&> (`AppE` x)) ff `AppT` g `AppT` a | fNotOccurs ff && fNotOccurs a -> - ((VarE 'hfmap `AppE`) <$> wrapLam (hfmapE $ g `AppT` a)) <&> (`AppE` x) - -- todo: tuple support + (True,) <$> (((VarE 'hfmap `AppE`) <$> wrapLam (fmap snd . hfmapE (g `AppT` a))) <&> (`AppE` x)) ForallT _ _ a -> hfmapE a x _ -> - case mapTupleE hfmapE t x of - Just e -> e + case mapTupleE ((fmap snd .) . hfmapE) t x of + Just e -> (True,) <$> e Nothing -> fail $ "Encounted unsupported structure: " ++ pprint t where t = unkindType tk @@ -147,7 +147,7 @@ | n == tyVarName f && fNotOccurs a -> fail $ "Functor type variable occurs in contravariant position: " ++ pprint t ArrowT `AppT` c `AppT` d -> - wrapLam \y -> cohfmapE d . (x `AppE`) =<< hfmapE c y + wrapLam \y -> (cohfmapE d . (x `AppE`)) . snd =<< hfmapE c y g `AppT` a | fNotOccurs g -> ((VarE 'fmap `AppE`) <$> wrapLam (cohfmapE a)) <&> (`AppE` x) @@ -166,8 +166,9 @@ vars <- replicateM (length conArgs) (newName "x") mappedArgs <- zipWithM hfmapE (map snd conArgs) (map VarE vars) - let body = foldl' AppE (ConE conName) mappedArgs - pure $ Clause [VarP mapFnName, ConP conName [] (map VarP vars)] (NormalB body) [] + let body = foldl' AppE (ConE conName) (map snd mappedArgs) + isPolynomial = all fst mappedArgs + pure (isPolynomial, Clause [VarP mapFnName, ConP conName [] (map VarP vars)] (NormalB body) []) cxt <- manualCxt $ @@ -188,16 +189,25 @@ (T.intercalate ", " $ map ((\t -> "‘" <> t <> "’") . T.pack . nameBase . tyVarName) hfArgs) ) - hfmapDecls <- FunD 'hfmap <$> mapM hfmapClause cons - let fnInline = PragmaD (InlineP 'hfmap Inline FunLike AllPhases) + hfmapClauses <- mapM hfmapClause cons + let hfmapDecls = FunD 'hfmap $ map snd hfmapClauses + fnInline = PragmaD (InlineP 'hfmap Inline FunLike AllPhases) + isPolynomial = all fst hfmapClauses + h = foldl' AppT (ConT name) hfArgNames - pure - [ InstanceD + pure $ + InstanceD Nothing (fromMaybe [cxt] $ decomposeTupleT cxt) - (ConT ''HFunctor `AppT` foldl' AppT (ConT name) hfArgNames) + (ConT ''HFunctor `AppT` h) [hfmapDecls, fnInline] - ] + : [ InstanceD + Nothing + [] + (ConT ''PolyHFunctor `AppT` h) + [] + | isPolynomial + ] wrapLam :: (Exp -> Q Exp) -> Q Exp wrapLam f = do diff --git a/src/Data/Effect/TH.hs b/src/Data/Effect/TH.hs --- a/src/Data/Effect/TH.hs +++ b/src/Data/Effect/TH.hs @@ -32,6 +32,7 @@ noGeneratePerformerSignature, noGenerateLabel, noGenerateOrderInstance, + Infinite ((:<)), ) where import Control.Monad.Reader (ask, runReaderT) @@ -63,6 +64,7 @@ taggedPerformerConf, ) import Data.Function ((&)) +import Data.List.Infinite (Infinite ((:<))) import Language.Haskell.TH (Dec, Name, Q, Type (TupleT)) makeEffectF :: Name -> Q [Dec]