TTG3 Combined Step 1 and 3 for Trees That Grow
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 12 Nov 2017 19:56:16 +0000 (21:56 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Tue, 14 Nov 2017 21:14:49 +0000 (23:14 +0200)
Further progress on implementing Trees that Grow on hsSyn AST.

See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

Trees that grow extension points are added for
  - Rest of HsExpr.hs

Updates haddock submodule

Test Plan: ./validate

Reviewers: bgamari, shayan-najd, goldfire

Subscribers: goldfire, rwbarton, thomie, mpickering

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

35 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.hs
compiler/deSugar/PmExpr.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExtension.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyDecls.hs
testsuite/tests/ghc-api/annotations/parseTree.hs
testsuite/tests/perf/haddock/all.T
utils/haddock

index 44d9591..5bdff0f 100644 (file)
@@ -640,9 +640,10 @@ addTickHsExpr (HsWrap x w e) =
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
 addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
-                                      ; return (L l (Present e')) }
+addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
+                                      ; return (L l (Present e')) }
 addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg"
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                   -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
@@ -778,11 +779,12 @@ addTickApplicativeArg isGuard (op, arg) =
 
 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                       -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
-    liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
         (addTickLStmts isGuard stmts)
         (return ids)
         (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
 
 addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
 addTickHsLocalBinds (HsValBinds binds) =
@@ -828,12 +830,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
 addTickLPat pat = return pat
 
 addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
-        liftM4 HsCmdTop
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
                 (addTickLHsCmd cmd)
-                (return tys)
-                (return ty)
-                (return syntaxtable)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
 
 addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
 addTickLHsCmd (L pos c0) = do
@@ -841,10 +842,10 @@ addTickLHsCmd (L pos c0) = do
         return $ L pos c1
 
 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam matchgroup) =
-        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp c e) =
-        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
 {-
 addTickHsCmd (OpApp e1 c2 fix c3) =
         liftM4 OpApp
@@ -853,41 +854,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
                 (return fix)
                 (addTickLHsCmd c3)
 -}
-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
-        liftM2 HsCmdCase
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase e mgs) =
+        liftM2 (HsCmdCase x)
                 (addTickLHsExpr e)
                 (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
-        liftM3 (HsCmdIf cnd)
+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
+        liftM3 (HsCmdIf cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsCmd c2)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet (L l binds) c) =
+addTickHsCmd (HsCmdLet (L l binds) c) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsCmdLet . L l)
+          liftM2 (HsCmdLet . L l)
                    (addTickHsLocalBinds binds) -- to think about: !patterns.
                    (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo (L l stmts') srcloc) }
+       ; return (HsCmdDo srcloc (L l stmts')) }
 
-addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
         liftM5 HsCmdArrApp
+               (return arr_ty)
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (return ty1)
-               (return arr_ty)
                (return lr)
-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
-        liftM4 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
                (addTickLHsExpr e)
                (return f)
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
-addTickHsCmd (HsCmdWrap w cmd)
-  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap x w cmd)
+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
 
 -- Others should never happen in a command context.
 --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
index c9c0a08..61dc7c5 100644 (file)
@@ -313,7 +313,7 @@ dsProcExpr
         :: LPat GhcTc
         -> LHsCmdTop GhcTc
         -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
     (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
@@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
                     (Lam var match_code)
                     core_cmd
     return (mkLets meth_binds proc_code)
+dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
 
 {-
 Translation of a command judgement of the form
@@ -363,7 +364,7 @@ dsCmd   :: DsCmdEnv             -- arrow combinators
 --              ---> premap (\ ((xs), _stk) -> arg) fun
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty
 --              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
     let
         arg_ty = exprType core_arg
@@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats  = pats
+        (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats  = pats
                                                   , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
         env_ids = do
     let pat_vars = mkVarSet (collectPatsBinders pats)
@@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty
     return (do_premap ids in_ty in_ty' res_ty select_code core_body,
             free_vars `udfmMinusUFM` getUniqSet pat_vars)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
 
 -- D, xs |- e :: Bool
@@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
 --                       if e then Left ((xs1),stk) else Right ((xs2),stk))
 --                     (c1 ||| c2)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         env_ids = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
@@ -553,8 +554,8 @@ case bodies, containing the following fields:
 -}
 
 dsCmd ids local_vars stack_ty res_ty
-      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
-                         , mg_origin = origin }))
+      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
+                           , mg_origin = origin }))
       env_ids = do
     stack_id <- newSysLocalDs stack_ty
 
@@ -616,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+                                                                    env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
@@ -641,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
 --
 --              ---> premap (\ (env,stk) -> env) c
 
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+                                                                   env_ids = do
     putSrcSpanDs loc $
       dsNoLevPoly stmts_ty
         (text "In the do-command:" <+> ppr do_block)
@@ -661,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e
 -- -----------------------------------
 -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionDVarSets fv_sets)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
     core_wrap <- dsHsWrapper wrap
     return (core_wrap core_cmd, env_ids')
@@ -685,7 +688,8 @@ dsTrimCmdArg
         -> LHsCmdTop GhcTc       -- command argument to desugar
         -> DsM (CoreExpr,       -- desugared expression
                 DIdSet)         -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
+dsTrimCmdArg local_vars env_ids
+                       (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
     stack_id <- newSysLocalDs stack_ty
@@ -696,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
         arg_code = if env_ids' == env_ids then core_cmd else
                 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
     return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
 
 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
index 42c8455..bba301c 100644 (file)
@@ -369,11 +369,12 @@ ds_expr _ (ExplicitTuple _ tup_args boxity)
                     -- another lambda in the desugaring.
                = do { lam_var <- newSysLocalDsNoLP ty
                     ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (L _ (Present expr))
+             go (lam_vars, args) (L _ (Present expr))
                     -- Expressions that are present don't generate
                     -- lambdas, just arguments.
                = do { core_expr <- dsLExprNoLP expr
                     ; return (lam_vars, core_expr : args) }
+             go _ (L _ (XTupArg {})) = panic "ds_expr"
 
        ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
index fea637f..860c1ba 100644 (file)
@@ -82,7 +82,7 @@ dsListComp lquals res_ty = do
 -- of that comprehension that we need in the outer comprehension into such an expression
 -- and the type of the elements that it outputs (tuples of binders)
 dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock stmts bndrs _)
+dsInnerListComp (ParStmtBlock stmts bndrs _)
   = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
              list_ty          = mkListTy bndrs_tuple_type
 
@@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
        ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
 
        ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
 
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
         to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
 
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+                                                        from_bndrs noSyntaxExpr)
 
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
@@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
        ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
                     quals list }
   where
-        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
 
         -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
         pat  = mkBigLHsPatTupId pats
@@ -623,13 +625,15 @@ dePArrParComp qss quals = do
     deParStmt []             =
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
-    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
+    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
       let res_expr = mkLHsVarTuple xs
       cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
       parStmts qss (mkLHsVarPatTup xs) cqs
+    deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp"
     ---
     parStmts []             pa cea = return (pa, cea)
