data-effects-th 0.4.0.2 → 0.4.1.0

raw patch · 4 files changed

+39/−24 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• data-effects-th.cabal +3/−3
• src/Data/Effect/HFunctor/TH.hs +5/−2
• src/Data/Effect/HFunctor/TH/Internal.hs +29/−19
• src/Data/Effect/TH.hs +2/−0

@@ -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,

@@ -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)

@@ -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

@@ -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]