Merge types and kinds in DsMeta
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 28 Jul 2017 15:35:37 +0000 (11:35 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Fri, 28 Jul 2017 15:35:38 +0000 (11:35 -0400)
Summary:
Types and kinds are now the same in GHC... well, except in the code
that involves Template Haskell, where types and kinds are given separate
treatment. This aims to unify that treatment in the `DsMeta` module.

The gist of this patch is replacing all uses of `repLKind` with `repLTy`.
This is isn't quite as simple as one might imagine, since `repLTy` returns a
`Core (Q Type)` (a monadic expression), whereas `repLKind` returns a
`Core Kind` (a pure expression). This causes many awkward impedance mismatches.

One option would be to change every combinator in `Language.Haskell.TH.Lib` to
take `KindQ` as an argument instead of `Kind`. But this would be a breaking
change of colossal proportions.

Instead, this patch takes a somewhat different approach. This migrates the
existing `Language.Haskell.TH.Lib` module to
`Language.Haskell.TH.Lib.Internal`, and changes all `Kind`-related combinators
in `Language.Haskell.TH.Lib.Internal` to live in `Q`. The new
`Language.Haskell.TH.Lib` module then re-exports most of
`Language.Haskell.TH.Lib.Internal` with the exception of the `Kind`-related
combinators, for which it redefines them to be their current definitions (which
don't live in `Q`). This allows us to retain backwards compatibility with
previous `template-haskell` releases, but more importantly, it allows GHC to
make as many changes to the `Internal` code as it wants for its purposes
without fear of disrupting the public API.

This solves half of #11785 (the other half being `TcSplice`).

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, thomie

GHC Trac Issues: #11785

Differential Revision: https://phabricator.haskell.org/D3751

compiler/deSugar/DsMeta.hs
compiler/prelude/THNames.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs [new file with mode: 0644]
libraries/template-haskell/changelog.md
libraries/template-haskell/template-haskell.cabal
testsuite/tests/quotes/TH_localname.stderr
testsuite/tests/th/T13642.hs
testsuite/tests/th/T13642.stderr [deleted file]
testsuite/tests/th/T7276.stderr
testsuite/tests/th/all.T

index c679981..e732ce5 100644 (file)
@@ -307,7 +307,7 @@ repRoleD (L loc (RoleAnnotDecl tycon roles))
        ; return (loc, dec) }
 
 -------------------------
-repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
             -> Maybe (Core [TH.TypeQ])
             -> HsDataDefn GhcRn
             -> DsM (Core TH.DecQ)
@@ -318,20 +318,20 @@ repDataDefn tc bndrs opt_tys
        ; derivs1  <- repDerivs mb_derivs
        ; case (new_or_data, cons) of
            (NewType, [con])  -> do { con'  <- repC con
-                                   ; ksig' <- repMaybeLKind ksig
+                                   ; ksig' <- repMaybeLTy ksig
                                    ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                 derivs1 }
            (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                        <+> pprQuotedList
                                        (getConNames $ unLoc $ head cons))
-           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
                                ; consL <- mapM repC cons
                                ; cons1 <- coreList conQTyConName consL
                                ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                          derivs1 }
        }
 
-repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
            -> LHsType GhcRn
            -> DsM (Core TH.DecQ)
 repSynDecl tc bndrs ty
@@ -373,9 +373,9 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
        }
 
 -- | Represent result signature of a type family
-repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig)
+repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
 repFamilyResultSig  NoSig          = repNoSig
-repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki
+repFamilyResultSig (KindSig ki)    = do { ki' <- repLTy ki
                                         ; repKindSig ki' }
 repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
                                         ; repTyVarSig bndr' }
@@ -384,12 +384,12 @@ repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
 -- where the result signature can be either missing or a kind but never a named
 -- result variable.
 repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
-                              -> DsM (Core (Maybe TH.Kind))
+                              -> DsM (Core (Maybe TH.KindQ))
 repFamilyResultSigToMaybeKind NoSig =
-    do { coreNothing kindTyConName }
+    do { coreNothing kindQTyConName }
 repFamilyResultSigToMaybeKind (KindSig ki) =
-    do { ki' <- repLKind ki
-       ; coreJust kindTyConName ki' }
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
 repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
 
 -- | Represent injectivity annotation of a type family
@@ -769,7 +769,7 @@ rep_wc_ty_sig mk_sig loc sig_ty nm
   = do { nm1 <- lookupLOcc nm
        ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                      ; repTyVarBndrWithKind tv name }
-       ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv
+       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
                                     explicit_tvs
          -- NB: Don't pass any implicit type variables to repList above
          -- See Note [Don't quantify implicit type variables in quotes]
@@ -864,7 +864,7 @@ addSimpleTyVarBinds names thing_inside
        ; wrapGenSyms fresh_names term }
 
 addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
-              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
+              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
@@ -875,7 +875,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
        ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
        ; let fresh_names = fresh_imp_names ++ fresh_exp_names
        ; term <- addBinds fresh_names $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
                                      (exp_tvs `zip` fresh_exp_names)
                     ; m kbs }
        ; wrapGenSyms fresh_names term }
@@ -883,7 +883,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
 addTyClTyVarBinds :: LHsQTyVars GhcRn
-                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
+                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
                   -> DsM (Core (TH.Q a))
 
 -- Used for data/newtype declarations, and family instances,
@@ -899,29 +899,31 @@ addTyClTyVarBinds tvs m
             -- This makes things work for family declarations
 
        ; term <- addBinds freshNames $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (hsQTvExplicit tvs)
                     ; m kbs }
 
        ; wrapGenSyms freshNames term }
   where
+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
     mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
                        ; repTyVarBndrWithKind tv v }
 
 -- Produce kinded binder constructors from the Haskell tyvar binders
 --
 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
+                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
 repTyVarBndrWithKind (L _ (UserTyVar _)) nm
   = repPlainTV nm
 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
-  = repLKind ki >>= repKindedTV nm
+  = repLTy ki >>= repKindedTV nm
 
 -- | Represent a type variable binder
-repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr)
+repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
 repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                              ; repPlainTV nm' }
 repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
-                                                  ; ki' <- repLKind ki
+                                                  ; ki' <- repLTy ki
                                                   ; repKindedTV nm' ki' }
 
 -- represent a type context
@@ -995,6 +997,8 @@ repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
 repTy (HsTyVar _ (L _ n))
+  | isLiftedTypeKindTyConName n       = repTStar
+  | n `hasKey` constraintKindTyConKey = repTConstraint
   | isTvOcc occ   = do tv1 <- lookupOcc n
                        repTvar tv1
   | isDataOcc occ = do tc1 <- lookupOcc n
@@ -1043,7 +1047,7 @@ repTy (HsEqTy t1 t2) = do
                          repTapps eq [t1', t2']
 repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
-                                k1 <- repLKind k
+                                k1 <- repLTy k
                                 repTSig t1 k1
 repTy (HsSpliceTy splice _)     = repSplice splice
 repTy (HsExplicitListTy _ _ tys) = do
@@ -1067,59 +1071,14 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                             ; rep2 strTyLitName [s']
                             }
 
--- represent a kind
---
--- It would be great to scrap this function in favor of repLTy, since Types
--- and Kinds are the same things. We have not done so yet for engineering
--- reasons, as repLTy returns a monadic TypeQ, whereas repLKind returns a pure
--- Kind, so in order to replace repLKind with repLTy, we'd need to go through
--- and purify repLTy and every monadic function it calls. This is the subject
--- GHC Trac #11785.
-repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind)
-repLKind ki
-  = do { let (kis, ki') = splitHsFunType ki
-       ; kis_rep <- mapM repLKind kis
-       ; ki'_rep <- repNonArrowLKind ki'
-       ; kcon <- repKArrow
-       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
-       ; foldrM f ki'_rep kis_rep
-       }
-
--- | Represent a kind wrapped in a Maybe
-repMaybeLKind :: Maybe (LHsKind GhcRn)
-              -> DsM (Core (Maybe TH.Kind))
-repMaybeLKind Nothing =
-    do { coreNothing kindTyConName }
-repMaybeLKind (Just ki) =
-    do { ki' <- repLKind ki
-       ; coreJust kindTyConName ki' }
-
-repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind)
-repNonArrowLKind (L _ ki) = repNonArrowKind ki
-
-repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind)
-repNonArrowKind (HsTyVar _ (L _ name))
-  | isLiftedTypeKindTyConName name       = repKStar
-  | name `hasKey` constraintKindTyConKey = repKConstraint
-  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
-  | otherwise                       = lookupOcc name >>= repKCon
-repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f
-                                          ; a' <- repLKind a
-                                          ; repKApp f' a'
-                                          }
-repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k
-                                          ; kcon <- repKList
-                                          ; repKApp kcon k'
-                                          }
-repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks
-                                          ; kcon <- repKTuple (length ks)
-                                          ; repKApps kcon ks'
-                                          }
-repNonArrowKind (HsKindSig k sort)  = do  { k'    <- repLKind k
-                                          ; sort' <- repLKind sort
-                                          ; repKSig k' sort'
-                                          }
-repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)
+-- | Represent a type wrapped in a Maybe
+repMaybeLTy :: Maybe (LHsKind GhcRn)
+            -> DsM (Core (Maybe TH.TypeQ))
+repMaybeLTy Nothing =
+    do { coreNothing kindQTyConName }
+repMaybeLTy (Just ki) =
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
 
 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
 repRole (L _ (Just Nominal))          = rep2 nominalRName []
@@ -2045,8 +2004,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
         -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
   = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
@@ -2054,8 +2013,8 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
         (MkC derivs)
   = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
 
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
            -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
            (MkC derivs)
@@ -2064,7 +2023,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
            (MkC derivs)
   = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
 
-repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
   = rep2 tySynDName [nm, tvs, rhs]
@@ -2104,7 +2063,7 @@ repOverlap mb =
   just    = coreJust overlapTyConName
 
 
-repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core [TH.FunDep] -> Core [TH.DecQ]
          -> DsM (Core TH.DecQ)
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
@@ -2149,22 +2108,22 @@ repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
 repTySynInst (MkC nm) (MkC eqn)
     = rep2 tySynInstDName [nm, eqn]
 
-repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]
-               -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)
+repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
+               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
     = rep2 dataFamilyDName [nm, tvs, kind]
 
 repOpenFamilyD :: Core TH.Name