-    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)
+    parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do
+                                              -- subsequent statements (zip'ed)
       zipP <- dsDPHBuiltin zipPVar
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
@@ -638,6 +642,7 @@ dePArrParComp qss quals = do
       let ty'cqs = parrElemType cqs
           cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
       parStmts qss pa' cea'
+    parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp"
 
 -- generate Core corresponding to `\p -> e'
 --
@@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
        ; mzip_op'    <- dsExpr mzip_op
 
        ; let -- The pattern variables
-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
              -- Pattern with tuples of variables
              -- [v1,v2,v3]  =>  (v1, (v2, v3))
              pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
 
        ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
   where
-    ds_inner (ParStmtBlock stmts bndrs return_op)
+    ds_inner (ParStmtBlock stmts bndrs return_op)
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
             ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
 
 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 
index 10bb241..c910fbf 100644 (file)
@@ -77,13 +77,14 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
 
-    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
-    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
 
 {- -------------- Examples --------------------
 
@@ -1099,10 +1100,11 @@ repRole (L _ Nothing)                 = rep2 inferRName []
 repSplice :: HsSplice GhcRn -> DsM (Core a)
 -- See Note [How brackets and nested splices are handled] in TcSplice
 -- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice   _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ n _) = rep_splice n
-repSplice (HsQuasiQuote n _ _ _)  = rep_splice n
-repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)
 
 rep_splice :: Name -> DsM (Core a)
 rep_splice splice_name
@@ -1207,9 +1209,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple _ es boxed)
   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
-  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
-                        ; repUnboxedTup xs }
+  | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+                       ; repUnboxedTup xs }
 
 repE (ExplicitSum _ alt arity e)
  = do { e1 <- repLE e
@@ -1384,10 +1386,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
    where
      rep_stmt_block :: ParStmtBlock GhcRn GhcRn
                     -> DsM ([GenSymBind], Core [TH.StmtQ])
-     rep_stmt_block (ParStmtBlock stmts _ _) =
+     rep_stmt_block (ParStmtBlock stmts _ _) =
        do { (ss1, zs) <- repSts (map unLoc stmts)
           ; zs1 <- coreList stmtQTyConName zs
           ; return (ss1, zs1) }
+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"
 repSts [LastStmt e _ _]
   = do { e2 <- repLE e
        ; z <- repNoBindSt e2
index e95ac2f..4cb8bf3 100644 (file)
@@ -1031,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         wrap res_wrap1 res_wrap2
 
     ---------
-    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
-    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
index 437732d..f008a31 100644 (file)
@@ -252,7 +252,7 @@ hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
   | otherwise            = PmExprOther e
   where
     tuple_con  = tupleDataCon boxity (length ps)
-    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
 
 hsExprToPmExpr e@(ExplicitList _  mb_ol elems)
   | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
index c64ea53..f20abab 100644 (file)
@@ -214,7 +214,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                         , tcdFixity = Prefix
                                         , tcdDataDefn = defn
-                                        , tcdDataCusk = PlaceHolder
+                                        , tcdDataCusk = placeHolder
                                         , tcdFVs = placeHolderNames }) }
 
 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
@@ -230,7 +230,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                     , tcdFixity = Prefix
                                     , tcdDataDefn = defn
-                                    , tcdDataCusk = PlaceHolder
+                                    , tcdDataCusk = placeHolder
                                     , tcdFVs = placeHolderNames }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
@@ -805,10 +805,12 @@ cvtl e = wrapL (cvt e)
                                  -- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es
                             ; return $ ExplicitTuple noExt
-                                             (map (noLoc . Present) es') Boxed }
+                                             (map (noLoc . (Present noExt)) es')
+                                                                         Boxed }
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
                                    ; return $ ExplicitTuple noExt
-                                           (map (noLoc . Present) es') Unboxed }
+                                           (map (noLoc . (Present noExt)) es')
+                                                                       Unboxed }
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                        ; unboxedSumChecks alt arity
                                        ; return $ ExplicitSum noExt
@@ -1000,8 +1002,9 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
                             ; returnL $ LetStmt (noLoc ds') }
 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
-                       where
-                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
+  where
+    cvt_one ds = do { ds' <- cvtStmts ds
+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
 
 cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -1124,7 +1127,7 @@ cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
 cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
                             ; return $ AsPat noExt s' p' }
-cvtp TH.WildP          = return $ WildPat placeHolderType
+cvtp TH.WildP          = return $ WildPat noExt
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
                             ; return $ ConPatIn c'
                                      $ Hs.RecCon (HsRecFields fs' Nothing) }
index 9a106e3..10e1307 100644 (file)
@@ -123,47 +123,13 @@ deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR)
 -- ---------------------------------------------------------------------
 -- Deal with ValBindsOut
 
+-- TODO: make this the only type for ValBinds
 data NHsValBindsLR idL
   = NValBinds
       [(RecFlag, LHsBinds idL)]
       [LSig GhcRn]
 deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL)
 
-{-
--- The ValBindsIn pattern exists so we can use the COMPLETE pragma for these
--- patterns
-pattern
-  ValBindsIn ::
-    (XValBinds idL idR) ->
-    (LHsBindsLR idL idR) ->
-    [LSig idR] ->
-    HsValBindsLR idL idR
-pattern
-  ValBindsOut ::
-    [(RecFlag, LHsBinds idL)] ->
-    [LSig GhcRn] ->
-    HsValBindsLR idL idR
-
-pattern
-  ValBindsIn x b s
-    = ValBinds  x b s
-pattern
-  ValBindsOut a b
-    = XValBindsLR (NValBindsOut a b)
-
-{-#
-  COMPLETE
-    ValBindsIn,
-    ValBindsOut
-  #-}
--}
-
--- This is not extensible using the parameterised GhcPass namespace
--- type instance
---   XValBinds      (GhcPass pass) (GhcPass pass') = NoFieldExt
--- type instance
---   XNewValBindsLR (GhcPass pass) (GhcPass pass')
---     = NewHsValBindsLR  (GhcPass pass) (GhcPass pass')
 type instance XValBinds    (GhcPass pL) (GhcPass pR) = PlaceHolder
 type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
             = NHsValBindsLR (GhcPass pL)
index 3641e27..9e05a3d 100644 (file)
@@ -101,7 +101,7 @@ import Name
 import BasicTypes
 import Coercion
 import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
 import HsExtension
 import NameSet
 
@@ -1725,10 +1725,10 @@ deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
 -}
 
 noForeignImportCoercionYet :: PlaceHolder
-noForeignImportCoercionYet = PlaceHolder
+noForeignImportCoercionYet = placeHolder
 
 noForeignExportCoercionYet :: PlaceHolder
-noForeignExportCoercionYet = PlaceHolder
+noForeignExportCoercionYet = placeHolder
 
 -- Specification Of an imported external entity in dependence on the calling
 -- convention
index 6fd4d0e..6b3440a 100644 (file)
@@ -744,7 +744,6 @@ data RecordUpdTc = RecordUpdTc
       } deriving Data
 
 -- ---------------------------------------------------------------------
-type instance XVarPat  (GhcPass _) = PlaceHolder
 
 type instance XVar           (GhcPass _) = PlaceHolder
 type instance XUnboundVar    (GhcPass _) = PlaceHolder
@@ -861,13 +860,23 @@ type LHsTupArg id = Located (HsTupArg id)
 
 -- | Haskell Tuple Argument
 data HsTupArg id
-  = Present (LHsExpr id)     -- ^ The argument
-  | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
+  = Present (XPresent id) (LHsExpr id)     -- ^ The argument
+  | Missing (XMissing id)    -- ^ The argument is missing, but this is its type
+  | XTupArg (XXTupArg id)    -- ^ Note [Trees that Grow] extension point
 deriving instance (DataIdLR id id) => Data (HsTupArg id)
 
+type instance XPresent         (GhcPass _) = PlaceHolder
+
+type instance XMissing         GhcPs = PlaceHolder
+type instance XMissing         GhcRn = PlaceHolder
+type instance XMissing         GhcTc = Type
+
+type instance XXTupArg         (GhcPass _) = PlaceHolder
+
 tupArgPresent :: LHsTupArg id -> Bool
 tupArgPresent (L _ (Present {})) = True
 tupArgPresent (L _ (Missing {})) = False
+tupArgPresent (L _ (XTupArg {})) = False
 
 {-
 Note [Parens in HsSyn]
@@ -1054,11 +1063,13 @@ ppr_expr (ExplicitTuple _ exprs boxity)
   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
   where
     ppr_tup_args []               = []
-    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
-    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es
+    ppr_tup_args (XTupArg x   : es) = (ppr x <> punc es) : ppr_tup_args es
 
     punc (Present {} : _) = comma <> space
     punc (Missing {} : _) = comma
+    punc (XTupArg {} : _) = comma <> space
     punc []               = empty
 
 ppr_expr (ExplicitSum _ alt arity expr)
@@ -1149,8 +1160,10 @@ ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
 ppr_expr (HsTcBracketOut _ e []) = ppr e
 ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
 
-ppr_expr (HsProc _ pat (L _ (HsCmdTop cmd _ _ _)))
+ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
   = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
+  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
 
 ppr_expr (HsStatic _ e)
   = hsep [text "static", ppr e]
@@ -1317,10 +1330,10 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
+        (XCmdArrApp id)  -- type of the arrow expressions f,
+                         -- of the form a t t', where arg :: t
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
-        (PostTc id Type) -- type of the arrow expressions f,
-                         -- of the form a t t', where arg :: t
         HsArrAppType     -- higher-order (-<<) or first-order (-<)
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
@@ -1330,6 +1343,7 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
+        (XCmdArrForm id)
         (LHsExpr id)     -- The operator.
                          -- After type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
@@ -1339,22 +1353,26 @@ data HsCmd id
                          -- were converted from OpApp's by the renamer
         [LHsCmdTop id]   -- argument commands
 
-  | HsCmdApp    (LHsCmd id)
+  | HsCmdApp    (XCmdApp id)
+                (LHsCmd id)
                 (LHsExpr id)
 
-  | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
+  | HsCmdLam    (XCmdLam id)
+                (MatchGroup id (LHsCmd id))     -- kappa
        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --       'ApiAnnotation.AnnRarrow',
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdPar    (LHsCmd id)                     -- parenthesised command
+  | HsCmdPar    (XCmdPar id)
+                (LHsCmd id)                     -- parenthesised command
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
     --             'ApiAnnotation.AnnClose' @')'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdCase   (LHsExpr id)
+  | HsCmdCase   (XCmdCase id)
+                (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
     --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
@@ -1362,7 +1380,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
+  | HsCmdIf     (XCmdIf id)
+                (Maybe (SyntaxExpr id))         -- cond function
                 (LHsExpr id)                    -- predicate
                 (LHsCmd id)                     -- then part
                 (LHsCmd id)                     -- else part
@@ -1373,7 +1392,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdLet    (LHsLocalBinds id)      -- let(rec)
+  | HsCmdLet    (XCmdLet id)
+                (LHsLocalBinds id)      -- let(rec)
                 (LHsCmd  id)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
     --       'ApiAnnotation.AnnOpen' @'{'@,
@@ -1381,8 +1401,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdDo     (Located [CmdLStmt id])
-                (PostTc id Type)                -- Type of the whole expression
+  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression
+                (Located [CmdLStmt id])
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
     --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
     --             'ApiAnnotation.AnnVbar',
@@ -1390,12 +1410,33 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdWrap   HsWrapper
+  | HsCmdWrap   (XCmdWrap id)
+                HsWrapper
                 (HsCmd id)     -- If   cmd :: arg1 --> res
                                --      wrap :: arg1 "->" arg2
                                -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
+  | XCmd        (XXCmd id)     -- Note [Trees that Grow] extension point
 deriving instance (DataIdLR id id) => Data (HsCmd id)
 
+type instance XCmdArrApp  GhcPs = PlaceHolder
+type instance XCmdArrApp  GhcRn = PlaceHolder
+type instance XCmdArrApp  GhcTc = Type
+
+type instance XCmdArrForm (GhcPass _) = PlaceHolder
+type instance XCmdApp     (GhcPass _) = PlaceHolder
+type instance XCmdLam     (GhcPass _) = PlaceHolder
+type instance XCmdPar     (GhcPass _) = PlaceHolder
+type instance XCmdCase    (GhcPass _) = PlaceHolder
+type instance XCmdIf      (GhcPass _) = PlaceHolder
+type instance XCmdLet     (GhcPass _) = PlaceHolder
+
+type instance XCmdDo      GhcPs = PlaceHolder
+type instance XCmdDo      GhcRn = PlaceHolder
+type instance XCmdDo      GhcTc = Type
+
+type instance XCmdWrap    (GhcPass _) = PlaceHolder
+type instance XXCmd       (GhcPass _) = PlaceHolder
+
 -- | Haskell Array Application Type
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
   deriving Data
@@ -1411,12 +1452,23 @@ type LHsCmdTop p = Located (HsCmdTop p)
 
 -- | Haskell Top-level Command
 data HsCmdTop p
-  = HsCmdTop (LHsCmd p)
-             (PostTc p Type)    -- Nested tuple of inputs on the command's stack
-             (PostTc p Type)    -- return type of the command
-             (CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
+  = HsCmdTop (XCmdTop p)
+             (LHsCmd p)
+  | XCmdTop (XXCmdTop p)        -- Note [Trees that Grow] extension point
 deriving instance (DataIdLR p p) => Data (HsCmdTop p)
 
+data CmdTopTc
+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack
+             Type    -- return type of the command
+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
+  deriving Data
+
+type instance XCmdTop  GhcPs = PlaceHolder
+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
+type instance XCmdTop  GhcTc = CmdTopTc
+
+type instance XXCmdTop (GhcPass _) = PlaceHolder
+
 instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
        => Outputable (HsCmd (GhcPass p)) where
     ppr cmd = pprCmd cmd
@@ -1437,9 +1489,9 @@ isQuietHsCmd :: HsCmd id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsCmd (HsCmdPar _) = True
+isQuietHsCmd (HsCmdPar {}) = True
 -- applications don't display anything themselves
-isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd (HsCmdApp {}) = True
 isQuietHsCmd _ = False
 
 -----------------------
@@ -1449,70 +1501,72 @@ ppr_lcmd c = ppr_cmd (unLoc c)
 
 ppr_cmd :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
         => HsCmd (GhcPass p) -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
 
-ppr_cmd (HsCmdApp c e)
+ppr_cmd (HsCmdApp c e)
   = let (fun, args) = collect_args c [e] in
     hang (ppr_lcmd fun) 2 (sep (map ppr args))
   where
-    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
     collect_args fun args = (fun, args)
 
-ppr_cmd (HsCmdLam matches)
+ppr_cmd (HsCmdLam matches)
   = pprMatches matches
 
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_cmd (HsCmdIf _ e ct ce)
+ppr_cmd (HsCmdIf _ e ct ce)
   = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
          nest 4 (ppr ct),
          text "else",
          nest 4 (ppr ce)]
 
 -- special case: let ... in let ...
-ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
   = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
          ppr_lcmd cmd]
 
-ppr_cmd (HsCmdLet (L _ binds) cmd)
+ppr_cmd (HsCmdLet (L _ binds) cmd)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr cmd)]
 
-ppr_cmd (HsCmdDo (L _ stmts) _)  = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts
 
-ppr_cmd (HsCmdWrap w cmd)
+ppr_cmd (HsCmdWrap w cmd)
   = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm op _ _ args)
+ppr_cmd (HsCmdArrForm  _ op _ _ args)
   = hang (text "(|" <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+ppr_cmd (XCmd x) = ppr x
 
 pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
           => HsCmdTop (GhcPass p) -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg (HsCmdTop _ cmd)
   = ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
 
 instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
        => Outputable (HsCmdTop (GhcPass p)) where
@@ -1551,6 +1605,7 @@ a function defined by pattern matching must have the same number of
 patterns in each equation.
 -}
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 data MatchGroup p body
   = MG { mg_alts    :: Located [LMatch p body]  -- The alternatives
        , mg_arg_tys :: [PostTc p Type]  -- Types of the arguments, t1..tn
@@ -1566,6 +1621,7 @@ type LMatch id body = Located (Match id body)
 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 --   list
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Match p body
   = Match {
@@ -1654,6 +1710,7 @@ hsLMatchPats (L _ (Match { m_pats = pats })) = pats
 --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 --        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- For details on above see note [Api annotations] in ApiAnnotation
 data GRHSs p body
   = GRHSs {
@@ -1665,6 +1722,7 @@ deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body)
 -- | Located Guarded Right-Hand Side
 type LGRHS id body = Located (GRHS id body)
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- | Guarded Right Hand Side.
 data GRHS id body = GRHS [GuardLStmt id] -- Guards
                          body            -- Right hand side
@@ -1937,11 +1995,16 @@ data TransForm   -- The 'f' below is the 'using' function, 'e' is the by functio
 -- | Parenthesised Statement Block
 data ParStmtBlock idL idR
   = ParStmtBlock
+        (XParStmtBlock idL idR)
         [ExprLStmt idL]
         [IdP idR]          -- The variables to be returned
         (SyntaxExpr idR)   -- The return operator
+  | XParStmtBlock (XXParStmtBlock idL idR)
 deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR)
 
+type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
+
 -- | Applicative Argument
 data ApplicativeArg idL
   = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
@@ -2122,9 +2185,11 @@ Bool flag that is True when the original statement was a BodyStmt, so
 that we can pretty-print it correctly.
 -}
 
-instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL))
+instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL),
+          Outputable (XXParStmtBlock (GhcPass idL) idR))
        => Outputable (ParStmtBlock (GhcPass idL) idR) where
-  ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+  ppr (XParStmtBlock x) = ppr x
 
 instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR),
           OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
@@ -2277,31 +2342,45 @@ pprQuals quals = interpp'SP quals
 -- | Haskell Splice
 data HsSplice id
    = HsTypedSplice       --  $$z  or $$(f 4)
+        (XTypedSplice id)
         SpliceDecoration -- Whether $$( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsUntypedSplice     --  $z  or $(f 4)
+        (XUntypedSplice id)
         SpliceDecoration -- Whether $( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsQuasiQuote        -- See Note [Quasi-quote overview] in TcSplice
+        (XQuasiQuote id)
         (IdP id)         -- Splice point
         (IdP id)         -- Quoter
         SrcSpan          -- The span of the enclosed string
         FastString       -- The enclosed string
 
+   -- AZ:TODO: use XSplice instead of HsSpliced
    | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in
                 -- RnSplice.
                 -- This is the result of splicing a splice. It is produced by
                 -- the renamer and consumed by the typechecker. It lives only
                 -- between the two.
+        (XSpliced id)
         ThModFinalizers     -- TH finalizers produced by the splice.
         (HsSplicedThing id) -- The result of splicing
+   | XSplice (XXSplice id)  -- Note [Trees that Grow] extension point
   deriving Typeable
 deriving instance (DataIdLR id id) => Data (HsSplice id)
 
+
+type instance XTypedSplice   (GhcPass _) = PlaceHolder
+type instance XUntypedSplice (GhcPass _) = PlaceHolder
+type instance XQuasiQuote    (GhcPass _) = PlaceHolder
+type instance XSpliced       (GhcPass _) = PlaceHolder
+type instance XXSplice       (GhcPass _) = PlaceHolder
+
+
 -- | A splice can appear with various decorations wrapped around it. This data
 -- type captures explicitly how it was originally written, for use in the pretty
 -- printer.
@@ -2452,25 +2531,26 @@ pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e
 
 ppr_splice_decl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
                 => HsSplice (GhcPass p) -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
 ppr_splice_decl e = pprSplice e
 
 pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
           => HsSplice (GhcPass p) -> SDoc
-pprSplice (HsTypedSplice HasParens  n e)
+pprSplice (HsTypedSplice HasParens  n e)
   = ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice HasDollar n e)
+pprSplice (HsTypedSplice HasDollar n e)
   = ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice NoParens n e)
+pprSplice (HsTypedSplice NoParens n e)
   = ppr_splice empty n e empty
-pprSplice (HsUntypedSplice HasParens  n e)
+pprSplice (HsUntypedSplice HasParens  n e)
   = ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice HasDollar n e)
+pprSplice (HsUntypedSplice HasDollar n e)
   = ppr_splice (text "$")  n e empty
-pprSplice (HsUntypedSplice NoParens n e)
+pprSplice (HsUntypedSplice NoParens n e)
   = ppr_splice empty  n e empty
-pprSplice (HsQuasiQuote n q _ s)      = ppr_quasi n q s
-pprSplice (HsSpliced _ thing)         = ppr thing
+pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s
+pprSplice (HsSpliced _ _ thing)         = ppr thing
+pprSplice (XSplice x)                   = ppr x
 
 ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
 ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
@@ -2483,16 +2563,27 @@ ppr_splice herald n e trail
     = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
 
 -- | Haskell Bracket
-data HsBracket p = ExpBr (LHsExpr p)    -- [|  expr  |]
-                  | PatBr (LPat p)      -- [p| pat   |]
-                  | DecBrL [LHsDecl p]  -- [d| decls |]; result of parser
-                  | DecBrG (HsGroup p)  -- [d| decls |]; result of renamer
-                  | TypBr (LHsType p)   -- [t| type  |]
-                  | VarBr Bool (IdP p)  -- True: 'x, False: ''T
-                                 -- (The Bool flag is used only in pprHsBracket)
-                  | TExpBr (LHsExpr p)  -- [||  expr  ||]
+data HsBracket p
+  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]
+  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]
+  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser
+  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer
+  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]
+  | VarBr  (XVarBr p)   Bool (IdP p)  -- True: 'x, False: ''T
+                                -- (The Bool flag is used only in pprHsBracket)
+  | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]
+  | XBracket (XXBracket p)            -- Note [Trees that Grow] extension point
 deriving instance (DataIdLR p p) => Data (HsBracket p)
 
+type instance XExpBr      (GhcPass _) = PlaceHolder
+type instance XPatBr      (GhcPass _) = PlaceHolder
+type instance XDecBrL     (GhcPass _) = PlaceHolder
+type instance XDecBrG     (GhcPass _) = PlaceHolder
+type instance XTypBr      (GhcPass _) = PlaceHolder
+type instance XVarBr      (GhcPass _) = PlaceHolder
+type instance XTExpBr     (GhcPass _) = PlaceHolder
+type instance XXBracket   (GhcPass _) = PlaceHolder
+
 isTypedBracket :: HsBracket id -> Bool
 isTypedBracket (TExpBr {}) = True
 isTypedBracket _           = False
@@ -2504,16 +2595,17 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
 
 pprHsBracket :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
              => HsBracket (GhcPass p) -> SDoc
-pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
-pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
+pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr True n)
   = char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr False n)
   = text "''" <> pprPrefixOcc n
-pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
+pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)
+pprHsBracket (XBracket e)  = ppr e
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -2547,6 +2639,7 @@ data ArithSeqInfo id
                     (LHsExpr id)
                     (LHsExpr id)
 deriving instance (DataIdLR id id) => Data (ArithSeqInfo id)
+-- AZ: Sould ArithSeqInfo have a TTG extension?
 
 instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p))
          => Outputable (ArithSeqInfo (GhcPass p)) where
index fb689c5..86a0bd9 100644 (file)
@@ -149,7 +149,7 @@ type ForallXPat (c :: * -> Constraint) (x :: *) =
 type family XValBinds    x x'
 type family XXValBindsLR x x'
 
-type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)=
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
        ( c (XValBinds    x x')
        , c (XXValBindsLR x x')
        )
@@ -410,6 +410,104 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) =
        )
 -- ---------------------------------------------------------------------
 
+type family XPresent  x
+type family XMissing  x
+type family XXTupArg  x
+
+type ForallXTupArg (c :: * -> Constraint) (x :: *) =
+       ( c (XPresent x)
+       , c (XMissing x)
+       , c (XXTupArg x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XTypedSplice   x
+type family XUntypedSplice x
+type family XQuasiQuote    x
+type family XSpliced       x
+type family XXSplice       x
+
+type ForallXSplice (c :: * -> Constraint) (x :: *) =
+       ( c (XTypedSplice   x)
+       , c (XUntypedSplice x)
+       , c (XQuasiQuote    x)
+       , c (XSpliced       x)
+       , c (XXSplice       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XExpBr      x
+type family XPatBr      x
+type family XDecBrL     x
+type family XDecBrG     x
+type family XTypBr      x
+type family XVarBr      x
+type family XTExpBr     x
+type family XXBracket   x
+
+type ForallXBracket (c :: * -> Constraint) (x :: *) =
+       ( c (XExpBr      x)
+       , c (XPatBr      x)
+       , c (XDecBrL     x)
+       , c (XDecBrG     x)
+       , c (XTypBr      x)
+       , c (XVarBr      x)
+       , c (XTExpBr     x)
+       , c (XXBracket   x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdTop  x
+type family XXCmdTop x
+
+type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdTop  x)
+       , c (XXCmdTop x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdArrApp  x
+type family XCmdArrForm x
+type family XCmdApp     x
+type family XCmdLam     x
+type family XCmdPar     x
+type family XCmdCase    x
+type family XCmdIf      x
+type family XCmdLet     x
+type family XCmdDo      x
+type family XCmdWrap    x
+type family XXCmd       x
+
+type ForallXCmd (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdArrApp  x)
+       , c (XCmdArrForm x)
+       , c (XCmdApp     x)
+       , c (XCmdLam     x)
+       , c (XCmdPar     x)
+       , c (XCmdCase    x)
+       , c (XCmdIf      x)
+       , c (XCmdLet     x)
+       , c (XCmdDo      x)
+       , c (XCmdWrap    x)
+       , c (XXCmd       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XParStmtBlock  x x'
+type family XXParStmtBlock x x'
+
+type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XParStmtBlock  x x')
+       , c (XXParStmtBlock x x')
+       )
+
+-- ---------------------------------------------------------------------
+
 -- | The 'SourceText' fields have been moved into the extension fields, thus
 -- placing a requirement in the extension field to contain a 'SourceText' so
 -- that the pretty printing and round tripping of source can continue to
@@ -501,6 +599,8 @@ type OutputableX p =
 
   , Outputable (XAppTypeE p)
   , Outputable (XAppTypeE GhcRn)
+
+  -- , Outputable (XXParStmtBlock (GhcPass idL) idR)
   )
 -- TODO: Should OutputableX be included in OutputableBndrId?
 
@@ -513,12 +613,15 @@ type DataId p =
   , ForallXHsLit Data p
   , ForallXPat   Data p
 
-  -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut
-  -- , ForallXPat Data (GhcPass 'Parsed)
-  , ForallXPat Data (GhcPass 'Renamed)
-  -- , ForallXPat Data (GhcPass 'Typechecked)
-  , ForallXType Data (GhcPass 'Renamed)
-  , ForallXExpr Data (GhcPass 'Renamed)
+  -- Th following GhcRn constraints should go away once TTG is fully implemented
+  , ForallXPat     Data GhcRn
+  , ForallXType    Data GhcRn
+  , ForallXExpr    Data GhcRn
+  , ForallXTupArg  Data GhcRn
+  , ForallXSplice  Data GhcRn
+  , ForallXBracket Data GhcRn
+  , ForallXCmdTop  Data GhcRn
+  , ForallXCmd     Data GhcRn
 
   , ForallXOverLit           Data p
   , ForallXType              Data p
@@ -527,7 +630,12 @@ type DataId p =
   , ForallXFieldOcc          Data p
   , ForallXAmbiguousFieldOcc Data p
 
-  , ForallXExpr Data p
+  , ForallXExpr    Data p
+  , ForallXTupArg  Data p
+  , ForallXSplice  Data p
+  , ForallXBracket Data p
+  , ForallXCmdTop  Data p
+  , ForallXCmd     Data p
 
   , Data (NameOrRdrName (IdP p))
 
@@ -554,6 +662,11 @@ type DataIdLR pL pR =
   , ForallXValBindsLR Data pL pR
   , ForallXValBindsLR Data pL pL
   , ForallXValBindsLR Data pR pR
+
+  , ForallXParStmtBlock Data pL pR
+  , ForallXParStmtBlock Data pL pL
+  , ForallXParStmtBlock Data pR pR
+  , ForallXParStmtBlock Data GhcRn GhcRn
   )
 
 -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
index 71f932c..863f00c 100644 (file)
@@ -602,7 +602,7 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 mkCharLitPat :: (SourceTextX (GhcPass p))
              => SourceText -> Char -> OutPat (GhcPass p)
 mkCharLitPat src c = mkPrefixConPat charDataCon
-                      [noLoc $ LitPat PlaceHolder
+                      [noLoc $ LitPat noExt
                                       (HsCharPrim (setSourceText src) c)]
                       []
 
index d9c1b46..be70fe8 100644 (file)
@@ -74,7 +74,7 @@ import GhcPrelude
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
 import HsExtension
 import HsLit () -- for instances
 
@@ -275,8 +275,8 @@ data LHsQTyVars pass   -- See Note [HsType binders]
 deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass)
 
 mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
-mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
-                      , hsq_dependent = PlaceHolder }
+mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs
+                      , hsq_dependent = placeHolder }
 
 hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
 hsQTvExplicit = hsq_explicit
@@ -366,12 +366,12 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
 
 mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
 mkHsImplicitBndrs x = HsIB { hsib_body   = x
-                           , hsib_vars   = PlaceHolder
-                           , hsib_closed = PlaceHolder }
+                           , hsib_vars   = placeHolder
+                           , hsib_closed = placeHolder }
 
 mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
 mkHsWildCardBndrs x = HsWC { hswc_body = x
-                           , hswc_wcs  = PlaceHolder }
+                           , hswc_wcs  = placeHolder }
 
 -- Add empty binders.  This is a bit suspicious; what if
 -- the wrapped thing had free type variables?
@@ -1223,7 +1223,7 @@ instance Outputable (FieldOcc pass) where
   ppr = ppr . rdrNameFieldOcc
 
 mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc PlaceHolder rdr
+mkFieldOcc rdr = FieldOcc placeHolder rdr
 
 
 -- | Ambiguous Field Occurrence
index edd5da6..e5f0fb6 100644 (file)
@@ -50,7 +50,7 @@ module HsUtils(
   -- Patterns
   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
-  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
+  nlWildPatName, nlTuplePat, mkParPat, nlParPat,
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
   -- Types
@@ -219,7 +219,7 @@ mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le)
                       | otherwise           = le
 
 mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
-mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat PlaceHolder lp)
+mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp)
                       | otherwise          = lp
 
 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
@@ -263,7 +263,7 @@ mkHsFractional   f  = OverLit noExt (HsFractional     f) noExpr
 mkHsIsString src s  = OverLit noExt (HsIsString   src s) noExpr
 
 noRebindableInfo :: PlaceHolder
-noRebindableInfo = PlaceHolder -- Just another placeholder;
+noRebindableInfo = placeHolder -- Just another placeholder;
 
 mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
@@ -305,7 +305,7 @@ emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
                            , trS_stmts = [], trS_bndrs = []
                            , trS_by = Nothing, trS_using = noLoc noExpr
                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
-                           , trS_bind_arg_ty = PlaceHolder
+                           , trS_bind_arg_ty = placeHolder
                            , trS_fmap = noExpr }
 mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
 mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
@@ -314,7 +314,7 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
 
 mkLastStmt body     = LastStmt body False noSyntaxExpr
 mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
-mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
+mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr placeHolder
 mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
   -- don't use placeHolderTypeTc above, because that panics during zonking
 
@@ -345,21 +345,22 @@ unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 
 mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
-mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
+mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
 
 mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
 mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e)
 
 mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
 mkHsSpliceTE hasParen e
-  = HsSpliceE noExt (HsTypedSplice hasParen unqualSplice e)
+  = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e)
 
 mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
 mkHsSpliceTy hasParen e = HsSpliceTy noExt
-                      (HsUntypedSplice hasParen unqualSplice e)
+                      (HsUntypedSplice noExt hasParen unqualSplice e)
 
 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
-mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
+mkHsQuasiQuote quoter span quote
+  = HsQuasiQuote noExt unqualSplice quoter span quote
 
 unqualQuasiQuote :: RdrName
 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
@@ -461,13 +462,10 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                              nlWildPat)))
 
 nlWildPat :: LPat GhcPs
-nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
+nlWildPat  = noLoc (WildPat noExt )  -- Pre-typechecking
 
 nlWildPatName :: LPat GhcRn
-nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
-
-nlWildPatId :: LPat GhcTc
-nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking
+nlWildPatName  = noLoc (WildPat noExt )  -- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
        -> LHsExpr GhcPs
@@ -517,7 +515,8 @@ types on the tuple.
 mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 mkLHsTupleExpr [e] = e
-mkLHsTupleExpr es = noLoc $ ExplicitTuple noExt (map (noLoc . Present) es) Boxed
+mkLHsTupleExpr es
+  = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
 
 mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
@@ -526,7 +525,7 @@ nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
 nlTuplePat pats box = noLoc (TuplePat noExt pats box)
 
 missingTupArg :: HsTupArg GhcPs
-missingTupArg = Missing placeHolderType
+missingTupArg = Missing noExt
 
 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
 mkLHsPatTup []     = noLoc $ TuplePat noExt [] Boxed
@@ -704,11 +703,11 @@ mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
 mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
 
-mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
+mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
-                  | otherwise       = HsCmdWrap w cmd
+                  | otherwise       = HsCmdWrap noExt w cmd
 
-mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
+mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
 
 mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
@@ -964,8 +963,8 @@ collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
 collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
 collectStmtBinders (BodyStmt {})         = []
 collectStmtBinders (LastStmt {})         = []
-collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
-                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+collectStmtBinders (ParStmt xs _ _ _)  = collectLStmtsBinders
+                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
 collectStmtBinders ApplicativeStmt{} = []
@@ -1005,7 +1004,7 @@ collect_lpat (L _ pat) bndrs
 
     go (SigPat _ pat)               = collect_lpat pat bndrs
 
-    go (SplicePat _ (HsSpliced _ (HsSplicedPat pat)))
+    go (SplicePat _ (HsSpliced _ (HsSplicedPat pat)))
                                   = go pat
     go (SplicePat _ _)            = bndrs
     go (CoPat _ _ pat _)          = go pat
@@ -1236,7 +1235,8 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (LetStmt binds)      = hs_local_binds (unLoc binds)
     hs_stmt (BodyStmt {})        = emptyNameSet
     hs_stmt (LastStmt {})        = emptyNameSet
-    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
+                                                , s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
 
index 19b4af0..9d99c9a 100644 (file)
@@ -8,7 +8,6 @@ module PlaceHolder where
 
 import GhcPrelude ( Eq(..), Ord(..) )
 
-import Type       ( Type )
 import Outputable hiding ( (<>) )
 import Name
 import NameSet
@@ -36,21 +35,18 @@ data PlaceHolder = PlaceHolder
 instance Outputable PlaceHolder where
   ppr _ = text "PlaceHolder"
 
+placeHolder :: PlaceHolder
+placeHolder = PlaceHolder
+
 placeHolderType :: PlaceHolder
 placeHolderType = PlaceHolder
 
-placeHolderTypeTc :: Type
-placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"
-
 placeHolderNames :: PlaceHolder
 placeHolderNames = PlaceHolder
 
 placeHolderNamesTc :: NameSet
 placeHolderNamesTc = emptyNameSet
 
-placeHolderHsWrapper :: PlaceHolder
-placeHolderHsWrapper = PlaceHolder
-
 {-
 
 Note [Pass sensitive types]
index 2fa9434..51ce863 100644 (file)
@@ -2430,8 +2430,7 @@ exp10_top :: { LHsExpr GhcPs }
         | 'proc' aexp '->' exp
                        {% checkPattern empty $2 >>= \ p ->
                            checkCommand $4 >>= \ cmd ->
-                           ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop cmd placeHolderType
-                                                placeHolderType []))
+                           ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
                                             -- TODO: is LL right here?
                                [mj AnnProc $1,mu AnnRarrow $3] }
 
@@ -2530,7 +2529,7 @@ aexp2   :: { LHsExpr GhcPs }
                                               ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
 
         | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
-                                                         (Present $2)] Unboxed))
+                                                         (Present noExt $2)] Unboxed))
                                                [mo $1,mc $3] }
         | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
                                               ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
@@ -2542,20 +2541,20 @@ aexp2   :: { LHsExpr GhcPs }
         -- Template Haskell Extension
         | splice_exp            { $1 }
 
-        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket noExt (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
-        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket noExt (ExpBr $2))
+        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
                                                     else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
-        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket noExt (TExpBr $2))
+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
-        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket noExt (TypBr $2)) [mo $1,mu AnnCloseQ $3] }
+        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
-                                      ams (sLL $1 $> $ HsBracket noExt (PatBr p))
+                                      ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
                                           [mo $1,mu AnnCloseQ $3] }
-        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL (snd $2)))
+        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
                                       (mo $1:mu AnnCloseQ $3:fst $2) }
         | quasiquote          { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
 
@@ -2584,8 +2583,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
 
 acmd    :: { LHsCmdTop GhcPs }
         : aexp2                 {% checkCommand $1 >>= \ cmd ->
-                                    return (sL1 $1 $ HsCmdTop cmd
-                                           placeHolderType placeHolderType []) }
+                                    return (sL1 $1 $ HsCmdTop noExt cmd) }
 
 cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
         :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1
@@ -2626,7 +2624,7 @@ texp :: { LHsExpr GhcPs }
 tup_exprs :: { ([AddAnn],SumOrTuple) }
            : texp commas_tup_tail
                           {% do { addAnnotation (gl $1) AnnComma (fst $2)
-                                ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+                                ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
 
            | texp bars    { (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }
 
@@ -2649,8 +2647,8 @@ commas_tup_tail : commas tup_tail
 -- Always follows a comma
 tup_tail :: { [LHsTupArg GhcPs] }
           : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
-                                    return ((L (gl $1) (Present $1)) : snd $2) }
-          | texp                 { [L (gl $1) (Present $1)] }
+                                    return ((L (gl $1) (Present noExt $1)) : snd $2) }
+          | texp                 { [L (gl $1) (Present noExt $1)] }
           | {- empty -}          { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
@@ -2693,7 +2691,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
                     -- We just had one thing in our "parallel" list so
                     -- we simply return that thing directly
 
-                    qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+                    qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock noExt qs [] noSyntaxExpr |
                                             qs <- qss]
                                             noExpr noSyntaxExpr placeHolderType]
                     -- We actually found some actual parallel lists so
index d44be79..7285f5f 100644 (file)
@@ -186,7 +186,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
        ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
                                    tcdDataDefn = defn,
-                                   tcdDataCusk = PlaceHolder,
+                                   tcdDataCusk = placeHolder,
                                    tcdFVs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
@@ -841,7 +841,7 @@ checkAPat msg loc e0 = do
  pState <- getPState
  let opts = options pState
  case e0 of
-   EWildPat _ -> return (WildPat placeHolderType)
+   EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
    HsLit _ (HsStringPrim _ _) -- (#13260)
        -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
@@ -892,7 +892,7 @@ checkAPat msg loc e0 = do
 
    ExplicitTuple _ es b
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
-                                              [e | L _ (Present e) <- es]
+                                              [e | L _ (Present e) <- es]
                                    return (TuplePat noExt ps b)
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
@@ -1201,34 +1201,34 @@ locMap f (L l a) = f l a >>= (\b -> return $ L l b)
 
 checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
 checkCmd _ (HsArrApp _ e1 e2 haat b) =
-    return $ HsCmdArrApp e1 e2 noExt haat b
+    return $ HsCmdArrApp noExt e1 e2 haat b
 checkCmd _ (HsArrForm _ e mf args) =
-    return $ HsCmdArrForm e Prefix mf args
+    return $ HsCmdArrForm noExt e Prefix mf args
 checkCmd _ (HsApp _ e1 e2) =
-    checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
+    checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
 checkCmd _ (HsLam _ mg) =
-    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
 checkCmd _ (HsPar _ e) =
-    checkCommand e >>= (\c -> return $ HsCmdPar c)
+    checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
 checkCmd _ (HsCase _ e mg) =
-    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
 checkCmd _ (HsIf _ cf ep et ee) = do
     pt <- checkCommand et
     pe <- checkCommand ee
-    return $ HsCmdIf cf ep pt pe
+    return $ HsCmdIf noExt cf ep pt pe
 checkCmd _ (HsLet _ lb e) =
-    checkCommand e >>= (\c -> return $ HsCmdLet lb c)
+    checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
 checkCmd _ (HsDo _ DoExpr (L l stmts)) =
     mapM checkCmdLStmt stmts >>=
-    (\ss -> return $ HsCmdDo (L l ss) placeHolderType)
+    (\ss -> return $ HsCmdDo noExt (L l ss) )
 
 checkCmd _ (OpApp _ eLeft op eRight) = do
     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
     c1 <- checkCommand eLeft
     c2 <- checkCommand eRight
-    let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
-        arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
-    return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
+    let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
+        arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+    return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
 
 checkCmd l e = cmdFail l e
 
index 2d4ec89..8f719c4 100644 (file)
@@ -282,10 +282,11 @@ rnExpr (ExplicitTuple x tup_args boxity)
        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
        ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
   where
-    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
-                                    ; return (L l (Present e'), fvs) }
-    rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
+    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
+                                      ; return (L l (Present x e'), fvs) }
+    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
                                         , emptyFVs)
+    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
 
 rnExpr (ExplicitSum x alt arity expr)
   = do { (expr', fvs) <- rnLExpr expr
@@ -465,26 +466,26 @@ rnCmdArgs (arg:args)
 rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
 rnCmdTop = wrapLocFstM rnCmdTop'
  where
-  rnCmdTop' (HsCmdTop cmd _ _ _)
+  rnCmdTop' (HsCmdTop _ cmd)
    = do { (cmd', fvCmd) <- rnLCmd cmd
         ; let cmd_names = [arrAName, composeAName, firstAName] ++
                           nameSetElemsStable (methodNamesCmd (unLoc cmd'))
         -- Generate the rebindable syntax for the monad
         ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
 
-        ; return (HsCmdTop cmd' placeHolderType placeHolderType
-                  (cmd_names `zip` cmd_names'),
+        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
                   fvCmd `plusFV` cmd_fvs) }
+  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
 
 rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
 rnLCmd = wrapLocFstM rnCmd
 
 rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
 
-rnCmd (HsCmdArrApp arrow arg _ ho rtl)
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
   = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
        ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
+       ; return (HsCmdArrApp x arrow' arg' ho rtl,
                  fvArrow `plusFV` fvArg) }
   where
     select_arrow_scope tc = case ho of
@@ -497,7 +498,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
         -- inside 'arrow'.  In the higher-order case (-<<), they are.
 
 -- infix form
-rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
        ; let L _ (HsVar _ (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
@@ -507,47 +508,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
 
-rnCmd (HsCmdArrForm op f fixity cmds)
+rnCmd (HsCmdArrForm op f fixity cmds)
   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
        ; (cmds',fvCmds) <- rnCmdArgs cmds
-       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
+       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
 
-rnCmd (HsCmdApp fun arg)
+rnCmd (HsCmdApp fun arg)
   = do { (fun',fvFun) <- rnLCmd  fun
        ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
+       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
 
-rnCmd (HsCmdLam matches)
+rnCmd (HsCmdLam matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
-       ; return (HsCmdLam matches', fvMatch) }
+       ; return (HsCmdLam matches', fvMatch) }
 
-rnCmd (HsCmdPar e)
+rnCmd (HsCmdPar e)
   = do  { (e', fvs_e) <- rnLCmd e
-        ; return (HsCmdPar e', fvs_e) }
+        ; return (HsCmdPar e', fvs_e) }
 
-rnCmd (HsCmdCase expr matches)
+rnCmd (HsCmdCase expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
-       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
 
-rnCmd (HsCmdIf _ p b1 b2)
+rnCmd (HsCmdIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
        ; (b1', fvB1) <- rnLCmd b1
        ; (b2', fvB2) <- rnLCmd b2
        ; (mb_ite, fvITE) <- lookupIfThenElse
-       ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
 
-rnCmd (HsCmdLet (L l binds) cmd)
+rnCmd (HsCmdLet (L l binds) cmd)
   = rnLocalBindsAndThen binds $ \ binds' _ -> do
       { (cmd',fvExpr) <- rnLCmd cmd
-      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
+      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
 
-rnCmd (HsCmdDo (L l stmts) _)
+rnCmd (HsCmdDo x (L l stmts))
   = do  { ((stmts', _), fvs) <-
             rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
-        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
+        ; return ( HsCmdDo x (L l stmts'), fvs ) }
 
 rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)
 
 ---------------------------------------------------
 type CmdNeeds = FreeVars        -- Only inhabitants are
@@ -559,26 +561,28 @@ methodNamesLCmd = methodNamesCmd . unLoc
 
 methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
 
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
   = emptyFVs
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
   = unitFV appAName
 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
+methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
 
-methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
+methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
 
-methodNamesCmd (HsCmdIf _ _ c1 c2)
+methodNamesCmd (HsCmdIf _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
-methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
-methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
-methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
+methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
+methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
 
-methodNamesCmd (HsCmdCase _ matches)
+methodNamesCmd (HsCmdCase _ matches)
   = methodNamesMatch matches `addOneFV` choiceAName
 
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
 --methodNamesCmd _ = emptyFVs
    -- Other forms can't occur in commands, but it's not convenient
    -- to error here so we just do what's convenient.
@@ -862,7 +866,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
-        ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
+        ; return (( [( L loc (BindStmt pat' body' bind_op fail_op placeHolder)
                      , fv_expr )]
                   , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
@@ -945,7 +949,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
        ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
                                     , trS_by = by', trS_using = using', trS_form = form
                                     , trS_ret = return_op, trS_bind = bind_op
-                                    , trS_bind_arg_ty = PlaceHolder
+                                    , trS_bind_arg_ty = placeHolder
                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
 
 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
@@ -970,7 +974,7 @@ rnParallelStmts ctxt return_op segs thing_inside
            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
            ; return (([], thing), fvs) }
 
-    rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
+    rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
                     <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
                        setLocalRdrEnv env       $ do
@@ -978,8 +982,9 @@ rnParallelStmts ctxt return_op segs thing_inside
                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
                        ; return ((used_bndrs, segs', thing), fvs) }
 
-           ; let seg' = ParStmtBlock stmts' used_bndrs return_op
+           ; let seg' = ParStmtBlock stmts' used_bndrs return_op
            ; return ((seg':segs', thing), fvs) }
+    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
 
     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
     dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
@@ -1195,7 +1200,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
+                  L loc (BindStmt pat' body' bind_op fail_op placeHolder))] }
 
 rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
index 1057cd2..7d31a87 100644 (file)
@@ -385,7 +385,7 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
 rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
 
 rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
-rnPatAndThen _  (WildPat _)   = return (WildPat placeHolderType)
+rnPatAndThen _  (WildPat _)   = return (WildPat noExt)
 rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat
                                      ; return (ParPat x pat') }
 rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
@@ -500,8 +500,8 @@ rnPatAndThen mk (SumPat x pat alt arity)
        }
 
 -- If a splice has been run already, just rename the result.
-rnPatAndThen mk (SplicePat x (HsSpliced mfs (HsSplicedPat pat)))
-  = SplicePat x . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
 
 rnPatAndThen mk (SplicePat _ splice)
   = do { eith <- liftCpsFV $ rnSplicePat splice
index d18657b..fc7240e 100644 (file)
@@ -114,7 +114,7 @@ rnBracket e br_body
        }
 
 rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
-rn_bracket outer_stage br@(VarBr flg rdr_name)
+rn_bracket outer_stage br@(VarBr flg rdr_name)
   = do { name <- lookupOccRn rdr_name
        ; this_mod <- getModule
 
@@ -136,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
                                              (quotedNameStageErr br) }
                         }
                     }
-       ; return (VarBr flg name, unitFV name) }
+       ; return (VarBr flg name, unitFV name) }
 
-rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
-                            ; return (ExpBr e', fvs) }
+rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
+                            ; return (ExpBr e', fvs) }
 
-rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+rn_bracket _ (PatBr x p)
+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
 
-rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
-                            ; return (TypBr t', fvs) }
+rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+                              ; return (TypBr x t', fvs) }
 
-rn_bracket _ (DecBrL decls)
+rn_bracket _ (DecBrL decls)
   = do { group <- groupDecls decls
        ; gbl_env  <- getGblEnv
        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -158,7 +159,7 @@ rn_bracket _ (DecBrL decls)
               -- Discard the tcg_env; it contains only extra info about fixity
         ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
                    ppr (duUses (tcg_dus tcg_env)))
-        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
+        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
   where
     groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
     groupDecls decls
@@ -172,10 +173,12 @@ rn_bracket _ (DecBrL decls)
                   }
            }}
 
-rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
 
-rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
-                             ; return (TExpBr e', fvs) }
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+                               ; return (TExpBr x e', fvs) }
+
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
 
 quotationCtxtDoc :: HsBracket GhcPs -> SDoc
 quotationCtxtDoc br_body
@@ -293,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice
   = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
 
        ; let the_expr = case splice' of
-                  HsUntypedSplice _ _ e   ->  e
-                  HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
-                  HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)
-                  HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)
+                HsUntypedSplice _ _ _ e   ->  e
+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)
+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)
+                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)
 
              -- Typecheck the expression
        ; meta_exp_ty   <- tcMetaTy meta_ty_name
@@ -334,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice
 makePending :: UntypedSpliceFlavour
             -> HsSplice GhcRn
             -> PendingRnSplice
-makePending flavour (HsUntypedSplice _ n e)
+makePending flavour (HsUntypedSplice _ n e)
   = PendingRnSplice flavour n e
-makePending flavour (HsQuasiQuote n quoter q_span quote)
+makePending flavour (HsQuasiQuote n quoter q_span quote)
   = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
 makePending _ splice@(HsTypedSplice {})
   = pprPanic "makePending" (ppr splice)
 makePending _ splice@(HsSpliced {})
   = pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+  = pprPanic "makePending" (ppr splice)
 
 ------------------
 mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
@@ -365,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote
 ---------------------
 rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
 -- Not exported...used for all
-rnSplice (HsTypedSplice hasParen splice_name expr)
+rnSplice (HsTypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell typed splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsTypedSplice hasParen n' expr', fvs) }
+        ; return (HsTypedSplice hasParen n' expr', fvs) }
 
-rnSplice (HsUntypedSplice hasParen splice_name expr)
+rnSplice (HsUntypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell untyped splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsUntypedSplice hasParen n' expr', fvs) }
+        ; return (HsUntypedSplice hasParen n' expr', fvs) }
 
-rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
+rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
   = do  { checkTH quoter "Template Haskell quasi-quote"
         ; loc  <- getSrcSpanM
         ; splice_name' <- newLocalBndrRn (L loc splice_name)
@@ -390,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
         ; when (nameIsLocalOrFrom this_mod quoter') $
           checkThLocalName quoter'
 
-        ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
+        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+                                                             , unitFV quoter') }
 
 rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)
 
 ---------------------
 rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
@@ -423,7 +431,7 @@ rnSpliceExpr splice
            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
              -- See Note [Delaying modFinalizers in untyped splices].
            ; return ( HsPar noExt $ HsSpliceE noExt
-                            . HsSpliced (ThModFinalizers mod_finalizers)
+                            . HsSpliced noExt (ThModFinalizers mod_finalizers)
                             . HsSplicedExpr <$>
                             lexpr3
                     , fvs)
@@ -537,7 +545,7 @@ rnSpliceType splice
                                     -- checkNoErrs: see Note [Renamer errors]
              -- See Note [Delaying modFinalizers in untyped splices].
            ; return ( HsParTy noExt $ HsSpliceTy noExt
-                              . HsSpliced (ThModFinalizers mod_finalizers)
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
                               . HsSplicedTy <$>
                               hs_ty3
                     , fvs
@@ -602,9 +610,9 @@ rnSplicePat splice
                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice
              -- See Note [Delaying modFinalizers in untyped splices].
            ; return ( Left $ ParPat noExt $ (SplicePat noExt)
-                                    . HsSpliced (ThModFinalizers mod_finalizers)
-                                    . HsSplicedPat <$>
-                                    pat
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedPat <$>
+                              pat
                     , emptyFVs
                     ) }
               -- Wrap the result of the quasi-quoter in parens so that we don't
@@ -687,6 +695,7 @@ spliceCtxt splice
              HsTypedSplice   {} -> text "typed splice:"
              HsQuasiQuote    {} -> text "quasi-quotation:"
              HsSpliced       {} -> text "spliced expression:"
+             XSplice         {} -> text "spliced expression:"
 
 -- | The splice data to be logged
 data SpliceInfo
index 14ef4f4..2e1b12d 100644 (file)
@@ -1116,7 +1116,7 @@ collectAnonWildCards lty = go lty
                                       `mappend` go ty
       HsQualTy { hst_ctxt = L _ ctxt
                , hst_body = ty }  -> gos ctxt `mappend` go ty
-      HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
+      HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
       HsSpliceTy{} -> mempty
       HsTyLit{} -> mempty
       HsTyVar{} -> mempty
@@ -1341,25 +1341,24 @@ mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
           -> RnM (HsCmd GhcRn)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
-                                     [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1)
+                                     [a11,a12]))))
         op2 fix2 a2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
+       return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
 
   | associate_right
   = do new_c <- mkOpFormRn a12 op2 fix2 a2
-       return (HsCmdArrForm op1 f (Just fix1)
-               [a11, L loc (HsCmdTop (L loc new_c)
-               placeHolderType placeHolderType [])])
+       return (HsCmdArrForm noExt op1 f (Just fix1)
+               [a11, L loc (HsCmdTop [] (L loc new_c))])
         -- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
 
 --      Default case
 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
-  = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
+  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
 
 
 --------------------------------------
index 96750f7..318e4c6 100644 (file)
@@ -121,11 +121,13 @@ tcCmdTop :: CmdEnv
          -> CmdType
          -> TcM (LHsCmdTop GhcTcId)
 
-tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty)
+tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
   = setSrcSpan loc $
     do  { cmd'   <- tcCmd env cmd cmd_ty
         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
-        ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"
+
 ----------------------------------------
 tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
         -- The main recursive function
@@ -135,35 +137,35 @@ tcCmd env (L loc cmd) res_ty
         ; return (L loc cmd') }
 
 tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
-tc_cmd env (HsCmdPar cmd) res_ty
+tc_cmd env (HsCmdPar cmd) res_ty
   = do  { cmd' <- tcCmd env cmd res_ty
-        ; return (HsCmdPar cmd') }
+        ; return (HsCmdPar cmd') }
 
-tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty
+tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty
   = do  { (binds', body') <- tcLocalBinds binds         $
                              setSrcSpan body_loc        $
                              tc_cmd env body res_ty
-        ; return (HsCmdLet (L l binds') (L body_loc body')) }
+        ; return (HsCmdLet (L l binds') (L body_loc body')) }
 
-tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
+tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
       (scrut', scrut_ty) <- tcInferRho scrut
       matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
-      return (HsCmdCase scrut' matches')
+      return (HsCmdCase scrut' matches')
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
                               ; tcCmd env body (stk, res_ty') }
 
-tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf Nothing pred' b1' b2')
+        ; return (HsCmdIf Nothing pred' b1' b2')
     }
 
-tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
   = do  { pred_ty <- newOpenFlexiTyVarTy
         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
         -- because we're going to apply it to the environment, not
@@ -179,7 +181,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
 
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf (Just fun') pred' b1' b2')
+        ; return (HsCmdIf (Just fun') pred' b1' b2')
     }
 
 -------------------------------------------
@@ -198,7 +200,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
 --
 -- (plus -<< requires ArrowApply)
 
-tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
+tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; let fun_ty = mkCmdArrTy env arg_ty res_ty
@@ -206,7 +208,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
 
         ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
 
-        ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
+        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
   where
        -- Before type-checking f, use the environment of the enclosing
        -- proc for the (-<) case.
@@ -225,12 +227,12 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
 -- -----------------------------
 -- D;G |-a cmd exp : stk --> res
 
-tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
         ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
-        ; return (HsCmdApp fun' arg') }
+        ; return (HsCmdApp fun' arg') }
 
 -------------------------------------------
 --              Lambda
@@ -240,9 +242,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
 -- D;G |-a (\x.cmd) : (t,stk) --> res
 
 tc_cmd env
-       (HsCmdLam (MG { mg_alts = L l [L mtch_loc
+       (HsCmdLam (MG { mg_alts = L l [L mtch_loc
                                    (match@(Match { m_pats = pats, m_grhss = grhss }))],
-                       mg_origin = origin }))
+                         mg_origin = origin }))
        (cmd_stk, res_ty)
   = addErrCtxt (pprMatchInCtxt match)        $
     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
@@ -255,8 +257,9 @@ tc_cmd env
         ; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats'
                                          , m_grhss = grhss' })
               arg_tys = map hsLPatType pats'
-              cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
-                                  , mg_res_ty = res_ty, mg_origin = origin })
+              cmd' = HsCmdLam x (MG { mg_alts = L l [match']
+                                    , mg_arg_tys = arg_tys
+                                    , mg_res_ty = res_ty, mg_origin = origin })
         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
   where
     n_pats     = length pats
@@ -277,10 +280,10 @@ tc_cmd env
 -------------------------------------------
 --              Do notation
 
-tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
+tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
   = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
         ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
-        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) }
+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
 
 
 -----------------------------------------------------------------
@@ -297,7 +300,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
 --      ----------------------------------------------
 --      D; G |-a  (| e c1 ... cn |)  :  stk --> t
 
-tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
                               -- We use alphaTyVar for 'w'
@@ -305,7 +308,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
                      mkFunTys cmd_tys $
                      mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
         ; expr' <- tcPolyExpr expr e_ty
-        ; return (HsCmdArrForm expr' f fixity cmd_args') }
+        ; return (HsCmdArrForm expr' f fixity cmd_args') }
 
   where
     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
@@ -317,6 +320,8 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
             ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
 
+tc_cmd _ (XCmd {}) _ = panic "tc_cmd"
+
 -----------------------------------------------------------------
 --              Base case for illegal commands
 -- This is where expressions that aren't commands get rejected
index b1a473c..a9d8b64 100644 (file)
@@ -1041,7 +1041,7 @@ tcExpr (PArrSeq {}) _
 -- Here we get rid of it and add the finalizers to the global environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tcExpr (HsSpliceE _ (HsSpliced mod_finalizers (HsSplicedExpr expr)))
+tcExpr (HsSpliceE _ (HsSpliced mod_finalizers (HsSplicedExpr expr)))
        res_ty
   = do addModFinalizersWithLclEnv mod_finalizers
        tcExpr expr res_ty
@@ -1392,8 +1392,9 @@ tcTupArgs args tys
   = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
   where
     go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))
-    go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
-                                         ; return (L l (Present expr')) }
+    go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (L l (Present x expr')) }
+    go (L _ (XTupArg{}), _) = panic "tcTupArgs"
 
 ---------------------------
 -- See TcType.SyntaxOpType also for commentary
index 5544a91..29dfefb 100644 (file)
@@ -689,10 +689,11 @@ zonkExpr env (ExplicitTuple x tup_args boxed)
   = do { new_tup_args <- mapM zonk_tup_arg tup_args
        ; return (ExplicitTuple x new_tup_args boxed) }
   where
-    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
-                                        ; return (L l (Present e')) }
+    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
+                                          ; return (L l (Present x e')) }
     zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                         ; return (L l (Missing t')) }
+    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
 
 zonkExpr env (ExplicitSum args alt arity expr)
   = do new_args <- mapM (zonkTcTypeToType env) args
@@ -861,60 +862,60 @@ zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
 
 zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd
 
-zonkCmd env (HsCmdWrap w cmd)
+zonkCmd env (HsCmdWrap w cmd)
   = do { (env1, w') <- zonkCoFn env w
        ; cmd' <- zonkCmd env1 cmd
-       ; return (HsCmdWrap w' cmd') }
-zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
+       ; return (HsCmdWrap w' cmd') }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
   = do new_e1 <- zonkLExpr env e1
        new_e2 <- zonkLExpr env e2
        new_ty <- zonkTcTypeToType env ty
-       return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
+       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
 
-zonkCmd env (HsCmdArrForm op f fixity args)
+zonkCmd env (HsCmdArrForm op f fixity args)
   = do new_op <- zonkLExpr env op
        new_args <- mapM (zonkCmdTop env) args
-       return (HsCmdArrForm new_op f fixity new_args)
+       return (HsCmdArrForm new_op f fixity new_args)
 
-zonkCmd env (HsCmdApp c e)
+zonkCmd env (HsCmdApp c e)
   = do new_c <- zonkLCmd env c
        new_e <- zonkLExpr env e
-       return (HsCmdApp new_c new_e)
+       return (HsCmdApp new_c new_e)
 
-zonkCmd env (HsCmdLam matches)
+zonkCmd env (HsCmdLam matches)
   = do new_matches <- zonkMatchGroup env zonkLCmd matches
-       return (HsCmdLam new_matches)
+       return (HsCmdLam new_matches)
 
-zonkCmd env (HsCmdPar c)
+zonkCmd env (HsCmdPar c)
   = do new_c <- zonkLCmd env c
-       return (HsCmdPar new_c)
+       return (HsCmdPar new_c)
 
-zonkCmd env (HsCmdCase expr ms)
+zonkCmd env (HsCmdCase expr ms)
   = do new_expr <- zonkLExpr env expr
        new_ms <- zonkMatchGroup env zonkLCmd ms
-       return (HsCmdCase new_expr new_ms)
+       return (HsCmdCase new_expr new_ms)
 
-zonkCmd env (HsCmdIf eCond ePred cThen cElse)
+zonkCmd env (HsCmdIf eCond ePred cThen cElse)
   = do { (env1, new_eCond) <- zonkWit env eCond
        ; new_ePred <- zonkLExpr env1 ePred
        ; new_cThen <- zonkLCmd env1 cThen
        ; new_cElse <- zonkLCmd env1 cElse
-       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
+       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
   where
     zonkWit env Nothing  = return (env, Nothing)
     zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
 
-zonkCmd env (HsCmdLet (L l binds) cmd)
+zonkCmd env (HsCmdLet (L l binds) cmd)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_cmd <- zonkLCmd new_env cmd
-       return (HsCmdLet (L l new_binds) new_cmd)
+       return (HsCmdLet (L l new_binds) new_cmd)
 
-zonkCmd env (HsCmdDo (L l stmts) ty)
+zonkCmd env (HsCmdDo ty (L l stmts))
   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
        new_ty <- zonkTcTypeToType env ty
-       return (HsCmdDo (L l new_stmts) new_ty)
-
+       return (HsCmdDo new_ty (L l new_stmts))
 
+zonkCmd _ (XCmd{}) = panic "zonkCmd"
 
 
 
@@ -922,7 +923,7 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
 
 zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
-zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
   = do new_cmd <- zonkLCmd env cmd
        new_stack_tys <- zonkTcTypeToType env stack_tys
        new_ty <- zonkTcTypeToType env ty
@@ -933,7 +934,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
          -- but indeed it should always be lifted due to the typing
          -- rules for arrows
 
-       return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
 
 -------------------------------------------------------------------------
 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
@@ -1010,15 +1012,18 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
   = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
        ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
        ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
-       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
+       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+                              , b <- bs]
              env2 = extendIdZonkEnvRec env1 new_binders
        ; new_mzip <- zonkExpr env2 mzip_op
        ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
   where
-    zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
+    zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
        = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
             ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
-            ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
+            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+                                                                   new_return) }
+    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
 
 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                             , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
index 07cd4d2..762efbf 100644 (file)
@@ -507,7 +507,7 @@ tc_infer_hs_type mode (HsKindSig _ ty sig)
 -- splices or not.
 --
 -- See Note [Delaying modFinalizers in untyped splices].
-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty)))
+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty)))
   = tc_infer_hs_type mode ty
 tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
 tc_infer_hs_type _    (XHsType (NHsCoreTy ty))  = return (ty, typeKind ty)
@@ -560,7 +560,7 @@ tc_hs_type _ ty@(HsRecTy _ _)      _
 -- while capturing the local environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices].
-tc_hs_type mode (HsSpliceTy _ (HsSpliced mod_finalizers (HsSplicedTy ty)))
+tc_hs_type mode (HsSpliceTy _ (HsSpliced mod_finalizers (HsSplicedTy ty)))
            exp_kind
   = do addModFinalizersWithLclEnv mod_finalizers
        tc_hs_type mode ty exp_kind
index 1dbafbb..1863a2f 100644 (file)
@@ -468,13 +468,14 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
     loop [] = do { thing <- thing_inside elt_ty
                  ; return ([], thing) }         -- matching in the branches
 
-    loop (ParStmtBlock stmts names _ : pairs)
+    loop (ParStmtBlock stmts names _ : pairs)
       = do { (stmts', (ids, pairs', thing))
                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
                    do { ids <- tcLookupLocalIds names
                       ; (pairs', thing) <- loop pairs
                       ; return (ids, pairs', thing) }
-           ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) }
+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+    loop (XParStmtBlock{}:_) = panic "tcLcStmt"
 
 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                               , trS_bndrs =  bindersMap
@@ -761,7 +762,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
 
         -- type dummies since we don't know all binder types yet
        ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
-                       [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
+                       [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
 
        -- Typecheck bind:
        ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
@@ -791,7 +792,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
                                    -- matching in the branches
 
     loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
-                           (ParStmtBlock stmts names return_op : pairs)
+                           (ParStmtBlock stmts names return_op : pairs)
       = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
            ; (stmts', (ids, return_op', pairs', thing))
                 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
@@ -804,7 +805,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
                                      \ _ -> return ()
                       ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
                       ; return (ids, return_op', pairs', thing) }
-           ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
+           ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
     loop _ _ _ _ = panic "tcMcStmt.loop"
 
 tcMcStmt _ stmt _ _
index 6dd0f47..05aa489 100644 (file)
@@ -609,7 +609,7 @@ tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty
 -- Here we get rid of it and add the finalizers to the global environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tc_pat penv (SplicePat _ (HsSpliced mod_finalizers (HsSplicedPat pat)))
+tc_pat penv (SplicePat _ (HsSpliced mod_finalizers (HsSplicedPat pat)))
             pat_ty thing_inside
   = do addModFinalizersWithLclEnv mod_finalizers
        tc_pat penv pat pat_ty thing_inside
index 0f64e9c..2035abc 100644 (file)
@@ -705,7 +705,8 @@ tcPatToExpr name args pat = go pat
       | otherwise                   = notInvertibleListPat p
     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
                                          ; return $ ExplicitTuple noExt
-                                              (map (noLoc . Present) exprs) box }
+                                           (map (noLoc . (Present noExt)) exprs)
+                                                                           box }
     go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
                                          ; return $ ExplicitSum noExt alt arity
                                                                    (noLoc expr)
@@ -717,7 +718,7 @@ tcPatToExpr name args pat = go pat
         | otherwise                 = return $ HsOverLit noExt n
     go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
     go1 (CoPat{})                   = panic "CoPat in output of renamer"
-    go1 (SplicePat _ (HsSpliced _ (HsSplicedPat pat)))
+    go1 (SplicePat _ (HsSpliced _ (HsSplicedPat pat)))
                                     = go1 pat
     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
 
@@ -732,6 +733,7 @@ tcPatToExpr name args pat = go pat
     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
     go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
+    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p
 
     notInvertible p = Left (not_invertible_msg p)
 
@@ -861,7 +863,7 @@ tcCheckPatSynPat = go
     go1   (SigPat _ pat)        = go pat
     go1   (ViewPat _ _ pat)     = go pat
     go1   (SplicePat _ splice)
-      | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice
+      | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice
                               = do addModFinalizersWithLclEnv mod_finalizers
                                    go1 pat
       | otherwise             = panic "non-pattern from spliced thing"
index 6c04a67..58fb78b 100644 (file)
@@ -2007,7 +2007,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
                                        (nlHsApp ghciStep rn_expr)
                                        (mkRnSyntaxExpr bindIOName)
                                        noSyntaxExpr
-                                       PlaceHolder
+                                       placeHolder
 
               -- [; print it]
               print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
index 195af1a..1543b7f 100644 (file)
@@ -161,7 +161,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
 
 -- See Note [How brackets and nested splices are handled]
 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
-tcTypedBracket rn_expr brack@(TExpBr expr) res_ty
+tcTypedBracket rn_expr brack@(TExpBr expr) res_ty
   = addErrCtxt (quotationCtxtDoc brack) $
     do { cur_stage <- getStage
        ; ps_ref <- newMutVar []
@@ -198,13 +198,15 @@ tcUntypedBracket rn_expr brack ps res_ty
 
 ---------------
 tcBrackTy :: HsBracket GhcRn -> TcM TcType
-tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName  -- Result type is Var (not Q-monadic)
-tcBrackTy (ExpBr _)   = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
-tcBrackTy (TypBr _)   = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcBrackTy (DecBrG _)  = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcBrackTy (PatBr _)   = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
-tcBrackTy (DecBrL _)  = panic "tcBrackTy: Unexpected DecBrL"
-tcBrackTy (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (VarBr {})  = tcMetaTy nameTyConName
+                                           -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"
 
 ---------------
 tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
@@ -432,7 +434,7 @@ When a variable is used, we compare
 ************************************************************************
 -}
 
-tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty
+tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty
   = addErrCtxt (spliceCtxtDoc splice) $
     setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
index 710c055..7d8a004 100644 (file)
@@ -899,7 +899,7 @@ mkOneRecordSelector all_cons idDetails fl
     -- mentions this particular record selector
     deflt | all dealt_with all_cons = []
           | otherwise = [mkSimpleMatch CaseAlt
-                            [L loc (WildPat placeHolderType)]
+                            [L loc (WildPat noExt)]
                             (mkHsApp (L loc (HsVar noExt
                                             (L loc (getName rEC_SEL_ERROR_ID))))
                                      (L loc (HsLit noExt msg_lit)))]
index 149658a..b04be77 100644 (file)
@@ -51,9 +51,9 @@ testOneFile libdir fileName = do
      gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast
 
      doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)]
-     doLHsTupArg (L l arg@(Present _))
+     doLHsTupArg (L l arg@(Present {}))
                                 = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)]
-     doLHsTupArg (L l arg@(Missing _))
+     doLHsTupArg (L l arg@(Missing {}))
                                 = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)]
 
 
index 402d170..4d7c171 100644 (file)
@@ -144,7 +144,7 @@ test('haddock.compiler',
      [extra_files(['../../../../compiler/stage2/haddock.t']),
       unless(in_tree_compiler(), skip), req_haddock
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 89414230688, 10)
+          [(wordsize(64), 102142130576, 10)
             # 2012-08-14: 26070600504 (amd64/Linux)
             # 2012-08-29: 26353100288 (amd64/Linux, new CG)
             # 2012-09-18: 26882813032 (amd64/Linux)
@@ -167,7 +167,8 @@ test('haddock.compiler',
             # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk
             # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex
             # 2017-11-07: 65807004616 (amd64/Linux) Trees that grow
-            # 2017-11-12: 89414230688 (amd64/Linux) Trees that grow HsExpr
+            # 2017-11-11: 89414230688 (amd64/Linux) Trees that grow HsExpr
+            # 2017-11-12: 102142130576 (amd64/Linux) Trees that grow HsExpr #2
 
           ,(platform('i386-unknown-mingw32'),   367546388, 10)
             # 2012-10-30:                     13773051312 (x86/Windows)
index 9f054dc..134a7bb 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 9f054dc365379c66668de6719840918190ae6e44
+Subproject commit 134a7bb054ea730b13c8629a76232d73e3ace049