Add support for ImplicitParams and RecursiveDo in TH

Summary:
This adds TH support for the ImplicitParams and RecursiveDo extensions.

I'm submitting this as one review because I cannot cleanly make
the two commits independent.

Initially, my goal was just to add ImplicitParams support, and
I found that reasonably straightforward, so figured I might
as well use my newfound knowledge to address some other TH omissions.

Test Plan: Validate

Reviewers: goldfire, austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: carter, RyanGlScott, thomie

GHC Trac Issues: #1262

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

22 files changed, 444 insertions, 172 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 21ee15718c..d25a7cfd06 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1137,6 +1137,10 @@ repTy (HsTyLit _ lit) = do
                           lit' <- repTyLit lit
                           repTLit lit'
 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
+repTy (HsIParamTy _ n t) = do
+                             n' <- rep_implicit_param_name (unLoc n)
+                             t' <- repLTy t
+                             repTImplicitParam n' t'
 
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
@@ -1206,7 +1210,7 @@ repE (HsVar _ (L _ x))            =
         Just (DsBound y)   -> repVarOrCon x (coreVar y)
         Just (DsSplice e)  -> do { e' <- dsExpr e
                                  ; return (MkC e') } }
-repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e)
+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
 repE (HsOverLabel _ _ s) = repOverLabel s
 
 repE e@(HsRecFld _ f) = case f of
@@ -1271,8 +1275,13 @@ repE e@(HsDo _ ctxt (L _ sts))
         e'      <- repComp (nonEmptyCoreList zs);
         wrapGenSyms ss e' }
 
+ | MDoExpr <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repMDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
   | otherwise
-  = notHandled "mdo, monad comprehension and [: :]" (ppr e)
+  = notHandled "monad comprehension and [: :]" (ppr e)
 
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitTuple _ es boxed)
@@ -1467,6 +1476,16 @@ repSts [LastStmt _ e _ _]
   = do { e2 <- repLE e
        ; z <- repNoBindSt e2
        ; return ([], [z]) }
+repSts (stmt@RecStmt{} : ss)
+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)
+       ; ss1 <- mkGenSyms binders
+       -- Bring all of binders in the recursive group into scope for the
+       -- whole group.
+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
+       ; MASSERT(sort ss1 == sort ss1_other)
+       ; z <- repRecSt (nonEmptyCoreList rss)
+       ; (ss2,zs) <- addBinds ss1 (repSts ss)
+       ; return (ss1++ss2, z : zs) }
 repSts []    = return ([],[])
 repSts other = notHandled "Exotic statement" (ppr other)
 
@@ -1480,7 +1499,15 @@ repBinds (EmptyLocalBinds _)
   = do  { core_list <- coreList decQTyConName []
         ; return ([], core_list) }
 
-repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b)
+repBinds (HsIPBinds _ (IPBinds _ decs))
+ = do   { ips <- mapM rep_implicit_param_bind decs
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc ips))
+        ; return ([], core_list)
+        }
+
+repBinds b@(HsIPBinds _ XHsIPBinds {})
+ = notHandled "Implicit parameter binds extension" (ppr b)
 
 repBinds (HsValBinds _ decs)
  = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
@@ -1496,6 +1523,21 @@ repBinds (HsValBinds _ decs)
         ; return (ss, core_list) }
 repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
 
+rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
+ = do { name <- case ename of
+                    Left (L _ n) -> rep_implicit_param_name n
+                    Right _ ->
+                        panic "rep_implicit_param_bind: post typechecking"
+      ; rhs' <- repE rhs
+      ; ipb <- repImplicitParamBind name rhs'
+      ; return (loc, ipb) }
+rep_implicit_param_bind (L _ b@(XIPBind _))
+ = notHandled "Implicit parameter bind extension" (ppr b)
+
+rep_implicit_param_name :: HsIPName -> DsM (Core String)
+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
+
 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are already in the meta-env
 rep_val_binds (XValBindsLR (NValBinds binds sigs))
@@ -2008,6 +2050,9 @@ repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 repDoE (MkC ss) = rep2 doEName [ss]
 
+repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repMDoE (MkC ss) = rep2 mdoEName [ss]
+
 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 repComp (MkC ss) = rep2 compEName [ss]
 
@@ -2035,6 +2080,9 @@ repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 
+repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
+
 ------------ Right hand sides (guarded expressions) ----
 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
@@ -2068,6 +2116,9 @@ repNoBindSt (MkC e) = rep2 noBindSName [e]
 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
 repParSt (MkC sss) = rep2 parSName [sss]
 
+repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
+repRecSt (MkC ss) = rep2 recSName [ss]
+
 -------------- Range (Arithmetic sequences) -----------
 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repFrom (MkC x) = rep2 fromEName [x]
@@ -2249,6 +2300,9 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 
+repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
+
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
@@ -2350,6 +2404,9 @@ repTLit (MkC lit) = rep2 litTName [lit]
 repTWildCard :: DsM (Core TH.TypeQ)
 repTWildCard = rep2 wildCardTName []
 
+repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
+
 repTStar :: DsM (Core TH.TypeQ)
 repTStar = rep2 starKName []
 
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 832a5134aa..5d0f5afce1 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -399,6 +399,12 @@ cvtDec (TH.PatSynSigD nm ty)
        ; ty' <- cvtPatSynSigTy ty
        ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
 
+-- Implicit parameter bindings are handled in cvtLocalDecs and
+-- cvtImplicitParamBind. They are not allowed in any other scope, so
+-- reaching this case indicates an error.
+cvtDec (TH.ImplicitParamBindD _ _)
+  = failWith (text "Implicit parameter binding only allowed in let or where")
+
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
 cvtTySynEqn tc (TySynEqn lhs rhs)
@@ -496,6 +502,10 @@ is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
 is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
 is_bind decl                     = Right decl
 
