th-abstraction 0.1.0.0 → 0.1.1.0
raw patch · 5 files changed
+404/−59 lines, 5 filesdep ~containersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers
API changes (from Hackage documentation)
+ Language.Haskell.TH.Datatype: dataDCompat :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
Files
- ChangeLog.md +7/−0
- src/Language/Haskell/TH/Datatype.hs +105/−18
- test/Harness.hs +70/−0
- test/Main.hs +216/−38
- th-abstraction.cabal +6/−3
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for th-abstraction +## 0.1.1.0 --++* Better matching of constraints generated for GADTs across GHC versions+* Added `dataDCompat`+* Support for giving value constructors to reifyDatatype. This enables+ data families to be reified easily.+ ## 0.1.0.0 -- 2017-04-26 * First version.
src/Language/Haskell/TH/Datatype.hs view
@@ -8,7 +8,7 @@ Maintainer : emertens@gmail.com This module provides a flattened view of information about data types-and newtypes that can be supported uniformly across multiple verisons+and newtypes that can be supported uniformly across multiple versions of the template-haskell package. Sample output for @'reifyDatatype' ''Maybe@@@ -16,22 +16,22 @@ @ 'DatatypeInfo' { 'datatypeContext' = []- , 'datatypeName' = GHC.Base.Maybe- , 'datatypeVars' = [ 'VarT' a_3530822107858468866 ]+ , 'datatypeName' = GHC.Base.Maybe+ , 'datatypeVars' = [ 'VarT' a_3530822107858468866 ] , 'datatypeVariant' = 'Datatype'- , 'datatypeCons' =+ , 'datatypeCons' = [ 'ConstructorInfo'- { 'constructorName' = GHC.Base.Nothing- , 'constructorVars' = []+ { 'constructorName' = GHC.Base.Nothing+ , 'constructorVars' = [] , 'constructorContext' = []- , 'constructorFields' = []+ , 'constructorFields' = [] , 'constructorVariant' = 'NormalConstructor' } , 'ConstructorInfo'- { 'constructorName' = GHC.Base.Just- , 'constructorVars' = []+ { 'constructorName' = GHC.Base.Just+ , 'constructorVars' = [] , 'constructorContext' = []- , 'constructorFields' = [ 'VarT' a_3530822107858468866 ]+ , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] , 'constructorVariant' = 'NormalConstructor' } ]@@ -65,6 +65,8 @@ , equalPred , classPred + -- * Backward compatible data definitions+ , dataDCompat -- * Convenience functions , resolveTypeSynonyms@@ -75,7 +77,7 @@ import Data.Data (Typeable, Data) import Data.Foldable (foldMap, foldl')-import Data.List (union, (\\))+import Data.List (find, union, (\\)) import Data.Map (Map) import qualified Data.Map as Map import Control.Monad (foldM)@@ -124,7 +126,7 @@ -- | Construct a Type using the datatype's type constructor and type--- parameteters.+-- parameters. datatypeType :: DatatypeInfo -> Type datatypeType di = foldl AppT (ConT (datatypeName di))@@ -143,9 +145,28 @@ -- Fail in 'Q' otherwise. normalizeInfo :: Info -> Q DatatypeInfo normalizeInfo (TyConI dec) = normalizeDec dec+# if MIN_VERSION_template_haskell(2,11,0)+normalizeInfo (DataConI name _ parent) = reifyParent name parent+# else+normalizeInfo (DataConI name _ parent _) = reifyParent name parent+# endif normalizeInfo _ = fail "reifyDatatype: Expected a type constructor" +reifyParent :: Name -> Name -> Q DatatypeInfo+reifyParent con parent =+ do info <- reify parent+ case info of+ TyConI dec -> normalizeDec dec+ FamilyI _ instances ->+ do instances' <- traverse normalizeDec instances+ case find p instances' of+ Nothing -> fail "PANIC: reifyParent lost the instance"+ Just dec -> return dec+ where+ p info = con `elem` map constructorName (datatypeCons info)++ -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeDec :: Dec -> Q DatatypeInfo@@ -155,8 +176,10 @@ normalizeDec (DataD context name tyvars _kind cons _derives) = normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) =+ repair13618 =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) =+ repair13618 =<< normalizeDec' context name params cons DataInstance #elif MIN_VERSION_template_haskell(2,11,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) =@@ -164,8 +187,10 @@ normalizeDec (DataD context name tyvars _kind cons _derives) = normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) =+ repair13618 =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) =+ repair13618 =<< normalizeDec' context name params cons DataInstance #else normalizeDec (NewtypeD context name tyvars con _derives) =@@ -173,8 +198,10 @@ normalizeDec (DataD context name tyvars cons _derives) = normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params con _derives) =+ repair13618 =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params cons _derives) =+ repair13618 =<< normalizeDec' context name params cons DataInstance #endif normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required"@@ -261,9 +288,9 @@ _ -> fail "normalizeGadtC: Expected type constructor application" mergeArguments :: [Name] -> [Type] -> (Map Name Name, Cxt)-mergeArguments ns ts = foldl' aux (Map.empty, []) (zip ns ts)+mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts) where- aux (subst, context) (n,p) =+ aux (n,p) (subst, context) = case p of VarT m | Map.notMember m subst -> (Map.insert m n subst, context) _ -> (subst, EqualityT `AppT` VarT n `AppT` p : context)@@ -324,7 +351,7 @@ -- | Add universal quantifier for all free variables in the type. This is -- useful when constructing a type signature for a declaration. -- This code is careful to ensure that the order of the variables quantified--- is determined by their order of appearance in the type singnature. (In+-- is determined by their order of appearance in the type signature. (In -- contrast with being dependent upon the Ord instance for 'Name') -- quantifyType :: Type -> Type@@ -398,7 +425,7 @@ , constructorFields = applySubstitution subst' (constructorFields ci) } --- Pred became a type synonym for Type+-- 'Pred' became a type synonym for 'Type' #if !MIN_VERSION_template_haskell(2,10,0) instance TypeSubstitution Pred where freeVariables (ClassP _ xs) = freeVariables xs@@ -409,7 +436,7 @@ (applySubstitution p y) #endif --- Kind became a type synonym for Type. Previously there were no kind variables+-- 'Kind' became a type synonym for 'Type'. Previously there were no kind variables #if !MIN_VERSION_template_haskell(2,8,0) instance TypeSubstitution Kind where freeVariables _ = []@@ -483,7 +510,7 @@ ------------------------------------------------------------------------ --- NonEmpty didn't move into base into recently. Reimplementing it locally+-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally -- saves dependencies for supporting older GHCs data NonEmpty a = a :| [a]@@ -494,3 +521,63 @@ reverseNonEmpty :: NonEmpty a -> NonEmpty a reverseNonEmpty (x :| xs) = y :| ys where y:ys = reverse (x:xs)++------------------------------------------------------------------------++-- | Prior to GHC 8.2.1, reify was broken for data instances and newtype+-- instances. This code attempts to detect the problem and repair it if+-- possible.+--+-- The particular problem is that the type variables used in the patterns+-- while defining a data family instance do not completely match those+-- used when defining the fields of the value constructors beyond the+-- base names. This code attempts to recover the relationship between the+-- type variables.+--+-- It is possible, however, to generate these kinds of declarations by+-- means other than reify. In these cases the name bases might not be+-- unique and the declarations might be well formed. In such a case this+-- code attempts to avoid altering the declaration.+--+-- https://ghc.haskell.org/trac/ghc/ticket/13618+repair13618 :: DatatypeInfo -> Q DatatypeInfo+repair13618 info =+ do s <- sequenceA (Map.fromList substList)+ return info { datatypeCons = applySubstitution s (datatypeCons info) }++ where+ used = freeVariables (datatypeCons info)+ bound = freeVariables (datatypeVars info)+ free = used \\ bound++ substList =+ [ (u, substEntry u vs)+ | u <- free+ , let vs = [v | v <- bound, nameBase v == nameBase u]+ ]++ substEntry _ [v] = varT v+ substEntry u [] = fail ("Impossible free variable: " ++ show u)+ substEntry u _ = fail ("Ambiguous free variable: " ++ show u)++------------------------------------------------------------------------++-- | Backward compatible version of 'dataD'+dataDCompat ::+ CxtQ {- ^ context -} ->+ Name {- ^ type constructor -} ->+ [TyVarBndr] {- ^ type parameters -} ->+ [ConQ] {- ^ constructor definitions -} ->+ [Name] {- ^ derived class names -} ->+ DecQ+#if MIN_VERSION_template_haskell(2,12,0)+dataDCompat c n ts cs ds =+ dataD c n ts Nothing cs+ (if null ds then [] else [derivClause Nothing (map conT ds)])+#elif MIN_VERSION_template_haskell(2,11,0)+dataDCompat c n ts cs ds =+ dataD c n ts Nothing cs+ (pure (map ConT ds))+#else+dataDCompat = dataD+#endif
+ test/Harness.hs view
@@ -0,0 +1,70 @@+{-# Language TemplateHaskell #-}++{-|+Module : Harness+Description : Comparison functions for data type info used in tests+Copyright : Eric Mertens 2017+License : ISC+Maintainer : emertens@gmail.com++This module provides comparison functions that are able to check+that the computed 'DatatypeInfo' values match the expected ones+up to alpha renaming.++-}+module Harness (validate) where++import Control.Monad+import qualified Data.Map as Map+import Language.Haskell.TH+import Language.Haskell.TH.Datatype++validate :: DatatypeInfo -> DatatypeInfo -> ExpQ+validate x y = either fail (\_ -> [| return () |]) (equateDI x y)++-- | If the arguments are equal up to renaming return @'Right' ()@,+-- otherwise return a string exlaining the mismatch.+equateDI :: DatatypeInfo -> DatatypeInfo -> Either String ()+equateDI dat1 dat2 =+ do check "datatypeName" datatypeName dat1 dat2+ check "datatypeVars len" (length . datatypeVars) dat1 dat2+ check "datatypeVariant" datatypeVariant dat1 dat2+ check "datatypeCons len" (length . datatypeCons) dat1 dat2++ let sub = Map.fromList (zip (freeVariables (datatypeVars dat2))+ (map VarT (freeVariables (datatypeVars dat1))))++ check "datatypeContext" id+ (datatypeContext dat1)+ (applySubstitution sub (datatypeContext dat2))++ check "datatypeVars" id+ (datatypeVars dat1)+ (applySubstitution sub (datatypeVars dat2))++ zipWithM_ equateCI+ (datatypeCons dat1)+ (applySubstitution sub (datatypeCons dat2))++-- | If the arguments are equal up to renaming return @'Right' ()@,+-- otherwise return a string exlaining the mismatch.+equateCI :: ConstructorInfo -> ConstructorInfo -> Either String ()+equateCI con1 con2 =+ do check "constructorName" constructorName con1 con2+ check "constructorVariant" constructorVariant con1 con2++ let sub = Map.fromList (zip (map tvName (constructorVars con2))+ (map VarT (map tvName (constructorVars con1))))++ check "constructorContext" id+ (constructorContext con1)+ (applySubstitution sub (constructorContext con2))++ check "constructorFields" id+ (constructorFields con1)+ (applySubstitution sub (constructorFields con2))++check :: (Show b, Eq b) => String -> (a -> b) -> a -> a -> Either String ()+check lbl f x y+ | f x == f y = Right ()+ | otherwise = Left (lbl ++ ":\n\n" ++ show (f x) ++ "\n\n" ++ show (f y))
test/Main.hs view
@@ -1,11 +1,25 @@-{-# Language TemplateHaskell, GADTs #-}+{-# Language TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +{-|+Module : Main+Description : Test cases for the th-abstraction package+Copyright : Eric Mertens 2017+License : ISC+Maintainer : emertens@gmail.com++This module checks that the 'reifyDatatype' logic works consistently+across a wide range of datatypes. These tests are validated across+the versions of GHC supported by this package.++-} module Main (main) where import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Datatype +import Harness+ type Gadt1Int = Gadt1 Int data Gadt1 a where@@ -15,71 +29,235 @@ data Adt1 a b = Adtc1 (a,b) | Bool `Adtc2` Int data Gadtrec1 a where- Gadtrecc1 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b)+ Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) +data Equal :: * -> * -> * -> * where+ Equalc :: (Read a, Show a) => [a] -> Maybe a -> Equal a a a++data Showable :: * where+ Showable :: Show a => a -> Showable++data R = R1 { field1, field2 :: Int }++data Gadt2 :: * -> * -> * where+ Gadt2c1 :: Gadt2 a [a]+ Gadt2c2 :: Gadt2 [a] a+ Gadt2c3 :: Gadt2 [a] [a]++data family DF a+data instance DF (Maybe a) = DFMaybe Int [a]+ return [] -- segment type declarations above from refiy below +-- | Test entry point. Tests will pass or fail at compile time. main :: IO () main = do adt1Test gadt1Test gadtrec1Test+ equalTest+ showableTest+ recordTest+ dataFamilyTest adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1 - let [a,b] = freeVariables (datatypeVars info)- [c1,c2] = datatypeCons info-- unless (datatypeName info == ''Adt1) (fail "bad name adt1")- unless (datatypeVariant info == Datatype) (fail "bad variant adt1")-- unless (c1 == ConstructorInfo 'Adtc1 [] [] [AppT (AppT (TupleT 2) (VarT a)) (VarT b)] NormalConstructor)- (fail "Bad adtc1")-- unless (c2 == ConstructorInfo 'Adtc2 [] [] [ConT ''Bool, ConT ''Int] NormalConstructor)- (fail "Bad adtc2")+ let [a,b] = map (VarT . mkName) ["a","b"] - [| putStrLn "Adt1 tests passed" |]+ validate info+ DatatypeInfo+ { datatypeName = ''Adt1+ , datatypeContext = []+ , datatypeVars = [a, b]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'Adtc1+ , constructorContext = []+ , constructorVars = []+ , constructorFields = [AppT (AppT (TupleT 2) a) b]+ , constructorVariant = NormalConstructor }+ , ConstructorInfo+ { constructorName = 'Adtc2+ , constructorContext = []+ , constructorVars = []+ , constructorFields = [ConT ''Bool, ConT ''Int]+ , constructorVariant = NormalConstructor }+ ]+ } ) gadt1Test :: IO () gadt1Test = $(do info <- reifyDatatype ''Gadt1 - let [a] = freeVariables (datatypeVars info)- [c1,c2] = datatypeCons info-- unless (c1 == ConstructorInfo 'Gadtc1 [] [equalPred (VarT a) (ConT ''Int)]- [ConT ''Int] NormalConstructor)- (fail ("bad Gadtc1 " ++ show c1))-- unless (c2 == ConstructorInfo 'Gadtc2 [] []- [AppT (AppT (TupleT 2) (VarT a)) (VarT a)]- NormalConstructor)- (fail ("bad Gadtc2 " ++ show c2))+ let a = VarT (mkName "a") - [| putStrLn "Gadt1 tests passed" |]+ validate info+ DatatypeInfo+ { datatypeName = ''Gadt1+ , datatypeContext = []+ , datatypeVars = [a]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'Gadtc1+ , constructorVars = []+ , constructorContext = [equalPred a (ConT ''Int)]+ , constructorFields = [ConT ''Int]+ , constructorVariant = NormalConstructor }+ , ConstructorInfo+ { constructorName = 'Gadtc2+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [AppT (AppT (TupleT 2) a) a]+ , constructorVariant = NormalConstructor }+ ]+ } ) gadtrec1Test :: IO () gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 - let [a] = freeVariables (datatypeVars info)- [c] = datatypeCons info- [v1,v2] = constructorVars c+ let a = VarT (mkName "a")+ let [v1,v2] = map mkName ["v1","v2"] - expectedCxt = [equalPred- (VarT a)- (AppT (AppT (TupleT 2) (VarT (tvName v1)))- (VarT (tvName v2)))]+ let con = ConstructorInfo+ { constructorName = 'Gadtrecc1+ , constructorVars = [PlainTV v1, PlainTV v2]+ , constructorContext =+ [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))]+ , constructorFields = [VarT v1, VarT v2]+ , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } - unless (c == ConstructorInfo 'Gadtrecc1 [v1,v2] expectedCxt- [VarT (tvName v1), VarT (tvName v2)]- (RecordConstructor [ 'gadtrec1a, 'gadtrec1b ]))- (fail ("bad constructor for gadtrec1" ++ show c))+ validate info+ DatatypeInfo+ { datatypeName = ''Gadtrec1+ , datatypeContext = []+ , datatypeVars = [a]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ con, con { constructorName = 'Gadtrecc2 } ]+ }+ ) - [| putStrLn "Gadtrecc1 tests" |]+equalTest :: IO ()+equalTest =+ $(do info <- reifyDatatype ''Equal++ let [a,b,c] = map (VarT . mkName) ["a","b","c"]++ validate info+ DatatypeInfo+ { datatypeName = ''Equal+ , datatypeContext = []+ , datatypeVars = [a,b,c]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'Equalc+ , constructorVars = []+ , constructorContext =+ [equalPred a c, equalPred b c, classPred ''Read [c], classPred ''Show [c] ]+ , constructorFields =+ [ListT `AppT` c, ConT ''Maybe `AppT` c]+ , constructorVariant = NormalConstructor }+ ]+ } )++showableTest :: IO ()+showableTest =+ $(do info <- reifyDatatype ''Showable++ let a = mkName "a"++ validate info+ DatatypeInfo+ { datatypeName = ''Showable+ , datatypeContext = []+ , datatypeVars = []+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'Showable+ , constructorVars = [PlainTV a]+ , constructorContext = [classPred ''Show [VarT a]]+ , constructorFields = [VarT a]+ , constructorVariant = NormalConstructor }+ ]+ }+ )++recordTest :: IO ()+recordTest =+ $(do info <- reifyDatatype ''R+ validate info+ DatatypeInfo+ { datatypeName = ''R+ , datatypeContext = []+ , datatypeVars = []+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'R1+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [ConT ''Int, ConT ''Int]+ , constructorVariant = RecordConstructor ['field1, 'field2] }+ ]+ }+ )++gadt2Test :: IO ()+gadt2Test =+ $(do info <- reifyDatatype ''Gadt2+ let [a,b] = map (VarT . mkName) ["a","b"]+ x = mkName "x"+ con = ConstructorInfo+ { constructorName = undefined+ , constructorVars = []+ , constructorContext = []+ , constructorFields = []+ , constructorVariant = NormalConstructor }+ validate info+ DatatypeInfo+ { datatypeName = ''Gadt2+ , datatypeContext = []+ , datatypeVars = [a,b]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ con { constructorName = 'Gadt2c1+ , constructorContext = [equalPred b (AppT ListT a)] }+ , con { constructorName = 'Gadt2c2+ , constructorContext = [equalPred a (AppT ListT b)] }+ , con { constructorName = 'Gadt2c3+ , constructorVars = [PlainTV x]+ , constructorContext =+ [equalPred a (AppT ListT (VarT x))+ ,equalPred b (AppT ListT (VarT x))] } ]+ }+ )++dataFamilyTest :: IO ()+dataFamilyTest =+ $(do info <- reifyDatatype 'DFMaybe+ let a = mkName "a"+ validate info+ DatatypeInfo+ { datatypeName = ''DF+ , datatypeContext = []+ , datatypeVars = [AppT (ConT ''Maybe) (VarT a)]+ , datatypeVariant = DataInstance+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'DFMaybe+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [ConT ''Int, ListT `AppT` VarT a]+ , constructorVariant = NormalConstructor } ]+ }+ )
th-abstraction.cabal view
@@ -1,6 +1,6 @@ name: th-abstraction-version: 0.1.0.0-synopsis: Nicer interface to reified information about data types+version: 0.1.1.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 so that packages and support a single, easier to use@@ -11,6 +11,8 @@ author: Eric Mertens maintainer: emertens@gmail.com copyright: 2017 Eric Mertens+homepage: https://github.com/glguy/th-abstraction+bug-reports: https://github.com/glguy/th-abstraction/issues category: Development build-type: Simple extra-source-files: ChangeLog.md@@ -31,8 +33,9 @@ default-language: Haskell2010 test-suite unit-tests+ other-modules: Harness type: exitcode-stdio-1.0 main-is: Main.hs- build-depends: th-abstraction, base, template-haskell+ build-depends: th-abstraction, base, containers, template-haskell hs-source-dirs: test default-language: Haskell2010