diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -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 diff --git a/test/Harness.hs b/test/Harness.hs new file mode 100644 --- /dev/null +++ b/test/Harness.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 } ] + } + ) diff --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -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