deep-transformations 0.2.1.2 → 0.2.2
raw patch · 6 files changed
+88/−28 lines, 6 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- deep-transformations.cabal +3/−3
- src/Transformation/Deep/TH.hs +34/−9
- src/Transformation/Shallow/TH.hs +35/−8
- test/RepMin.hs +5/−4
- test/RepMinAuto.hs +5/−4
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for deep-transformations +## 0.2.2 -- 2023-06-25++* Updated for GHC 9.8.1 and TH 2.22+* Updated TH code to use `DuplicateRecordFields` and `OverloadedRecordDot` when enabled+* Fixed warnings in tests+ ## 0.2.1.2 -- 2023-06-25 * Bumped the upper bound of the `template-haskell` dependency
deep-transformations.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: deep-transformations-version: 0.2.1.2+version: 0.2.2 synopsis: Deep natural and unnatural tree transformations, including attribute grammars description: @@ -22,7 +22,7 @@ category: Control, Generics build-type: Custom cabal-version: >=1.10-tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4+tested-with: GHC==9.2.2, GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 extra-source-files: README.md, CHANGELOG.md source-repository head type: git@@ -45,7 +45,7 @@ ghc-options: -Wall build-depends: base >= 4.11 && < 5, rank2classes >= 1.4.1 && < 1.6, transformers >= 0.5 && < 0.7,- template-haskell >= 2.11 && < 2.21, generic-lens >= 1.2 && < 2.3+ template-haskell >= 2.11 && < 2.22, generic-lens >= 1.2 && < 2.3 default-language: Haskell2010 test-suite doctests
src/Transformation/Deep/TH.hs view
@@ -18,7 +18,7 @@ import Data.Functor.Const (Const(getConst)) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-import Language.Haskell.TH+import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ) import qualified Transformation@@ -95,18 +95,30 @@ NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c]) _ -> fail "deriveApply: tyCon may not be a type synonym." + let reifySynonyms (ConT name) = TH.reify name >>= reifySynonymInfo name+ reifySynonyms (AppT t1 t2) = AppT <$> reifySynonyms t1 <*> reifySynonyms t2+ reifySynonyms t = pure t+ reifySynonymInfo _ (TyConI (TySynD _ [] t)) = reifySynonyms t+ reifySynonymInfo name _ = pure (ConT name) #if MIN_VERSION_template_haskell(2,17,0)+ reifyTVKindSynonyms (KindedTV v s k) = KindedTV v s <$> reifySynonyms k+#else+ reifyTVKindSynonyms (KindedTV v k) = KindedTV v <$> reifySynonyms k+#endif+ reifyTVKindSynonyms tv = pure tv+ tyVars' <- traverse reifyTVKindSynonyms tyVars+#if MIN_VERSION_template_haskell(2,17,0) let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) :- KindedTV tyVar' _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+ KindedTV tyVar' _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars' apply t (PlainTV name _) = appT t (varT name) apply t (KindedTV name _ _) = appT t (varT name) #else let (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT) :- KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars+ KindedTV tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars' apply t (PlainTV name) = appT t (varT name) apply t (KindedTV name _) = appT t (varT name) #endif- instanceType = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars)+ instanceType = foldl apply (conT tyConName) (reverse $ drop 2 $ reverse tyVars') putQ (Deriving tyConName tyVar' tyVar) return (instanceType, cs)@@ -152,7 +164,7 @@ newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genDeepmapField (varE t) fieldType baseConstraint deepConstraint fullConstraint- (appE (varE fieldName) (varE x)) id+ (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP t, x `asP` recP name []] body [] genDeepmapClause baseConstraint deepConstraint fullConstraint instanceType@@ -197,8 +209,8 @@ constraintsAndFields = map newField fields append a b = [| $(a) <> $(b) |] newField :: VarBangType -> Q ([Type], Exp)- newField (fieldName, _, fieldType) = genFoldMapField (varE t) fieldType baseConstraint deepConstraint- fullConstraint (appE (varE fieldName) (varE x)) id+ newField (fieldName, _, fieldType) =+ genFoldMapField (varE t) fieldType baseConstraint deepConstraint fullConstraint (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP t, x `asP` recP name []] (normalB body) [] genFoldMapClause baseConstraint deepConstraint fullConstraint instanceType@@ -253,8 +265,7 @@ newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>)- <$> genField (varE f) fieldType baseConstraint deepConstraint fullConstraint- (appE (varE fieldName) (varE x)) id+ <$> genField (varE f) fieldType baseConstraint deepConstraint fullConstraint (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP f, x `asP` recP name []] (normalB body) [] genTraverseClause genField baseConstraint deepConstraint fullConstraint instanceType@@ -340,3 +351,17 @@ SigT ty _kind -> genTraverseField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap ParensT ty -> genTraverseField trans ty baseConstraint deepConstraint fullConstraint fieldAccess wrap _ -> (,) [] <$> [| pure $fieldAccess |]++getFieldOf :: Name -> Name -> Q Exp+getFieldOf = getFieldOfE . varE++getFieldOfE :: Q Exp -> Name -> Q Exp+getFieldOfE record field = do+#if MIN_VERSION_template_haskell(2,19,0)+ dotty <- TH.isExtEnabled TH.OverloadedRecordDot+ if dotty+ then TH.getFieldE record (TH.nameBase field)+ else appE (varE field) record+#else+ appE (varE field) record+#endif
src/Transformation/Shallow/TH.hs view
@@ -18,7 +18,7 @@ import Data.Functor.Const (Const(getConst)) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid, (<>))-import Language.Haskell.TH+import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ) import qualified Transformation@@ -91,14 +91,27 @@ NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c]) _ -> fail "deriveApply: tyCon may not be a type synonym." + let reifySynonyms (ConT name) = TH.reify name >>= reifySynonymInfo name+ reifySynonyms (AppT t1 t2) = AppT <$> reifySynonyms t1 <*> reifySynonyms t2+ reifySynonyms t = pure t+ reifySynonymInfo _ (TyConI (TySynD _ [] t)) = reifySynonyms t+ reifySynonymInfo name _ = pure (ConT name) #if MIN_VERSION_template_haskell(2,17,0)- let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars- instanceType = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars)+ reifyTVKindSynonyms (KindedTV v s k) = KindedTV v s <$> reifySynonyms k+#else+ reifyTVKindSynonyms (KindedTV v k) = KindedTV v <$> reifySynonyms k+#endif+ reifyTVKindSynonyms tv = pure tv+ tyVars' <- traverse reifyTVKindSynonyms tyVars++#if MIN_VERSION_template_haskell(2,17,0)+ let (KindedTV tyVar _ (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars'+ instanceType = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars') apply t (PlainTV name _) = appT t (varT name) apply t (KindedTV name _ _) = appT t (varT name) #else- let (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars- instanceType = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars)+ let (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT) : _) = reverse tyVars'+ instanceType = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars') apply t (PlainTV name) = appT t (varT name) apply t (KindedTV name _) = appT t (varT name) #endif@@ -142,7 +155,7 @@ newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>)- <$> genShallowmapField (varE t) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+ <$> genShallowmapField (varE t) fieldType shallowConstraint baseConstraint (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP t, x `asP` recP name []] body [] genShallowmapClause shallowConstraint baseConstraint instanceType@@ -184,7 +197,7 @@ append a b = [| $(a) <> $(b) |] newField :: VarBangType -> Q ([Type], Exp) newField (fieldName, _, fieldType) =- genFoldMapField (varE t) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+ genFoldMapField (varE t) fieldType shallowConstraint baseConstraint (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP t, x `asP` recP name []] (normalB body) [] genFoldMapClause shallowConstraint baseConstraint instanceType@@ -234,7 +247,7 @@ newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>)- <$> genField (varE f) fieldType shallowConstraint baseConstraint (appE (varE fieldName) (varE x)) id+ <$> genField (varE f) fieldType shallowConstraint baseConstraint (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> clause [varP f, x `asP` recP name []] (normalB body) [] genTraverseClause genField shallowConstraint baseConstraint instanceType@@ -304,3 +317,17 @@ SigT ty _kind -> genTraverseField trans ty shallowConstraint baseConstraint fieldAccess wrap ParensT ty -> genTraverseField trans ty shallowConstraint baseConstraint fieldAccess wrap _ -> (,) [] <$> [| pure $fieldAccess |]++getFieldOf :: Name -> Name -> Q Exp+getFieldOf = getFieldOfE . varE++getFieldOfE :: Q Exp -> Name -> Q Exp+getFieldOfE record field = do+#if MIN_VERSION_template_haskell(2,19,0)+ dotty <- TH.isExtEnabled TH.OverloadedRecordDot+ if dotty+ then TH.getFieldE record (TH.nameBase field)+ else appE (varE field) record+#else+ appE (varE field) record+#endif
test/RepMin.hs view
@@ -1,10 +1,11 @@ {-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving,- TypeFamilies, UndecidableInstances #-}+ TypeFamilies, TypeOperators, UndecidableInstances #-} -- | The RepMin example - replicate a binary tree with all leaves replaced by the minimal leaf value. module RepMin where import Data.Functor.Identity+import Data.Kind (Type) import qualified Rank2 import Transformation (Transformation(..)) import Transformation.AG (Inherited(..), Synthesized(..))@@ -14,9 +15,9 @@ import qualified Transformation.Full as Full -- | tree data type-data Tree a (f' :: * -> *) (f :: * -> *) = Fork{left :: f (Tree a f' f'),- right:: f (Tree a f' f')}- | Leaf{leafValue :: f a}+data Tree a (f' :: Type -> Type) (f :: Type -> Type) = Fork{left :: f (Tree a f' f'),+ right:: f (Tree a f' f')}+ | Leaf{leafValue :: f a} -- | tree root data Root a f' f = Root{root :: f (Tree a f' f')}
test/RepMinAuto.hs view
@@ -1,11 +1,12 @@ {-# Language DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,- StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-}+ StandaloneDeriving, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances #-} -- | The RepMin example with automatic derivation of attributes. module RepMinAuto where import Data.Functor.Identity+import Data.Kind (Type) import Data.Semigroup (Min(Min, getMin)) import GHC.Generics (Generic) import qualified Rank2@@ -22,9 +23,9 @@ import qualified Transformation.Shallow.TH -- | tree data type-data Tree a (f' :: * -> *) (f :: * -> *) = Fork{left :: f (Tree a f' f'),- right:: f (Tree a f' f')}- | Leaf{leafValue :: f a}+data Tree a (f' :: Type -> Type) (f :: Type -> Type) = Fork{left :: f (Tree a f' f'),+ right:: f (Tree a f' f')}+ | Leaf{leafValue :: f a} -- | tree root data Root a f' f = Root{root :: f (Tree a f' f')}