-               -> Core [TH.TyVarBndr]
-               -> Core TH.FamilyResultSig
+               -> Core [TH.TyVarBndrQ]
+               -> Core TH.FamilyResultSigQ
                -> Core (Maybe TH.InjectivityAnn)
                -> DsM (Core TH.DecQ)
 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
     = rep2 openTypeFamilyDName [nm, tvs, result, inj]
 
 repClosedFamilyD :: Core TH.Name
-                 -> Core [TH.TyVarBndr]
-                 -> Core TH.FamilyResultSig
+                 -> Core [TH.TyVarBndrQ]
+                 -> Core TH.FamilyResultSigQ
                  -> Core (Maybe TH.InjectivityAnn)
                  -> Core [TH.TySynEqnQ]
                  -> DsM (Core TH.DecQ)
@@ -2250,7 +2209,7 @@ repConstr _ _ _ =
 
 ------------ Types -------------------
 
-repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
+repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
            -> DsM (Core TH.TypeQ)
 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
     = rep2 forallTName [tvars, ctxt, ty]
@@ -2265,7 +2224,7 @@ repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTapps f []     = return f
 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 
-repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
+repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
 
 repTequality :: DsM (Core TH.TypeQ)
@@ -2285,6 +2244,12 @@ repTLit (MkC lit) = rep2 litTName [lit]
 repTWildCard :: DsM (Core TH.TypeQ)
 repTWildCard = rep2 wildCardTName []
 
+repTStar :: DsM (Core TH.TypeQ)
+repTStar = rep2 starKName []
+
+repTConstraint :: DsM (Core TH.TypeQ)
+repTConstraint = rep2 constraintKName []
+
 --------- Type constructors --------------
 
 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
@@ -2324,56 +2289,24 @@ repPromotedNilTyCon = rep2 promotedNilTName []
 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
 repPromotedConsTyCon = rep2 promotedConsTName []
 
------------- Kinds -------------------
+------------ TyVarBndrs -------------------
 
-repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
 repPlainTV (MkC nm) = rep2 plainTVName [nm]
 
-repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
+repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
 
-repKVar :: Core TH.Name -> DsM (Core TH.Kind)
-repKVar (MkC s) = rep2 varKName [s]
-
-repKCon :: Core TH.Name -> DsM (Core TH.Kind)
-repKCon (MkC s) = rep2 conKName [s]
-
-repKTuple :: Int -> DsM (Core TH.Kind)
-repKTuple i = do dflags <- getDynFlags
-                 rep2 tupleKName [mkIntExprInt dflags i]
-
-repKArrow :: DsM (Core TH.Kind)
-repKArrow = rep2 arrowKName []
-
-repKList :: DsM (Core TH.Kind)
-repKList = rep2 listKName []
-
-repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
-repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
-
-repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
-repKApps f []     = return f
-repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
-
-repKStar :: DsM (Core TH.Kind)
-repKStar = rep2 starKName []
-
-repKConstraint :: DsM (Core TH.Kind)
-repKConstraint = rep2 constraintKName []
-
-repKSig :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
-repKSig (MkC k) (MkC sort) = rep2 sigTDataConName [k, sort]
-
 ----------------------------------------------------------
 --       Type family result signature
 
-repNoSig :: DsM (Core TH.FamilyResultSig)
+repNoSig :: DsM (Core TH.FamilyResultSigQ)
 repNoSig = rep2 noSigName []
 
-repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)
+repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
 repKindSig (MkC ki) = rep2 kindSigName [ki]
 
-repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)
+repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
 
 ----------------------------------------------------------