+is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
+is_ip_bind decl             = Right decl
+
 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
 mkBadDecMsg doc bads
   = sep [ text "Illegal declaration(s) in" <+> doc <> colon
@@ -766,14 +776,19 @@ cvtRuleBndr (TypedRuleVar n ty)
 
 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
 cvtLocalDecs doc ds
-  | null ds
-  = return (EmptyLocalBinds noExt)
-  | otherwise
-  = do { ds' <- cvtDecs ds
-       ; let (binds, prob_sigs) = partitionWith is_bind ds'
-       ; let (sigs, bads) = partitionWith is_sig prob_sigs
-       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-       ; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }
+  = case partitionWith is_ip_bind ds of
+      ([], []) -> return (EmptyLocalBinds noExt)
+      ([], _) -> do
+        ds' <- cvtDecs ds
+        let (binds, prob_sigs) = partitionWith is_bind ds'
+        let (sigs, bads) = partitionWith is_sig prob_sigs
+        unless (null bads) (failWith (mkBadDecMsg doc bads))
+        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
+      (ip_binds, []) -> do
+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
+        return (HsIPBinds noExt (IPBinds noExt binds))
+      ((_:_), (_:_)) ->
+        failWith (text "Implicit parameters mixed with other bindings")
 
 cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -784,6 +799,11 @@ cvtClause ctxt (Clause ps body wheres)
         ; ds' <- cvtLocalDecs (text "a where clause") wheres
         ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
 
+cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
+cvtImplicitParamBind n e = do
+    n' <- wrapL (ipName n)
+    e' <- cvtl e
+    returnL (IPBind noExt (Left n') e')
 
 -------------------------------------------------------------------
 --              Expressions
@@ -859,6 +879,7 @@ cvtl e = wrapL (cvt e)
                             ; return $ HsCase noExt e'
                                                  (mkMatchGroup FromSource ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
                             ; return $ ArithSeq noExt Nothing dd' }
@@ -918,6 +939,7 @@ cvtl e = wrapL (cvt e)
                               { s' <- vcName s
                               ; return $ HsVar noExt (noLoc s') }
     cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }
+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1045,6 +1067,7 @@ cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
   where
     cvt_one ds = do { ds' <- cvtStmts ds
                     ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
 
 cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -1396,6 +1419,11 @@ cvtTypeKind ty_str ty
              | otherwise ->
                    mk_apps (HsTyVar noExt NotPromoted
                             (noLoc eqTyCon_RDR)) tys'
+           ImplicitParamT n t
+             -> do { n' <- wrapL $ ipName n
+                   ; t' <- cvtType t
+                   ; returnL (HsIParamTy noExt n' t')
+                   }
 
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
@@ -1632,6 +1660,11 @@ tName n = cvtName OccName.tvName n
 tconNameL n = wrapL (tconName n)
 tconName n = cvtName OccName.tcClsName n
 
+ipName :: String -> CvtM HsIPName
+ipName n
+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
+       ; return (HsIPName (fsLit n)) }
+
 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 cvtName ctxt_ns (TH.Name occ flavour)
   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 8c526d59ec..7183a7edd6 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -53,10 +53,10 @@ templateHaskellNames = [
     varEName, conEName, litEName, appEName, appTypeEName, infixEName,
     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName, unboxedSumEName,
-    condEName, multiIfEName, letEName, caseEName, doEName, compEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
-    labelEName,
+    labelEName, implicitParamVarEName,
     -- FieldExp
     fieldExpName,
     -- Body
@@ -64,7 +64,7 @@ templateHaskellNames = [
     -- Guard
     normalGEName, patGEName,
     -- Stmt
-    bindSName, letSName, noBindSName, parSName,
+    bindSName, letSName, noBindSName, parSName, recSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
     classDName, instanceWithOverlapDName,
@@ -75,6 +75,7 @@ templateHaskellNames = [
     dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName,
     roleAnnotDName, patSynDName, patSynSigDName,
+    implicitParamBindDName,
     -- Cxt
     cxtName,
 
@@ -99,7 +100,7 @@ templateHaskellNames = [
     tupleTName, unboxedTupleTName, unboxedSumTName,
     arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName,
+    wildCardTName, implicitParamTName,
     -- TyLit
     numTyLitName, strTyLitName,
     -- TyVarBndr
@@ -275,43 +276,45 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
-    caseEName, doEName, compEName, staticEName, unboundVarEName,
-    labelEName :: Name
-varEName        = libFun (fsLit "varE")        varEIdKey
-conEName        = libFun (fsLit "conE")        conEIdKey
-litEName        = libFun (fsLit "litE")        litEIdKey
-appEName        = libFun (fsLit "appE")        appEIdKey
-appTypeEName    = libFun (fsLit "appTypeE")    appTypeEIdKey
-infixEName      = libFun (fsLit "infixE")      infixEIdKey
-infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
-sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
-sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
-lamEName        = libFun (fsLit "lamE")        lamEIdKey
-lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
-tupEName        = libFun (fsLit "tupE")        tupEIdKey
-unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
-unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
-condEName       = libFun (fsLit "condE")       condEIdKey
-multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey
-letEName        = libFun (fsLit "letE")        letEIdKey
-caseEName       = libFun (fsLit "caseE")       caseEIdKey
-doEName         = libFun (fsLit "doE")         doEIdKey
-compEName       = libFun (fsLit "compE")       compEIdKey
+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName :: Name
+varEName              = libFun (fsLit "varE")              varEIdKey
+conEName              = libFun (fsLit "conE")              conEIdKey
+litEName              = libFun (fsLit "litE")              litEIdKey
+appEName              = libFun (fsLit "appE")              appEIdKey
+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey
+infixEName            = libFun (fsLit "infixE")            infixEIdKey
+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey
+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey
+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey
+lamEName              = libFun (fsLit "lamE")              lamEIdKey
+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey
+tupEName              = libFun (fsLit "tupE")              tupEIdKey
+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey
+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey
+condEName             = libFun (fsLit "condE")             condEIdKey
+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey
+letEName              = libFun (fsLit "letE")              letEIdKey
+caseEName             = libFun (fsLit "caseE")             caseEIdKey
+doEName               = libFun (fsLit "doE")               doEIdKey
+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey
+compEName             = libFun (fsLit "compE")             compEIdKey
 -- ArithSeq skips a level
 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
-fromEName       = libFun (fsLit "fromE")       fromEIdKey
-fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey
-fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey
-fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
+fromEName             = libFun (fsLit "fromE")             fromEIdKey
+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey
+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey
+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey
 -- end ArithSeq
 listEName, sigEName, recConEName, recUpdEName :: Name
-listEName       = libFun (fsLit "listE")       listEIdKey
-sigEName        = libFun (fsLit "sigE")        sigEIdKey
-recConEName     = libFun (fsLit "recConE")     recConEIdKey
-recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
-staticEName     = libFun (fsLit "staticE")     staticEIdKey
-unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
-labelEName      = libFun (fsLit "labelE")      labelEIdKey
+listEName             = libFun (fsLit "listE")             listEIdKey
+sigEName              = libFun (fsLit "sigE")              sigEIdKey
+recConEName           = libFun (fsLit "recConE")           recConEIdKey
+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey
+staticEName           = libFun (fsLit "staticE")           staticEIdKey
+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
+labelEName            = libFun (fsLit "labelE")            labelEIdKey
+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -328,11 +331,12 @@ normalGEName = libFun (fsLit "normalGE") normalGEIdKey
 patGEName    = libFun (fsLit "patGE")    patGEIdKey
 
 -- data Stmt = ...
-bindSName, letSName, noBindSName, parSName :: Name
+bindSName, letSName, noBindSName, parSName, recSName :: Name
 bindSName   = libFun (fsLit "bindS")   bindSIdKey
 letSName    = libFun (fsLit "letS")    letSIdKey
 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
 parSName    = libFun (fsLit "parS")    parSIdKey
+recSName    = libFun (fsLit "recS")    recSIdKey
 
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
@@ -342,7 +346,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
-    pragCompleteDName :: Name
+    pragCompleteDName, implicitParamBindDName :: Name
 funDName                         = libFun (fsLit "funD")                         funDIdKey
 valDName                         = libFun (fsLit "valD")                         valDIdKey
 dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
@@ -373,6 +377,7 @@ infixNDName                      = libFun (fsLit "infixND")
 roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
 patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
 patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -428,7 +433,7 @@ forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
     unboxedSumTName, arrowTName, listTName, appTName, sigTName,
     equalityTName, litTName, promotedTName,
     promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName :: Name
+    wildCardTName, implicitParamTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
 varTName            = libFun (fsLit "varT")           varTIdKey
 conTName            = libFun (fsLit "conT")           conTIdKey
@@ -446,6 +451,7 @@ promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
 promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
 promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
 wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
 
 -- data TyLit = ...
 numTyLitName, strTyLitName :: Name
@@ -792,38 +798,40 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
-    unboundVarEIdKey, labelEIdKey :: Unique
-varEIdKey         = mkPreludeMiscIdUnique 270
-conEIdKey         = mkPreludeMiscIdUnique 271
-litEIdKey         = mkPreludeMiscIdUnique 272
-appEIdKey         = mkPreludeMiscIdUnique 273
-appTypeEIdKey     = mkPreludeMiscIdUnique 274
-infixEIdKey       = mkPreludeMiscIdUnique 275
-infixAppIdKey     = mkPreludeMiscIdUnique 276
-sectionLIdKey     = mkPreludeMiscIdUnique 277
-sectionRIdKey     = mkPreludeMiscIdUnique 278
-lamEIdKey         = mkPreludeMiscIdUnique 279
-lamCaseEIdKey     = mkPreludeMiscIdUnique 280
-tupEIdKey         = mkPreludeMiscIdUnique 281
-unboxedTupEIdKey  = mkPreludeMiscIdUnique 282
-unboxedSumEIdKey  = mkPreludeMiscIdUnique 283
-condEIdKey        = mkPreludeMiscIdUnique 284
-multiIfEIdKey     = mkPreludeMiscIdUnique 285
-letEIdKey         = mkPreludeMiscIdUnique 286
-caseEIdKey        = mkPreludeMiscIdUnique 287
-doEIdKey          = mkPreludeMiscIdUnique 288
-compEIdKey        = mkPreludeMiscIdUnique 289
-fromEIdKey        = mkPreludeMiscIdUnique 290
-fromThenEIdKey    = mkPreludeMiscIdUnique 291
-fromToEIdKey      = mkPreludeMiscIdUnique 292
-fromThenToEIdKey  = mkPreludeMiscIdUnique 293
-listEIdKey        = mkPreludeMiscIdUnique 294
-sigEIdKey         = mkPreludeMiscIdUnique 295
-recConEIdKey      = mkPreludeMiscIdUnique 296
-recUpdEIdKey      = mkPreludeMiscIdUnique 297
-staticEIdKey      = mkPreludeMiscIdUnique 298
-unboundVarEIdKey  = mkPreludeMiscIdUnique 299
-labelEIdKey       = mkPreludeMiscIdUnique 300
+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+varEIdKey              = mkPreludeMiscIdUnique 270
+conEIdKey              = mkPreludeMiscIdUnique 271
+litEIdKey              = mkPreludeMiscIdUnique 272
+appEIdKey              = mkPreludeMiscIdUnique 273
+appTypeEIdKey          = mkPreludeMiscIdUnique 274
+infixEIdKey            = mkPreludeMiscIdUnique 275
+infixAppIdKey          = mkPreludeMiscIdUnique 276
+sectionLIdKey          = mkPreludeMiscIdUnique 277
+sectionRIdKey          = mkPreludeMiscIdUnique 278
+lamEIdKey              = mkPreludeMiscIdUnique 279
+lamCaseEIdKey          = mkPreludeMiscIdUnique 280
+tupEIdKey              = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey       = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey       = mkPreludeMiscIdUnique 283
+condEIdKey             = mkPreludeMiscIdUnique 284
+multiIfEIdKey          = mkPreludeMiscIdUnique 285
+letEIdKey              = mkPreludeMiscIdUnique 286
+caseEIdKey             = mkPreludeMiscIdUnique 287
+doEIdKey               = mkPreludeMiscIdUnique 288
+compEIdKey             = mkPreludeMiscIdUnique 289
+fromEIdKey             = mkPreludeMiscIdUnique 290
+fromThenEIdKey         = mkPreludeMiscIdUnique 291
+fromToEIdKey           = mkPreludeMiscIdUnique 292
+fromThenToEIdKey       = mkPreludeMiscIdUnique 293
+listEIdKey             = mkPreludeMiscIdUnique 294
+sigEIdKey              = mkPreludeMiscIdUnique 295
+recConEIdKey           = mkPreludeMiscIdUnique 296
+recUpdEIdKey           = mkPreludeMiscIdUnique 297
+staticEIdKey           = mkPreludeMiscIdUnique 298
+unboundVarEIdKey       = mkPreludeMiscIdUnique 299
+labelEIdKey            = mkPreludeMiscIdUnique 300
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
+mdoEIdKey              = mkPreludeMiscIdUnique 302
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
@@ -840,11 +848,12 @@ normalGEIdKey     = mkPreludeMiscIdUnique 308
 patGEIdKey        = mkPreludeMiscIdUnique 309
 
 -- data Stmt = ...
-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
 bindSIdKey       = mkPreludeMiscIdUnique 310
 letSIdKey        = mkPreludeMiscIdUnique 311
 noBindSIdKey     = mkPreludeMiscIdUnique 312
 parSIdKey        = mkPreludeMiscIdUnique 313
+recSIdKey        = mkPreludeMiscIdUnique 314
 
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
@@ -854,7 +863,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
-    patSynSigDIdKey, pragCompleteDIdKey :: Unique
+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
 funDIdKey                         = mkPreludeMiscIdUnique 320
 valDIdKey                         = mkPreludeMiscIdUnique 321
 dataDIdKey                        = mkPreludeMiscIdUnique 322
@@ -886,138 +895,140 @@ defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
 patSynDIdKey                      = mkPreludeMiscIdUnique 348
 patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
 pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
 
 -- type Cxt = ...
 cxtIdKey :: Unique
-cxtIdKey               = mkPreludeMiscIdUnique 351
+cxtIdKey               = mkPreludeMiscIdUnique 361
 
 -- data SourceUnpackedness = ...
 noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
-noSourceUnpackednessKey = mkPreludeMiscIdUnique 352
-sourceNoUnpackKey       = mkPreludeMiscIdUnique 353
-sourceUnpackKey         = mkPreludeMiscIdUnique 354
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363
+sourceUnpackKey         = mkPreludeMiscIdUnique 364
 
 -- data SourceStrictness = ...
 noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
-noSourceStrictnessKey   = mkPreludeMiscIdUnique 355
-sourceLazyKey           = mkPreludeMiscIdUnique 356
-sourceStrictKey         = mkPreludeMiscIdUnique 357
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365
+sourceLazyKey           = mkPreludeMiscIdUnique 366
+sourceStrictKey         = mkPreludeMiscIdUnique 367
 
 -- data Con = ...
 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
   recGadtCIdKey :: Unique
-normalCIdKey      = mkPreludeMiscIdUnique 358
-recCIdKey         = mkPreludeMiscIdUnique 359
-infixCIdKey       = mkPreludeMiscIdUnique 360
-forallCIdKey      = mkPreludeMiscIdUnique 361
-gadtCIdKey        = mkPreludeMiscIdUnique 362
-recGadtCIdKey     = mkPreludeMiscIdUnique 363
+normalCIdKey      = mkPreludeMiscIdUnique 368
+recCIdKey         = mkPreludeMiscIdUnique 369
+infixCIdKey       = mkPreludeMiscIdUnique 370
+forallCIdKey      = mkPreludeMiscIdUnique 371
+gadtCIdKey        = mkPreludeMiscIdUnique 372
+recGadtCIdKey     = mkPreludeMiscIdUnique 373
 
 -- data Bang = ...
 bangIdKey :: Unique
-bangIdKey         = mkPreludeMiscIdUnique 364
+bangIdKey         = mkPreludeMiscIdUnique 374
 
 -- type BangType = ...
 bangTKey :: Unique
-bangTKey          = mkPreludeMiscIdUnique 365
+bangTKey          = mkPreludeMiscIdUnique 375
 
 -- type VarBangType = ...
 varBangTKey :: Unique
-varBangTKey       = mkPreludeMiscIdUnique 366
+varBangTKey       = mkPreludeMiscIdUnique 376
 
 -- data PatSynDir = ...
 unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
-unidirPatSynIdKey    = mkPreludeMiscIdUnique 367
-implBidirPatSynIdKey = mkPreludeMiscIdUnique 368
-explBidirPatSynIdKey = mkPreludeMiscIdUnique 369
+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
 
 -- data PatSynArgs = ...
 prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
-prefixPatSynIdKey = mkPreludeMiscIdUnique 370
-infixPatSynIdKey  = mkPreludeMiscIdUnique 371
-recordPatSynIdKey = mkPreludeMiscIdUnique 372
+prefixPatSynIdKey = mkPreludeMiscIdUnique 380
+infixPatSynIdKey  = mkPreludeMiscIdUnique 381
+recordPatSynIdKey = mkPreludeMiscIdUnique 382
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
     unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
     equalityTIdKey, litTIdKey, promotedTIdKey,
     promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
-    wildCardTIdKey :: Unique
-forallTIdKey        = mkPreludeMiscIdUnique 381
-varTIdKey           = mkPreludeMiscIdUnique 382
-conTIdKey           = mkPreludeMiscIdUnique 383
-tupleTIdKey         = mkPreludeMiscIdUnique 384
-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 385
-unboxedSumTIdKey    = mkPreludeMiscIdUnique 386
-arrowTIdKey         = mkPreludeMiscIdUnique 387
-listTIdKey          = mkPreludeMiscIdUnique 388
-appTIdKey           = mkPreludeMiscIdUnique 389
-sigTIdKey           = mkPreludeMiscIdUnique 390
-equalityTIdKey      = mkPreludeMiscIdUnique 391
-litTIdKey           = mkPreludeMiscIdUnique 392
-promotedTIdKey      = mkPreludeMiscIdUnique 393
-promotedTupleTIdKey = mkPreludeMiscIdUnique 394
-promotedNilTIdKey   = mkPreludeMiscIdUnique 395
-promotedConsTIdKey  = mkPreludeMiscIdUnique 396
-wildCardTIdKey      = mkPreludeMiscIdUnique 397
+    wildCardTIdKey, implicitParamTIdKey :: Unique
+forallTIdKey        = mkPreludeMiscIdUnique 391
+varTIdKey           = mkPreludeMiscIdUnique 392
+conTIdKey           = mkPreludeMiscIdUnique 393
+tupleTIdKey         = mkPreludeMiscIdUnique 394
+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396
+arrowTIdKey         = mkPreludeMiscIdUnique 397
+listTIdKey          = mkPreludeMiscIdUnique 398
+appTIdKey           = mkPreludeMiscIdUnique 399
+sigTIdKey           = mkPreludeMiscIdUnique 400
+equalityTIdKey      = mkPreludeMiscIdUnique 401
+litTIdKey           = mkPreludeMiscIdUnique 402
+promotedTIdKey      = mkPreludeMiscIdUnique 403
+promotedTupleTIdKey = mkPreludeMiscIdUnique 404
+promotedNilTIdKey   = mkPreludeMiscIdUnique 405
+promotedConsTIdKey  = mkPreludeMiscIdUnique 406
+wildCardTIdKey      = mkPreludeMiscIdUnique 407
+implicitParamTIdKey = mkPreludeMiscIdUnique 408
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 400
-strTyLitIdKey = mkPreludeMiscIdUnique 401
+numTyLitIdKey = mkPreludeMiscIdUnique 410
+strTyLitIdKey = mkPreludeMiscIdUnique 411
 
 -- data TyVarBndr = ...
 plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey       = mkPreludeMiscIdUnique 402
-kindedTVIdKey      = mkPreludeMiscIdUnique 403
+plainTVIdKey       = mkPreludeMiscIdUnique 412
+kindedTVIdKey      = mkPreludeMiscIdUnique 413
 
 -- data Role = ...
 nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey          = mkPreludeMiscIdUnique 404
-representationalRIdKey = mkPreludeMiscIdUnique 405
-phantomRIdKey          = mkPreludeMiscIdUnique 406
-inferRIdKey            = mkPreludeMiscIdUnique 407
+nominalRIdKey          = mkPreludeMiscIdUnique 414
+representationalRIdKey = mkPreludeMiscIdUnique 415
+phantomRIdKey          = mkPreludeMiscIdUnique 416
+inferRIdKey            = mkPreludeMiscIdUnique 417
 
 -- data Kind = ...
 varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
   starKIdKey, constraintKIdKey :: Unique
-varKIdKey         = mkPreludeMiscIdUnique 408
-conKIdKey         = mkPreludeMiscIdUnique 409
-tupleKIdKey       = mkPreludeMiscIdUnique 410
-arrowKIdKey       = mkPreludeMiscIdUnique 411
-listKIdKey        = mkPreludeMiscIdUnique 412
-appKIdKey         = mkPreludeMiscIdUnique 413
-starKIdKey        = mkPreludeMiscIdUnique 414
-constraintKIdKey  = mkPreludeMiscIdUnique 415
+varKIdKey         = mkPreludeMiscIdUnique 418
+conKIdKey         = mkPreludeMiscIdUnique 419
+tupleKIdKey       = mkPreludeMiscIdUnique 420
+arrowKIdKey       = mkPreludeMiscIdUnique 421
+listKIdKey        = mkPreludeMiscIdUnique 422
+appKIdKey         = mkPreludeMiscIdUnique 423
+starKIdKey        = mkPreludeMiscIdUnique 424
+constraintKIdKey  = mkPreludeMiscIdUnique 425
 
 -- data FamilyResultSig = ...
 noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
-noSigIdKey        = mkPreludeMiscIdUnique 416
-kindSigIdKey      = mkPreludeMiscIdUnique 417
-tyVarSigIdKey     = mkPreludeMiscIdUnique 418
+noSigIdKey        = mkPreludeMiscIdUnique 426
+kindSigIdKey      = mkPreludeMiscIdUnique 427
+tyVarSigIdKey     = mkPreludeMiscIdUnique 428
 
 -- data InjectivityAnn = ...
 injectivityAnnIdKey :: Unique
-injectivityAnnIdKey = mkPreludeMiscIdUnique 419
+injectivityAnnIdKey = mkPreludeMiscIdUnique 429
 
 -- data Callconv = ...
 cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
   javaScriptCallIdKey :: Unique
-cCallIdKey          = mkPreludeMiscIdUnique 420
-stdCallIdKey        = mkPreludeMiscIdUnique 421
-cApiCallIdKey       = mkPreludeMiscIdUnique 422
-primCallIdKey       = mkPreludeMiscIdUnique 423
-javaScriptCallIdKey = mkPreludeMiscIdUnique 424
+cCallIdKey          = mkPreludeMiscIdUnique 430
+stdCallIdKey        = mkPreludeMiscIdUnique 431
+cApiCallIdKey       = mkPreludeMiscIdUnique 432
+primCallIdKey       = mkPreludeMiscIdUnique 433
+javaScriptCallIdKey = mkPreludeMiscIdUnique 434
 
 -- data Safety = ...
 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey        = mkPreludeMiscIdUnique 430
-safeIdKey          = mkPreludeMiscIdUnique 431
-interruptibleIdKey = mkPreludeMiscIdUnique 432
+unsafeIdKey        = mkPreludeMiscIdUnique 440
+safeIdKey          = mkPreludeMiscIdUnique 441
+interruptibleIdKey = mkPreludeMiscIdUnique 442
 
 -- data FunDep = ...
 funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 440
+funDepIdKey = mkPreludeMiscIdUnique 445
 
 -- data TySynEqn = ...
 tySynEqnIdKey :: Unique
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 5e2cec6252..21eb8292d5 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1772,7 +1772,7 @@ reifyKind :: Kind -> TcM TH.Kind
 reifyKind = reifyType
 
 reifyCxt :: [PredType] -> TcM [TH.Pred]
-reifyCxt   = mapM reifyPred
+reifyCxt   = mapM reifyType
 
 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
@@ -1933,13 +1933,6 @@ reify_tc_app tc tys
 
         in not (subVarSet result_vars dropped_vars)
 
-reifyPred :: TyCoRep.PredType -> TcM TH.Pred
-reifyPred ty
-  -- We could reify the invisible parameter as a class but it seems
-  -- nicer to support them properly...
-  | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
-  | otherwise   = reifyType ty
-
 ------------------------------
 reifyName :: NamedThing n => n -> TH.Name
 reifyName thing
diff --git a/docs/users_guide/8.8.1-notes.rst b/docs/users_guide/8.8.1-notes.rst
index 50323b3939..c99eb3756f 100644
--- a/docs/users_guide/8.8.1-notes.rst
+++ b/docs/users_guide/8.8.1-notes.rst
@@ -76,6 +76,8 @@ Template Haskell
   longer included when reifying ``C``. It's possible that this may break some
   code which assumes the existence of ``forall a. C a =>``.
 
+- Template Haskell now supports implicit parameters and recursive do.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index b0aa580d04..778e6c0553 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -37,8 +37,8 @@ module Language.Haskell.TH.Lib (
         normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,
 
     -- *** Expressions
-        dyn, varE, unboundVarE, labelE,  conE, litE, appE, appTypeE, uInfixE, parensE,
-        staticE, infixE, infixApp, sectionL, sectionR,
+        dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE,
+        appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
         lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,
         letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
     -- **** Ranges
@@ -48,13 +48,13 @@ module Language.Haskell.TH.Lib (
     arithSeqE,
     fromR, fromThenR, fromToR, fromThenToR,
     -- **** Statements
-    doE, compE,
-    bindS, letS, noBindS, parS,
+    doE, mdoE, compE,
+    bindS, letS, noBindS, parS, recS,
 
     -- *** Types
         forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
         listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT,
-        promotedT, promotedTupleT, promotedNilT, promotedConsT,
+        promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT,
     -- **** Type literals
     numTyLit, strTyLit,
     -- **** Strictness
@@ -113,6 +113,9 @@ module Language.Haskell.TH.Lib (
     patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
     infixPatSyn, recordPatSyn,
 
+    -- **** Implicit Parameters
+    implicitParamBindD,
+
     -- ** Reify
     thisModule
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 0ddfddf23a..989e8168ba 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -165,6 +165,9 @@ noBindS e = do { e1 <- e; return (NoBindS e1) }
 parS :: [[StmtQ]] -> StmtQ
 parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
 
+recS :: [StmtQ] -> StmtQ
+recS ss = do { ss1 <- sequence ss; return (RecS ss1) }
+
 -------------------------------------------------------------------------------
 -- *   Range
 
@@ -305,6 +308,9 @@ 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) }
 
+mdoE :: [StmtQ] -> ExpQ
+mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) }
+
 compE :: [StmtQ] -> ExpQ
 compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
 
@@ -339,6 +345,9 @@ unboundVarE s = return (UnboundVarE s)
 labelE :: String -> ExpQ
 labelE s = return (LabelE s)
 
+implicitParamVarE :: String -> ExpQ
+implicitParamVarE n = return (ImplicitParamVarE n)
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: ExpQ -> ExpQ
 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
@@ -563,6 +572,14 @@ patSynSigD nm ty =
   do ty' <- ty
      return $ PatSynSigD nm ty'
 
+-- | Implicit parameter binding declaration. Can only be used in let
+-- and where clauses which consist entirely of implicit bindings.
+implicitParamBindD :: String -> ExpQ -> DecQ
+implicitParamBindD n e =
+  do
+    e' <- e
+    return $ ImplicitParamBindD n e'
+
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
   do
@@ -681,6 +698,12 @@ equalityT = return EqualityT
 wildCardT :: TypeQ
 wildCardT = return WildCardT
 
+implicitParamT :: String -> TypeQ -> TypeQ
+implicitParamT n t
+  = do
+      t' <- t
+      return $ ImplicitParamT n t'
+
 {-# 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
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7edc15c696..8158af6ffd 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -179,6 +179,11 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
     pprStms []  = empty
     pprStms [s] = ppr s
     pprStms ss  = braces (semiSep ss)
+pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_
+  where
+    pprStms []  = empty
+    pprStms [s] = ppr s
+    pprStms ss  = braces (semiSep ss)
 
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
@@ -203,6 +208,7 @@ pprExp i (StaticE e) = parensIf (i >= appPrec) $
                          text "static"<+> pprExp appPrec e
 pprExp _ (UnboundVarE v) = pprName' Applied v
 pprExp _ (LabelE s) = text "#" <> text s
+pprExp _ (ImplicitParamVarE n) = text ('?' : n)
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
@@ -218,6 +224,7 @@ instance Ppr Stmt where
     ppr (NoBindS e) = ppr e
     ppr (ParS sss) = sep $ punctuate bar
                          $ map commaSep sss
+    ppr (RecS ss) = text "rec" <+> (braces (semiSep ss))
 
 ------------------------------
 instance Ppr Match where
@@ -386,6 +393,8 @@ ppr_dec _ (PatSynD name args dir pat)
                 | otherwise            = ppr pat
 ppr_dec _ (PatSynSigD name ty)
   = pprPatSynSig name ty
+ppr_dec _ (ImplicitParamBindD n e)
+  = hsep [text ('?' : n), text "=", ppr e]
 
 ppr_deriv_strategy :: DerivStrategy -> Doc
 ppr_deriv_strategy ds =
@@ -716,6 +725,7 @@ pprParendType (ParensT t)         = ppr t
 pprParendType tuple | (TupleT n, args) <- split tuple
                     , length args == n
                     = parens (commaSep args)
+pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t
 pprParendType other               = parens (ppr other)
 
 pprUInfixT :: Type -> Doc
@@ -784,6 +794,7 @@ pprCxt ts = ppr_cxt_preds ts <+> text "=>"
 
 ppr_cxt_preds :: Cxt -> Doc
 ppr_cxt_preds [] = empty
+ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t)
 ppr_cxt_preds [t] = ppr t
 ppr_cxt_preds ts = parens (commaSep ts)
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 4e0a1c9330..294e443afb 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1601,9 +1601,10 @@ data Exp
   | UnboxedSumE Exp SumAlt SumArity    -- ^ @{ (\#|e|\#) }@
   | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@
   | MultiIfE [(Guard, Exp)]            -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
-  | LetE [Dec] Exp                     -- ^ @{ let x=e1;   y=e2 in e3 }@
+  | LetE [Dec] Exp                     -- ^ @{ let { x=e1; y=e2 } in e3 }@
   | CaseE Exp [Match]                  -- ^ @{ case e of m1; m2 }@
   | DoE [Stmt]                         -- ^ @{ do { p <- e1; e2 }  }@
+  | MDoE [Stmt]                        -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@
   | CompE [Stmt]                       -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@
       --
       -- The result expression of the comprehension is
@@ -1628,6 +1629,7 @@ data Exp
                                        -- it could either have a variable name
                                        -- or constructor name.
   | LabelE String                      -- ^ @{ #x }@ ( Overloaded label )
+  | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )
   deriving( Show, Eq, Ord, Data, Generic )
 
 type FieldExp = (Name,Exp)
@@ -1647,10 +1649,11 @@ data Guard
   deriving( Show, Eq, Ord, Data, Generic )
 
 data Stmt
-  = BindS Pat Exp
-  | LetS [ Dec ]
-  | NoBindS Exp
-  | ParS [[Stmt]]
+  = BindS Pat Exp -- ^ @p <- e@
+  | LetS [ Dec ]  -- ^ @{ let { x=e1; y=e2 } }@
+  | NoBindS Exp   -- ^ @e@
+  | ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE')
+  | RecS [Stmt]   -- ^ @rec { s1; s2 }@
   deriving( Show, Eq, Ord, Data, Generic )
 
 data Range = FromR Exp | FromThenR Exp Exp
@@ -1729,6 +1732,12 @@ data Dec
       -- pattern synonyms are supported. See 'PatSynArgs' for details
 
   | PatSynSigD Name PatSynType  -- ^ A pattern synonym's type signature.
+
+  | ImplicitParamBindD String Exp
+      -- ^ @{ ?x = expr }@
+      --
+      -- Implicit parameter binding declaration. Can only be used in let
+      -- and where clauses which consist entirely of implicit bindings.
   deriving( Show, Eq, Ord, Data, Generic )
 
 -- | Varieties of allowed instance overlap.
@@ -2015,6 +2024,7 @@ data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> => \<t
           | ConstraintT                   -- ^ @Constraint@
           | LitT TyLit                    -- ^ @0,1,2, etc.@
           | WildCardT                     -- ^ @_@
+          | ImplicitParamT String Type    -- ^ @?x :: t@
       deriving( Show, Eq, Ord, Data, Generic )
 
 data TyVarBndr = PlainTV  Name            -- ^ @a@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 53b5b5692c..c3d6c252e7 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -18,6 +18,11 @@
 
   * Add a `ViaStrategy` constructor to `DerivStrategy`.
 
+  * Add support for `-XImplicitParams` via `ImplicitParamT`,
+    `ImplicitParamVarE`, and `ImplicitParamBindD`.
+
+  * Add support for `-XRecursiveDo` via `MDoE` and `RecS`.
+
 ## 2.13.0.0 *March 2018*
 
   * Bundled with GHC 8.4.1
diff --git a/testsuite/tests/th/TH_implicitParams.hs b/testsuite/tests/th/TH_implicitParams.hs
new file mode 100644
index 0000000000..eb948b98ed
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParams.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImplicitParams #-}
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+funcToReify :: (?z :: Int) => Int
+funcToReify = ?z
+
+$( [d|
+        f :: (?x :: Int) => Int
+        f = let ?y = 2 in ?x + ?y |] )
+
+main = do
+    putStrLn $(lift . pprint =<< reify 'funcToReify)
+    print (let ?x = 3 in f)
+    print $( [| let ?x = 1 in ?x |] )
+    print $(letE [implicitParamBindD "y" (lift (2 :: Int))]
+                 (implicitParamVarE "y") )
+    putStrLn $( lift . pprint =<< [d|
+        f :: (?x :: Int) => Int
+        f = let ?y = 2 in ?x + ?y |] )
diff --git a/testsuite/tests/th/TH_implicitParams.stdout b/testsuite/tests/th/TH_implicitParams.stdout
new file mode 100644
index 0000000000..571d2e74fe
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParams.stdout
@@ -0,0 +1,8 @@
+Main.funcToReify :: GHC.Classes.IP "z" GHC.Types.Int =>
+                    GHC.Types.Int
+5
+1
+2
+f_0 :: (?x :: GHC.Types.Int) => GHC.Types.Int
+f_0 = let ?y = 2
+       in ?x GHC.Num.+ ?y
diff --git a/testsuite/tests/th/TH_implicitParamsErr1.hs b/testsuite/tests/th/TH_implicitParamsErr1.hs
new file mode 100644
index 0000000000..56cf285c59
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr1.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+$(fmap (:[]) (implicitParamBindD "x" [e| 1 |]))
diff --git a/testsuite/tests/th/TH_implicitParamsErr1.stderr b/testsuite/tests/th/TH_implicitParamsErr1.stderr
new file mode 100644
index 0000000000..82324810ad
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr1.stderr
@@ -0,0 +1,4 @@
+
+TH_implicitParamsErr1.hs:5:3: error:
+    Implicit parameter binding only allowed in let or where
+    When splicing a TH declaration: ?x = 1
diff --git a/testsuite/tests/th/TH_implicitParamsErr2.hs b/testsuite/tests/th/TH_implicitParamsErr2.hs
new file mode 100644
index 0000000000..5b8ad90e81
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr2.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+main = $(letE [ implicitParamBindD "x" [e| 1 |]
+              , funD (mkName "y") [clause [] (normalB [e| 2 |]) []]
+              ]
+              (varE (mkName "y")))
diff --git a/testsuite/tests/th/TH_implicitParamsErr2.stderr b/testsuite/tests/th/TH_implicitParamsErr2.stderr
new file mode 100644
index 0000000000..f93aa55a58
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr2.stderr
@@ -0,0 +1,10 @@
+
+TH_implicitParamsErr2.hs:5:10: error:
+    • Implicit parameters mixed with other bindings
+      When splicing a TH expression: let {?x = 1; y = 2}
+ in y
+    • In the untyped splice:
+        $(letE
+            [implicitParamBindD "x" [| 1 |],
+             funD (mkName "y") [clause [] (normalB [| 2 |]) []]]
+            (varE (mkName "y")))
diff --git a/testsuite/tests/th/TH_implicitParamsErr3.hs b/testsuite/tests/th/TH_implicitParamsErr3.hs
new file mode 100644
index 0000000000..b217d60846
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr3.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+main = print $(letE [implicitParamBindD "invalid name" [e| "hi" |]]
+                    (implicitParamVarE "invalid name"))
diff --git a/testsuite/tests/th/TH_implicitParamsErr3.stderr b/testsuite/tests/th/TH_implicitParamsErr3.stderr
new file mode 100644
index 0000000000..fe3bf67259
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr3.stderr
@@ -0,0 +1,10 @@
+
+TH_implicitParamsErr3.hs:5:16: error:
+    • Illegal variable name: ‘invalid name’
+      When splicing a TH expression:
+        let ?invalid name = "hi"
+ in ?invalid name
+    • In the untyped splice:
+        $(letE
+            [implicitParamBindD "invalid name" [| "hi" |]]
+            (implicitParamVarE "invalid name"))
diff --git a/testsuite/tests/th/TH_recursiveDo.hs b/testsuite/tests/th/TH_recursiveDo.hs
new file mode 100644
index 0000000000..f193cf7088
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDo.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE RecursiveDo #-}
+import Data.IORef
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import TH_recursiveDoImport
+
+main = testRec >> testMdo
+
+testRec = do
+    putStrLn $(lift . pprint =<< recIO)
+    -- Test that we got the expected structure.
+    SelfRef r1 <- $(recIO)
+    r2 <- readIORef r1
+    SelfRef r1' <- readIORef r2
+    print (r1 == r1')
+
+testMdo =
+    putStrLn $(lift . pprint =<< mdoIO)
diff --git a/testsuite/tests/th/TH_recursiveDo.stdout b/testsuite/tests/th/TH_recursiveDo.stdout
new file mode 100644
index 0000000000..5508b5dcdc
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDo.stdout
@@ -0,0 +1,7 @@
+do {rec {r1_0 <- GHC.IORef.newIORef r2_1;
+         r2_1 <- GHC.IORef.newIORef (TH_recursiveDoImport.SelfRef r1_0)};
+    GHC.IORef.readIORef r2_1}
+True
+mdo {rec {r1_0 <- GHC.Base.return r2_1;
+          r2_1 <- GHC.Base.return (GHC.Base.const 1 r1_0)};
+     GHC.Base.return r1_0}
diff --git a/testsuite/tests/th/TH_recursiveDoImport.hs b/testsuite/tests/th/TH_recursiveDoImport.hs
new file mode 100644
index 0000000000..519987863f
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDoImport.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE RecursiveDo #-}
+module TH_recursiveDoImport where
+import Data.IORef
+import Language.Haskell.TH
+
+data SelfRef = SelfRef (IORef (IORef SelfRef))
+
+recIO :: ExpQ
+recIO = [e|
+    do rec r1 <- newIORef r2
+           r2 <- newIORef (SelfRef r1)
+       readIORef r2 |]
+
+mdoIO :: ExpQ
+mdoIO = [e|
+    mdo r1 <- return r2
+        r2 <- return (const 1 r1)
+        return r1 |]
+
+emptyRecIO :: ExpQ
+emptyRecIO = [e|
+   do rec {}
+      return () |]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index cf9153e43d..9a25591937 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -429,3 +429,8 @@ test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_implicitParams', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr1', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr2', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])