th-abstraction 0.4.3.0 → 0.4.4.0
raw patch · 6 files changed
+91/−19 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 +5/−0
- src/Language/Haskell/TH/Datatype.hs +51/−11
- test/Harness.hs +2/−2
- test/Main.hs +28/−3
- test/Types.hs +2/−0
- th-abstraction.cabal +3/−3
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for th-abstraction +## 0.4.4.0 -- 2022.07.23+* Support free variable substitution and infix resolution for+ `PromotedInfixT` and `PromotedUInfixT` on `template-haskell-2.19.0.0` or+ later.+ ## 0.4.3.0 -- 2021.08.30 * Make `applySubstitution` avoid capturing type variable binders when substituting into `forall`s.
src/Language/Haskell/TH/Datatype.hs view
@@ -1306,6 +1306,16 @@ ForallVisT `fmap` mapM resolve_tvb_syns tvbs `ap` resolveTypeSynonyms body #endif+#if MIN_VERSION_template_haskell(2,19,0)+ PromotedInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ return $ PromotedInfixT t1' n t2'+ PromotedUInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ return $ PromotedUInfixT t1' n t2'+#endif _ -> defaultCase f -- | Expand all of the type synonyms in a 'TypeArg'.@@ -1493,29 +1503,41 @@ resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTVKind resolveInfixT) vs <*> resolveInfixT t # endif+# if MIN_VERSION_template_haskell(2,19,0)+resolveInfixT (PromotedInfixT l o r)+ = promotedT o `appT` resolveInfixT l `appT` resolveInfixT r+resolveInfixT t@PromotedUInfixT{}+ = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)+# endif resolveInfixT t = return t gatherUInfixT :: Type -> InfixList-gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r)+gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o False (gatherUInfixT r)+# if MIN_VERSION_template_haskell(2,19,0)+gatherUInfixT (PromotedUInfixT l o r) = ilAppend (gatherUInfixT l) o True (gatherUInfixT r)+# endif gatherUInfixT t = ILNil t -- This can fail due to incompatible fixities resolveInfixT1 :: InfixList -> TypeQ resolveInfixT1 = go [] where- go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ- go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts)- go ts (ILCons l o r) =+ go :: [(Type,Name,Bool,Fixity)] -> InfixList -> TypeQ+ go ts (ILNil u) = return (foldl (\acc (l,o,p,_) -> mkConT p o `AppT` l `AppT` acc) u ts)+ go ts (ILCons l o p r) = do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o- let push = go ((l,o,ofx):ts) r+ let push = go ((l,o,p,ofx):ts) r case ts of- (l1,o1,o1fx):ts' ->+ (l1,o1,p1,o1fx):ts' -> case compareFixity o1fx ofx of- Just True -> go ((ConT o1 `AppT` l1 `AppT` l, o, ofx):ts') r+ Just True -> go ((mkConT p1 o1 `AppT` l1 `AppT` l, o, p, ofx):ts') r Just False -> push Nothing -> fail (precedenceError o1 o1fx o ofx) _ -> push + mkConT :: Bool -> Name -> Type+ mkConT promoted = if promoted then PromotedT else ConT+ compareFixity :: Fixity -> Fixity -> Maybe Bool compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2) compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2)@@ -1532,11 +1554,17 @@ nameBase o2 ++ "’ [" ++ showFixity ofx2 ++ "] in the same infix type expression" -data InfixList = ILCons Type Name InfixList | ILNil Type+data InfixList+ = ILCons Type -- The first argument to the type operator+ Name -- The name of the infix type operator+ Bool -- 'True' if this is a promoted infix data constructor,+ -- 'False' otherwise+ InfixList -- The rest of the infix applications to resolve+ | ILNil Type -ilAppend :: InfixList -> Name -> InfixList -> InfixList-ilAppend (ILNil l) o r = ILCons l o r-ilAppend (ILCons l1 o1 r1) o r = ILCons l1 o1 (ilAppend r1 o r)+ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList+ilAppend (ILNil l) o p r = ILCons l o p r+ilAppend (ILCons l1 o1 p1 r1) o p r = ILCons l1 o1 p1 (ilAppend r1 o p r) #else -- older template-haskell packages don't have UInfixT@@ -1788,6 +1816,12 @@ ForallVisT tvs' (applySubstitution subst' t) #endif+#if MIN_VERSION_template_haskell(2,19,0)+ go (PromotedInfixT l c r)+ = PromotedInfixT (go l) c (go r)+ go (PromotedUInfixT l c r)+ = PromotedUInfixT (go l) c (go r)+#endif go t = t subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a@@ -1813,6 +1847,12 @@ #if MIN_VERSION_template_haskell(2,16,0) ForallVisT tvs t' -> fvs_under_forall tvs (freeVariables t')+#endif+#if MIN_VERSION_template_haskell(2,19,0)+ PromotedInfixT l _ r+ -> freeVariables l `union` freeVariables r+ PromotedUInfixT l _ r+ -> freeVariables l `union` freeVariables r #endif _ -> [] where
test/Harness.hs view
@@ -40,7 +40,7 @@ validate equate x y = either fail (\_ -> [| return () |]) (equate x y) -- | If the arguments are equal up to renaming return @'Right' ()@,--- otherwise return a string exlaining the mismatch.+-- otherwise return a string explaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () equateDI dat1 dat2 = do check "datatypeName" (nameBase . datatypeName) dat1 dat2@@ -75,7 +75,7 @@ check (lbl ++ " equality") asEqualPred pred1 pred2 -- | If the arguments are equal up to renaming return @'Right' ()@,--- otherwise return a string exlaining the mismatch.+-- otherwise return a string explaining the mismatch. equateCI :: ConstructorInfo -> ConstructorInfo -> Either String () equateCI con1 con2 = do check "constructorName" (nameBase . constructorName) con1 con2
test/Main.hs view
@@ -92,8 +92,11 @@ t80Test #endif #if MIN_VERSION_template_haskell(2,11,0)- t79Test+ t79TestA #endif+#if MIN_VERSION_template_haskell(2,19,0)+ t79TestB+#endif #if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest@@ -829,6 +832,10 @@ test (ParensT (idAppT $ ConT ''Int)) (ConT ''Int) #endif+#if MIN_VERSION_template_haskell(2,19,0)+ test (PromotedInfixT (idAppT $ ConT ''Int) '(:^:) (idAppT $ ConT ''Int))+ (PromotedInfixT (ConT ''Int) '(:^:) (ConT ''Int))+#endif [| return () |]) t66Test :: IO ()@@ -880,12 +887,30 @@ #endif #if MIN_VERSION_template_haskell(2,11,0)-t79Test :: IO ()-t79Test =+t79TestA :: IO ()+t79TestA = $(do let [a,b,c] = map mkName ["a","b","c"] t = ForallT [kindedTVSpecified a (UInfixT (VarT b) ''(:+:) (VarT c))] [] (ConT ''()) expected = ForallT [kindedTVSpecified a (ConT ''(:+:) `AppT` VarT b `AppT` VarT c)] []+ (ConT ''())+ actual <- resolveInfixT t+ unless (expected == actual) $+ fail $ "resolveInfixT does not recur into the kinds of "+ ++ "ForallT type variable binders: "+ ++ unlines [ "Expected: " ++ pprint expected+ , "Actual: " ++ pprint actual+ ]+ [| return () |])+#endif++#if MIN_VERSION_template_haskell(2,19,0)+t79TestB :: IO ()+t79TestB =+ $(do let [a,b,c] = map mkName ["a","b","c"]+ t = ForallT [kindedTVSpecified a (PromotedUInfixT (VarT b) '(:^:) (VarT c))] []+ (ConT ''())+ expected = ForallT [kindedTVSpecified a (PromotedT '(:^:) `AppT` VarT b `AppT` VarT c)] [] (ConT ''()) actual <- resolveInfixT t unless (expected == actual) $
test/Types.hs view
@@ -71,6 +71,8 @@ type (:+:) = Either +data MyPair a b = a :^: b+ -- Data families data family T43Fam
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.4.3.0+version: 0.4.4.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell@@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10-tested-with: GHC==9.2.*, GHC==9.0.1, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4+tested-with: GHC==9.2.2, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 source-repository head type: git@@ -29,7 +29,7 @@ other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.3 && <5, ghc-prim,- template-haskell >=2.5 && <2.19,+ template-haskell >=2.5 && <2.20, containers >=0.4 && <0.7 hs-source-dirs: src default-language: Haskell2010