Commit 47ad6578 authored by Alan Zimmerman's avatar Alan Zimmerman

TTG3 Combined Step 1 and 3 for Trees That Grow

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
parent f5700001
......@@ -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 x e)) = do { e' <- addTickLHsExpr e
; return (L l (Present x 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 x 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 x matchgroup) =
liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp x 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 x e mgs) =
liftM2 (HsCmdCase x)
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsCmdIf cnd)
addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
liftM3 (HsCmdIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsCmdLet (L l binds) c) =
addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
liftM2 (HsCmdLet . L l)
liftM2 (HsCmdLet x . 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 x 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)
......
......@@ -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))
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
---------
......
......@@ -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)
......
......@@ -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) }
......
......@@ -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)
......
......@@ -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
......
This diff is collapsed.
......@@ -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