index 8536243..4128ab3 100644 (file)
@@ -95,7 +95,7 @@ templateHaskellNames = [
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, unboxedSumTName,
-    arrowTName, listTName, sigTName, sigTDataConName, litTName,
+    arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
     wildCardTName,
     -- TyLit
@@ -152,10 +152,10 @@ templateHaskellNames = [
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
     stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
     varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
-    typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
+    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
     predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
-    roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
+    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
     overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,
 
     -- Quasiquoting
@@ -163,7 +163,7 @@ templateHaskellNames = [
 
 thSyn, thLib, qqLib :: Module
 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
 
 mkTHModule :: FastString -> Module
@@ -184,9 +184,9 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
 
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
-    tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
-    predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
-    overlapTyConName, derivStrategyTyConName :: Name
+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
+    tExpTyConName, injAnnTyConName, overlapTyConName,
+    derivStrategyTyConName :: Name
 qTyConName             = thTc (fsLit "Q")              qTyConKey
 nameTyConName          = thTc (fsLit "Name")           nameTyConKey
 fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey
@@ -195,14 +195,12 @@ fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey
 expTyConName           = thTc (fsLit "Exp")            expTyConKey
 decTyConName           = thTc (fsLit "Dec")            decTyConKey
 typeTyConName          = thTc (fsLit "Type")           typeTyConKey
-tyVarBndrTyConName     = thTc (fsLit "TyVarBndr")      tyVarBndrTyConKey
 matchTyConName         = thTc (fsLit "Match")          matchTyConKey
 clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
 funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
 predTyConName          = thTc (fsLit "Pred")           predTyConKey
 tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey
 injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
-kindTyConName          = thTc (fsLit "Kind")           kindTyConKey
 overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
 derivStrategyTyConName = thTc (fsLit "DerivStrategy")  derivStrategyTyConKey
 
@@ -347,38 +345,36 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
     pragCompleteDName :: Name
-funDName             = libFun (fsLit "funD")              funDIdKey
-valDName             = libFun (fsLit "valD")              valDIdKey
-dataDName            = libFun (fsLit "dataD")             dataDIdKey
-newtypeDName         = libFun (fsLit "newtypeD")          newtypeDIdKey
-tySynDName           = libFun (fsLit "tySynD")            tySynDIdKey
-classDName           = libFun (fsLit "classD")            classDIdKey
-instanceWithOverlapDName
-  = libFun (fsLit "instanceWithOverlapD")              instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun
-        (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
-sigDName             = libFun (fsLit "sigD")              sigDIdKey
-defaultSigDName      = libFun (fsLit "defaultSigD")       defaultSigDIdKey
-forImpDName          = libFun (fsLit "forImpD")           forImpDIdKey
-pragInlDName         = libFun (fsLit "pragInlD")          pragInlDIdKey
-pragSpecDName        = libFun (fsLit "pragSpecD")         pragSpecDIdKey
-pragSpecInlDName     = libFun (fsLit "pragSpecInlD")      pragSpecInlDIdKey
-pragSpecInstDName    = libFun (fsLit "pragSpecInstD")     pragSpecInstDIdKey
-pragRuleDName        = libFun (fsLit "pragRuleD")         pragRuleDIdKey
-pragCompleteDName    = libFun (fsLit "pragCompleteD")     pragCompleteDIdKey
-pragAnnDName         = libFun (fsLit "pragAnnD")          pragAnnDIdKey
-dataInstDName        = libFun (fsLit "dataInstD")         dataInstDIdKey
-newtypeInstDName     = libFun (fsLit "newtypeInstD")      newtypeInstDIdKey
-tySynInstDName       = libFun (fsLit "tySynInstD")        tySynInstDIdKey
-openTypeFamilyDName  = libFun (fsLit "openTypeFamilyD")   openTypeFamilyDIdKey
-closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey
-dataFamilyDName      = libFun (fsLit "dataFamilyD")       dataFamilyDIdKey
-infixLDName          = libFun (fsLit "infixLD")           infixLDIdKey
-infixRDName          = libFun (fsLit "infixRD")           infixRDIdKey
-infixNDName          = libFun (fsLit "infixND")           infixNDIdKey
-roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey
-patSynDName          = libFun (fsLit "patSynD")           patSynDIdKey
-patSynSigDName       = libFun (fsLit "patSynSigD")        patSynSigDIdKey
+funDName                         = libFun (fsLit "funD")                         funDIdKey
+valDName                         = libFun (fsLit "valD")                         valDIdKey
+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey
+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
+classDName                       = libFun (fsLit "classD")                       classDIdKey
+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
+defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey
+forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey
+pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey
+pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey
+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey
+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey
+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey
+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey
+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey
+infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey
+infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey
+infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey
+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -432,7 +428,7 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
     unboxedSumTName, arrowTName, listTName, appTName, sigTName,
-    sigTDataConName, equalityTName, litTName, promotedTName,
+    equalityTName, litTName, promotedTName,
     promotedTupleTName, promotedNilTName, promotedConsTName,
     wildCardTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
@@ -445,9 +441,6 @@ arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
 listTName           = libFun (fsLit "listT")          listTIdKey
 appTName            = libFun (fsLit "appT")           appTIdKey
 sigTName            = libFun (fsLit "sigT")           sigTIdKey
--- Yes, we need names for both the monadic sigT as well as the pure SigT. Why?
--- Refer to the documentation for repLKind in DsMeta.
-sigTDataConName     = thCon  (fsLit "SigT")           sigTDataConKey
 equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
 litTName            = libFun (fsLit "litT")           litTIdKey
 promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
@@ -463,8 +456,8 @@ strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
 
 -- data TyVarBndr = ...
 plainTVName, kindedTVName :: Name
-plainTVName       = libFun (fsLit "plainTV")       plainTVIdKey
-kindedTVName      = libFun (fsLit "kindedTV")      kindedTVIdKey
+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
 
 -- data Role = ...
 nominalRName, representationalRName, phantomRName, inferRName :: Name
@@ -487,9 +480,9 @@ constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
 
 -- data FamilyResultSig = ...
 noSigName, kindSigName, tyVarSigName :: Name
-noSigName       = libFun (fsLit "noSig")        noSigIdKey
-kindSigName     = libFun (fsLit "kindSig")      kindSigIdKey
-tyVarSigName    = libFun (fsLit "tyVarSig")     tyVarSigIdKey
+noSigName    = libFun (fsLit "noSig")    noSigIdKey
+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey
+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
 
 -- data InjectivityAnn = ...
 injectivityAnnName :: Name
@@ -546,7 +539,7 @@ matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
     ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
-    derivClauseQTyConName :: Name
+    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
 clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
 expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
@@ -565,6 +558,8 @@ ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
 tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
 roleTyConName           = libTc (fsLit "Role")           roleTyConKey
 derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey
+kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey
+tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -630,12 +625,12 @@ liftClassKey = mkPreludeClassUnique 200
 
 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
-    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
-    decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
     predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
-    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
     overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
 matchTyConKey           = mkPreludeTyConUnique 201
@@ -662,14 +657,14 @@ fieldExpQTyConKey       = mkPreludeTyConUnique 221
 funDepTyConKey          = mkPreludeTyConUnique 222
 predTyConKey            = mkPreludeTyConUnique 223
 predQTyConKey           = mkPreludeTyConUnique 224
-tyVarBndrTyConKey       = mkPreludeTyConUnique 225
+tyVarBndrQTyConKey      = mkPreludeTyConUnique 225
 decsQTyConKey           = mkPreludeTyConUnique 226
 ruleBndrQTyConKey       = mkPreludeTyConUnique 227
 tySynEqnQTyConKey       = mkPreludeTyConUnique 228
 roleTyConKey            = mkPreludeTyConUnique 229
 tExpTyConKey            = mkPreludeTyConUnique 230
 injAnnTyConKey          = mkPreludeTyConUnique 231
-kindTyConKey            = mkPreludeTyConUnique 232
+kindQTyConKey           = mkPreludeTyConUnique 232
 overlapTyConKey         = mkPreludeTyConUnique 233
 derivClauseQTyConKey    = mkPreludeTyConUnique 234
 derivStrategyTyConKey   = mkPreludeTyConUnique 235
@@ -955,7 +950,7 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 372
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
     unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
-    sigTDataConKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+    equalityTIdKey, litTIdKey, promotedTIdKey,
     promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
     wildCardTIdKey :: Unique
 forallTIdKey        = mkPreludeMiscIdUnique 381
@@ -968,14 +963,13 @@ arrowTIdKey         = mkPreludeMiscIdUnique 387
 listTIdKey          = mkPreludeMiscIdUnique 388
 appTIdKey           = mkPreludeMiscIdUnique 389
 sigTIdKey           = mkPreludeMiscIdUnique 390
-sigTDataConKey      = mkPreludeMiscIdUnique 391
-equalityTIdKey      = mkPreludeMiscIdUnique 392
-litTIdKey           = mkPreludeMiscIdUnique 393
-promotedTIdKey      = mkPreludeMiscIdUnique 394
-promotedTupleTIdKey = mkPreludeMiscIdUnique 395
-promotedNilTIdKey   = mkPreludeMiscIdUnique 396
-promotedConsTIdKey  = mkPreludeMiscIdUnique 397
-wildCardTIdKey      = mkPreludeMiscIdUnique 398
+equalityTIdKey      = mkPreludeMiscIdUnique 391
+litTIdKey           = mkPreludeMiscIdUnique 392
+promotedTIdKey      = mkPreludeMiscIdUnique 393
+promotedTupleTIdKey = mkPreludeMiscIdUnique 394
+promotedNilTIdKey   = mkPreludeMiscIdUnique 395
+promotedConsTIdKey  = mkPreludeMiscIdUnique 396
+wildCardTIdKey      = mkPreludeMiscIdUnique 397
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
index 78fbc41..9ad36f8 100644 (file)
@@ -1,8 +1,13 @@
 -- |
--- TH.Lib contains lots of useful helper functions for
+-- Language.Haskell.TH.Lib contains lots of useful helper functions for
 -- generating and manipulating Template Haskell terms
 
-{-# LANGUAGE CPP #-}
+-- Note: this module mostly re-exports functions from
+-- Language.Haskell.TH.Lib.Internal, but if a change occurs to Template
+-- Haskell which requires breaking the API offered in this module, we opt to
+-- copy the old definition here, and make the changes in
+-- Language.Haskell.TH.Lib.Internal. This way, we can retain backwards
+-- compatibility while still allowing GHC to make changes as it needs.
 
 module Language.Haskell.TH.Lib (
     -- All of the exports from this module should
@@ -11,11 +16,12 @@ module Language.Haskell.TH.Lib (
 
     -- * Library functions
     -- ** Abbreviations
-        InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ,
-        DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ,
-        SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ,
-        StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ,
-        TySynEqnQ, PatSynDirQ, PatSynArgsQ,
+        InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ,
+        TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ,
+        StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ,
+        BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ,
+        FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ,
+        FamilyResultSigQ,
 
     -- ** Constructors lifted to 'Q'
     -- *** Literals
@@ -111,358 +117,45 @@ module Language.Haskell.TH.Lib (
 
    ) where
 
-import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
-import qualified Language.Haskell.TH.Syntax as TH
-import Control.Monad( liftM, liftM2 )
-import Data.Word( Word8 )
-
-----------------------------------------------------------
--- * Type synonyms
-----------------------------------------------------------
-
-type InfoQ               = Q Info
-type PatQ                = Q Pat
-type FieldPatQ           = Q FieldPat
-type ExpQ                = Q Exp
-type TExpQ a             = Q (TExp a)
-type DecQ                = Q Dec
-type DecsQ               = Q [Dec]
-type ConQ                = Q Con
-type TypeQ               = Q Type
-type TyLitQ              = Q TyLit
-type CxtQ                = Q Cxt
-type PredQ               = Q Pred
-type DerivClauseQ        = Q DerivClause
-type MatchQ              = Q Match
-type ClauseQ             = Q Clause
-type BodyQ               = Q Body
-type GuardQ              = Q Guard
-type StmtQ               = Q Stmt
-type RangeQ              = Q Range
-type SourceStrictnessQ   = Q SourceStrictness
-type SourceUnpackednessQ = Q SourceUnpackedness
-type BangQ               = Q Bang
-type BangTypeQ           = Q BangType
-type VarBangTypeQ        = Q VarBangType
-type StrictTypeQ         = Q StrictType
-type VarStrictTypeQ      = Q VarStrictType
-type FieldExpQ           = Q FieldExp
-type RuleBndrQ           = Q RuleBndr
-type TySynEqnQ           = Q TySynEqn
-type PatSynDirQ          = Q PatSynDir
-type PatSynArgsQ         = Q PatSynArgs
-
--- must be defined here for DsMeta to find it
-type Role                = TH.Role
-type InjectivityAnn      = TH.InjectivityAnn
-
-----------------------------------------------------------
--- * Lowercase pattern syntax functions
-----------------------------------------------------------
-
-intPrimL    :: Integer -> Lit
-intPrimL    = IntPrimL
-wordPrimL    :: Integer -> Lit
-wordPrimL    = WordPrimL
-floatPrimL  :: Rational -> Lit
-floatPrimL  = FloatPrimL
-doublePrimL :: Rational -> Lit
-doublePrimL = DoublePrimL
-integerL    :: Integer -> Lit
-integerL    = IntegerL
-charL       :: Char -> Lit
-charL       = CharL
-charPrimL   :: Char -> Lit
-charPrimL   = CharPrimL
-stringL     :: String -> Lit
-stringL     = StringL
-stringPrimL :: [Word8] -> Lit
-stringPrimL = StringPrimL
-rationalL   :: Rational -> Lit
-rationalL   = RationalL
-
-litP :: Lit -> PatQ
-litP l = return (LitP l)
-
-varP :: Name -> PatQ
-varP v = return (VarP v)
-
-tupP :: [PatQ] -> PatQ
-tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
-
-unboxedTupP :: [PatQ] -> PatQ
-unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
-
-unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
-unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
-
-conP :: Name -> [PatQ] -> PatQ
-conP n ps = do ps' <- sequence ps
-               return (ConP n ps')
-infixP :: PatQ -> Name -> PatQ -> PatQ
-infixP p1 n p2 = do p1' <- p1
-                    p2' <- p2
-                    return (InfixP p1' n p2')
-uInfixP :: PatQ -> Name -> PatQ -> PatQ
-uInfixP p1 n p2 = do p1' <- p1
-                     p2' <- p2
-                     return (UInfixP p1' n p2')
-parensP :: PatQ -> PatQ
-parensP p = do p' <- p
-               return (ParensP p')
-
-tildeP :: PatQ -> PatQ
-tildeP p = do p' <- p
-              return (TildeP p')
-bangP :: PatQ -> PatQ
-bangP p = do p' <- p
-             return (BangP p')
-asP :: Name -> PatQ -> PatQ
-asP n p = do p' <- p
-             return (AsP n p')
-wildP :: PatQ
-wildP = return WildP
-recP :: Name -> [FieldPatQ] -> PatQ
-recP n fps = do fps' <- sequence fps
-                return (RecP n fps')
-listP :: [PatQ] -> PatQ
-listP ps = do ps' <- sequence ps
-              return (ListP ps')
-sigP :: PatQ -> TypeQ -> PatQ
-sigP p t = do p' <- p
-              t' <- t
-              return (SigP p' t')
-viewP :: ExpQ -> PatQ -> PatQ
-viewP e p = do e' <- e
-               p' <- p
-               return (ViewP e' p')
-
-fieldPat :: Name -> PatQ -> FieldPatQ
-fieldPat n p = do p' <- p
-                  return (n, p')
-
-
--------------------------------------------------------------------------------
--- *   Stmt
-
-bindS :: PatQ -> ExpQ -> StmtQ
-bindS p e = liftM2 BindS p e
-
-letS :: [DecQ] -> StmtQ
-letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
-
-noBindS :: ExpQ -> StmtQ
-noBindS e = do { e1 <- e; return (NoBindS e1) }
-
-parS :: [[StmtQ]] -> StmtQ
-parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
-
--------------------------------------------------------------------------------
--- *   Range
-
-fromR :: ExpQ -> RangeQ
-fromR x = do { a <- x; return (FromR a) }
-
-fromThenR :: ExpQ -> ExpQ -> RangeQ
-fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
-
-fromToR :: ExpQ -> ExpQ -> RangeQ
-fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
-
-fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
-fromThenToR x y z = do { a <- x; b <- y; c <- z;
-                         return (FromThenToR a b c) }
--------------------------------------------------------------------------------
--- *   Body
-
-normalB :: ExpQ -> BodyQ
-normalB e = do { e1 <- e; return (NormalB e1) }
-
-guardedB :: [Q (Guard,Exp)] -> BodyQ
-guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
-
--------------------------------------------------------------------------------
--- *   Guard
-
-normalG :: ExpQ -> GuardQ
-normalG e = do { e1 <- e; return (NormalG e1) }
-
-normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
-normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
-
-patG :: [StmtQ] -> GuardQ
-patG ss = do { ss' <- sequence ss; return (PatG ss') }
-
-patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
-patGE ss e = do { ss' <- sequence ss;
-                  e'  <- e;
-                  return (PatG ss', e') }
-
--------------------------------------------------------------------------------
--- *   Match and Clause
-
--- | Use with 'caseE'
-match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
-match p rhs ds = do { p' <- p;
-                      r' <- rhs;
-                      ds' <- sequence ds;
-                      return (Match p' r' ds') }
-
--- | Use with 'funD'
-clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
-clause ps r ds = do { ps' <- sequence ps;
-                      r' <- r;
-                      ds' <- sequence ds;
-                      return (Clause ps' r' ds') }
-
-
----------------------------------------------------------------------------
--- *   Exp
-
--- | Dynamically binding a variable (unhygenic)
-dyn :: String -> ExpQ
-dyn s = return (VarE (mkName s))
-
-varE :: Name -> ExpQ
-varE s = return (VarE s)
-
-conE :: Name -> ExpQ
-conE s =  return (ConE s)
-
-litE :: Lit -> ExpQ
-litE c = return (LitE c)
-
-appE :: ExpQ -> ExpQ -> ExpQ
-appE x y = do { a <- x; b <- y; return (AppE a b)}
-
-appTypeE :: ExpQ -> TypeQ -> ExpQ
-appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }
-
-parensE :: ExpQ -> ExpQ
-parensE x = do { x' <- x; return (ParensE x') }
-
-uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
-                     return (UInfixE x' s' y') }
-
-infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
-infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
-                                  return (InfixE (Just a) s' (Just b))}
-infixE Nothing  s (Just y) = do { s' <- s; b <- y;
-                                  return (InfixE Nothing s' (Just b))}
-infixE (Just x) s Nothing  = do { a <- x; s' <- s;
-                                  return (InfixE (Just a) s' Nothing)}
-infixE Nothing  s Nothing  = do { s' <- s; return (InfixE Nothing s' Nothing) }
-
-infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-infixApp x y z = infixE (Just x) y (Just z)
-sectionL :: ExpQ -> ExpQ -> ExpQ
-sectionL x y = infixE (Just x) y Nothing
-sectionR :: ExpQ -> ExpQ -> ExpQ
-sectionR x y = infixE Nothing x (Just y)
-
-lamE :: [PatQ] -> ExpQ -> ExpQ
-lamE ps e = do ps' <- sequence ps
-               e' <- e
-               return (LamE ps' e')
-
--- | Single-arg lambda
-lam1E :: PatQ -> ExpQ -> ExpQ
-lam1E p e = lamE [p] e
-
-lamCaseE :: [MatchQ] -> ExpQ
-lamCaseE ms = sequence ms >>= return . LamCaseE
-
-tupE :: [ExpQ] -> ExpQ
-tupE es = do { es1 <- sequence es; return (TupE es1)}
-
-unboxedTupE :: [ExpQ] -> ExpQ
-unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
-
-unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
-unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
-
-condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
-
-multiIfE :: [Q (Guard, Exp)] -> ExpQ
-multiIfE alts = sequence alts >>= return . MultiIfE
-
-letE :: [DecQ] -> ExpQ -> ExpQ
-letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
-
-caseE :: ExpQ -> [MatchQ] -> ExpQ
-caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
-
-doE :: [StmtQ] -> ExpQ
-doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
-
-compE :: [StmtQ] -> ExpQ
-compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
-
-arithSeqE :: RangeQ -> ExpQ
-arithSeqE r = do { r' <- r; return (ArithSeqE r') }
-
-listE :: [ExpQ] -> ExpQ
-listE es = do { es1 <- sequence es; return (ListE es1) }
-
-sigE :: ExpQ -> TypeQ -> ExpQ
-sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
-
-recConE :: Name -> [Q (Name,Exp)] -> ExpQ
-recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
-
-recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
-recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
-
-stringE :: String -> ExpQ
-stringE = litE . stringL
-
-fieldExp :: Name -> ExpQ -> Q (Name, Exp)
-fieldExp s e = do { e' <- e; return (s,e') }
-
--- | @staticE x = [| static x |]@
-staticE :: ExpQ -> ExpQ
-staticE = fmap StaticE
-
-unboundVarE :: Name -> ExpQ
-unboundVarE s = return (UnboundVarE s)
-
-labelE :: String -> ExpQ
-labelE s = return (LabelE s)
-
--- ** 'arithSeqE' Shortcuts
-fromE :: ExpQ -> ExpQ
-fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
-
-fromThenE :: ExpQ -> ExpQ -> ExpQ
-fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
-
-fromToE :: ExpQ -> ExpQ -> ExpQ
-fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
-
-fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-fromThenToE x y z = do { a <- x; b <- y; c <- z;
-                         return (ArithSeqE (FromThenToR a b c)) }
-
+import Language.Haskell.TH.Lib.Internal hiding
+  ( tySynD
+  , dataD
+  , newtypeD
+  , classD
+  , dataInstD
+  , newtypeInstD
+  , dataFamilyD
+  , openTypeFamilyD
+  , closedTypeFamilyD
+  , forallC
+
+  , forallT
+  , sigT
+
+  , plainTV
+  , kindedTV
+  , starK
+  , constraintK
+
+  , noSig
+  , kindSig
+  , tyVarSig
+
+  , Role
+  , InjectivityAnn
+  )
+import Language.Haskell.TH.Syntax
+
+import Control.Monad (liftM2)
+
+-- All definitions below represent the "old" API, since their definitions are
+-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before
+-- deciding to change the APIs of the functions below, as they represent the
+-- public API (as opposed to the Internal module, which has no API promises.)
 
 -------------------------------------------------------------------------------
 -- *   Dec
 
-valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
-valD p b ds =
-  do { p' <- p
-     ; ds' <- sequence ds
-     ; b' <- b
-     ; return (ValD p' b' ds')
-     }
-
-funD :: Name -> [ClauseQ] -> DecQ
-funD nm cs =
- do { cs1 <- sequence cs
-    ; return (FunD nm cs1)
-    }
-
 tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
 
@@ -491,78 +184,6 @@ classD ctxt cls tvs fds decs =
     ctxt1 <- ctxt
     return $ ClassD ctxt1 cls tvs fds decs1
 
-instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
-instanceD = instanceWithOverlapD Nothing
-
-instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
-instanceWithOverlapD o ctxt ty decs =
-  do
-    ctxt1 <- ctxt
-    decs1 <- sequence decs
-    ty1   <- ty
-    return $ InstanceD o ctxt1 ty1 decs1
-
-
-
-sigD :: Name -> TypeQ -> DecQ
-sigD fun ty = liftM (SigD fun) $ ty
-
-forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
-forImpD cc s str n ty
- = do ty' <- ty
-      return $ ForeignD (ImportF cc s str n ty')
-
-infixLD :: Int -> Name -> DecQ
-infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
-
-infixRD :: Int -> Name -> DecQ
-infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
-
-infixND :: Int -> Name -> DecQ
-infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
-
-pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
-pragInlD name inline rm phases
-  = return $ PragmaD $ InlineP name inline rm phases
-
-pragSpecD :: Name -> TypeQ -> Phases -> DecQ
-pragSpecD n ty phases
-  = do
-      ty1    <- ty
-      return $ PragmaD $ SpecialiseP n ty1 Nothing phases
-
-pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
-pragSpecInlD n ty inline phases
-  = do
-      ty1    <- ty
-      return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
-
-pragSpecInstD :: TypeQ -> DecQ
-pragSpecInstD ty
-  = do
-      ty1    <- ty
-      return $ PragmaD $ SpecialiseInstP ty1
-
-pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
-pragRuleD n bndrs lhs rhs phases
-  = do
-      bndrs1 <- sequence bndrs
-      lhs1   <- lhs
-      rhs1   <- rhs
-      return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
-
-pragAnnD :: AnnTarget -> ExpQ -> DecQ
-pragAnnD target expr
-  = do
-      exp1 <- expr
-      return $ PragmaD $ AnnP target exp1
-
-pragLineD :: Int -> String -> DecQ
-pragLineD line file = return $ PragmaD $ LineP line file
-
-pragCompleteD :: [Name] -> Maybe Name -> DecQ
-pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
-
 dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
           -> DecQ
 dataInstD ctxt tc tys ksig cons derivs =
@@ -583,12 +204,6 @@ newtypeInstD ctxt tc tys ksig con derivs =
     derivs1 <- sequence derivs
     return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1)
 
-tySynInstD :: Name -> TySynEqnQ -> DecQ
-tySynInstD tc eqn =
-  do
-    eqn1 <- eqn
-    return (TySynInstD tc eqn1)
-
 dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
 dataFamilyD tc tvs kind
     = return $ DataFamilyD tc tvs kind
@@ -604,112 +219,9 @@ closedTypeFamilyD tc tvs result injectivity eqns =
   do eqns1 <- sequence eqns
      return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
 
--- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you
--- remove this check please also:
---   1. remove deprecated functions
---   2. remove CPP language extension from top of this module
---   3. remove the FamFlavour data type from Syntax module
---   4. make sure that all references to FamFlavour are gone from DsMeta,
---      Convert, TcSplice (follows from 3)
-#if __GLASGOW_HASKELL__ >= 804
-#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD
-#endif
-
-{-# DEPRECATED familyNoKindD, familyKindD
-               "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-}
-familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
-familyNoKindD flav tc tvs =
-    case flav of
-      TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing)
-      DataFam -> return $ DataFamilyD tc tvs Nothing
-
-familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
-familyKindD flav tc tvs k =
-    case flav of
-      TypeFam ->
-        return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing)
-      DataFam -> return $ DataFamilyD tc tvs (Just k)
-
-{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD
-               "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-}
-closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
-closedTypeFamilyNoKindD tc tvs eqns =
- do eqns1 <- sequence eqns
-    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1)
-
-closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
-closedTypeFamilyKindD tc tvs kind eqns =
- do eqns1 <- sequence eqns
-    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing)
-            eqns1)
-
-roleAnnotD :: Name -> [Role] -> DecQ
-roleAnnotD name roles = return $ RoleAnnotD name roles
-
-standaloneDerivD :: CxtQ -> TypeQ -> DecQ
-standaloneDerivD = standaloneDerivWithStrategyD Nothing
-
-standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ
-standaloneDerivWithStrategyD ds ctxtq tyq =
-  do
-    ctxt <- ctxtq
-    ty   <- tyq
-    return $ StandaloneDerivD ds ctxt ty
-
-defaultSigD :: Name -> TypeQ -> DecQ
-defaultSigD n tyq =
-  do
-    ty <- tyq
-    return $ DefaultSigD n ty
-
--- | Pattern synonym declaration
-patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
-patSynD name args dir pat = do
-  args'    <- args
-  dir'     <- dir
-  pat'     <- pat
-  return (PatSynD name args' dir' pat')
-
--- | Pattern synonym type signature
-patSynSigD :: Name -> TypeQ -> DecQ
-patSynSigD nm ty =
-  do ty' <- ty
-     return $ PatSynSigD nm ty'
-
-tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
-tySynEqn lhs rhs =
-  do
-    lhs1 <- sequence lhs
-    rhs1 <- rhs
-    return (TySynEqn lhs1 rhs1)
-
-cxt :: [PredQ] -> CxtQ
-cxt = sequence
-
-derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
-derivClause ds p = do p' <- cxt p
-                      return $ DerivClause ds p'
-
-normalC :: Name -> [BangTypeQ] -> ConQ
-normalC con strtys = liftM (NormalC con) $ sequence strtys
-
-recC :: Name -> [VarBangTypeQ] -> ConQ
-recC con varstrtys = liftM (RecC con) $ sequence varstrtys
-
-infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
-infixC st1 con st2 = do st1' <- st1
-                        st2' <- st2
-                        return $ InfixC st1' con st2'
-
 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
-gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
-gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
-
-recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
-recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
-
 -------------------------------------------------------------------------------
 -- *   Type
 
@@ -719,145 +231,12 @@ forallT tvars ctxt ty = do
     ty1   <- ty
     return $ ForallT tvars ctxt1 ty1
 
-varT :: Name -> TypeQ
-varT = return . VarT
-
-conT :: Name -> TypeQ
-conT = return . ConT
-
-infixT :: TypeQ -> Name -> TypeQ -> TypeQ
-infixT t1 n t2 = do t1' <- t1
-                    t2' <- t2
-                    return (InfixT t1' n t2')
-
-uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
-uInfixT t1 n t2 = do t1' <- t1
-                     t2' <- t2
-                     return (UInfixT t1' n t2')
-
-parensT :: TypeQ -> TypeQ
-parensT t = do t' <- t
-               return (ParensT t')
-
-appT :: TypeQ -> TypeQ -> TypeQ
-appT t1 t2 = do
-           t1' <- t1
-           t2' <- t2
-           return $ AppT t1' t2'
-
-arrowT :: TypeQ
-arrowT = return ArrowT
-
-listT :: TypeQ
-listT = return ListT
-
-litT :: TyLitQ -> TypeQ
-litT l = fmap LitT l
-
-tupleT :: Int -> TypeQ
-tupleT i = return (TupleT i)
-
-unboxedTupleT :: Int -> TypeQ
-unboxedTupleT i = return (UnboxedTupleT i)
-
-unboxedSumT :: SumArity -> TypeQ
-unboxedSumT arity = return (UnboxedSumT arity)
-
 sigT :: TypeQ -> Kind -> TypeQ
 sigT t k
   = do
       t' <- t
       return $ SigT t' k
 
-equalityT :: TypeQ
-equalityT = return EqualityT
-
-wildCardT :: TypeQ
-wildCardT = return WildCardT
-
-{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
-classP :: Name -> [Q Type] -> Q Pred
-classP cla tys
-  = do
-      tysl <- sequence tys
-      return (foldl AppT (ConT cla) tysl)
-
-{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
-equalP :: TypeQ -> TypeQ -> PredQ
-equalP tleft tright
-  = do
-      tleft1  <- tleft
-      tright1 <- tright
-      eqT <- equalityT
-      return (foldl AppT eqT [tleft1, tright1])
-
-promotedT :: Name -> TypeQ
-promotedT = return . PromotedT
-
-promotedTupleT :: Int -> TypeQ
-promotedTupleT i = return (PromotedTupleT i)
-
-promotedNilT :: TypeQ
-promotedNilT = return PromotedNilT
-
-promotedConsT :: TypeQ
-promotedConsT = return PromotedConsT
-
-noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
-noSourceUnpackedness = return NoSourceUnpackedness
-sourceNoUnpack       = return SourceNoUnpack
-sourceUnpack         = return SourceUnpack
-
-noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
-noSourceStrictness = return NoSourceStrictness
-sourceLazy         = return SourceLazy
-sourceStrict       = return SourceStrict
-
-{-# DEPRECATED isStrict
-    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
-     "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}
-{-# DEPRECATED notStrict
-    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
-     "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}
-{-# DEPRECATED unpacked
-    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
-     "Example usage: 'bang sourceUnpack sourceStrict'"] #-}
-isStrict, notStrict, unpacked :: Q Strict
-isStrict = bang noSourceUnpackedness sourceStrict
-notStrict = bang noSourceUnpackedness noSourceStrictness
-unpacked = bang sourceUnpack sourceStrict
-
-bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
-bang u s = do u' <- u
-              s' <- s
-              return (Bang u' s')
-
-bangType :: BangQ -> TypeQ -> BangTypeQ
-bangType = liftM2 (,)
-
-varBangType :: Name -> BangTypeQ -> VarBangTypeQ
-varBangType v bt = do (b, t) <- bt
-                      return (v, b, t)
-
-{-# DEPRECATED strictType
-               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
-strictType :: Q Strict -> TypeQ -> StrictTypeQ
-strictType = bangType
-
-{-# DEPRECATED varStrictType
-               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
-varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
-varStrictType = varBangType
-
--- * Type Literals
-
-numTyLit :: Integer -> TyLitQ
-numTyLit n = if n >= 0 then return (NumTyLit n)
-                       else fail ("Negative type-level number: " ++ show n)
-
-strTyLit :: String -> TyLitQ
-strTyLit s = return (StrTyLit s)
-
 -------------------------------------------------------------------------------
 -- *   Kind
 
@@ -867,24 +246,6 @@ plainTV = PlainTV
 kindedTV :: Name -> Kind -> TyVarBndr
 kindedTV = KindedTV
 
-varK :: Name -> Kind
-varK = VarT
-
-conK :: Name -> Kind
-conK = ConT
-
-tupleK :: Int -> Kind
-tupleK = TupleT
-
-arrowK :: Kind
-arrowK = ArrowT
-
-listK :: Kind
-listK = ListT
-
-appK :: Kind -> Kind -> Kind
-appK = AppT
-
 starK :: Kind
 starK = StarT
 
@@ -902,104 +263,3 @@ kindSig = KindSig
 
 tyVarSig :: TyVarBndr -> FamilyResultSig
 tyVarSig = TyVarSig
-
--------------------------------------------------------------------------------
--- *   Injectivity annotation
-
-injectivityAnn :: Name -> [Name] -> InjectivityAnn
-injectivityAnn = TH.InjectivityAnn
-
--------------------------------------------------------------------------------
--- *   Role
-
-nominalR, representationalR, phantomR, inferR :: Role
-nominalR          = NominalR
-representationalR = RepresentationalR
-phantomR          = PhantomR
-inferR            = InferR
-
--------------------------------------------------------------------------------
--- *   Callconv
-
-cCall, stdCall, cApi, prim, javaScript :: Callconv
-cCall      = CCall
-stdCall    = StdCall
-cApi       = CApi
-prim       = Prim
-javaScript = JavaScript
-
--------------------------------------------------------------------------------
--- *   Safety
-
-unsafe, safe, interruptible :: Safety
-unsafe = Unsafe
-safe = Safe
-interruptible = Interruptible
-
--------------------------------------------------------------------------------
--- *   FunDep
-
-funDep :: [Name] -> [Name] -> FunDep
-funDep = FunDep
-
--------------------------------------------------------------------------------
--- *   FamFlavour
-
-typeFam, dataFam :: FamFlavour
-typeFam = TypeFam
-dataFam = DataFam
-
--------------------------------------------------------------------------------
--- *   RuleBndr
-ruleVar :: Name -> RuleBndrQ
-ruleVar = return . RuleVar
-
-typedRuleVar :: Name -> TypeQ -> RuleBndrQ
-typedRuleVar n ty = ty >>= return . TypedRuleVar n
-
--------------------------------------------------------------------------------
--- *   AnnTarget
-valueAnnotation :: Name -> AnnTarget
-valueAnnotation = ValueAnnotation
-
-typeAnnotation :: Name -> AnnTarget
-typeAnnotation = TypeAnnotation
-
-moduleAnnotation :: AnnTarget
-moduleAnnotation = ModuleAnnotation
-
--------------------------------------------------------------------------------
--- * Pattern Synonyms (sub constructs)
-
-unidir, implBidir :: PatSynDirQ
-unidir    = return Unidir
-implBidir = return ImplBidir
-
-explBidir :: [ClauseQ] -> PatSynDirQ
-explBidir cls = do
-  cls' <- sequence cls
-  return (ExplBidir cls')
-
-prefixPatSyn :: [Name] -> PatSynArgsQ
-prefixPatSyn args = return $ PrefixPatSyn args
-
-recordPatSyn :: [Name] -> PatSynArgsQ
-recordPatSyn sels = return $ RecordPatSyn sels
-
-infixPatSyn :: Name -> Name -> PatSynArgsQ
-infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
-
---------------------------------------------------------------
--- * Useful helper function
-
-appsE :: [ExpQ] -> ExpQ
-appsE [] = error "appsE []"
-appsE [x] = x
-appsE (x:y:zs) = appsE ( (appE x y) : zs )
-
--- | Return the Module at the place of splicing.  Can be used as an
--- input for 'reifyModule'.
-thisModule :: Q Module
-thisModule = do
-  loc <- location
-  return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
new file mode 100644 (file)
index 0000000..d58ce84
--- /dev/null
@@ -0,0 +1,936 @@
+-- |
+-- Language.Haskell.TH.Lib.Internal exposes some additional functionality that
+-- is used internally in GHC's integration with Template Haskell. This is not a
+-- part of the public API, and as such, there are no API guarantees for this
+-- module from version to version.
+
+-- Why do we have both Language.Haskell.TH.Lib.Internal and
+-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the
+-- former (which are tailored for GHC's use) need different type signatures
+-- than the ones in the latter. Syncing up the Internal type signatures would
+-- involve a massive amount of breaking changes, so for the time being, we
+-- relegate as many changes as we can to just the Internal module, where it
+-- is safe to break things.
+
+{-# LANGUAGE CPP #-}
+
+module Language.Haskell.TH.Lib.Internal where
+
+import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
+import qualified Language.Haskell.TH.Syntax as TH
+import Control.Monad( liftM, liftM2 )
+import Data.Word( Word8 )
+
+----------------------------------------------------------
+-- * Type synonyms
+----------------------------------------------------------
+
+type InfoQ               = Q Info
+type PatQ                = Q Pat
+type FieldPatQ           = Q FieldPat
+type ExpQ                = Q Exp
+type TExpQ a             = Q (TExp a)
+type DecQ                = Q Dec
+type DecsQ               = Q [Dec]
+type ConQ                = Q Con
+type TypeQ               = Q Type
+type KindQ               = Q Kind
+type TyVarBndrQ          = Q TyVarBndr
+type TyLitQ              = Q TyLit
+type CxtQ                = Q Cxt
+type PredQ               = Q Pred
+type DerivClauseQ        = Q DerivClause
+type MatchQ              = Q Match
+type ClauseQ             = Q Clause
+type BodyQ               = Q Body
+type GuardQ              = Q Guard
+type StmtQ               = Q Stmt
+type RangeQ              = Q Range
+type SourceStrictnessQ   = Q SourceStrictness
+type SourceUnpackednessQ = Q SourceUnpackedness
+type BangQ               = Q Bang
+type BangTypeQ           = Q BangType
+type VarBangTypeQ        = Q VarBangType
+type StrictTypeQ         = Q StrictType
+type VarStrictTypeQ      = Q VarStrictType
+type FieldExpQ           = Q FieldExp
+type RuleBndrQ           = Q RuleBndr
+type TySynEqnQ           = Q TySynEqn
+type PatSynDirQ          = Q PatSynDir
+type PatSynArgsQ         = Q PatSynArgs
+type FamilyResultSigQ    = Q FamilyResultSig
+
+-- must be defined here for DsMeta to find it
+type Role                = TH.Role
+type InjectivityAnn      = TH.InjectivityAnn
+
+----------------------------------------------------------
+-- * Lowercase pattern syntax functions
+----------------------------------------------------------
+
+intPrimL    :: Integer -> Lit
+intPrimL    = IntPrimL
+wordPrimL    :: Integer -> Lit
+wordPrimL    = WordPrimL
+floatPrimL  :: Rational -> Lit
+floatPrimL  = FloatPrimL
+doublePrimL :: Rational -> Lit
+doublePrimL = DoublePrimL
+integerL    :: Integer -> Lit
+integerL    = IntegerL
+charL       :: Char -> Lit
+charL       = CharL
+charPrimL   :: Char -> Lit
+charPrimL   = CharPrimL
+stringL     :: String -> Lit
+stringL     = StringL
+stringPrimL :: [Word8] -> Lit
+stringPrimL = StringPrimL
+rationalL   :: Rational -> Lit
+rationalL   = RationalL
+
+litP :: Lit -> PatQ
+litP l = return (LitP l)
+
+varP :: Name -> PatQ
+varP v = return (VarP v)
+
+tupP :: [PatQ] -> PatQ
+tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+
+unboxedTupP :: [PatQ] -> PatQ
+unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
+
+unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
+unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
+
+conP :: Name -> [PatQ] -> PatQ
+conP n ps = do ps' <- sequence ps
+               return (ConP n ps')
+infixP :: PatQ -> Name -> PatQ -> PatQ
+infixP p1 n p2 = do p1' <- p1
+                    p2' <- p2
+                    return (InfixP p1' n p2')
+uInfixP :: PatQ -> Name -> PatQ -> PatQ
+uInfixP p1 n p2 = do p1' <- p1
+                     p2' <- p2
+                     return (UInfixP p1' n p2')
+parensP :: PatQ -> PatQ
+parensP p = do p' <- p
+               return (ParensP p')
+
+tildeP :: PatQ -> PatQ
+tildeP p = do p' <- p
+              return (TildeP p')
+bangP :: PatQ -> PatQ
+bangP p = do p' <- p
+             return (BangP p')
+asP :: Name -> PatQ -> PatQ
+asP n p = do p' <- p
+             return (AsP n p')
+wildP :: PatQ
+wildP = return WildP
+recP :: Name -> [FieldPatQ] -> PatQ
+recP n fps = do fps' <- sequence fps
+                return (RecP n fps')
+listP :: [PatQ] -> PatQ
+listP ps = do ps' <- sequence ps
+              return (ListP ps')
+sigP :: PatQ -> TypeQ -> PatQ
+sigP p t = do p' <- p
+              t' <- t
+              return (SigP p' t')
+viewP :: ExpQ -> PatQ -> PatQ
+viewP e p = do e' <- e
+               p' <- p
+               return (ViewP e' p')
+
+fieldPat :: Name -> PatQ -> FieldPatQ
+fieldPat n p = do p' <- p
+                  return (n, p')
+
+
+-------------------------------------------------------------------------------
+-- *   Stmt
+
+bindS :: PatQ -> ExpQ -> StmtQ
+bindS p e = liftM2 BindS p e
+
+letS :: [DecQ] -> StmtQ
+letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
+
+noBindS :: ExpQ -> StmtQ
+noBindS e = do { e1 <- e; return (NoBindS e1) }
+
+parS :: [[StmtQ]] -> StmtQ
+parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
+
+-------------------------------------------------------------------------------
+-- *   Range
+
+fromR :: ExpQ -> RangeQ
+fromR x = do { a <- x; return (FromR a) }
+
+fromThenR :: ExpQ -> ExpQ -> RangeQ
+fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
+
+fromToR :: ExpQ -> ExpQ -> RangeQ
+fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
+
+fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
+fromThenToR x y z = do { a <- x; b <- y; c <- z;
+                         return (FromThenToR a b c) }
+-------------------------------------------------------------------------------
+-- *   Body
+
+normalB :: ExpQ -> BodyQ
+normalB e = do { e1 <- e; return (NormalB e1) }
+
+guardedB :: [Q (Guard,Exp)] -> BodyQ
+guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
+
+-------------------------------------------------------------------------------
+-- *   Guard
+
+normalG :: ExpQ -> GuardQ
+normalG e = do { e1 <- e; return (NormalG e1) }
+
+normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
+normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
+
+patG :: [StmtQ] -> GuardQ
+patG ss = do { ss' <- sequence ss; return (PatG ss') }
+
+patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
+patGE ss e = do { ss' <- sequence ss;
+                  e'  <- e;
+                  return (PatG ss', e') }
+
+-------------------------------------------------------------------------------
+-- *   Match and Clause
+
+-- | Use with 'caseE'
+match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
+match p rhs ds = do { p' <- p;
+                      r' <- rhs;
+                      ds' <- sequence ds;
+                      return (Match p' r' ds') }
+
+-- | Use with 'funD'
+clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
+clause ps r ds = do { ps' <- sequence ps;
+                      r' <- r;
+                      ds' <- sequence ds;
+                      return (Clause ps' r' ds') }
+
+
+---------------------------------------------------------------------------
+-- *   Exp
+
+-- | Dynamically binding a variable (unhygenic)
+dyn :: String -> ExpQ
+dyn s = return (VarE (mkName s))
+
+varE :: Name -> ExpQ
+varE s = return (VarE s)
+
+conE :: Name -> ExpQ
+conE s =  return (ConE s)
+
+litE :: Lit -> ExpQ
+litE c = return (LitE c)
+
+appE :: ExpQ -> ExpQ -> ExpQ
+appE x y = do { a <- x; b <- y; return (AppE a b)}
+
+appTypeE :: ExpQ -> TypeQ -> ExpQ
+appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }
+
+parensE :: ExpQ -> ExpQ
+parensE x = do { x' <- x; return (ParensE x') }
+
+uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
+                     return (UInfixE x' s' y') }
+
+infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
+infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
+                                  return (InfixE (Just a) s' (Just b))}
+infixE Nothing  s (Just y) = do { s' <- s; b <- y;
+                                  return (InfixE Nothing s' (Just b))}
+infixE (Just x) s Nothing  = do { a <- x; s' <- s;
+                                  return (InfixE (Just a) s' Nothing)}
+infixE Nothing  s Nothing  = do { s' <- s; return (InfixE Nothing s' Nothing) }
+
+infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+infixApp x y z = infixE (Just x) y (Just z)
+sectionL :: ExpQ -> ExpQ -> ExpQ
+sectionL x y = infixE (Just x) y Nothing
+sectionR :: ExpQ -> ExpQ -> ExpQ
+sectionR x y = infixE Nothing x (Just y)
+
+lamE :: [PatQ] -> ExpQ -> ExpQ
+lamE ps e = do ps' <- sequence ps
+               e' <- e
+               return (LamE ps' e')
+
+-- | Single-arg lambda
+lam1E :: PatQ -> ExpQ -> ExpQ
+lam1E p e = lamE [p] e
+
+lamCaseE :: [MatchQ] -> ExpQ
+lamCaseE ms = sequence ms >>= return . LamCaseE
+
+tupE :: [ExpQ] -> ExpQ
+tupE es = do { es1 <- sequence es; return (TupE es1)}
+
+unboxedTupE :: [ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
+
+unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
+unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
+
+condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
+
+multiIfE :: [Q (Guard, Exp)] -> ExpQ
+multiIfE alts = sequence alts >>= return . MultiIfE
+
+letE :: [DecQ] -> ExpQ -> ExpQ
+letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
+
+caseE :: ExpQ -> [MatchQ] -> ExpQ
+caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
+
+doE :: [StmtQ] -> ExpQ
+doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
+
+compE :: [StmtQ] -> ExpQ
+compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
+
+arithSeqE :: RangeQ -> ExpQ
+arithSeqE r = do { r' <- r; return (ArithSeqE r') }
+
+listE :: [ExpQ] -> ExpQ
+listE es = do { es1 <- sequence es; return (ListE es1) }
+
+sigE :: ExpQ -> TypeQ -> ExpQ
+sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
+
+recConE :: Name -> [Q (Name,Exp)] -> ExpQ
+recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
+
+recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
+recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
+
+stringE :: String -> ExpQ
+stringE = litE . stringL
+
+fieldExp :: Name -> ExpQ -> Q (Name, Exp)
+fieldExp s e = do { e' <- e; return (s,e') }
+
+-- | @staticE x = [| static x |]@
+staticE :: ExpQ -> ExpQ
+staticE = fmap StaticE
+
+unboundVarE :: Name -> ExpQ
+unboundVarE s = return (UnboundVarE s)
+
+labelE :: String -> ExpQ
+labelE s = return (LabelE s)
+
+-- ** 'arithSeqE' Shortcuts
+fromE :: ExpQ -> ExpQ
+fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
+
+fromThenE :: ExpQ -> ExpQ -> ExpQ
+fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
+
+fromToE :: ExpQ -> ExpQ -> ExpQ
+fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
+
+fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+fromThenToE x y z = do { a <- x; b <- y; c <- z;
+                         return (ArithSeqE (FromThenToR a b c)) }
+
+
+-------------------------------------------------------------------------------
+-- *   Dec
+
+valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
+valD p b ds =
+  do { p' <- p
+     ; ds' <- sequence ds
+     ; b' <- b
+     ; return (ValD p' b' ds')
+     }
+
+funD :: Name -> [ClauseQ] -> DecQ
+funD nm cs =
+ do { cs1 <- sequence cs
+    ; return (FunD nm cs1)
+    }
+
+tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ
+tySynD tc tvs rhs =
+  do { tvs1 <- sequenceA tvs
+     ; rhs1 <- rhs
+     ; return (TySynD tc tvs1 rhs1)
+     }
+
+dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ]
+      -> [DerivClauseQ] -> DecQ
+dataD ctxt tc tvs ksig cons derivs =
+  do
+    ctxt1   <- ctxt
+    tvs1    <- sequenceA tvs
+    ksig1   <- sequenceA ksig
+    cons1   <- sequence cons
+    derivs1 <- sequence derivs
+    return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)
+
+newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ
+         -> [DerivClauseQ] -> DecQ
+newtypeD ctxt tc tvs ksig con derivs =
+  do
+    ctxt1   <- ctxt
+    tvs1    <- sequenceA tvs
+    ksig1   <- sequenceA ksig
+    con1    <- con
+    derivs1 <- sequence derivs
+    return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)
+
+classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ
+classD ctxt cls tvs fds decs =
+  do
+    tvs1  <- sequenceA tvs
+    decs1 <- sequenceA decs
+    ctxt1 <- ctxt
+    return $ ClassD ctxt1 cls tvs1 fds decs1
+
+instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceD = instanceWithOverlapD Nothing
+
+instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceWithOverlapD o ctxt ty decs =
+  do
+    ctxt1 <- ctxt
+    decs1 <- sequence decs
+    ty1   <- ty
+    return $ InstanceD o ctxt1 ty1 decs1
+
+
+
+sigD :: Name -> TypeQ -> DecQ
+sigD fun ty = liftM (SigD fun) $ ty
+
+forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
+forImpD cc s str n ty
+ = do ty' <- ty
+      return $ ForeignD (ImportF cc s str n ty')
+
+infixLD :: Int -> Name -> DecQ
+infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
+
+infixRD :: Int -> Name -> DecQ
+infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
+
+infixND :: Int -> Name -> DecQ
+infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
+
+pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
+pragInlD name inline rm phases
+  = return $ PragmaD $ InlineP name inline rm phases
+
+pragSpecD :: Name -> TypeQ -> Phases -> DecQ
+pragSpecD n ty phases
+  = do
+      ty1    <- ty
+      return $ PragmaD $ SpecialiseP n ty1 Nothing phases
+
+pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
+pragSpecInlD n ty inline phases
+  = do
+      ty1    <- ty
+      return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
+
+pragSpecInstD :: TypeQ -> DecQ
+pragSpecInstD ty
+  = do
+      ty1    <- ty
+      return $ PragmaD $ SpecialiseInstP ty1
+
+pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD n bndrs lhs rhs phases
+  = do
+      bndrs1 <- sequence bndrs
+      lhs1   <- lhs
+      rhs1   <- rhs
+      return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
+
+pragAnnD :: AnnTarget -> ExpQ -> DecQ
+pragAnnD target expr
+  = do
+      exp1 <- expr
+      return $ PragmaD $ AnnP target exp1
+
+pragLineD :: Int -> String -> DecQ
+pragLineD line file = return $ PragmaD $ LineP line file
+
+pragCompleteD :: [Name] -> Maybe Name -> DecQ
+pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
+
+dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ]
+          -> [DerivClauseQ] -> DecQ
+dataInstD ctxt tc tys ksig cons derivs =
+  do
+    ctxt1   <- ctxt
+    tys1    <- sequenceA tys
+    ksig1   <- sequenceA ksig
+    cons1   <- sequenceA cons
+    derivs1 <- sequenceA derivs
+    return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1)
+
+newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ
+             -> [DerivClauseQ] -> DecQ
+newtypeInstD ctxt tc tys ksig con derivs =
+  do
+    ctxt1   <- ctxt
+    tys1    <- sequenceA tys
+    ksig1   <- sequenceA ksig
+    con1    <- con
+    derivs1 <- sequence derivs
+    return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1)
+
+tySynInstD :: Name -> TySynEqnQ -> DecQ
+tySynInstD tc eqn =
+  do
+    eqn1 <- eqn
+    return (TySynInstD tc eqn1)
+
+dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ
+dataFamilyD tc tvs kind =
+  do tvs'  <- sequenceA tvs
+     kind' <- sequenceA kind
+     return $ DataFamilyD tc tvs' kind'
+
+openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
+                -> Maybe InjectivityAnn -> DecQ
+openTypeFamilyD tc tvs res inj =
+  do tvs' <- sequenceA tvs
+     res' <- res
+     return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)
+
+closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
+                  -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
+closedTypeFamilyD tc tvs result injectivity eqns =
+  do tvs1    <- sequenceA tvs
+     result1 <- result
+     eqns1   <- sequenceA eqns
+     return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)
+
+-- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you
+-- remove this check please also:
+--   1. remove deprecated functions
+--   2. remove CPP language extension from top of this module
+--   3. remove the FamFlavour data type from Syntax module
+--   4. make sure that all references to FamFlavour are gone from DsMeta,
+--      Convert, TcSplice (follows from 3)
+#if __GLASGOW_HASKELL__ >= 804
+#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD
+#endif
+
+{-# DEPRECATED familyNoKindD, familyKindD
+               "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-}
+familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
+familyNoKindD flav tc tvs =
+    case flav of
+      TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing)
+      DataFam -> return $ DataFamilyD tc tvs Nothing
+
+familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
+familyKindD flav tc tvs k =
+    case flav of
+      TypeFam ->
+        return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing)
+      DataFam -> return $ DataFamilyD tc tvs (Just k)
+
+{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD
+               "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-}
+closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
+closedTypeFamilyNoKindD tc tvs eqns =
+ do eqns1 <- sequence eqns
+    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1)
+
+closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
+closedTypeFamilyKindD tc tvs kind eqns =
+ do eqns1 <- sequence eqns
+    return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing)
+            eqns1)
+
+roleAnnotD :: Name -> [Role] -> DecQ
+roleAnnotD name roles = return $ RoleAnnotD name roles
+
+standaloneDerivD :: CxtQ -> TypeQ -> DecQ
+standaloneDerivD = standaloneDerivWithStrategyD Nothing
+
+standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ
+standaloneDerivWithStrategyD ds ctxtq tyq =
+  do
+    ctxt <- ctxtq
+    ty   <- tyq
+    return $ StandaloneDerivD ds ctxt ty
+
+defaultSigD :: Name -> TypeQ -> DecQ
+defaultSigD n tyq =
+  do
+    ty <- tyq
+    return $ DefaultSigD n ty
+
+-- | Pattern synonym declaration
+patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
+patSynD name args dir pat = do
+  args'    <- args
+  dir'     <- dir
+  pat'     <- pat
+  return (PatSynD name args' dir' pat')
+
+-- | Pattern synonym type signature
+patSynSigD :: Name -> TypeQ -> DecQ
+patSynSigD nm ty =
+  do ty' <- ty
+     return $ PatSynSigD nm ty'
+
+tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn lhs rhs =
+  do
+    lhs1 <- sequence lhs
+    rhs1 <- rhs
+    return (TySynEqn lhs1 rhs1)
+
+cxt :: [PredQ] -> CxtQ
+cxt = sequence
+
+derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
+derivClause ds p = do p' <- cxt p
+                      return $ DerivClause ds p'
+
+normalC :: Name -> [BangTypeQ] -> ConQ
+normalC con strtys = liftM (NormalC con) $ sequence strtys
+
+recC :: Name -> [VarBangTypeQ] -> ConQ
+recC con varstrtys = liftM (RecC con) $ sequence varstrtys
+
+infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
+infixC st1 con st2 = do st1' <- st1
+                        st2' <- st2
+                        return $ InfixC st1' con st2'
+
+forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ
+forallC ns ctxt con = do
+  ns'   <- sequenceA ns
+  ctxt' <- ctxt
+  con'  <- con
+  pure $ ForallC ns' ctxt' con'
+
+gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
+gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
+
+recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
+recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
+
+-------------------------------------------------------------------------------
+-- *   Type
+
+forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ
+forallT tvars ctxt ty = do
+    tvars1 <- sequenceA tvars
+    ctxt1  <- ctxt
+    ty1    <- ty
+    return $ ForallT tvars1 ctxt1 ty1
+
+varT :: Name -> TypeQ
+varT = return . VarT
+
+conT :: Name -> TypeQ
+conT = return . ConT
+
+infixT :: TypeQ -> Name -> TypeQ -> TypeQ
+infixT t1 n t2 = do t1' <- t1
+                    t2' <- t2
+                    return (InfixT t1' n t2')
+
+uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
+uInfixT t1 n t2 = do t1' <- t1
+                     t2' <- t2
+                     return (UInfixT t1' n t2')
+
+parensT :: TypeQ -> TypeQ
+parensT t = do t' <- t
+               return (ParensT t')
+
+appT :: TypeQ -> TypeQ -> TypeQ
+appT t1 t2 = do
+           t1' <- t1
+           t2' <- t2
+           return $ AppT t1' t2'
+
+arrowT :: TypeQ
+arrowT = return ArrowT
+
+listT :: TypeQ
+listT = return ListT
+
+litT :: TyLitQ -> TypeQ
+litT l = fmap LitT l
+
+tupleT :: Int -> TypeQ
+tupleT i = return (TupleT i)
+
+unboxedTupleT :: Int -> TypeQ
+unboxedTupleT i = return (UnboxedTupleT i)
+
+unboxedSumT :: SumArity -> TypeQ
+unboxedSumT arity = return (UnboxedSumT arity)
+
+sigT :: TypeQ -> KindQ -> TypeQ
+sigT t k
+  = do
+      t' <- t
+      k' <- k
+      return $ SigT t' k'
+
+equalityT :: TypeQ
+equalityT = return EqualityT
+
+wildCardT :: TypeQ
+wildCardT = return WildCardT
+
+{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
+classP :: Name -> [Q Type] -> Q Pred
+classP cla tys
+  = do
+      tysl <- sequence tys
+      return (foldl AppT (ConT cla) tysl)
+
+{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
+equalP :: TypeQ -> TypeQ -> PredQ
+equalP tleft tright
+  = do
+      tleft1  <- tleft
+      tright1 <- tright
+      eqT <- equalityT
+      return (foldl AppT eqT [tleft1, tright1])
+
+promotedT :: Name -> TypeQ
+promotedT = return . PromotedT
+
+promotedTupleT :: Int -> TypeQ
+promotedTupleT i = return (PromotedTupleT i)
+
+promotedNilT :: TypeQ
+promotedNilT = return PromotedNilT
+
+promotedConsT :: TypeQ
+promotedConsT = return PromotedConsT
+
+noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
+noSourceUnpackedness = return NoSourceUnpackedness
+sourceNoUnpack       = return SourceNoUnpack
+sourceUnpack         = return SourceUnpack
+
+noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
+noSourceStrictness = return NoSourceStrictness
+sourceLazy         = return SourceLazy
+sourceStrict       = return SourceStrict
+
+{-# DEPRECATED isStrict
+    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
+     "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}
+{-# DEPRECATED notStrict
+    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
+     "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}
+{-# DEPRECATED unpacked
+    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
+     "Example usage: 'bang sourceUnpack sourceStrict'"] #-}
+isStrict, notStrict, unpacked :: Q Strict
+isStrict = bang noSourceUnpackedness sourceStrict
+notStrict = bang noSourceUnpackedness noSourceStrictness
+unpacked = bang sourceUnpack sourceStrict
+
+bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
+bang u s = do u' <- u
+              s' <- s
+              return (Bang u' s')
+
+bangType :: BangQ -> TypeQ -> BangTypeQ
+bangType = liftM2 (,)
+
+varBangType :: Name -> BangTypeQ -> VarBangTypeQ
+varBangType v bt = do (b, t) <- bt
+                      return (v, b, t)
+
+{-# DEPRECATED strictType
+               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
+strictType :: Q Strict -> TypeQ -> StrictTypeQ
+strictType = bangType
+
+{-# DEPRECATED varStrictType
+               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
+varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
+varStrictType = varBangType
+
+-- * Type Literals
+
+numTyLit :: Integer -> TyLitQ
+numTyLit n = if n >= 0 then return (NumTyLit n)
+                       else fail ("Negative type-level number: " ++ show n)
+
+strTyLit :: String -> TyLitQ
+strTyLit s = return (StrTyLit s)
+
+-------------------------------------------------------------------------------
+-- *   Kind
+
+plainTV :: Name -> TyVarBndrQ
+plainTV = pure . PlainTV
+
+kindedTV :: Name -> KindQ -> TyVarBndrQ
+kindedTV n = fmap (KindedTV n)
+
+varK :: Name -> Kind
+varK = VarT
+
+conK :: Name -> Kind
+conK = ConT
+
+tupleK :: Int -> Kind
+tupleK = TupleT
+
+arrowK :: Kind
+arrowK = ArrowT
+
+listK :: Kind
+listK = ListT
+
+appK :: Kind -> Kind -> Kind
+appK = AppT
+
+starK :: KindQ
+starK = pure StarT
+
+constraintK :: KindQ
+constraintK = pure ConstraintT
+
+-------------------------------------------------------------------------------
+-- *   Type family result
+
+noSig :: FamilyResultSigQ
+noSig = pure NoSig
+
+kindSig :: KindQ -> FamilyResultSigQ
+kindSig = fmap KindSig
+
+tyVarSig :: TyVarBndrQ -> FamilyResultSigQ
+tyVarSig = fmap TyVarSig
+
+-------------------------------------------------------------------------------
+-- *   Injectivity annotation
+
+injectivityAnn :: Name -> [Name] -> InjectivityAnn
+injectivityAnn = TH.InjectivityAnn
+
+-------------------------------------------------------------------------------
+-- *   Role
+
+nominalR, representationalR, phantomR, inferR :: Role
+nominalR          = NominalR
+representationalR = RepresentationalR
+phantomR          = PhantomR
+inferR            = InferR
+
+-------------------------------------------------------------------------------
+-- *   Callconv
+
+cCall, stdCall, cApi, prim, javaScript :: Callconv
+cCall      = CCall
+stdCall    = StdCall
+cApi       = CApi
+prim       = Prim
+javaScript = JavaScript
+
+-------------------------------------------------------------------------------
+-- *   Safety
+
+unsafe, safe, interruptible :: Safety
+unsafe = Unsafe
+safe = Safe
+interruptible = Interruptible
+
+-------------------------------------------------------------------------------
+-- *   FunDep
+
+funDep :: [Name] -> [Name] -> FunDep
+funDep = FunDep
+
+-------------------------------------------------------------------------------
+-- *   FamFlavour
+
+typeFam, dataFam :: FamFlavour
+typeFam = TypeFam
+dataFam = DataFam
+
+-------------------------------------------------------------------------------
+-- *   RuleBndr
+ruleVar :: Name -> RuleBndrQ
+ruleVar = return . RuleVar
+
+typedRuleVar :: Name -> TypeQ -> RuleBndrQ
+typedRuleVar n ty = ty >>= return . TypedRuleVar n
+
+-------------------------------------------------------------------------------
+-- *   AnnTarget
+valueAnnotation :: Name -> AnnTarget
+valueAnnotation = ValueAnnotation
+
+typeAnnotation :: Name -> AnnTarget
+typeAnnotation = TypeAnnotation
+
+moduleAnnotation :: AnnTarget
+moduleAnnotation = ModuleAnnotation
+
+-------------------------------------------------------------------------------
+-- * Pattern Synonyms (sub constructs)
+
+unidir, implBidir :: PatSynDirQ
+unidir    = return Unidir
+implBidir = return ImplBidir
+
+explBidir :: [ClauseQ] -> PatSynDirQ
+explBidir cls = do
+  cls' <- sequence cls
+  return (ExplBidir cls')
+
+prefixPatSyn :: [Name] -> PatSynArgsQ
+prefixPatSyn args = return $ PrefixPatSyn args
+
+recordPatSyn :: [Name] -> PatSynArgsQ
+recordPatSyn sels = return $ RecordPatSyn sels
+
+infixPatSyn :: Name -> Name -> PatSynArgsQ
+infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
+
+--------------------------------------------------------------
+-- * Useful helper function
+
+appsE :: [ExpQ] -> ExpQ
+appsE [] = error "appsE []"
+appsE [x] = x
+appsE (x:y:zs) = appsE ( (appE x y) : zs )
+
+-- | Return the Module at the place of splicing.  Can be used as an
+-- input for 'reifyModule'.
+thisModule :: Q Module
+thisModule = do
+  loc <- location
+  return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
index 8eddedc..0e3429c 100644 (file)
@@ -6,6 +6,14 @@
 
   * Add support for overloaded labels. Introduces `labelE :: String -> ExpQ`.
 
+  * Add `KindQ`, `TyVarBndrQ`, and `FamilyResultSigQ` aliases to
+    `Language.Haskell.TH.Lib`.
+
+  * Add `Language.Haskell.TH.Lib.Internal` module, which exposes some
+    additional functionality that is used internally in GHC's integration
+    with Template Haskell. This is not a part of the public API, and as
+    such, there are no API guarantees for this module from version to version.
+
 ## 2.12.0.0 *TBA*
 
   * Bundled with GHC *TBA*
index dfb3b07..fcfa448 100644 (file)
@@ -45,6 +45,8 @@ Library
         Language.Haskell.TH.Syntax
         Language.Haskell.TH.LanguageExtensions
 
+        Language.Haskell.TH.Lib.Internal
+
     other-modules:
         Language.Haskell.TH.Lib.Map
 
index a5af954..41eb988 100644 (file)
@@ -5,7 +5,7 @@ TH_localname.hs:3:11: error:
                                   t0)’ from being solved.
       Relevant bindings include
         y :: t0 (bound at TH_localname.hs:3:6)
-        x :: t0 -> Language.Haskell.TH.Lib.ExpQ
+        x :: t0 -> Language.Haskell.TH.Lib.Internal.ExpQ
           (bound at TH_localname.hs:3:1)
       Probable fix: use a type annotation to specify what ‘t0’ should be.
       These potential instances exist:
index 35aee30..090b891 100644 (file)
@@ -5,5 +5,5 @@ import Data.Kind (Type)
 import Language.Haskell.TH (stringE, pprint)
 
 foo :: IO ()
-foo = $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |]
-         >>= \d -> stringE (pprint d))
+foo = putStrLn $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |]
+                 >>= \d -> stringE (pprint d))
diff --git a/testsuite/tests/th/T13642.stderr b/testsuite/tests/th/T13642.stderr
deleted file mode 100644 (file)
index a6ff054..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-
-T13642.hs:8:9: error:
-    Exotic form of kind not (yet) handled by Template Haskell
-      forall a. a -> Type
index 93c9a0c..4fa2a3c 100644 (file)
@@ -2,7 +2,7 @@
 T7276.hs:6:8: error:
     • Couldn't match type ‘[Language.Haskell.TH.Syntax.Dec]’
                      with ‘Language.Haskell.TH.Syntax.Exp’
-      Expected type: Language.Haskell.TH.Lib.ExpQ
-        Actual type: Language.Haskell.TH.Lib.DecsQ
+      Expected type: Language.Haskell.TH.Lib.Internal.ExpQ
+        Actual type: Language.Haskell.TH.Lib.Internal.DecsQ
     • In the expression: [d| y = 3 |]
       In the untyped splice: $([d| y = 3 |])
index b52042b..3db9857 100644 (file)
@@ -386,7 +386,7 @@ test('T13473', normal, multimod_compile_and_run,
      ['T13473.hs', '-v0 ' + config.ghc_th_way_flags])
 test('T13587', expect_broken(13587), compile_and_run, ['-v0'])
 test('T13618', normal, compile_and_run, ['-v0'])
-test('T13642', normal, compile_fail, ['-v0'])
+test('T13642', normal, compile, ['-v0'])
 test('T13781', normal, compile, ['-v0'])
 test('T13782', normal, compile, [''])
 test('T13837', normal, compile_fail, ['-v0 -dsuppress-uniques'])