th-abstraction 0.1.3.0 → 0.2.0.0

raw patch · 6 files changed

+852/−207 lines, 6 filesdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−1
• src/Language/Haskell/TH/Datatype.hs +551/−124
• src/Language/Haskell/TH/Datatype/Internal.hs +4/−0
• test/Harness.hs +41/−11
• test/Main.hs +243/−67
• th-abstraction.cabal +4/−4

@@ -1,6 +1,14 @@ # Revision history for th-abstraction -## 0.1.3.0 -- 2016-05-27+## 0.2.0.0 -- 2017-06-03++* Added `reifyFixityCompat`+* Added `constructorStrictness` field to `ConstructorInfo`+* Infer more kind signatures when missing on old GHCs+* Added parameter to `normalizeCon`+* Support GHC back to 7.0.4++## 0.1.3.0 -- 2017-05-27  * Added `resolveInfixT` which uses reified fixity information to resolve `UInfixT` * Added `asEqualPred` and `asClassPred`

@@ -1,5 +1,10 @@-{-# Language CPP, DeriveGeneric, DeriveDataTypeable #-}+{-# Language CPP, DeriveDataTypeable #-} +#if MIN_VERSION_base(4,4,0)+#define HAS_GENERICS+{-# Language DeriveGeneric #-}+#endif+ {-| Module      : Language.Haskell.TH.Datatype Description : Backwards-compatible interface to reified information about datatypes.@@ -17,22 +22,27 @@ 'DatatypeInfo'  { 'datatypeContext' = []  , 'datatypeName'    = GHC.Base.Maybe- , 'datatypeVars'    = [ 'VarT' a_3530822107858468866 ]+ , 'datatypeVars'    = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ]  , 'datatypeVariant' = 'Datatype'  , 'datatypeCons'    =      [ 'ConstructorInfo'-         { 'constructorName'    = GHC.Base.Nothing-         , 'constructorVars'    = []-         , 'constructorContext' = []-         , 'constructorFields'  = []-         , 'constructorVariant' = 'NormalConstructor'+         { 'constructorName'       = GHC.Base.Nothing+         , 'constructorVars'       = []+         , 'constructorContext'    = []+         , 'constructorFields'     = []+         , 'constructorStrictness' = []+         , 'constructorVariant'    = 'NormalConstructor'          }      , 'ConstructorInfo'-         { 'constructorName'    = GHC.Base.Just-         , 'constructorVars'    = []-         , 'constructorContext' = []-         , 'constructorFields'  = [ 'VarT' a_3530822107858468866 ]-         , 'constructorVariant' = 'NormalConstructor'+         { 'constructorName'       = GHC.Base.Just+         , 'constructorVars'       = []+         , 'constructorContext'    = []+         , 'constructorFields'     = [ 'VarT' a_3530822107858468866 ]+         , 'constructorStrictness' = [ 'FieldStrictness'+                                         'UnspecifiedUnpackedness'+                                         'Lazy'+                                     ]+         , 'constructorVariant'    = 'NormalConstructor'          }      ]  }@@ -49,6 +59,7 @@   , ConstructorInfo(..)   , DatatypeVariant(..)   , ConstructorVariant(..)+  , FieldStrictness(..)    -- * Normalization functions   , reifyDatatype@@ -71,16 +82,24 @@   , dataDCompat   , arrowKCompat +  -- * Strictness annotations+  , isStrictAnnot+  , notStrictAnnot+  , unpackedAnnot+   -- * Type simplification   , resolveTypeSynonyms   , resolveInfixT +  -- * Fixities+  , reifyFixityCompat+  , showFixity+  , showFixityDirection+   -- * Convenience functions   , unifyTypes   , tvName   , datatypeType-  , showFixity-  , showFixityDirection   ) where  import           Data.Data (Typeable, Data)@@ -88,19 +107,30 @@ import           Data.List (find, union, (\\)) import           Data.Map (Map) import qualified Data.Map as Map-import           Data.Maybe (fromMaybe)-import           Control.Monad (foldM)-import           GHC.Generics (Generic)+import           Data.Maybe+import qualified Data.Traversable as T+import           Control.Monad import           Language.Haskell.TH+#if MIN_VERSION_template_haskell(2,11,0)+                                     hiding (Extension(..))+#endif import           Language.Haskell.TH.Datatype.Internal-import           Language.Haskell.TH.Lib (arrowK) -- needed for th-2.4+import           Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4 +#ifdef HAS_GENERICS+import           GHC.Generics (Generic)+#endif+ #if !MIN_VERSION_base(4,8,0) import           Control.Applicative (Applicative(..), (<$>))-import           Data.Traversable (traverse, sequenceA) #endif  -- | Normalized information about newtypes and data types.+--+-- 'datatypeVars' types will have an outermost 'SigT' to indicate the+-- parameter's kind. These types will be simple variables for /ADT/s+-- declared with @data@ and @newtype@, but can be more complex for+-- types declared with @data instance@ and @newtype instance@. data DatatypeInfo = DatatypeInfo   { datatypeContext :: Cxt               -- ^ Data type context (deprecated)   , datatypeName    :: Name              -- ^ Type constructor@@ -108,34 +138,114 @@   , datatypeVariant :: DatatypeVariant   -- ^ Extra information   , datatypeCons    :: [ConstructorInfo] -- ^ Normalize constructor information   }-  deriving (Show, Eq, Typeable, Data, Generic)+  deriving (Show, Eq, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           )  -- | Possible variants of data type declarations. data DatatypeVariant-  = Datatype -- ^ Type declared with @data@-  | Newtype  -- ^ Type declared with @newtype@-  | DataInstance -- ^ Type declared with @data instance@+  = Datatype        -- ^ Type declared with @data@+  | Newtype         -- ^ Type declared with @newtype@+  | DataInstance    -- ^ Type declared with @data instance@   | NewtypeInstance -- ^ Type declared with @newtype instance@-  deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)+  deriving (Show, Read, Eq, Ord, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           )  -- | Normalized information about constructors associated with newtypes and -- data types. data ConstructorInfo = ConstructorInfo-  { constructorName    :: Name               -- ^ Constructor name-  , constructorVars    :: [TyVarBndr]        -- ^ Constructor type parameters-  , constructorContext :: Cxt                -- ^ Constructor constraints-  , constructorFields  :: [Type]             -- ^ Constructor fields-  , constructorVariant :: ConstructorVariant -- ^ Extra information+  { constructorName       :: Name               -- ^ Constructor name+  , constructorVars       :: [TyVarBndr]        -- ^ Constructor type parameters+  , constructorContext    :: Cxt                -- ^ Constructor constraints+  , constructorFields     :: [Type]             -- ^ Constructor fields+  , constructorStrictness :: [FieldStrictness]  -- ^ Constructor fields' strictness+                                                --   (Invariant: has the same length+                                                --   as constructorFields)+  , constructorVariant    :: ConstructorVariant -- ^ Extra information   }-  deriving (Show, Eq, Typeable, Data, Generic)+  deriving (Show, Eq, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           )  -- | Possible variants of data constructors. data ConstructorVariant   = NormalConstructor        -- ^ Constructor without field names+  | InfixConstructor         -- ^ Constructor without field names that is+                             --   declared infix   | RecordConstructor [Name] -- ^ Constructor with field names-  deriving (Show, Eq, Ord, Typeable, Data, Generic)+  deriving (Show, Eq, Ord, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           ) +-- | Normalized information about a constructor field's @UNPACK@ and+-- strictness annotations.+--+-- Note that the interface for reifying strictness in Template Haskell changed+-- considerably in GHC 8.0. The presentation in this library mirrors that which+-- can be found in GHC 8.0 or later, whereas previously, unpackedness and+-- strictness were represented with a single data type:+--+-- @+-- data Strict+--   = IsStrict+--   | NotStrict+--   | Unpacked -- On GHC 7.4 or later+-- @+--+-- For backwards compatibility, we retrofit these constructors onto the+-- following three values, respectively:+--+-- @+-- 'isStrictAnnot'  = 'FieldStrictness' 'UnspecifiedUnpackedness' 'Strict'+-- 'notStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'UnspecifiedStrictness'+-- 'unpackedAnnot'  = 'FieldStrictness' 'Unpack' 'Strict'+-- @+data FieldStrictness = FieldStrictness+  { fieldUnpackedness :: Unpackedness+  , fieldStrictness   :: Strictness+  }+  deriving (Show, Eq, Ord, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           ) +-- | Information about a constructor field's unpackedness annotation.+data Unpackedness+  = UnspecifiedUnpackedness -- ^ No annotation whatsoever+  | NoUnpack                -- ^ Annotated with @{\-\# NOUNPACK \#-\}@+  | Unpack                  -- ^ Annotated with @{\-\# UNPACK \#-\}@+  deriving (Show, Eq, Ord, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           )++-- | Information about a constructor field's strictness annotation.+data Strictness+  = UnspecifiedStrictness -- ^ No annotation whatsoever+  | Lazy                  -- ^ Annotated with @~@+  | Strict                -- ^ Annotated with @!@+  deriving (Show, Eq, Ord, Typeable, Data+#ifdef HAS_GENERICS+           ,Generic+#endif+           )++isStrictAnnot, notStrictAnnot, unpackedAnnot :: FieldStrictness+isStrictAnnot  = FieldStrictness UnspecifiedUnpackedness Strict+notStrictAnnot = FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness+unpackedAnnot  = FieldStrictness Unpack Strict+ -- | Construct a Type using the datatype's type constructor and type -- parameters. Kind signatures are removed. datatypeType :: DatatypeInfo -> Type@@ -146,36 +256,74 @@   -- | Compute a normalized view of the metadata about a data type or newtype--- given a type constructor.+-- given a constructor.+--+-- This function will accept any constructor (value or type) for a type+-- declared with newtype or data. Value constructors must be used to+-- lookup datatype information about /data instances/ and /newtype instances/.+--+-- GADT constructors are normalized into datatypes with explicit equality+-- constraints.+--+-- This function will apply various bug-fixes to the output of the underlying+-- @template-haskell@ library in order to provide a view of datatypes in+-- as uniform a way as possible. reifyDatatype ::-  Name {- ^ type constructor -} ->+  Name {- ^ constructor -} ->   Q DatatypeInfo-reifyDatatype n = normalizeInfo =<< reify n+reifyDatatype n = normalizeInfo' "reifyDatatype" =<< reify n   -- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeInfo :: Info -> Q DatatypeInfo-normalizeInfo (TyConI dec) = normalizeDec dec-# if MIN_VERSION_template_haskell(2,11,0)-normalizeInfo (DataConI name ty parent) = reifyParent name ty parent-# else-normalizeInfo (DataConI name ty parent _) = reifyParent name ty parent-# endif-normalizeInfo _ = fail "reifyDatatype: Expected a type constructor"+normalizeInfo = normalizeInfo' "normalizeInfo" +normalizeInfo' :: String -> Info -> Q DatatypeInfo+normalizeInfo' entry i =+  case i of+    PrimTyConI{}                      -> bad "Primitive type not supported"+    ClassI{}                          -> bad "Class not supported"+#if MIN_VERSION_template_haskell(2,11,0)+    FamilyI DataFamilyD{} _           ->+#elif MIN_VERSION_template_haskell(2,7,0)+    FamilyI (FamilyD DataFam _ _ _) _ ->+#else+    TyConI (FamilyD DataFam _ _ _)    ->+#endif+                                         bad "Use a value constructor to reify a data family instance"+#if MIN_VERSION_template_haskell(2,7,0)+    FamilyI _ _                       -> bad "Type families not supported"+#endif+    TyConI dec                        -> normalizeDec dec+#if MIN_VERSION_template_haskell(2,11,0)+    DataConI name _ parent            -> reifyParent name parent+#elif MIN_VERSION_template_haskell(2,7,0)+    DataConI name _ parent _          -> reifyParent name parent+#else+    -- Give a sensible error message if you try to look up a data family+    -- instance constructor in GHC 7.0 or 7.2+    DataConI{}                        -> bad $ "Data family instances can only " +++                                               "be reified with GHC 7.4 or later"+#endif+    _                                 -> bad "Expected a type constructor"+  where+    bad msg = fail (entry ++ ": " ++ msg) -reifyParent :: Name -> Type -> Name -> Q DatatypeInfo-reifyParent con ty parent =++reifyParent :: Name -> Name -> Q DatatypeInfo+reifyParent con parent =   do info <- reify parent      case info of        TyConI dec -> normalizeDec dec+#if MIN_VERSION_template_haskell(2,7,0)        FamilyI dec instances ->-         do let instances1 = map (repairInstance dec ty) instances-            instances2 <- traverse normalizeDec instances1+         do let instances1 = map (repairDataFam dec) instances+            instances2 <- mapM normalizeDec instances1             case find p instances2 of               Just inst -> return inst               Nothing   -> fail "PANIC: reifyParent lost the instance"+#endif        _ -> fail "PANIC: reifyParent unexpected parent"   where     p info = con `elem` map constructorName (datatypeCons info)@@ -184,66 +332,120 @@     kindPart (KindedTV _ k) = [k]     kindPart (PlainTV  _  ) = [] -    countKindVars = length . freeVariables . map kindPart-    -- GHC 7.8.4 will eta-reduce data instances. We can find the missing-    -- type variables on the data constructor.-    repairInstance+    -- A version of repairVarKindsWith that does much more extra work to+    -- (1) eta-expand missing type patterns, and (2) ensure that the kind+    -- signatures for these new type patterns match accordingly.+    repairVarKindsWith' :: [TyVarBndr] -> [Type] -> [Type]+    repairVarKindsWith' dvars ts =+      let nparams             = length dvars+          kparams             = kindVars dvars+          (tsKinds,tsNoKinds) = splitAt (length kparams) ts+          tsKinds'            = map sanitizeStars tsKinds+          extraTys            = drop (length tsNoKinds) (bndrParams dvars)+          ts'                 = tsNoKinds ++ extraTys -- eta-expand+      in applySubstitution (Map.fromList (zip kparams tsKinds')) $+         repairVarKindsWith dvars ts'++    -- A GHC 7.6-specific bug requires us to replace all occurrences of+    -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.+    -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.+    sanitizeStars :: Kind -> Kind+    sanitizeStars = go+      where+        go :: Kind -> Kind+        go (AppT t1 t2)                 = AppT (go t1) (go t2)+        go (SigT t k)                   = SigT (go t) (go k)+        go (ConT n) | n == starKindName = StarT+        go t                            = t++    kindVars = freeVariables . map kindPart++    -- Sadly, Template Haskell's treatment of data family instances leaves much+    -- to be desired. Here are some problems that we have to work around:+    --+    -- 1. On all versions of GHC, TH leaves off the kind signatures on the+    --    type patterns of data family instances where a kind signature isn't+    --    specified explicitly. Here, we can use the parent data family's+    --    type variable binders to reconstruct the kind signatures if they+    --    are missing.+    -- 2. On GHC 7.6 and 7.8, TH will eta-reduce data instances. We can find+    --    the missing type variables on the data constructor.+    --+    -- We opt to avoid propagating these new type variables through to the+    -- constructor now, but we will return to this task in normalizeCon.+    repairDataFam       (FamilyD _ _ dvars _)-      (ForallT tvars _ _)       (NewtypeInstD cx n ts con deriv) =-        NewtypeInstD cx n ts' con deriv-      where-        nparams = length dvars-        kparams = countKindVars dvars-        ts'     = take nparams (drop kparams (ts ++ bndrParams tvars))-    repairInstance+        NewtypeInstD cx n (repairVarKindsWith' dvars ts) con deriv+    repairDataFam       (FamilyD _ _ dvars _)-      (ForallT tvars _ _)       (DataInstD cx n ts cons deriv) =-        DataInstD cx n ts' cons deriv-      where-        nparams = length dvars-        kparams = countKindVars dvars-        ts'     = take nparams (drop kparams (ts ++ bndrParams tvars))+        DataInstD cx n (repairVarKindsWith' dvars ts) cons deriv+#else+    repairDataFam famD instD+# if MIN_VERSION_template_haskell(2,11,0)+      | DataFamilyD _ dvars _ <- famD+      , NewtypeInstD cx n ts k c deriv <- instD+      = NewtypeInstD cx n (repairVarKindsWith dvars ts) k c deriv++      | DataFamilyD _ dvars _ <- famD+      , DataInstD cx n ts k c deriv <- instD+      = DataInstD cx n (repairVarKindsWith dvars ts) k c deriv+# else+      | FamilyD _ _ dvars _ <- famD+      , NewtypeInstD cx n ts c deriv <- instD+      = NewtypeInstD cx n (repairVarKindsWith dvars ts) c deriv++      | FamilyD _ _ dvars _ <- famD+      , DataInstD cx n ts c deriv <- instD+      = DataInstD cx n (repairVarKindsWith dvars ts) c deriv+# endif #endif-    repairInstance _ _ x = x+    repairDataFam _ instD = instD +repairVarKindsWith :: [TyVarBndr] -> [Type] -> [Type]+repairVarKindsWith = zipWith stealKindForType +-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)+stealKindForType _   t        = t+ -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeDec :: Dec -> Q DatatypeInfo #if MIN_VERSION_template_haskell(2,12,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) =-  normalizeDec' context name (bndrParams tyvars) [con] Newtype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars _kind cons _derives) =-  normalizeDec' context name (bndrParams tyvars) cons Datatype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params cons DataInstance #elif MIN_VERSION_template_haskell(2,11,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) =-  normalizeDec' context name (bndrParams tyvars) [con] Newtype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars _kind cons _derives) =-  normalizeDec' context name (bndrParams tyvars) cons Datatype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params cons DataInstance #else normalizeDec (NewtypeD context name tyvars con _derives) =-  normalizeDec' context name (bndrParams tyvars) [con] Newtype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars cons _derives) =-  normalizeDec' context name (bndrParams tyvars) cons Datatype+  giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params con _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params cons _derives) =-  repair13618 =<<+  repair13618 . giveTypesStarKinds =<<   normalizeDec' context name params cons DataInstance #endif normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required"@@ -254,6 +456,10 @@     KindedTV t k -> SigT (VarT t) k     PlainTV  t   -> VarT t +-- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@.+tvbKind :: TyVarBndr -> Kind+tvbKind (PlainTV  _)   = starK+tvbKind (KindedTV _ k) = k  -- | Remove the outermost 'SigT'. stripSigT :: Type -> Type@@ -269,8 +475,8 @@   DatatypeVariant {- ^ Extra information   -} ->   Q DatatypeInfo normalizeDec' context name params cons variant =-  do cons' <- concat <$> traverse (normalizeCon name params) cons-     pure DatatypeInfo+  do cons' <- concat <$> mapM (normalizeCon name params variant) cons+     return DatatypeInfo        { datatypeContext = context        , datatypeName    = name        , datatypeVars    = params@@ -279,49 +485,195 @@        }  -- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of--- the type and parameters of the constructor as extracted from the outer+-- the type and parameters of the constructor, as well as whether the constructor+-- is for a data family instance, as extracted from the outer -- 'Dec'. normalizeCon ::-  Name   {- ^ Type constructor -} ->-  [Type] {- ^ Type parameters  -} ->-  Con    {- ^ Constructor      -} ->+  Name            {- ^ Type constructor  -} ->+  [Type]          {- ^ Type parameters   -} ->+  DatatypeVariant {- ^ Extra information -} ->+  Con             {- ^ Constructor       -} ->   Q [ConstructorInfo]-normalizeCon typename params = go [] []+normalizeCon typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch   where-    go tyvars context c =-      case c of-        NormalC n xs ->-          pure [ConstructorInfo n tyvars context (map snd xs) NormalConstructor]-        InfixC l n r ->-          pure [ConstructorInfo n tyvars context [snd l,snd r] NormalConstructor]-        RecC n xs ->-          let fns = takeFieldNames xs in-          pure [ConstructorInfo n tyvars context-                  (takeFieldTypes xs) (RecordConstructor fns)]-        ForallC tyvars' context' c' ->-          go (tyvars'++tyvars) (context'++context) c'+    -- A GADT constructor is declared infix when:+    --+    -- 1. Its name uses operator syntax (e.g., (:*:))+    -- 2. It has exactly two fields+    -- 3. It has a programmer-supplied fixity declaration+    checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant+    checkGadtFixity ts n = do+#if MIN_VERSION_template_haskell(2,11,0)+      mbFi <- reifyFixity n+      let userSuppliedFixity = isJust mbFi+#else+      -- On old GHCs, there is a bug where infix GADT constructors will+      -- mistakenly be marked as (ForallC (NormalC ...)) instead of+      -- (ForallC (InfixC ...)). This is especially annoying since on these+      -- versions of GHC, Template Haskell doesn't grant the ability to query+      -- whether a constructor was given a user-supplied fixity declaration.+      -- Rather, you can only check the fixity that GHC ultimately decides on+      -- for a constructor, regardless of whether it was a default fixity or+      -- it was user-supplied.+      --+      -- We can approximate whether a fixity was user-supplied by checking if+      -- it is not equal to defaultFixity (infixl 9). Unfortunately,+      -- there is no way to distinguish between a user-supplied fixity of+      -- infixl 9 and the fixity that GHC defaults to, so we cannot properly+      -- handle that case.+      DataConI _ _ _ fi <- reify n+      let userSuppliedFixity = fi /= defaultFixity+#endif+      return $ if isInfixDataCon (nameBase n)+                  && length ts == 2+                  && userSuppliedFixity+               then InfixConstructor+               else NormalConstructor +    -- Checks if a String names a valid Haskell infix data+    -- constructor (i.e., does it begin with a colon?).+    isInfixDataCon :: String -> Bool+    isInfixDataCon (':':_) = True+    isInfixDataCon _       = False++    dispatch :: Con -> Q [ConstructorInfo]+    dispatch =+      let defaultCase :: Con -> Q [ConstructorInfo]+          defaultCase = go [] [] False+            where+              go :: [TyVarBndr]+                 -> Cxt+                 -> Bool -- Is this a GADT? (see the documentation for+                         -- for checkGadtFixity)+                 -> Con+                 -> Q [ConstructorInfo]+              go tyvars context gadt c =+                case c of+                  NormalC n xs -> do+                    let (bangs, ts) = unzip xs+                        stricts     = map normalizeStrictness bangs+                    fi <- if gadt+                             then checkGadtFixity ts n+                             else return NormalConstructor+                    return [ConstructorInfo n tyvars context ts stricts fi]+                  InfixC l n r ->+                    let (bangs, ts) = unzip [l,r]+                        stricts     = map normalizeStrictness bangs in+                    return [ConstructorInfo n tyvars context ts stricts+                                            InfixConstructor]+                  RecC n xs ->+                    let fns     = takeFieldNames xs+                        stricts = takeFieldStrictness xs in+                    return [ConstructorInfo n tyvars context+                              (takeFieldTypes xs) stricts (RecordConstructor fns)]+                  ForallC tyvars' context' c' ->+                    go (tyvars'++tyvars) (context'++context) True c' #if MIN_VERSION_template_haskell(2,11,0)-        GadtC ns xs innerType ->-          gadtCase ns innerType (map snd xs) NormalConstructor-        RecGadtC ns xs innerType ->-          let fns = takeFieldNames xs in-          gadtCase ns innerType (takeFieldTypes xs) (RecordConstructor fns)-      where-        gadtCase = normalizeGadtC typename params tyvars context+                  GadtC ns xs innerType ->+                    let (bangs, ts) = unzip xs+                        stricts     = map normalizeStrictness bangs in+                    gadtCase ns innerType ts stricts (checkGadtFixity ts)+                  RecGadtC ns xs innerType ->+                    let fns     = takeFieldNames xs+                        stricts = takeFieldStrictness xs in+                    gadtCase ns innerType (takeFieldTypes xs) stricts+                             (const $ return $ RecordConstructor fns)+                where+                  gadtCase = normalizeGadtC typename params tyvars context+#endif+#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0))+          dataFamCompatCase :: Con -> Q [ConstructorInfo]+          dataFamCompatCase = go []+            where+              go tyvars c =+                case c of+                  NormalC n xs ->+                    let stricts = map (normalizeStrictness . fst) xs in+                    dataFamCase' n tyvars stricts NormalConstructor+                  InfixC l n r ->+                    let stricts = map (normalizeStrictness . fst) [l,r] in+                    dataFamCase' n tyvars stricts InfixConstructor+                  RecC n xs ->+                    let stricts = takeFieldStrictness xs in+                    dataFamCase' n tyvars stricts+                                 (RecordConstructor (takeFieldNames xs))+                  ForallC tyvars' context' c' ->+                    go (tyvars'++tyvars) c' +          dataFamCase' :: Name -> [TyVarBndr] -> [FieldStrictness]+                       -> ConstructorVariant+                       -> Q [ConstructorInfo]+          dataFamCase' n tyvars stricts variant = do+            info <- reify n+            case info of+              DataConI _ ty _ _ -> do+                let (context, argTys :|- returnTy) = uncurryType ty+                returnTy' <- resolveTypeSynonyms returnTy+                -- Notice that we've ignored the Cxt and argument Types from the+                -- Con argument above, as they might be scoped over eta-reduced+                -- variables. Instead of trying to figure out what the+                -- eta-reduced variables should be substituted with post facto,+                -- we opt for the simpler approach of using the context and+                -- argument types from the reified constructor Info, which will+                -- at least be correctly scoped. This will make the task of+                -- substituting those types with the variables we put in+                -- place of the eta-reduced variables (in normalizeDec)+                -- much easier.+                normalizeGadtC typename params tyvars context [n]+                               returnTy' argTys stricts (const $ return variant)+              _ -> fail "normalizeCon: impossible" +      in case variant of+           -- On GHC 7.6 and 7.8, there's quite a bit of post-processing that+           -- needs to be performed to work around an old bug that eta-reduces the+           -- type patterns of data families.+           DataInstance    -> dataFamCompatCase+           NewtypeInstance -> dataFamCompatCase+           Datatype        -> defaultCase+           Newtype         -> defaultCase+#else+      in defaultCase+#endif++#if MIN_VERSION_template_haskell(2,11,0)+normalizeStrictness :: Bang -> FieldStrictness+normalizeStrictness (Bang upk str) =+  FieldStrictness (normalizeSourceUnpackedness upk)+                  (normalizeSourceStrictness str)+  where+    normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness+    normalizeSourceUnpackedness NoSourceUnpackedness = UnspecifiedUnpackedness+    normalizeSourceUnpackedness SourceNoUnpack       = NoUnpack+    normalizeSourceUnpackedness SourceUnpack         = Unpack++    normalizeSourceStrictness :: SourceStrictness -> Strictness+    normalizeSourceStrictness NoSourceStrictness = UnspecifiedStrictness+    normalizeSourceStrictness SourceLazy         = Lazy+    normalizeSourceStrictness SourceStrict       = Strict+#else+normalizeStrictness :: Strict -> FieldStrictness+normalizeStrictness IsStrict  = isStrictAnnot+normalizeStrictness NotStrict = notStrictAnnot+# if MIN_VERSION_template_haskell(2,7,0)+normalizeStrictness Unpacked  = unpackedAnnot+# endif+#endif+ normalizeGadtC ::-  Name               {- ^ Type constructor             -} ->-  [Type]             {- ^ Type parameters              -} ->-  [TyVarBndr]        {- ^ Constructor parameters       -} ->-  Cxt                {- ^ Constructor context          -} ->-  [Name]             {- ^ Constructor names            -} ->-  Type               {- ^ Declared type of constructor -} ->-  [Type]             {- ^ Constructor field types      -} ->-  ConstructorVariant {- ^ Constructor variant          -} ->+  Name              {- ^ Type constructor             -} ->+  [Type]            {- ^ Type parameters              -} ->+  [TyVarBndr]       {- ^ Constructor parameters       -} ->+  Cxt               {- ^ Constructor context          -} ->+  [Name]            {- ^ Constructor names            -} ->+  Type              {- ^ Declared type of constructor -} ->+  [Type]            {- ^ Constructor field types      -} ->+  [FieldStrictness] {- ^ Constructor field strictness -} ->+  (Name -> Q ConstructorVariant)+                    {- ^ Determine a constructor variant+                         from its 'Name' -}              ->   Q [ConstructorInfo]-normalizeGadtC typename params tyvars context names innerType fields variant =+normalizeGadtC typename params tyvars context names innerType+               fields stricts getVariant =   do innerType' <- resolveTypeSynonyms innerType      case decomposeType innerType' of        ConT innerTyCon :| ts | typename == innerTyCon ->@@ -332,8 +684,11 @@               context2 = applySubstitution subst (context1 ++ context)              fields'  = applySubstitution subst fields-         in pure [ConstructorInfo name tyvars' context2 fields' variant-                 | name <- names]+         in sequence [ ConstructorInfo name tyvars' context2+                                       fields' stricts <$> variantQ+                     | name <- names+                     , let variantQ = getVariant name+                     ]         _ -> fail "normalizeGadtC: Expected type constructor application" @@ -352,17 +707,16 @@     aux (VarT 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)+        _ -> (subst, equalPred (VarT n) p : context)      aux _ sc = sc-#endif  -- | Expand all of the type synonyms in a type. resolveTypeSynonyms :: Type -> Q Type resolveTypeSynonyms t =   let f :| xs = decomposeType t -      notTypeSynCase = foldl AppT f <$> traverse resolveTypeSynonyms xs in+      notTypeSynCase = foldl AppT f <$> mapM resolveTypeSynonyms xs in    case f of     ConT n ->@@ -395,20 +749,38 @@ -- saves dependencies for supporting older GHCs data NonEmpty a = a :| [a] +#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0))+data NonEmptySnoc a = [a] :|- a +-- Decompose a function type into its context, argument types,+-- and return types. For instance, this+--+--   (Show a, b ~ Int) => (a -> b) -> Char -> Int+--+-- becomes+--+--   ([Show a, b ~ Int], [a -> b, Char] :|- Int)+uncurryType :: Type -> (Cxt, NonEmptySnoc Type)+uncurryType = go [] []+  where+    go ctxt args (AppT (AppT ArrowT t1) t2) = go ctxt (t1:args) t2+    go ctxt args (ForallT _ ctxt' t)        = go (ctxt++ctxt') args t+    go ctxt args t                          = (ctxt, reverse args :|- t)+#endif+ -- | Resolve any infix type application in a type using the fixities that -- are currently available. Starting in `template-haskell-2.11` types could -- contain unresolved infix applications. resolveInfixT :: Type -> Q Type  #if MIN_VERSION_template_haskell(2,11,0)-resolveInfixT (ForallT vs cx t) = forallT vs (traverse resolveInfixT cx) (resolveInfixT t)+resolveInfixT (ForallT vs cx t) = forallT vs (mapM resolveInfixT cx) (resolveInfixT t) resolveInfixT (f `AppT` x)      = resolveInfixT f `appT` resolveInfixT x resolveInfixT (ParensT t)       = resolveInfixT t resolveInfixT (InfixT l o r)    = conT o `appT` resolveInfixT l `appT` resolveInfixT r resolveInfixT (SigT t k)        = SigT <$> resolveInfixT t <*> resolveInfixT k resolveInfixT t@UInfixT{}       = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)-resolveInfixT t                 = pure t+resolveInfixT t                 = return t  gatherUInfixT :: Type -> InfixList gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r)@@ -419,7 +791,7 @@ resolveInfixT1 = go []   where     go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ-    go ts (ILNil u) = pure (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts)+    go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts)     go ts (ILCons l o r) =       do ofx <- fromMaybe defaultFixity <$> reifyFixity o          let push = go ((l,o,ofx):ts) r@@ -455,7 +827,7 @@  #else -- older template-haskell packages don't have UInfixT-resolveInfixT = pure+resolveInfixT = return #endif  @@ -484,6 +856,13 @@ takeFieldNames :: [(Name,a,b)] -> [Name] takeFieldNames xs = [a | (a,_,_) <- xs] +#if MIN_VERSION_template_haskell(2,11,0)+takeFieldStrictness :: [(a,Bang,b)]   -> [FieldStrictness]+#else+takeFieldStrictness :: [(a,Strict,b)] -> [FieldStrictness]+#endif+takeFieldStrictness xs = [normalizeStrictness a | (_,a,_) <- xs]+ takeFieldTypes :: [(a,b,Type)] -> [Type] takeFieldTypes xs = [a | (_,_,a) <- xs] @@ -506,7 +885,7 @@ freshenFreeVariables :: Type -> Q Type freshenFreeVariables t =   do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t]-     subst <- sequenceA (Map.fromList xs)+     subst <- T.sequence (Map.fromList xs)      return (applySubstitution subst t)  @@ -591,9 +970,9 @@ -- | Compute the type variable substitution that unifies a list of types, -- or fail in 'Q'. unifyTypes :: [Type] -> Q (Map Name Type)-unifyTypes [] = pure Map.empty+unifyTypes [] = return Map.empty unifyTypes (t:ts) =-  do t':ts' <- traverse resolveTypeSynonyms (t:ts)+  do t':ts' <- mapM resolveTypeSynonyms (t:ts)      let aux sub u =            do sub' <- unify' (applySubstitution sub t')                              (applySubstitution sub u)@@ -675,6 +1054,30 @@  ------------------------------------------------------------------------ +-- On old versions of GHC, reify would not give you kind signatures for+-- GADT type variables of kind *. To work around this, we insert the kinds+-- manually on any types without a signature.++giveTypesStarKinds :: DatatypeInfo -> DatatypeInfo+giveTypesStarKinds info =+  info { datatypeVars = annotateVars (datatypeVars info) }+  where+    annotateVars :: [Type] -> [Type]+    annotateVars = map $ \t ->+      case t of+        VarT n -> SigT (VarT n) starK+        _      -> t++giveTyVarBndrsStarKinds :: ConstructorInfo -> ConstructorInfo+giveTyVarBndrsStarKinds info =+  info { constructorVars = annotateVars (constructorVars info) }+  where+    annotateVars :: [TyVarBndr] -> [TyVarBndr]+    annotateVars = map $ \tvb ->+      case tvb of+        PlainTV n -> KindedTV n starK+        _         -> tvb+ -- | 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.@@ -693,7 +1096,7 @@ -- https://ghc.haskell.org/trac/ghc/ticket/13618 repair13618 :: DatatypeInfo -> Q DatatypeInfo repair13618 info =-  do s <- sequenceA (Map.fromList substList)+  do s <- T.sequence (Map.fromList substList)      return info { datatypeCons = applySubstitution s (datatypeCons info) }    where@@ -728,7 +1131,7 @@ #elif MIN_VERSION_template_haskell(2,11,0) dataDCompat c n ts cs ds =   dataD c n ts Nothing cs-    (pure (map ConT ds))+    (return (map ConT ds)) #else dataDCompat = dataD #endif@@ -738,4 +1141,28 @@ arrowKCompat x y = arrowK `appK` x `appK` y #else arrowKCompat = arrowK+#endif++------------------------------------------------------------------------++-- | Backwards compatibility wrapper for 'Fixity' lookup.+--+-- In @template-haskell-2.11.0.0@ and later, the answer will always+-- be 'Just' of a fixity.+--+-- Before @template-haskell-2.11.0.0@ it was only possible to determine+-- fixity information for variables, class methods, and data constructors.+-- In this case for type operators the answer could be 'Nothing', which+-- indicates that the answer is unavailable.+reifyFixityCompat :: Name -> Q (Maybe Fixity)+#if MIN_VERSION_template_haskell(2,11,0)+reifyFixityCompat n = (`mplus` Just defaultFixity) <$> reifyFixity n+#else+reifyFixityCompat n =+  do info <- reify n+     return $! case info of+       ClassOpI _ _ _ fixity -> Just fixity+       DataConI _ _ _ fixity -> Just fixity+       VarI     _ _ _ fixity -> Just fixity+       _                     -> Nothing #endif

@@ -14,3 +14,7 @@  eqTypeName :: Name eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~"++-- This is only needed for GHC 7.6-specific bug+starKindName :: Name+starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"

@@ -1,4 +1,4 @@-{-# Language TemplateHaskell #-}+{-# Language CPP, TemplateHaskell #-}  {-| Module      : Harness@@ -12,20 +12,17 @@ up to alpha renaming.  -}-module Harness (validate) where+module Harness (validate, varKCompat) where  import           Control.Monad import qualified Data.Map as Map import           Language.Haskell.TH import           Language.Haskell.TH.Datatype+import           Language.Haskell.TH.Lib (starK)  validate :: DatatypeInfo -> DatatypeInfo -> ExpQ validate x y = either fail (\_ -> [| return () |]) (equateDI x y) -stripOuterSigT :: Type -> Type-stripOuterSigT (SigT t _) = t-stripOuterSigT t          = t- -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String ()@@ -38,29 +35,34 @@      let sub = Map.fromList (zip (freeVariables (datatypeVars dat2))                                  (map VarT (freeVariables (datatypeVars dat1)))) -     check "datatypeContext" id+     zipWithM_ (equateCxt "datatypeContext")        (datatypeContext dat1)        (applySubstitution sub (datatypeContext dat2))       check "datatypeVars" id-       (map stripOuterSigT (datatypeVars dat1))+       (datatypeVars dat1)        (applySubstitution sub (datatypeVars dat2))       zipWithM_ equateCI        (datatypeCons dat1)        (applySubstitution sub (datatypeCons dat2)) +equateCxt :: String -> Pred -> Pred -> Either String ()+equateCxt lbl pred1 pred2 =+  do check (lbl ++ " class")    asClassPred pred1 pred2+     check (lbl ++ " equality") asEqualPred pred1 pred2+ -- | 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+  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+     zipWithM_ (equateCxt "constructorContext")         (constructorContext con1)         (applySubstitution sub (constructorContext con2)) @@ -68,7 +70,35 @@         (constructorFields con1)         (applySubstitution sub (constructorFields con2)) +     zipWithM_ equateStrictness+        (constructorStrictness con1)+        (constructorStrictness con2)++equateStrictness :: FieldStrictness -> FieldStrictness -> Either String ()+equateStrictness fs1 fs2 =+  check "constructorStrictness" oldGhcHack fs1 fs2+  where+#if MIN_VERSION_template_haskell(2,7,0)+    oldGhcHack = id+#else+    -- GHC 7.0 and 7.2 didn't have an Unpacked TH constructor, so as a+    -- simple workaround, we will treat unpackedAnnot as isStrictAnnot+    -- (the closest equivalent).+    oldGhcHack fs+      | fs == unpackedAnnot = isStrictAnnot+      | otherwise           = fs+#endif+ 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))++-- If on a recent-enough version of Template Haskell, construct a kind variable.+-- Otherwise, default to starK.+varKCompat :: Name -> Kind+#if MIN_VERSION_template_haskell(2,8,0)+varKCompat = VarT+#else+varKCompat _ = starK+#endif

@@ -1,5 +1,9 @@-{-# Language CPP, PolyKinds, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-}+{-# Language CPP, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +#if MIN_VERSION_template_haskell(2,8,0)+{-# Language PolyKinds #-}+#endif+ {-| Module      : Main Description : Test cases for the th-abstraction package@@ -16,14 +20,18 @@  import Language.Haskell.TH import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Lib (starK)  import Harness  type Gadt1Int = Gadt1 Int +infixr 6 :**: data Gadt1 (a :: *) where-  Gadtc1 :: Int   -> Gadt1Int-  Gadtc2 :: (a,a) -> Gadt1 a+  Gadtc1 :: Int          -> Gadt1Int+  Gadtc2 :: (a,a)        -> Gadt1 a+  (:**:) :: Bool -> Char -> Gadt1 ()     -- This is declared infix+  (:!!:) :: Char -> Bool -> Gadt1 Double -- This is not  data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int @@ -43,20 +51,43 @@   Gadt2c2 :: Gadt2 [a] a   Gadt2c3 :: Gadt2 [a] [a] +data VoidStoS (f :: * -> *)++data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int++#if MIN_VERSION_template_haskell(2,7,0)++-- Data families+ data family DF (a :: *) data instance DF (Maybe a) = DFMaybe Int [a] -#if MIN_VERSION_template_haskell(2,9,0)+# if MIN_VERSION_template_haskell(2,8,0) data family DF1 (a :: k)-#elif MIN_VERSION_template_haskell(2,8,0)-data family DF1 a-#else+# else data family DF1 (a :: *)-#endif+# endif data instance DF1 b = DF1 b -data VoidStoS (f :: * -> *) +# if MIN_VERSION_template_haskell(2,8,0)+data family Poly (a :: k)+# else+data family Poly (a :: *)+# endif+data instance Poly a = MkPoly++data family GadtFam (a :: *) (b :: *)+data instance GadtFam c d where+  MkGadtFam1 :: x   -> y        -> GadtFam y x+  (:&&:)     :: e   -> f        -> GadtFam [e] f   -- This is declard infix+  (:^^:)     :: Int -> Int      -> GadtFam Int Int -- This is not+  MkGadtFam4 :: (Int ~ z) => z  -> GadtFam z z+  MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool+infixl 3 :&&:++#endif+ return [] -- segment type declarations above from refiy below  -- | Test entry point. Tests will pass or fail at compile time.@@ -69,21 +100,28 @@      equalTest      showableTest      recordTest+     voidstosTest+     strictDemoTest+#if MIN_VERSION_template_haskell(2,7,0)      dataFamilyTest      ghc78bugTest-     voidstosTest+     polyTest+     gadtFamTest+#endif+     fixityLookupTest  adt1Test :: IO () adt1Test =   $(do info <- reifyDatatype ''Adt1 -       let [a,b] = map (VarT . mkName) ["a","b"]+       let vars@[a,b]  = map (VarT . mkName) ["a","b"]+           [aSig,bSig] = map (\v -> SigT v starK) vars         validate info          DatatypeInfo            { datatypeName = ''Adt1            , datatypeContext = []-           , datatypeVars = [a, b]+           , datatypeVars = [aSig, bSig]            , datatypeVariant = Datatype            , datatypeCons =                [ ConstructorInfo@@ -91,13 +129,15 @@                    , constructorContext = []                    , constructorVars = []                    , constructorFields = [AppT (AppT (TupleT 2) a) b]+                   , constructorStrictness = [notStrictAnnot]                    , constructorVariant = NormalConstructor }                , ConstructorInfo                    { constructorName = 'Adtc2                    , constructorContext = []                    , constructorVars = []                    , constructorFields = [ConT ''Bool, ConT ''Int]-                   , constructorVariant = NormalConstructor }+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant = InfixConstructor }                ]            }    )@@ -112,7 +152,7 @@          DatatypeInfo            { datatypeName = ''Gadt1            , datatypeContext = []-           , datatypeVars = [a]+           , datatypeVars = [SigT a starK]            , datatypeVariant = Datatype            , datatypeCons =                [ ConstructorInfo@@ -120,13 +160,29 @@                    , constructorVars = []                    , constructorContext = [equalPred a (ConT ''Int)]                    , constructorFields = [ConT ''Int]+                   , constructorStrictness = [notStrictAnnot]                    , constructorVariant = NormalConstructor }                , ConstructorInfo                    { constructorName = 'Gadtc2                    , constructorVars = []                    , constructorContext = []                    , constructorFields = [AppT (AppT (TupleT 2) a) a]+                   , constructorStrictness = [notStrictAnnot]                    , constructorVariant = NormalConstructor }+               , ConstructorInfo+                   { constructorName = '(:**:)+                   , constructorVars = []+                   , constructorContext = [equalPred a (TupleT 0)]+                   , constructorFields = [ConT ''Bool, ConT ''Char]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant = InfixConstructor }+               , ConstructorInfo+                   { constructorName = '(:!!:)+                   , constructorVars = []+                   , constructorContext = [equalPred a (ConT ''Double)]+                   , constructorFields = [ConT ''Char, ConT ''Bool]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant = NormalConstructor }                ]            }    )@@ -135,22 +191,24 @@ gadtrec1Test =   $(do info <- reifyDatatype ''Gadtrec1 -       let a = VarT (mkName "a")-       let [v1,v2] = map mkName ["v1","v2"]+       let a             = VarT (mkName "a")+           names@[v1,v2] = map mkName ["v1","v2"]+           [v1K,v2K]     = map (\n -> KindedTV n starK) names         let con = ConstructorInfo-                   { constructorName    = 'Gadtrecc1-                   , constructorVars    = [PlainTV v1, PlainTV v2]-                   , constructorContext =+                   { constructorName       = 'Gadtrecc1+                   , constructorVars       = [v1K, v2K]+                   , constructorContext    =                         [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))]-                   , constructorFields  = [VarT v1, VarT v2]-                   , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] }+                   , constructorFields     = [VarT v1, VarT v2]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = RecordConstructor ['gadtrec1a, 'gadtrec1b] }         validate info          DatatypeInfo            { datatypeName    = ''Gadtrec1            , datatypeContext = []-           , datatypeVars    = [a]+           , datatypeVars    = [SigT a starK]            , datatypeVariant = Datatype            , datatypeCons    =                [ con, con { constructorName = 'Gadtrecc2 } ]@@ -161,23 +219,26 @@ equalTest =   $(do info <- reifyDatatype ''Equal -       let [a,b,c] = map (VarT . mkName) ["a","b","c"]+       let vars@[a,b,c]     = map (VarT . mkName) ["a","b","c"]+           [aSig,bSig,cSig] = map (\v -> SigT v starK) vars         validate info          DatatypeInfo            { datatypeName    = ''Equal            , datatypeContext = []-           , datatypeVars    = [a, b, c]+           , datatypeVars    = [aSig, bSig, cSig]            , datatypeVariant = Datatype            , datatypeCons    =                [ ConstructorInfo-                   { constructorName    = 'Equalc-                   , constructorVars    = []-                   , constructorContext =+                   { constructorName       = 'Equalc+                   , constructorVars       = []+                   , constructorContext    =                         [equalPred a c, equalPred b c, classPred ''Read [c], classPred ''Show [c] ]-                   , constructorFields  =+                   , constructorFields     =                         [ListT `AppT` c, ConT ''Maybe `AppT` c]-                   , constructorVariant = NormalConstructor }+                   , constructorStrictness =+                        [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = NormalConstructor }                ]            }    )@@ -196,11 +257,12 @@            , datatypeVariant = Datatype            , datatypeCons    =                [ ConstructorInfo-                   { constructorName    = 'Showable-                   , constructorVars    = [PlainTV a]-                   , constructorContext = [classPred ''Show [VarT a]]-                   , constructorFields  = [VarT a]-                   , constructorVariant = NormalConstructor }+                   { constructorName       = 'Showable+                   , constructorVars       = [PlainTV a]+                   , constructorContext    = [classPred ''Show [VarT a]]+                   , constructorFields     = [VarT a]+                   , constructorStrictness = [notStrictAnnot]+                   , constructorVariant    = NormalConstructor }                ]            }    )@@ -216,11 +278,12 @@            , datatypeVariant = Datatype            , datatypeCons    =                [ ConstructorInfo-                   { constructorName    = 'R1-                   , constructorVars    = []-                   , constructorContext = []-                   , constructorFields  = [ConT ''Int, ConT ''Int]-                   , constructorVariant = RecordConstructor ['field1, 'field2] }+                   { constructorName       = 'R1+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = [ConT ''Int, ConT ''Int]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = RecordConstructor ['field1, 'field2] }                ]            }    )@@ -228,19 +291,21 @@ gadt2Test :: IO () gadt2Test =   $(do info <- reifyDatatype ''Gadt2-       let [a,b] = map (VarT . mkName) ["a","b"]+       let vars@[a,b]  = map (VarT . mkName) ["a","b"]+           [aSig,bSig] = map (\v -> SigT v starK) vars            x     = mkName "x"            con   = ConstructorInfo-                     { constructorName    = undefined-                     , constructorVars    = []-                     , constructorContext = []-                     , constructorFields  = []-                     , constructorVariant = NormalConstructor }+                     { constructorName       = undefined+                     , constructorVars       = []+                     , constructorContext    = []+                     , constructorFields     = []+                     , constructorStrictness = []+                     , constructorVariant    = NormalConstructor }        validate info          DatatypeInfo            { datatypeName    = ''Gadt2            , datatypeContext = []-           , datatypeVars    = [a, b]+           , datatypeVars    = [aSig, bSig]            , datatypeVariant = Datatype            , datatypeCons    =                [ con { constructorName = 'Gadt2c1@@ -248,13 +313,51 @@                , con { constructorName = 'Gadt2c2                      , constructorContext = [equalPred a (AppT ListT b)] }                , con { constructorName = 'Gadt2c3-                     , constructorVars = [PlainTV x]+                     , constructorVars = [KindedTV x starK]                      , constructorContext =                          [equalPred a (AppT ListT (VarT x))                          ,equalPred b (AppT ListT (VarT x))] } ]            }   ) +voidstosTest :: IO ()+voidstosTest =+  $(do info <- reifyDatatype ''VoidStoS+       let g = mkName "g"+       validate info+         DatatypeInfo+           { datatypeName    = ''VoidStoS+           , datatypeContext = []+           , datatypeVars    = [SigT (VarT g) (arrowKCompat starK starK)]+           , datatypeVariant = Datatype+           , datatypeCons    = []+           }+  )++strictDemoTest :: IO ()+strictDemoTest =+  $(do info <- reifyDatatype ''StrictDemo+       validate info+         DatatypeInfo+           { datatypeName    = ''StrictDemo+           , datatypeContext = []+           , datatypeVars    = []+           , datatypeVariant = Datatype+           , datatypeCons    =+               [ ConstructorInfo+                   { constructorName       = 'StrictDemo+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = [ConT ''Int, ConT ''Int, ConT ''Int]+                   , constructorStrictness = [ notStrictAnnot+                                             , isStrictAnnot+                                             , unpackedAnnot+                                             ]+                   , constructorVariant    = NormalConstructor } ]+           }+   )++#if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest :: IO () dataFamilyTest =   $(do info <- reifyDatatype 'DFMaybe@@ -267,44 +370,117 @@            , datatypeVariant = DataInstance            , datatypeCons    =                [ ConstructorInfo-                   { constructorName    = 'DFMaybe-                   , constructorVars    = []-                   , constructorContext = []-                   , constructorFields  = [ConT ''Int, ListT `AppT` VarT a]-                   , constructorVariant = NormalConstructor } ]+                   { constructorName       = 'DFMaybe+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = [ConT ''Int, ListT `AppT` VarT a]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = NormalConstructor } ]            }   )  ghc78bugTest :: IO () ghc78bugTest =   $(do info <- reifyDatatype 'DF1-       let c = mkName "c"+       let c = VarT (mkName "c")        validate info          DatatypeInfo            { datatypeName    = ''DF1            , datatypeContext = []-           , datatypeVars    = [VarT c]+           , datatypeVars    = [SigT c starK]            , datatypeVariant = DataInstance            , datatypeCons    =                [ ConstructorInfo-                   { constructorName    = 'DF1-                   , constructorVars    = []-                   , constructorContext = []-                   , constructorFields  = [VarT c]-                   , constructorVariant = NormalConstructor } ]+                   { constructorName       = 'DF1+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = [c]+                   , constructorStrictness = [notStrictAnnot]+                   , constructorVariant    = NormalConstructor } ]            }   ) -voidstosTest :: IO ()-voidstosTest =-  $(do info <- reifyDatatype ''VoidStoS-       let g = mkName "g"+polyTest :: IO ()+polyTest =+  $(do info <- reifyDatatype 'MkPoly+       let [a,k] = map mkName ["a","k"]        validate info          DatatypeInfo-           { datatypeName    = ''VoidStoS+           { datatypeName    = ''Poly            , datatypeContext = []-           , datatypeVars    = [VarT g]-           , datatypeVariant = Datatype-           , datatypeCons    = []+           , datatypeVars    = [SigT (VarT a) (varKCompat k)]+           , datatypeVariant = DataInstance+           , datatypeCons    =+               [ ConstructorInfo+                   { constructorName       = 'MkPoly+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = []+                   , constructorStrictness = []+                   , constructorVariant    = NormalConstructor } ]            }   )++gadtFamTest :: IO ()+gadtFamTest =+  $(do info <- reifyDatatype 'MkGadtFam1+       let names@[c,d,e,q]   = map mkName ["c","d","e","q"]+           [cTy,dTy,eTy,qTy] = map VarT names+           [cSig,dSig]       = map (\v -> SigT v starK) [cTy,dTy]+       validate info+         DatatypeInfo+           { datatypeName    = ''GadtFam+           , datatypeContext = []+           , datatypeVars    = [cSig,dSig]+           , datatypeVariant = DataInstance+           , datatypeCons    =+               [ ConstructorInfo+                   { constructorName       = 'MkGadtFam1+                   , constructorVars       = []+                   , constructorContext    = []+                   , constructorFields     = [dTy,cTy]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = NormalConstructor }+               , ConstructorInfo+                   { constructorName       = '(:&&:)+                   , constructorVars       = [PlainTV e]+                   , constructorContext    = [equalPred cTy (AppT ListT eTy)]+                   , constructorFields     = [eTy,dTy]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = InfixConstructor }+               , ConstructorInfo+                   { constructorName       = '(:^^:)+                   , constructorVars       = []+                   , constructorContext    = [ equalPred cTy (ConT ''Int)+                                             , equalPred dTy (ConT ''Int)+                                             ]+                   , constructorFields     = [ConT ''Int, ConT ''Int]+                   , constructorStrictness = [notStrictAnnot, notStrictAnnot]+                   , constructorVariant    = NormalConstructor }+               , ConstructorInfo+                   { constructorName       = 'MkGadtFam4+                   , constructorVars       = []+                   , constructorContext    = [ equalPred cTy dTy+                                             , equalPred (ConT ''Int) dTy+                                             ]+                   , constructorFields     = [dTy]+                   , constructorStrictness = [notStrictAnnot]+                   , constructorVariant    = NormalConstructor }+               , ConstructorInfo+                   { constructorName       = 'MkGadtFam5+                   , constructorVars       = [PlainTV q]+                   , constructorContext    = [ equalPred cTy (ConT ''Bool)+                                             , equalPred dTy (ConT ''Bool)+                                             , equalPred qTy (ConT ''Char)+                                             ]+                   , constructorFields     = [qTy]+                   , constructorStrictness = [notStrictAnnot]+                   , constructorVariant    = NormalConstructor } ]+           }+   )+#endif++fixityLookupTest :: IO ()+fixityLookupTest =+  $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:)+       [| return () |])

@@ -1,5 +1,5 @@ name:                th-abstraction-version:             0.1.3.0+version:             0.2.0.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 cabal-version:       >=1.10-tested-with:         GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with:         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@@ -26,9 +26,9 @@ library   exposed-modules:     Language.Haskell.TH.Datatype   other-modules:       Language.Haskell.TH.Datatype.Internal-  build-depends:       base             >=4.5   && <5,+  build-depends:       base             >=4.3   && <5,                        ghc-prim,-                       template-haskell >=2.7   && <2.13,+                       template-haskell >=2.5   && <2.13,                        containers       >=0.4   && <0.6   hs-source-dirs:      src   default-language:    Haskell2010