diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 14:28:58 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 16:36:43 -0500 |
| commit | 314bc31489f1f4cd69e913c3b1e33236b2bdf553 (patch) | |
| tree | b960f9b02ec06f9d61df019f53655b4e53847bd7 | |
| parent | 0b20d9c51d627febab34b826fccf522ca8bac323 (diff) | |
| download | haskell-314bc31489f1f4cd69e913c3b1e33236b2bdf553.tar.gz | |
Revert "trees that grow" work
As documented in #14490, the Data instances currently blow up
compilation time by too much to stomach. Alan will continue working on
this in a branch and we will perhaps merge to 8.2 before 8.2.1 to avoid
having to perform painful cherry-picks in 8.2 minor releases.
Reverts haddock submodule.
This reverts commit 47ad6578ea460999b53eb4293c3a3b3017a56d65.
This reverts commit e3ec2e7ae94524ebd111963faf34b84d942265b4.
This reverts commit 438dd1cbba13d35f3452b4dcef3f94ce9a216905.
This reverts commit 0ff152c9e633accca48815e26e59d1af1fe44ceb.
71 files changed, 3070 insertions, 4398 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index ae1de7716d..d49a5c3ab8 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -675,12 +675,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon) -- | A fake guard pattern (True <- _) used to represent cases we cannot handle fake_pat :: Pattern fake_pat = PmGrd { pm_grd_pv = [truePattern] - , pm_grd_expr = PmExprOther (EWildPat noExt) } + , pm_grd_expr = PmExprOther EWildPat } {-# INLINE fake_pat #-} -- | Check whether a guard pattern is generated by the checker (unhandled) isFakeGuard :: [Pattern] -> PmExpr -> Bool -isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _)) +isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat) | c == trueDataCon = True | otherwise = False isFakeGuard _pats _e = False @@ -723,25 +723,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec translatePat fam_insts pat = case pat of - WildPat ty -> mkPmVars [ty] - VarPat _ id -> return [PmVar (unLoc id)] - ParPat _ p -> translatePat fam_insts (unLoc p) - LazyPat _ _ -> mkPmVars [hsPatType pat] -- like a variable + WildPat ty -> mkPmVars [ty] + VarPat id -> return [PmVar (unLoc id)] + ParPat p -> translatePat fam_insts (unLoc p) + LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable -- ignore strictness annotations for now - BangPat _ p -> translatePat fam_insts (unLoc p) + BangPat p -> translatePat fam_insts (unLoc p) - AsPat _ lid p -> do + AsPat lid p -> do -- Note [Translating As Patterns] ps <- translatePat fam_insts (unLoc p) let [e] = map vaToPmExpr (coercePatVec ps) g = PmGrd [PmVar (unLoc lid)] e return (ps ++ [g]) - SigPat _ty p -> translatePat fam_insts (unLoc p) + SigPatOut p _ty -> translatePat fam_insts (unLoc p) -- See Note [Translate CoPats] - CoPat _ wrapper p ty + CoPat wrapper p ty | isIdHsWrapper wrapper -> translatePat fam_insts p | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p | otherwise -> do @@ -751,26 +751,26 @@ translatePat fam_insts pat = case pat of return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty + NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty -- (fun -> pat) ===> x (pat <- fun x) - ViewPat arg_ty lexpr lpat -> do + ViewPat lexpr lpat arg_ty -> do ps <- translatePat fam_insts (unLoc lpat) -- See Note [Guards and Approximation] case all cantFailPattern ps of True -> do (xp,xe) <- mkPmId2Forms arg_ty - let g = mkGuard ps (HsApp noExt lexpr xe) + let g = mkGuard ps (HsApp lexpr xe) return [xp,g] False -> mkCanFailPmPat arg_ty -- list - ListPat _ ps ty Nothing -> do + ListPat ps ty Nothing -> do foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat x lpats elem_ty (Just (pat_ty, _to_list)) + ListPat lpats elem_ty (Just (pat_ty, _to_list)) | Just e_ty <- splitListTyConApp_maybe pat_ty , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty -- elem_ty is frequently something like @@ -779,7 +779,7 @@ translatePat fam_insts pat = case pat of -- We have to ensure that the element types are exactly the same. -- Otherwise, one may give an instance IsList [Int] (more specific than -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat x lpats e_ty Nothing) + translatePat fam_insts (ListPat lpats e_ty Nothing) -- See Note [Guards and Approximation] | otherwise -> mkCanFailPmPat pat_ty @@ -799,27 +799,26 @@ translatePat fam_insts pat = case pat of , pm_con_dicts = dicts , pm_con_args = args }] - NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty + NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty - LitPat _ lit + LitPat lit -- If it is a string then convert it to a list of characters | HsString src s <- lit -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> - translatePatVec fam_insts - (map (LitPat noExt . HsChar src) (unpackFS s)) + translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s)) | otherwise -> return [mkLitPattern lit] - PArrPat ty ps -> do + PArrPat ps ty -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let fake_con = RealDataCon (parrFakeCon (length ps)) return [vanillaConPattern fake_con [ty] (concat tidy_ps)] - TuplePat tys ps boxity -> do + TuplePat ps boxity tys -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) return [vanillaConPattern tuple_con tys (concat tidy_ps)] - SumPat ty p alt arity -> do + SumPat p alt arity ty -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) return [vanillaConPattern sum_con ty tidy_p] @@ -828,23 +827,23 @@ translatePat fam_insts pat = case pat of -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" - XPat {} -> panic "Check.translatePat: XPat" + SigPatIn {} -> panic "Check.translatePat: SigPatIn" -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) translateNPat :: FamInstEnvs -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type -> DsM PatVec -translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty +translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg - = translatePat fam_insts (LitPat noExt (HsString src s)) + = translatePat fam_insts (LitPat (HsString src s)) | not type_change, isIntTy ty, HsIntegral i <- val = translatePat fam_insts - (LitPat noExt $ case mb_neg of - Nothing -> HsInt noExt i - Just _ -> HsInt noExt (negateIntegralLit i)) + (LitPat $ case mb_neg of + Nothing -> HsInt def i + Just _ -> HsInt def (negateIntegralLit i)) | not type_change, isWordTy ty, HsIntegral i <- val = translatePat fam_insts - (LitPat noExt $ case mb_neg of + (LitPat $ case mb_neg of Nothing -> HsWordPrim (il_text i) (il_value i) Just _ -> let ni = negateIntegralLit i in HsWordPrim (il_text ni) (il_value ni)) @@ -1217,7 +1216,7 @@ mkPmId ty = getUniqueM >>= \unique -> mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty - return (PmVar x, noLoc (HsVar noExt (noLoc x))) + return (PmVar x, noLoc (HsVar (noLoc x))) -- ---------------------------------------------------------------------------- -- * Converting between Value Abstractions, Patterns and PmExpr diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 5bdff0fe67..862e564aed 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -459,15 +459,15 @@ addTickLHsExprNever (L pos e0) = do -- general heuristic: expressions which do not denote values are good -- break points isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppType {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (HsAppTypeOut {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr _other = False isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppType{} = True -isCallSite OpApp{} = True +isCallSite HsApp{} = True +isCallSite HsAppTypeOut{} = True +isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) @@ -489,58 +489,55 @@ addBinTickLHsExpr boxLabel (L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e -addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut _ con) +addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e +addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e -addTickHsExpr e@(HsIPVar {}) = return e -addTickHsExpr e@(HsOverLit {}) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) - (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) - (addTickMatchGroup True mgs) -addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty) - (addTickLHsExprNever e) - - -addTickHsExpr (OpApp fix e1 e2 e3) = +addTickHsExpr e@(HsIPVar _) = return e +addTickHsExpr e@(HsOverLit _) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit _) = return e +addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs) +addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e) + (return ty) + +addTickHsExpr (OpApp e1 e2 fix e3) = liftM4 OpApp - (return fix) (addTickLHsExpr e1) (addTickLHsExprNever e2) + (return fix) (addTickLHsExpr e3) -addTickHsExpr (NegApp x e neg) = - liftM2 (NegApp x) +addTickHsExpr (NegApp e neg) = + liftM2 NegApp (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x e) = - liftM (HsPar x) (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL x e1 e2) = - liftM2 (SectionL x) +addTickHsExpr (HsPar e) = + liftM HsPar (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL e1 e2) = + liftM2 SectionL (addTickLHsExpr e1) (addTickLHsExprNever e2) -addTickHsExpr (SectionR x e1 e2) = - liftM2 (SectionR x) +addTickHsExpr (SectionR e1 e2) = + liftM2 SectionR (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple x es boxity) = - liftM2 (ExplicitTuple x) +addTickHsExpr (ExplicitTuple es boxity) = + liftM2 ExplicitTuple (mapM addTickTupArg es) (return boxity) -addTickHsExpr (ExplicitSum ty tag arity e) = do +addTickHsExpr (ExplicitSum tag arity e ty) = do e' <- addTickLHsExpr e - return (ExplicitSum ty tag arity e') -addTickHsExpr (HsCase x e mgs) = - liftM2 (HsCase x) + return (ExplicitSum tag arity e' ty) +addTickHsExpr (HsCase e mgs) = + liftM2 HsCase (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) -addTickHsExpr (HsIf x cnd e1 e2 e3) = - liftM3 (HsIf x cnd) +addTickHsExpr (HsIf cnd e1 e2 e3) = + liftM3 (HsIf cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) @@ -548,14 +545,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (L l binds) e) = +addTickHsExpr (HsLet (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . L l) + liftM2 (HsLet . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (L l stmts)) +addTickHsExpr (HsDo cxt (L l stmts) srcloc) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (L l stmts')) } + ; return (HsDo cxt (L l stmts') srcloc) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -585,12 +582,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ; flds' <- mapM addTickHsRecField flds ; return (expr { rupd_expr = e', rupd_flds = flds' }) } -addTickHsExpr (ExprWithTySig ty e) = +addTickHsExpr (ExprWithTySig e ty) = liftM2 ExprWithTySig - (return ty) (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures -addTickHsExpr (ArithSeq ty wit arith_seq) = + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = liftM3 ArithSeq (return ty) (addTickWit wit) @@ -600,26 +597,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = return (Just fl') -- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick x t e) = - liftM (HsTick x t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick x t0 t1 e) = - liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) +addTickHsExpr (HsTick t e) = + liftM (HsTick t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick t0 t1 e) = + liftM (HsBinTick t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 -addTickHsExpr (PArrSeq ty arith_seq) = +addTickHsExpr (PArrSeq ty arith_seq) = liftM2 PArrSeq (return ty) (addTickArithSeqInfo arith_seq) -addTickHsExpr (HsSCC x src nm e) = - liftM3 (HsSCC x) +addTickHsExpr (HsSCC src nm e) = + liftM3 HsSCC (return src) (return nm) (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn x src nm e) = - liftM3 (HsCoreAnn x) +addTickHsExpr (HsCoreAnn src nm e) = + liftM3 HsCoreAnn (return src) (return nm) (addTickLHsExpr e) @@ -627,23 +624,27 @@ addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc x pat cmdtop) = - liftM2 (HsProc x) +addTickHsExpr (HsProc pat cmdtop) = + liftM2 HsProc (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap x w e) = - liftM2 (HsWrap x) +addTickHsExpr (HsWrap w e) = + liftM2 HsWrap (return w) (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (ExprWithTySigOut e ty) = + liftM2 ExprWithTySigOut + (addTickLHsExprNever e) -- No need to tick the inner expression + (return ty) -- for expressions with signatures + -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present x 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)) @@ -761,8 +762,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where @@ -779,12 +780,11 @@ addTickApplicativeArg isGuard (op, arg) = addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = - liftM3 (ParStmtBlock x) +addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = + liftM3 ParStmtBlock (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) -addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds binds) = @@ -795,17 +795,15 @@ addTickHsLocalBinds (HsIPBinds binds) = (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds -addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) - -> TM (HsValBindsLR GhcTc (GhcPass b)) -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do - b <- liftM2 NValBinds +addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b) +addTickHsValBinds (ValBindsOut binds sigs) = + liftM2 ValBindsOut (mapM (\ (rec,binds') -> liftM2 (,) (return rec) (addTickLHsBinds binds')) binds) (return sigs) - return $ XValBindsLR b addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) @@ -830,11 +828,12 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop x cmd) = - liftM2 HsCmdTop - (return x) +addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = + liftM4 HsCmdTop (addTickLHsCmd cmd) -addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop" + (return tys) + (return ty) + (return syntaxtable) addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do @@ -842,10 +841,10 @@ addTickLHsCmd (L pos c0) = do return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam x matchgroup) = - liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp x c e) = - liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (HsCmdLam matchgroup) = + liftM HsCmdLam (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp c e) = + liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) {- addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp @@ -854,43 +853,41 @@ addTickHsCmd (OpApp e1 c2 fix c3) = (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) -addTickHsCmd (HsCmdCase x e mgs) = - liftM2 (HsCmdCase x) +addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) +addTickHsCmd (HsCmdCase e mgs) = + liftM2 HsCmdCase (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = - liftM3 (HsCmdIf x cnd) +addTickHsCmd (HsCmdIf cnd e1 c2 c3) = + liftM3 (HsCmdIf cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (L l binds) c) = +addTickHsCmd (HsCmdLet (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . L l) + liftM2 (HsCmdLet . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (L l stmts)) +addTickHsCmd (HsCmdDo (L l stmts) srcloc) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (L l stmts')) } + ; return (HsCmdDo (L l stmts') srcloc) } -addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = +addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsCmdArrApp - (return arr_ty) (addTickLHsExpr e1) (addTickLHsExpr e2) (return ty1) + (return arr_ty) (return lr) -addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = - liftM4 (HsCmdArrForm x) +addTickHsCmd (HsCmdArrForm e f fix cmdtop) = + liftM4 HsCmdArrForm (addTickLHsExpr e) (return f) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdWrap x w cmd) - = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) - -addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e) +addTickHsCmd (HsCmdWrap w cmd) + = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) @@ -1170,7 +1167,7 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick noExt tickish (L pos e))) + return (L pos (HsTick tickish (L pos e))) ) (do e <- m return (L pos e) @@ -1256,14 +1253,13 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( L pos $ HsTick noExt (HpcTick (this_mod env) c) - $ L pos $ HsBinTick noExt (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) + ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , noFVs + , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} + ) mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 61dc7c5b5b..24d7d8a61c 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -313,7 +313,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = 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,7 +328,6 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = 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 @@ -364,7 +363,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> premap (\ ((xs), _stk) -> arg) fun dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -389,7 +388,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_ty arrow arg HsHigherOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -417,7 +416,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 @@ -450,7 +449,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) @@ -480,7 +479,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 @@ -493,7 +492,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 @@ -554,8 +553,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 @@ -576,12 +575,10 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsConLikeOut noExt (RealDataCon left_con) - right_id = HsConLikeOut noExt (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp noExt - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp noExt - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + left_id = HsConLikeOut (RealDataCon left_con) + right_id = HsConLikeOut (RealDataCon right_con) + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -600,10 +597,9 @@ dsCmd ids local_vars stack_ty res_ty (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase noExt exp - (MG { mg_alts = L l matches' - , mg_arg_tys = arg_tys - , mg_res_ty = sum_ty, mg_origin = origin })) + core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' + , mg_arg_tys = arg_tys + , mg_res_ty = sum_ty, mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' @@ -617,8 +613,7 @@ 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 @@ -643,8 +638,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) - env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty (text "In the do-command:" <+> ppr do_block) @@ -664,14 +658,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn -dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do +dsCmd _ids 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') @@ -688,8 +682,7 @@ 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 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do +dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = 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 @@ -700,7 +693,6 @@ dsTrimCmdArg local_vars env_ids 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)) @@ -1195,31 +1187,31 @@ collectl :: LPat GhcTc -> [Id] -> [Id] collectl (L _ pat) bndrs = go pat where - go (VarPat _ (L _ var)) = var : bndrs + go (VarPat (L _ var)) = var : bndrs go (WildPat _) = bndrs - go (LazyPat _ pat) = collectl pat bndrs - go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (L _ a) pat) = a : collectl pat bndrs - go (ParPat _ pat) = collectl pat bndrs + go (LazyPat pat) = collectl pat bndrs + go (BangPat pat) = collectl pat bndrs + go (AsPat (L _ a) pat) = a : collectl pat bndrs + go (ParPat pat) = collectl pat bndrs - go (ListPat _ pats _ _) = foldr collectl bndrs pats - go (PArrPat _ pats) = foldr collectl bndrs pats - go (TuplePat _ pats _) = foldr collectl bndrs pats - go (SumPat _ pat _ _) = collectl pat bndrs + go (ListPat pats _ _) = foldr collectl bndrs pats + go (PArrPat pats _) = foldr collectl bndrs pats + go (TuplePat pats _ _) = foldr collectl bndrs pats + go (SumPat pat _ _ _) = collectl pat bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _ _) = bndrs + go (LitPat _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs + go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs - go (SigPat _ pat) = collectl pat bndrs - go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ _ pat) = collectl pat bndrs + go (SigPatIn pat _) = collectl pat bndrs + go (SigPatOut pat _) = collectl pat bndrs + go (CoPat _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ pat _) = collectl pat bndrs go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) - go p@(XPat {}) = pprPanic "collectl/go" (ppr p) collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index bba301c7ac..635a9c6137 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -78,9 +78,8 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body ------------------------- -- caller sets location dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsValBinds (XValBindsLR (NValBinds binds _)) body - = foldrM ds_val_bind body binds -dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" +dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds +dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr @@ -250,18 +249,17 @@ dsExpr = ds_expr False ds_expr :: Bool -- are we directly inside an HsWrap? -- See Wrinkle in Note [Detecting forced eta expansion] -> HsExpr GhcTc -> DsM CoreExpr -ds_expr _ (HsPar _ e) = dsLExpr e -ds_expr _ (ExprWithTySig _ e) = dsLExpr e -ds_expr w (HsVar _ (L _ var)) = dsHsVar w var +ds_expr _ (HsPar e) = dsLExpr e +ds_expr _ (ExprWithTySigOut e _) = dsLExpr e +ds_expr w (HsVar (L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -ds_expr w (HsConLikeOut _ con) = dsConLike w con -ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" +ds_expr w (HsConLikeOut con) = dsConLike w con +ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar" ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -ds_expr _ (HsLit _ lit) = dsLit (convertLit lit) -ds_expr _ (HsOverLit _ lit) = dsOverLit lit -ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" +ds_expr _ (HsLit lit) = dsLit (convertLit lit) +ds_expr _ (HsOverLit lit) = dsOverLit lit -ds_expr _ (HsWrap _ co_fn e) +ds_expr _ (HsWrap co_fn e) = do { e' <- ds_expr True e ; wrap' <- dsHsWrapper co_fn ; dflags <- getDynFlags @@ -271,7 +269,7 @@ ds_expr _ (HsWrap _ co_fn e) ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) +ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do { dflags <- getDynFlags @@ -280,23 +278,23 @@ ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) ; dsOverLit' dflags lit } ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (NegApp _ expr neg_expr) +ds_expr _ (NegApp expr neg_expr) = do { expr' <- dsLExpr expr ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (HsLam _ a_Match) +ds_expr _ (HsLam a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match -ds_expr _ (HsLamCase _ matches) +ds_expr _ (HsLamCase matches) = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches ; return $ Lam discrim_var matching_code } -ds_expr _ e@(HsApp _ fun arg) +ds_expr _ e@(HsApp fun arg) = do { fun' <- dsLExpr fun ; dsWhenNoErrs (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } -ds_expr _ (HsAppType _ e) +ds_expr _ (HsAppTypeOut e _) -- ignore type arguments here; they're in the wrappers instead at this point = dsLExpr e @@ -340,19 +338,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier will sort it out. -} -ds_expr _ e@(OpApp _ e1 op e2) +ds_expr _ e@(OpApp e1 op _ e2) = -- for the type of y, we need the type of op's 2nd argument do { op' <- dsLExpr op ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } -ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e) +ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e) = do { op' <- dsLExpr op ; dsWhenNoErrs (dsLExprNoLP expr) (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } -- dsLExpr (SectionR op expr) -- \ x -> op x expr -ds_expr _ e@(SectionR _ op expr) = do +ds_expr _ e@(SectionR op expr) = do core_op <- dsLExpr op -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) @@ -363,32 +361,31 @@ ds_expr _ e@(SectionR _ op expr) = do Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) -ds_expr _ (ExplicitTuple _ tup_args boxity) +ds_expr _ (ExplicitTuple tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- 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 (\(lam_vars, args) -> mkCoreLams lam_vars $ mkCoreTupBoxity boxity args) } -ds_expr _ (ExplicitSum types alt arity expr) +ds_expr _ (ExplicitSum alt arity expr types) = do { dsWhenNoErrs (dsLExprNoLP expr) (\core_expr -> mkCoreConApps (sumDataCon alt arity) (map (Type . getRuntimeRep) types ++ map Type types ++ [core_expr]) ) } -ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do +ds_expr _ (HsSCC _ cc expr@(L loc _)) = do dflags <- getDynFlags if gopt Opt_SccProfilingOn dflags then do @@ -399,31 +396,31 @@ ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do <$> dsLExpr expr else dsLExpr expr -ds_expr _ (HsCoreAnn _ _ _ expr) +ds_expr _ (HsCoreAnn _ _ expr) = dsLExpr expr -ds_expr _ (HsCase _ discrim matches) +ds_expr _ (HsCase discrim matches) = do { core_discrim <- dsLExpr discrim ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -ds_expr _ (HsLet _ binds body) = do +ds_expr _ (HsLet binds body) = do body' <- dsLExpr body dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty -ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts) -ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts - -ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) +ds_expr _ (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty +ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) +ds_expr _ (HsDo DoExpr (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo MDoExpr (L _ stmts) _) = dsDo stmts +ds_expr _ (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts + +ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr @@ -456,7 +453,7 @@ ds_expr _ (ExplicitList elt_ty wit xs) -- We desugar [:x1, ..., xn:] as -- singletonP x1 +:+ ... +:+ singletonP xn -- -ds_expr _ (ExplicitPArr ty []) = do +ds_expr _ (ExplicitPArr ty []) = do emptyP <- dsDPHBuiltin emptyPVar return (Var emptyP `App` Type ty) ds_expr _ (ExplicitPArr ty xs) = do @@ -538,9 +535,8 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. -} -ds_expr _ (RecordCon { rcon_flds = rbinds - , rcon_ext = RecordConTc { rcon_con_expr = con_expr - , rcon_con_like = con_like }}) +ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds + , rcon_con_like = con_like }) = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -599,11 +595,9 @@ So we need to cast (T a Int) to (T a b). Sigh. -} ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_ext = RecordUpdTc - { rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys - , rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap }} ) + , rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap } ) | null fields = dsLExpr record_expr | otherwise @@ -667,7 +661,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con) + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. wrap = mkWpEvVarApps theta_vars <.> @@ -719,16 +713,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- Template Haskell stuff -ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" -ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps -ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) +ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" +ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps +ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) -- Arrow notation extension -ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd +ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd -- Hpc Support -ds_expr _ (HsTick _ tickish e) = do +ds_expr _ (HsTick tickish e) = do e' <- dsLExpr e return (Tick tickish e') @@ -739,19 +733,20 @@ ds_expr _ (HsTick _ tickish e) = do -- (did you go here: YES or NO), but will effect accurate -- tick counting. -ds_expr _ (HsBinTick _ ixT ixF e) = do +ds_expr _ (HsBinTick ixT ixF e) = do e2 <- dsLExpr e do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } -ds_expr _ (HsTickPragma _ _ _ _ expr) = do +ds_expr _ (HsTickPragma _ _ _ expr) = do dflags <- getDynFlags if gopt Opt_Hpc dflags then panic "dsExpr:HsTickPragma" else dsLExpr expr -- HsSyn constructs that just shouldn't be here: +ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp" ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm" @@ -759,6 +754,7 @@ ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" +ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" @@ -937,9 +933,9 @@ dsDo stmts ; rhss' <- sequence rhss - ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) + ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty - ; let fun = L noSrcSpan $ HsLam noExt $ + ; let fun = L noSrcSpan $ HsLam $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] , mg_arg_tys = arg_tys @@ -971,15 +967,15 @@ dsDo stmts later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam noExt + mfix_arg = noLoc $ HsLam (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo body_ty - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) + mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats + body = noLoc $ HsDo + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, @@ -1141,9 +1137,9 @@ we're not directly in an HsWrap, reject. checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of - HsVar _ (L _ var) -> Just var - HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) - _ -> Nothing + HsVar (L _ var) -> Just var + HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc) + _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty , not (null bad_tys) = levPolyPrimopErr var ty bad_tys diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 4296630ba6..d521f537e5 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -136,25 +136,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return +isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut _ con)) - | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick _ tickish e)) +isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (L _ (HsTick tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) +isTrueLHsExpr (L _ (HsBinTick ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing {- diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 860c1baa14..fea637fafe 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -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,7 +90,6 @@ 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 @@ -106,8 +105,7 @@ 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 noExt stmts - from_bndrs noSyntaxExpr) + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock 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 @@ -255,7 +253,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 @@ -625,15 +623,13 @@ 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 @@ -642,7 +638,6 @@ 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' -- @@ -782,7 +777,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 @@ -793,10 +788,9 @@ 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) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c910fbf15b..2a181e8d16 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -77,14 +77,13 @@ 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 (XBracket {}) = panic "dsBracket: unexpected XBracket" + 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 } {- -------------- Examples -------------------- @@ -199,8 +198,8 @@ hsSigTvBinders binds get_scoped_tvs _ = [] sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (NValBinds _ sigs) -> sigs + ValBindsIn _ sigs -> sigs + ValBindsOut _ sigs -> sigs {- Notes @@ -696,7 +695,7 @@ repBangTy ty = do rep2 bangTypeName [b, t] where (su', ss', ty') = case ty of - L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty) + L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty) _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- @@ -918,20 +917,18 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm +repTyVarBndrWithKind (L _ (UserTyVar _)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm = repLTy ki >>= repKindedTV nm -repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLTy ki - ; repKindedTV nm' ki' } -repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr" +repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm + ; repPlainTV nm' } +repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm + ; ki' <- repLTy ki + ; repKindedTV nm' ki' } -- represent a type context -- @@ -1003,7 +1000,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty -repTy (HsTyVar _ _ (L _ n)) +repTy (HsTyVar _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | isTvOcc occ = do tv1 <- lookupOcc n @@ -1016,47 +1013,47 @@ repTy (HsTyVar _ _ (L _ n)) where occ = nameOccName n -repTy (HsAppTy _ f a) = do +repTy (HsAppTy f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsFunTy _ f a) = do +repTy (HsFunTy f a) = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] -repTy (HsListTy _ t) = do +repTy (HsListTy t) = do t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 -repTy (HsPArrTy _ t) = do +repTy (HsPArrTy t) = do t1 <- repLTy t - tcon <- repTy (HsTyVar noExt NotPromoted + tcon <- repTy (HsTyVar NotPromoted (noLoc (tyConName parrTyCon))) repTapp tcon t1 -repTy (HsTupleTy _ HsUnboxedTuple tys) = do +repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys +repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsSumTy _ tys) = do tys1 <- repLTys tys +repTy (HsSumTy tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) -repTy (HsParTy _ t) = repLTy t -repTy (HsEqTy _ t1 t2) = do +repTy (HsParTy t) = repLTy t +repTy (HsEqTy t1 t2) = do t1' <- repLTy t1 t2' <- repLTy t2 eq <- repTequality repTapps eq [t1', t2'] -repTy (HsKindSig _ t k) = do +repTy (HsKindSig t k) = do t1 <- repLTy t k1 <- repLTy k repTSig t1 k1 -repTy (HsSpliceTy _ splice) = repSplice splice +repTy (HsSpliceTy splice _) = repSplice splice repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 @@ -1064,9 +1061,9 @@ repTy (HsExplicitTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repPromotedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTyLit _ lit) = do - lit' <- repTyLit lit - repTLit lit' +repTy (HsTyLit lit) = do + lit' <- repTyLit lit + repTLit lit' repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard repTy ty = notHandled "Exotic form of type" (ppr ty) @@ -1100,11 +1097,10 @@ 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 e@(XSplice {}) = 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) rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -1129,7 +1125,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar _ (L _ x)) = +repE (HsVar (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1137,46 +1133,45 @@ repE (HsVar _ (L _ x)) = Just (DsBound y) -> repVarOrCon x (coreVar y) Just (DsSplice e) -> do { e' <- dsExpr e ; return (MkC e') } } -repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e) -repE (HsOverLabel _ _ s) = repOverLabel s +repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) +repE (HsOverLabel _ s) = repOverLabel s -repE e@(HsRecFld _ f) = case f of - Unambiguous x _ -> repE (HsVar noExt (noLoc x)) +repE e@(HsRecFld f) = case f of + Unambiguous _ x -> repE (HsVar (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) - XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so -- HsOverlit can definitely occur -repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } -repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = L _ ms })) +repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit l) = do { a <- repLiteral l; repLit a } +repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m +repE (HsLamCase (MG { mg_alts = L _ ms })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } -repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType t e) = do { a <- repLE e +repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType e t) = do { a <- repLE e ; s <- repLTy (hswc_body t) ; repAppType a s } -repE (OpApp _ e1 op e2) = +repE (OpApp e1 op _ e2) = do { arg1 <- repLE e1; arg2 <- repLE e2; the_op <- repLE op ; repInfixApp arg1 the_op arg2 } -repE (NegApp _ x _) = do +repE (NegApp x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar _ x) = repLE x -repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = L _ ms })) +repE (HsPar x) = repLE x +repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase e (MG { mg_alts = L _ ms })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 ; repCaseE arg core_ms2 } -repE (HsIf _ _ x y z) = do +repE (HsIf _ x y z) = do a <- repLE x b <- repLE y c <- repLE z @@ -1185,13 +1180,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (L _ sts)) +repE e@(HsDo ctxt (L _ sts) _) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1207,13 +1202,13 @@ repE e@(HsDo _ ctxt (L _ sts)) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) -repE e@(ExplicitTuple _ es boxed) +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) +repE (ExplicitSum alt arity e _) = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } @@ -1226,7 +1221,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) fs <- repUpdFields flds; repRecUpd x fs } -repE (ExprWithTySig ty e) +repE (ExprWithTySig e ty) = do { e1 <- repLE e ; t1 <- repHsSigWcType ty ; repSigExp e1 t1 } @@ -1248,9 +1243,9 @@ repE (ArithSeq _ _ aseq) = ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE _ splice) = repSplice splice +repE (HsSpliceE splice) = repSplice splice repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar _ uv) = do +repE (HsUnboundVar uv) = do occ <- occNameLit (unboundVarOcc uv) sname <- repNameS occ repUnboundVar sname @@ -1259,6 +1254,7 @@ repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) +repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e) repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- @@ -1322,7 +1318,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) + Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1386,11 +1382,10 @@ 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 @@ -1425,12 +1420,12 @@ repBinds (HsValBinds decs) rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (XValBindsLR (NValBinds binds sigs)) +rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) - = panic "rep_val_binds: ValBinds" +rep_val_binds (ValBindsIn _ _) + = panic "rep_val_binds: ValBindsIn" rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds @@ -1616,23 +1611,19 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP p repP :: Pat GhcRn -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild -repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' } -repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } -repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p - ; repPaspat x' p1 } -repP (ParPat _ p) = repLP p -repP (ListPat _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing) - ; e' <- repE (syn_expr e) - ; repPview e' p} -repP (TuplePat _ ps boxed) +repP (WildPat _) = repPwild +repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} +repP (TuplePat ps boxed _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat _ p alt arity) = do { p1 <- repLP p - ; repPunboxedSum p1 alt arity } +repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -1649,13 +1640,13 @@ repP (ConPatIn dc details) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } -repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } -repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) -repP (SigPat t p) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat _ splice) = repSplice splice +repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP (SigPatIn p t) = do { p' <- repLP p + ; t' <- repLTy (hsSigWcType t) + ; repPsig p' t' } +repP (SplicePat splice) = repSplice splice repP other = notHandled "Exotic pattern" (ppr other) @@ -2206,7 +2197,7 @@ repConstr (RecCon (L _ ips)) resTy cons rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) - rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) + rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2366,7 +2357,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat noExt r rat_ty + return $ HsRat def r rat_ty mk_string :: FastString -> DsM (HsLit GhcRn) mk_string s = return $ HsString noSourceText s @@ -2379,7 +2370,6 @@ repOverloadedLiteral (OverLit { ol_val = val}) -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral" mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index f4fe8de227..3748193a19 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -9,8 +9,6 @@ This module exports some utility functions of no great interest. -} {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( @@ -119,13 +117,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id] selectMatchVars ps = mapM selectMatchVar ps selectMatchVar :: Pat GhcTc -> DsM Id -selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) +selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -selectMatchVar (AsPat _ var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) +selectMatchVar (AsPat var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... {- @@ -738,7 +736,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) + | L _ (VarPat (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -785,17 +783,17 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat a -> LPat a -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ p)) = strip_bangs p -strip_bangs (L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (L _ (ParPat p)) = strip_bangs p +strip_bangs (L _ (BangPat p)) = strip_bangs p +strip_bangs lp = lp is_flat_prod_lpat :: LPat a -> Bool is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) is_flat_prod_pat :: Pat a -> Bool -is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) +is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) @@ -805,10 +803,10 @@ is_triv_lpat :: LPat a -> Bool is_triv_lpat p = is_triv_pat (unLoc p) is_triv_pat :: Pat a -> Bool -is_triv_pat (VarPat {}) = True -is_triv_pat (WildPat{}) = True -is_triv_pat (ParPat _ p) = is_triv_lpat p -is_triv_pat _ = False +is_triv_pat (VarPat _) = True +is_triv_pat (WildPat _) = True +is_triv_pat (ParPat p) = is_triv_lpat p +is_triv_pat _ = False {- ********************************************************************* @@ -830,7 +828,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box +mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc @@ -985,8 +983,8 @@ mkBinaryTickBox ixT ixF e = do -- pat => !pat -- when -XStrict -- pat => pat -- otherwise decideBangHood :: DynFlags - -> LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- Pattern with bang if necessary + -> LPat id -- ^ Original pattern + -> LPat id -- Pattern with bang if necessary decideBangHood dflags lpat | not (xopt LangExt.Strict dflags) = lpat @@ -995,20 +993,19 @@ decideBangHood dflags lpat where go lp@(L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> lp' - BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + ParPat p -> L l (ParPat (go p)) + LazyPat lp' -> lp' + BangPat _ -> lp + _ -> L l (BangPat lp) -- | Unconditionally make a 'Pat' strict. -addBang :: LPat GhcTc -- ^ Original pattern - -> LPat GhcTc -- ^ Banged pattern +addBang :: LPat id -- ^ Original pattern + -> LPat id -- ^ Banged pattern addBang = go where go lp@(L l p) = case p of - ParPat x p -> L l (ParPat x (go p)) - LazyPat _ lp' -> L l (BangPat noExt lp') - -- Should we bring the extension value over? - BangPat _ _ -> lp - _ -> L l (BangPat noExt lp) + ParPat p -> L l (ParPat (go p)) + LazyPat lp' -> L l (BangPat lp') + BangPat _ -> lp + _ -> L l (BangPat lp) diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 4cb8bf35ba..7a3ee6853c 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs" matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat _ co pat _ = firstPat eqn1 + = do { let CoPat co pat _ = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ @@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 + let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -299,13 +299,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ _ pat _) = pat +getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" -getBangPat (BangPat _ pat ) = unLoc pat +getBangPat (BangPat pat ) = unLoc pat getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ _ pat) = unLoc pat +getViewPat (ViewPat _ pat _) = unLoc pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing +getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing getOLPat _ = panic "getOLPat" {- @@ -398,19 +398,19 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat) -tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p +tidy1 v (ParPat pat) = tidy1 v (unLoc pat) +tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat _ (L _ var)) +tidy1 v (VarPat (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat _ (L _ var) pat) +tidy1 v (AsPat (L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -425,7 +425,7 @@ tidy1 v (AsPat _ (L _ var) pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat _ pat) +tidy1 v (LazyPat pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. @@ -441,7 +441,7 @@ tidy1 v (LazyPat _ pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat _ pats ty Nothing) +tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -450,29 +450,29 @@ tidy1 _ (ListPat _ pats ty Nothing) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat ty pats) +tidy1 _ (PArrPat pats ty) = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat tys pats boxity) +tidy1 _ (TuplePat pats boxity tys) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -tidy1 _ (SumPat tys pat alt arity) +tidy1 _ (SumPat pat alt arity tys) = return (idDsWrapper, unLoc sum_ConPat) where sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (LitPat _ lit) +tidy1 _ (LitPat lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat ty (L _ lit) mb_neg eq) +tidy1 _ (NPat (L _ lit) mb_neg eq ty) = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -484,14 +484,13 @@ tidy1 _ non_interesting_pat tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p -tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p))) -tidy_bang_pat v l (CoPat x w p t) - = tidy1 v (CoPat x w (BangPat noExt (L l p)) t) +tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) +tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p @@ -527,7 +526,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -538,16 +537,15 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [L l (BangPat noExt arg)] + PrefixCon [L l (BangPat arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg - = L l (BangPat noExt arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -977,18 +975,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ (L _ e)) e' = exp e e' - exp e (HsPar _ (L _ e')) = exp e e' + exp (HsPar (L _ e)) e' = exp e e' + exp e (HsPar (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' - exp (HsVar _ i) (HsVar _ i') = i == i' - exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' + exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' + exp (HsVar i) (HsVar i') = i == i' + exp (HsConLikeOut c) (HsConLikeOut c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does - exp (HsIPVar _ i) (HsIPVar _ i') = i == i' - exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' - exp (HsOverLit _ l) (HsOverLit _ l') = + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x' + exp (HsOverLit l) (HsOverLit l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', @@ -996,20 +994,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' + exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp _ l o ri) (OpApp _ l' o' ri') = + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' - exp (SectionL _ e1 e2) (SectionL _ e1' e2') = + exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' + exp (SectionL e1 e2) (SectionL e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (SectionR _ e1 e2) (SectionR _ e1' e2') = + exp (SectionR e1 e2) (SectionR e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = + exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' - exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = + exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions @@ -1031,8 +1029,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 --------- @@ -1073,7 +1071,7 @@ patGroup _ (ConPatOut { pat_con = L _ con | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = +patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1081,15 +1079,14 @@ patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) = +patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) - -- Type of innelexp pattern -patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList -patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) {- diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index c7bff64ff3..355927deef 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -102,8 +102,6 @@ dsLit (HsRat _ (FL _ _ val) ty) = do (head (tyConDataCons tycon), i_ty) x -> pprPanic "dsLit" (ppr x) -dsLit (XLit x) = pprPanic "dsLit" (ppr x) - dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit lit = do { dflags <- getDynFlags ; warnAboutOverflowedLiterals dflags lit @@ -112,12 +110,12 @@ dsOverLit lit = do { dflags <- getDynFlags dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr -- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty - , ol_witness = witness }) +dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = witness, ol_type = ty }) | not rebindable , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness -dsOverLit' _ XOverLit{} = panic "dsOverLit'" + {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -241,14 +239,14 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- See if the expression is an Integral literal -- Remember to look through automatically-added tick-boxes! (Trac #8384) -getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit getLHsIntegralLit _ = Nothing getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) -getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (il_value i, tyConName tc) getIntegralLit _ = Nothing @@ -275,7 +273,7 @@ tidyLitPat (HsString src s) (mkNilPat charTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat noExt lit +tidyLitPat lit = LitPat lit ---------------- tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat @@ -286,7 +284,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc -> Type -> Pat GhcTc -tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -315,8 +313,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty type_change = not (outer_ty `eqType` ty) mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc - mk_con_pat con lit - = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] []) + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of @@ -330,7 +327,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty _ -> Nothing tidyNPat _ over_lit mb_neg eq outer_ty - = NPat outer_ty (noLoc over_lit) mb_neg eq + = NPat (noLoc over_lit) mb_neg eq outer_ty {- ************************************************************************ @@ -364,7 +361,7 @@ matchLiterals (var:vars) ty sub_groups match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns = do dflags <- getDynFlags - let LitPat _ hs_lit = firstPat (head eqns) + let LitPat hs_lit = firstPat (head eqns) match_result <- match vars ty (shiftEqns eqns) return (hsLitKey dflags hs_lit, match_result) @@ -412,7 +409,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -443,7 +440,7 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 + = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] @@ -455,7 +452,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index f008a31d4b..aa1bc814c5 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr GhcTc -> PmExpr -hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x)) -hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c) -hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit) -hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit) +hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) +hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) +hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) -hsExprToPmExpr e@(NegApp _ _ neg_e) +hsExprToPmExpr e@(NegApp _ neg_e) | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e = PmExprLit (PmOLit True ol) | otherwise = PmExprOther e -hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e +hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e -hsExprToPmExpr e@(ExplicitTuple _ ps boxity) +hsExprToPmExpr e@(ExplicitTuple ps boxity) | all tupArgPresent ps = mkPmExprData tuple_con tuple_args | 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) +hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} where cons x xs = mkPmExprData consDataCon [x,xs] nil = mkPmExprData nilDataCon [] -hsExprToPmExpr (ExplicitPArr _ elems) +hsExprToPmExpr (ExplicitPArr _elem_ty elems) = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) @@ -272,15 +272,16 @@ hsExprToPmExpr (ExplicitPArr _ elems) -- con <- dsLookupDataCon (unLoc c) -- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds) -- return (PmExprCon con args) -hsExprToPmExpr e@(RecordCon {}) = PmExprOther e - -hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e +hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e + +hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e +hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e +hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index f20abab5b9..4336243e91 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -8,7 +8,6 @@ This module converts Template Haskell syntax into HsSyn {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, @@ -214,7 +213,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 +229,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) @@ -542,8 +541,7 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy noExt - (noLoc $ HsRecTy noExt rec_flds) ty') + ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness @@ -562,7 +560,7 @@ cvt_arg (Bang su ss, ty) ; ty' <- wrap_apps ty'' ; let su' = cvtSrcUnpackedness su ; let ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' } + ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) @@ -570,7 +568,7 @@ cvt_id_arg (i, str, ty) ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_names - = [L li $ FieldOcc noExt (L li i')] + = [L li $ FieldOcc (L li i') PlaceHolder] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -755,7 +753,7 @@ cvtLocalDecs doc ds ; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (sigs, bads) = partitionWith is_sig prob_sigs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) } + ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -774,89 +772,77 @@ cvtClause ctxt (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } cvt (LitE l) - | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' } - | otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' } + | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } + | otherwise = do { l' <- cvtLit l; return $ HsLit l' } cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExt (mkLHsPar x') - (mkLHsPar y')} + ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExt (mkLHsPar x') - (mkLHsPar y')} + ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; tp <- wrap_apps t' - ; return $ HsAppType (mkHsWildCardBndrs tp) e' } + ; return $ HsAppType e' $ mkHsWildCardBndrs tp } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing -- oddities that can result from zero-argument -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam noExt (mkMatchGroup FromSource + ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch LambdaExpr ps' e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms - ; return $ HsLamCase noExt - (mkMatchGroup FromSource ms') + ; return $ HsLamCase (mkMatchGroup FromSource ms') } - cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' } + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple noExt - (map (noLoc . (Present noExt)) es') - Boxed } + ; return $ ExplicitTuple (map (noLoc . Present) es') + Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple noExt - (map (noLoc . (Present noExt)) es') - Unboxed } + ; return $ ExplicitTuple + (map (noLoc . Present) es') Unboxed } cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity - ; return $ ExplicitSum noExt - alt arity e'} + ; return $ ExplicitSum + alt arity e' placeHolderType } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' } + ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf noExt alts' } + ; return $ HsMultiIf placeHolderType alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'} + ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsCase noExt e' - (mkMatchGroup FromSource ms') } + ; return $ HsCase e' (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd - ; return $ ArithSeq noExt Nothing dd' } + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } cvt (ListE xs) - | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) - ; return (HsLit noExt l') } + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList noExt Nothing xs' + ; return $ ExplicitList placeHolderType Nothing xs' } -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; wrapParL (HsPar noExt) $ - OpApp noExt (mkLHsPar x') s' - (mkLHsPar y') } + ; wrapParL HsPar $ + OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y - ; wrapParL (HsPar noExt) - $ SectionR noExt s' y' } + ; wrapParL HsPar $ SectionR s' y' } -- See Note [Sections in HsSyn] in HsExpr cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s - ; wrapParL (HsPar noExt) - $ SectionL noExt x' s' } + ; wrapParL HsPar $ SectionL x' s' } - cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s - ; return $ HsPar noExt s' } + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] @@ -866,9 +852,9 @@ cvtl e = wrapL (cvt e) _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' } + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig (mkLHsSigWcType t') e' } + ; return $ ExprWithTySig e' (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } @@ -877,9 +863,9 @@ cvtl e = wrapL (cvt e) <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } - cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) } + cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -970,7 +956,7 @@ cvtOpApp x op1 (UInfixE y op2 z) cvtOpApp x op y = do { op' <- cvtl op ; y' <- cvtl y - ; return (OpApp noExt x op' y') } + ; return (OpApp x op' undefined y') } ------------------------------------- -- Do notation and statements @@ -987,7 +973,7 @@ cvtHsDo do_or_lc stmts L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) } + ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt @@ -1002,9 +988,8 @@ 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 noExt ds' undefined noSyntaxExpr) } + where + cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } cvtMatch :: HsMatchContext RdrName -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1030,13 +1015,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral (mkIntegralLit i) } + = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType} cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (mkFractionalLit r) } + = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString (quotedSourceText s) s' + ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program @@ -1067,9 +1052,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs) cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f) - = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) } + = do { force f; return $ HsFloatPrim def (mkFractionalLit f) } cvtLit (DoublePrimL f) - = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) } + = do { force f; return $ HsDoublePrim def (mkFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } @@ -1098,46 +1083,40 @@ cvtp (TH.LitP l) ; return (mkNPat (noLoc l') Nothing) } -- Not right for negative patterns; -- need to think about that! - | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' } -cvtp (TH.VarP s) = do { s' <- vName s - ; return $ Hs.VarPat noExt (noLoc s') } -cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' } - -- Note [Dropping constructors] -cvtp (TupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExt ps' Boxed } -cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExt ps' Unboxed } + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } +cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') } +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } cvtp (UnboxedSumP p alt arity) = do { p' <- cvtPat p ; unboxedSumChecks alt arity - ; return $ SumPat noExt p' alt arity } + ; return $ SumPat p' alt arity placeHolderType } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; pps <- mapM wrap_conpat ps' ; return $ ConPatIn s' (PrefixCon pps) } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL (ParPat noExt) $ + ; wrapParL ParPat $ ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (ParensP p) = do { p' <- cvtPat p; ; case p' of -- may be wrapped ConPatIn (L _ (ParPat {})) -> return $ unLoc p' - _ -> return $ ParPat noExt p' } -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 noExt + _ -> return $ ParPat p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp TH.WildP = return $ WildPat placeHolderType cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps - ; return - $ ListPat noExt ps' placeHolderType Nothing } + ; return $ ListPat ps' placeHolderType Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat (mkLHsSigWcType t') p' } + ; return $ SigPatIn p' (mkLHsSigWcType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat noExt e' p'} + ; return $ ViewPat e' p' placeHolderType } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) @@ -1148,9 +1127,9 @@ cvtPatFld (s,p) , hsRecPun = False}) } wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs) -wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p +wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p -wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat noExt p +wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p wrap_conpat p = return p {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. @@ -1176,11 +1155,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) = do { nm' <- tNameL nm - ; returnL $ UserTyVar noExt nm' } + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tNameL nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExt nm' ki' } + ; returnL $ KindedTyVar nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1217,18 +1196,17 @@ cvtTypeKind ty_str ty | tys' `lengthIs` n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy noExt - HsBoxedOrConstraintTuple tys') + else returnL (HsTupleTy HsBoxedOrConstraintTuple tys') | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | tys' `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExt HsUnboxedTuple tys') + -> returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar noExt NotPromoted + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 @@ -1237,31 +1215,28 @@ cvtTypeKind ty_str ty , nest 2 $ text "Sums must have an arity of at least 2" ] | tys' `lengthIs` n -- Saturated - -> returnL (HsSumTy noExt tys') + -> returnL (HsSumTy tys') | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName (sumTyCon n)))) + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) tys' ArrowT | [x',y'] <- tys' -> do case x' of - (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x') - ; returnL (HsFunTy noExt x'' y') } - _ -> returnL (HsFunTy noExt x' y') + (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x') + ; returnL (HsFunTy x'' y') } + _ -> returnL (HsFunTy x' y') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName funTyCon))) + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) tys' ListT - | [x'] <- tys' -> returnL (HsListTy noExt x') + | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName listTyCon))) + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar noExt NotPromoted nm') tys' } + ; mk_apps (HsTyVar NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'} + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1277,11 +1252,11 @@ cvtTypeKind ty_str ty SigT ty ki -> do { ty' <- cvtType ty ; ki' <- cvtKind ki - ; mk_apps (HsKindSig noExt ty' ki') tys' + ; mk_apps (HsKindSig ty' ki') tys' } LitT lit - -> returnL (HsTyLit noExt (cvtTyLit lit)) + -> returnL (HsTyLit (cvtTyLit lit)) WildCardT -> mk_apps mkAnonWildCardTy tys' @@ -1290,7 +1265,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] } UInfixT t1 s t2 @@ -1302,46 +1277,46 @@ cvtTypeKind ty_str ty ParensT t -> do { t' <- cvtType t - ; returnL $ HsParTy noExt t' + ; returnL $ HsParTy t' } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar noExt NotPromoted - (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n | n == 1 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) | m == n -- Saturated - -> returnL (HsExplicitTupleTy noExt tys') + -> do { let kis = replicate m placeHolderKind + ; returnL (HsExplicitTupleTy kis tys') + } where m = length tys' PromotedNilT - -> returnL (HsExplicitListTy noExt Promoted []) + -> returnL (HsExplicitListTy Promoted placeHolderKind []) PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys' - -> returnL (HsExplicitListTy noExt ip (ty1:tys2)) + | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' + -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName consDataCon))) + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar noExt NotPromoted (noLoc + -> returnL (HsTyVar NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) ConstraintT - -> returnL (HsTyVar noExt NotPromoted + -> returnL (HsTyVar NotPromoted (noLoc (getRdrName constraintKindTyCon))) EqualityT - | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y') + | [x',y'] <- tys' -> returnL (HsEqTy x' y') | otherwise -> - mk_apps (HsTyVar noExt NotPromoted + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) @@ -1353,15 +1328,15 @@ mk_apps head_ty [] = returnL head_ty mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty ; p_ty <- add_parens ty - ; mk_apps (HsAppTy noExt head_ty' p_ty) tys } + ; mk_apps (HsAppTy head_ty' p_ty) tys } where -- See Note [Adding parens for splices] add_parens t - | isCompoundHsType t = returnL (HsParTy noExt t) + | isCompoundHsType t = returnL (HsParTy t) | otherwise = return t wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) -wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t) +wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t = return t -- --------------------------------------------------------------------- @@ -1392,7 +1367,7 @@ mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy noExt arg ret_ty_l) } + ; return (HsFunTy arg ret_ty_l) } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) split_ty_app ty = go ty [] @@ -1410,17 +1385,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ - HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2') + HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') where - t1' | L _ (HsAppsTy _ t1s) <- t1 + t1' | L _ (HsAppsTy t1s) <- t1 = t1s | otherwise - = [noLoc $ HsAppPrefix noExt t1] + = [noLoc $ HsAppPrefix t1] - t2' | L _ (HsAppsTy _ t2s) <- t2 + t2' | L _ (HsAppsTy t2s) <- t2 = t2s | otherwise - = [noLoc $ HsAppPrefix noExt t2] + = [noLoc $ HsAppPrefix t2] cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" @@ -1460,16 +1435,13 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) ; return $ L l (HsQualTy { hst_ctxt = L l [] - , hst_xqual = noExt , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy { hst_bndrs = univs' - , hst_xforall = noExt , hst_body = L l cxtTy } cxtTy = HsQualTy { hst_ctxt = L l [] - , hst_xqual = noExt , hst_body = ty' } ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) @@ -1519,16 +1491,15 @@ mkHsForAllTy :: [TH.TyVarBndr] -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall - -> LHsQTyVars GhcPs + -> LHsQTyVars name -- ^ The converted type variable binders - -> LHsType GhcPs + -> LHsType name -- ^ The converted rho type - -> LHsType GhcPs + -> LHsType name -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc tvs' rho_ty | null tvs = rho_ty | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExt , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument @@ -1543,16 +1514,15 @@ mkHsQualTy :: TH.Cxt -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit context - -> LHsContext GhcPs + -> LHsContext name -- ^ The converted context - -> LHsType GhcPs + -> LHsType name -- ^ The converted tau type - -> LHsType GhcPs + -> LHsType name -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 10e1307367..0dc5dd08ba 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -14,9 +14,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} module HsBinds where @@ -27,7 +24,6 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder import HsExtension import HsTypes import PprCore () @@ -92,7 +88,7 @@ data HsLocalBindsLR idL idR type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -107,34 +103,18 @@ data HsValBindsLR idL idR -- Before renaming RHS; idR is always RdrName -- Not dependency analysed -- Recursive by default - ValBinds - (XValBinds idL idR) + ValBindsIn (LHsBindsLR idL idR) [LSig idR] -- | Value Bindings Out -- -- After renaming RHS; idR can be Name or Id Dependency analysed, -- later bindings in the list may depend on earlier ones. - | XValBindsLR - (XXValBindsLR idL idR) + | ValBindsOut + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] -- AZ: how to do this? -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) - -type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XXValBindsLR (GhcPass pL) (GhcPass pR) - = NHsValBindsLR (GhcPass pL) - --- --------------------------------------------------------------------- +deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -305,7 +285,7 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) +deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -345,7 +325,7 @@ data PatSynBind idL idR psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } -deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR) +deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) {- Note [AbsBinds] @@ -580,20 +560,20 @@ Specifically, it's just an error thunk -} -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsLocalBindsLR (GhcPass idL) (GhcPass idR)) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsValBindsLR (GhcPass idL) (GhcPass idR)) where - ppr (ValBinds _ binds sigs) +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where + ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) - ppr (XValBindsLR (NValBinds sccs sigs)) + ppr (ValBindsOut sccs sigs) = getPprStyle $ \ sty -> if debugStyle sty then -- Print with sccs showing vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) @@ -604,19 +584,17 @@ instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - SourceTextX (GhcPass id2), - OutputableBndrId (GhcPass id2)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, + SourceTextX id2, OutputableBndrId id2) + => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups -- and we don't want several groups of bindings each @@ -648,7 +626,7 @@ pprDeclList ds = pprDeeperList vcat ds emptyLocalBinds :: HsLocalBindsLR a b emptyLocalBinds = EmptyLocalBinds -isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds isEmptyLocalBinds EmptyLocalBinds = True @@ -657,13 +635,13 @@ eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds EmptyLocalBinds = True eqEmptyLocalBinds _ = False -isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs +isEmptyValBinds :: HsValBindsLR a b -> Bool +isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs -emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds noExt emptyBag [] -emptyValBindsOut = XValBindsLR (NValBinds [] []) +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b +emptyValBindsIn = ValBindsIn emptyBag [] +emptyValBindsOut = ValBindsOut [] [] emptyLHsBinds :: LHsBindsLR idL idR emptyLHsBinds = emptyBag @@ -672,24 +650,22 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ -plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) - -> HsValBinds(GhcPass a) -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) -plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) - (XValBindsLR (NValBinds ds2 sigs2)) - = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) +plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a +plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) + = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) + = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => Outputable (HsBindLR (GhcPass idL) (GhcPass idR)) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc +ppr_monobind :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss @@ -729,9 +705,9 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (SourceTextX (GhcPass idR), - OutputableBndrId idL, OutputableBndrId (GhcPass idR)) - => Outputable (PatSynBind idL (GhcPass idR)) where +instance (SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs @@ -776,7 +752,7 @@ data HsIPBinds id [LIPBind id] TcEvBinds -- Only in typechecker output; binds -- uses of the implicit parameters -deriving instance (DataIdLR id id) => Data (HsIPBinds id) +deriving instance (DataId id) => Data (HsIPBinds id) isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds @@ -800,15 +776,13 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) -deriving instance (DataIdLR id id) => Data (IPBind id) +deriving instance (DataId name) => Data (IPBind name) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsIPBinds (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ whenPprDebug (ppr ds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) - => Outputable (IPBind (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -974,7 +948,7 @@ data Sig pass (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) -deriving instance (DataIdLR pass pass) => Data (Sig pass) +deriving instance (DataId pass) => Data (Sig pass) -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1081,12 +1055,11 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Sig (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Sig pass) where ppr sig = ppr_sig sig -ppr_sig :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) - => Sig (GhcPass p) -> SDoc +ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) @@ -1268,4 +1241,4 @@ data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) -deriving instance (DataIdLR id id) => Data (HsPatSynDir id) +deriving instance (DataId id) => Data (HsPatSynDir id) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 9e05a3d1c1..55d43fd058 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -101,7 +101,7 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PlaceHolder, placeHolder ) +import PlaceHolder ( PlaceHolder(..) ) import HsExtension import NameSet @@ -149,7 +149,7 @@ data HsDecl id -- (Includes quasi-quotes) | DocD (DocDecl) -- ^ Documentation comment declaration | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration -deriving instance (DataIdLR id id) => Data (HsDecl id) +deriving instance (DataId id) => Data (HsDecl id) -- NB: all top-level fixity decls are contained EITHER @@ -195,9 +195,9 @@ data HsGroup id hs_docs :: [LDocDecl] } -deriving instance (DataIdLR id id) => Data (HsGroup id) +deriving instance (DataId id) => Data (HsGroup id) -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a) +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } @@ -212,8 +212,7 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_splcds = [], hs_docs = [] } -appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a) - -> HsGroup (GhcPass a) +appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups HsGroup { hs_valds = val_groups1, @@ -256,8 +255,8 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDecl pass) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -273,8 +272,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsGroup (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsGroup pass) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -316,10 +315,10 @@ data SpliceDecl id = SpliceDecl -- Top level splice (Located (HsSplice id)) SpliceExplicitFlag -deriving instance (DataIdLR id id) => Data (SpliceDecl id) +deriving instance (DataId id) => Data (SpliceDecl id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (SpliceDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (SpliceDecl pass) where ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- @@ -539,7 +538,7 @@ data TyClDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (TyClDecl id) +deriving instance (DataId id) => Data (TyClDecl id) -- Simple classifiers for TyClDecl @@ -634,17 +633,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && rhs_annotated rhs where rhs_annotated (L _ ty) = case ty of - HsParTy _ lty -> rhs_annotated lty - HsKindSig {} -> True - _ -> False + HsParTy lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyClDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClDecl pass) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -675,8 +674,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyClGroup (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyClGroup pass) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -686,11 +685,11 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) ppr roles $$ ppr instds -pp_vanilla_decl_head :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) - -> LHsQTyVars (GhcPass p) +pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> LHsQTyVars pass -> LexicalFixity - -> HsContext (GhcPass p) + -> HsContext pass -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] @@ -784,7 +783,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis] = TyClGroup { group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_instds :: [LInstDecl pass] } -deriving instance (DataIdLR id id) => Data (TyClGroup id) +deriving instance (DataId id) => Data (TyClGroup id) emptyTyClGroup :: TyClGroup pass emptyTyClGroup = TyClGroup [] [] [] @@ -900,7 +899,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass) +deriving instance (DataId pass) => Data (FamilyResultSig pass) -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) @@ -923,7 +922,7 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (FamilyDecl id) +deriving instance (DataId id) => Data (FamilyDecl id) -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) @@ -950,7 +949,7 @@ data FamilyInfo pass -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass) +deriving instance (DataId pass) => Data (FamilyInfo pass) -- | Does this family declaration have a complete, user-supplied kind signature? famDeclHasCusk :: Maybe Bool @@ -965,21 +964,21 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature NoSig = False -hasReturnKindSignature (TyVarSig (L _ UserTyVar{})) = False -hasReturnKindSignature _ = True +hasReturnKindSignature NoSig = False +hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False +hasReturnKindSignature _ = True -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig a -> Maybe (IdP a) resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (FamilyDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (FamilyDecl pass) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc +pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> FamilyDecl pass -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity @@ -1058,7 +1057,7 @@ data HsDataDefn pass -- The payload of a data type defn -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataIdLR id id) => Data (HsDataDefn id) +deriving instance (DataId id) => Data (HsDataDefn id) -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1094,10 +1093,10 @@ data HsDerivingClause pass -- -- should produce a derived instance for @C [a] (T b)@. } -deriving instance (DataIdLR id id) => Data (HsDerivingClause id) +deriving instance (DataId id) => Data (HsDerivingClause id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDerivingClause (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDerivingClause pass) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" @@ -1177,7 +1176,7 @@ data ConDecl pass , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -deriving instance (DataIdLR pass pass) => Data (ConDecl pass) +deriving instance (DataId pass) => Data (ConDecl pass) -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass @@ -1205,7 +1204,7 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty (details, res_ty) -- See Note [Sorting out the result type] = case tau of - L _ (HsFunTy _ (L l (HsRecTy _ flds)) res_ty') + L _ (HsFunTy (L l (HsRecTy flds)) res_ty') -> (RecCon (L l flds), res_ty') _other -> (PrefixCon [], tau) @@ -1214,9 +1213,9 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => (HsContext (GhcPass p) -> SDoc) -- Printing the header - -> HsDataDefn (GhcPass p) +pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) + => (HsContext pass -> SDoc) -- Printing the header + -> HsDataDefn pass -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context , dd_cType = mb_ct @@ -1238,27 +1237,26 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsDataDefn (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsDataDefn pass) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LConDecl (GhcPass p)] -> SDoc +pp_condecls :: (SourceTextX pass, OutputableBndrId pass) + => [LConDecl pass] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ConDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDecl pass) where ppr = pprConDecl -pprConDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => ConDecl (GhcPass p) -> SDoc +pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1383,7 +1381,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass) +deriving instance DataId pass => Data (TyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1401,7 +1399,7 @@ newtype DataFamInstDecl pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass) +deriving instance DataId pass => Data (DataFamInstDecl pass) ----------------- Family instances (common types) ------------- @@ -1461,7 +1459,7 @@ data ClsInstDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (ClsInstDecl id) +deriving instance (DataId id) => Data (ClsInstDecl id) ----------------- Instances of all kinds ------------- @@ -1477,14 +1475,14 @@ data InstDecl pass -- Both class and family instances { dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance { tfid_inst :: TyFamInstDecl pass } -deriving instance (DataIdLR id id) => Data (InstDecl id) +deriving instance (DataId id) => Data (InstDecl id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (TyFamInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (TyFamInstDecl pass) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc +pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> TyFamInstDecl pass -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1492,16 +1490,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass) + => TyFamInstEqn pass -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }}) = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LTyFamDefltEqn (GhcPass p) -> SDoc +ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass) + => LTyFamDefltEqn pass -> SDoc ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon , feqn_pats = tvs , feqn_fixity = fixity @@ -1509,12 +1507,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] <+> equals <+> ppr rhs -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DataFamInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DataFamInstDecl pass) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) + => TopLevelFlag -> DataFamInstDecl pass -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_pats = pats @@ -1530,12 +1528,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd -pprFamInstLHS :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) - -> HsTyPats (GhcPass p) +pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass) + => Located (IdP pass) + -> HsTyPats pass -> LexicalFixity - -> HsContext (GhcPass p) - -> Maybe (LHsKind (GhcPass p)) + -> HsContext pass + -> Maybe (LHsKind pass) -> SDoc pprFamInstLHS thing typats fixity context mb_kind_sig -- explicit type patterns @@ -1555,8 +1553,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig | otherwise = empty -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ClsInstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ClsInstDecl pass) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1594,8 +1592,8 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (InstDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (InstDecl pass) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1634,10 +1632,10 @@ data DerivDecl pass = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataIdLR pass pass) => Data (DerivDecl pass) +deriving instance (DataId pass) => Data (DerivDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DerivDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DerivDecl pass) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1669,10 +1667,10 @@ data DefaultDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass) +deriving instance (DataId pass) => Data (DefaultDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (DefaultDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (DefaultDecl pass) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1714,7 +1712,7 @@ data ForeignDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass) +deriving instance (DataId pass) => Data (ForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1725,10 +1723,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 @@ -1775,8 +1773,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ForeignDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ForeignDecl pass) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1831,7 +1829,7 @@ type LRuleDecls pass = Located (RuleDecls pass) -- | Rule Declarations data RuleDecls pass = HsRules { rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } -deriving instance (DataIdLR pass pass) => Data (RuleDecls pass) +deriving instance (DataId pass) => Data (RuleDecls pass) -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -1857,7 +1855,7 @@ data RuleDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (RuleDecl pass) +deriving instance (DataId pass) => Data (RuleDecl pass) flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -1874,7 +1872,7 @@ data RuleBndr pass -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (RuleBndr pass) +deriving instance (DataId pass) => Data (RuleBndr pass) collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] @@ -1882,14 +1880,14 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleDecls (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecls pass) where ppr (HsRules st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleDecl pass) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), @@ -1898,8 +1896,8 @@ instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (RuleBndr (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (RuleBndr pass) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) @@ -1967,7 +1965,7 @@ data VectDecl pass (LHsSigType pass) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst -deriving instance (DataIdLR pass pass) => Data (VectDecl pass) +deriving instance (DataId pass) => Data (VectDecl pass) lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name @@ -1986,8 +1984,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (VectDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (VectDecl pass) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -2106,10 +2104,10 @@ data AnnDecl pass = HsAnnotation -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (AnnDecl pass) +deriving instance (DataId pass) => Data (AnnDecl pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (AnnDecl (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (AnnDecl pass) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 6b3440ae8b..fedaa4491a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -11,8 +11,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -22,7 +20,6 @@ module HsExpr where -- friends: import GhcPrelude -import PlaceHolder import HsDecls import HsPat import HsLit @@ -85,7 +82,7 @@ type PostTcExpr = HsExpr GhcTc type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit noExt (HsString noSourceText (fsLit "noPostTcExpr")) +noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr")) noPostTcTable :: PostTcTable noPostTcTable = [] @@ -112,17 +109,17 @@ noPostTcTable = [] data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p , syn_arg_wraps :: [HsWrapper] , syn_res_wrap :: HsWrapper } -deriving instance (DataIdLR p p) => Data (SyntaxExpr p) +deriving instance (DataId p) => Data (SyntaxExpr p) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: SourceTextX (GhcPass p) => HsExpr (GhcPass p) -noExpr = HsLit noExt (HsString (sourceText "noExpr") (fsLit "noExpr")) +noExpr :: SourceTextX p => HsExpr p +noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SourceTextX (GhcPass p) => SyntaxExpr (GhcPass p) +noSyntaxExpr :: SourceTextX p => SyntaxExpr p -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString noSourceText +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } @@ -130,14 +127,13 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString noSourceText -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (SyntaxExpr (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -281,13 +277,11 @@ information to use is the GlobalRdrEnv itself. -- | A Haskell expression. data HsExpr p - = HsVar (XVar p) - (Located (IdP p)) -- ^ Variable + = HsVar (Located (IdP p)) -- ^ Variable -- See Note [Located RdrNames] - | HsUnboundVar (XUnboundVar p) - UnboundVar -- ^ Unbound variable; also used for "holes" + | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope @@ -295,31 +289,24 @@ data HsExpr p -- Turned into HsVar by type checker, to support -- deferred type errors. - | HsConLikeOut (XConLikeOut p) - ConLike -- ^ After typechecker only; must be different + | HsConLikeOut ConLike -- ^ After typechecker only; must be different -- HsVar for pretty printing - | HsRecFld (XRecFld p) - (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector -- Not in use after typechecking - | HsOverLabel (XOverLabel p) - (Maybe (IdP p)) FastString + | HsOverLabel (Maybe (IdP p)) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the -- in-scope 'fromLabel'. -- NB: Not in use after typechecking - | HsIPVar (XIPVar p) - HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (XOverLitE p) - (HsOverLit p) -- ^ Overloaded literals + | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (HsOverLit p) -- ^ Overloaded literals - | HsLit (XLitE p) - (HsLit p) -- ^ Simple (non-overloaded) literals + | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals - | HsLam (XLam p) - (MatchGroup p (LHsExpr p)) + | HsLam (MatchGroup p (LHsExpr p)) -- ^ Lambda abstraction. Currently always a single match -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', @@ -327,7 +314,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', @@ -335,24 +322,28 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application + | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application - | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application + | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', + -- TODO:AZ: Sort out Name + | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing + + -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (XOpApp p) - (LHsExpr p) -- left operand + | OpApp (LHsExpr p) -- left operand (LHsExpr p) -- operator + (PostRn p Fixity) -- Renamer adds fixity; bottom until then (LHsExpr p) -- right operand -- | Negation operator. Contains the negated expression and the name @@ -361,22 +352,18 @@ data HsExpr p -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (XNegApp p) - (LHsExpr p) + | NegApp (LHsExpr p) (SyntaxExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (XPar p) - (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - | SectionL (XSectionL p) - (LHsExpr p) -- operand; see Note [Sections in HsSyn] + | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn] (LHsExpr p) -- operator - | SectionR (XSectionR p) - (LHsExpr p) -- operator; see Note [Sections in HsSyn] + | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn] (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof @@ -386,7 +373,6 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitTuple - (XExplicitTuple p) [LHsTupArg p] Boxity @@ -398,18 +384,17 @@ data HsExpr p -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before -- the expression, (arity - alternative) after it | ExplicitSum - (XExplicitSum p) ConTag -- Alternative (one-based) Arity -- Sum arity (LHsExpr p) + (PostTc p [Type]) -- the type arguments -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (XCase p) - (LHsExpr p) + | HsCase (LHsExpr p) (MatchGroup p (LHsExpr p)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', @@ -418,8 +403,7 @@ data HsExpr p -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (XIf p) - (Maybe (SyntaxExpr p)) -- cond function + | HsIf (Maybe (SyntaxExpr p)) -- cond function -- Nothing => use the built-in 'if' -- See Note [Rebindable if] (LHsExpr p) -- predicate @@ -432,7 +416,7 @@ data HsExpr p -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] + | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)] -- | let(rec) -- @@ -441,8 +425,7 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (XLet p) - (LHsLocalBinds p) + | HsLet (LHsLocalBinds p) (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', @@ -451,11 +434,11 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (XDo p) -- Type of the whole expression - (HsStmtContext Name) -- The parameterisation is unimportant + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts + (PostTc p Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] -- @@ -464,7 +447,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitList - (XExplicitList p) -- Gives type of components of list + (PostTc p Type) -- Gives type of components of list (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromListN witness [LHsExpr p] @@ -478,7 +461,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitPArr - (XExplicitPArr p) -- type of elements of the parallel array + (PostTc p Type) -- type of elements of the parallel array [LHsExpr p] -- | Record construction @@ -488,9 +471,11 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordCon - { rcon_ext :: XRecordCon p - , rcon_con_name :: Located (IdP p) -- The constructor name; + { rcon_con_name :: Located (IdP p) -- The constructor name; -- not used after type checking + , rcon_con_like :: PostTc p ConLike + -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update @@ -500,9 +485,18 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd - { rupd_ext :: XRecordUpd p - , rupd_expr :: LHsExpr p + { rupd_expr :: LHsExpr p , rupd_flds :: [LHsRecUpdField p] + , rupd_cons :: PostTc p [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type + , rupd_out_tys :: PostTc p [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -513,10 +507,14 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig - (XExprWithTySig p) -- Retain the signature, + (LHsExpr p) + (LHsSigWcType p) + + | ExprWithTySigOut -- Post typechecking + (LHsExpr p) + (LHsSigWcType GhcRn) -- Retain the signature, -- as HsSigType Name, for -- round-tripping purposes - (LHsExpr p) -- | Arithmetic sequence -- @@ -526,7 +524,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ArithSeq - (XArithSeq p) + PostTcExpr (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromList witness (ArithSeqInfo p) @@ -542,7 +540,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | PArrSeq - (XPArrSeq p) + PostTcExpr (ArithSeqInfo p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, @@ -550,8 +548,7 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes + | HsSCC SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- "set cost centre" SCC pragma (LHsExpr p) -- expr whose cost is to be measured @@ -559,8 +556,7 @@ data HsExpr p -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes + | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- hdaume: core annotation (LHsExpr p) @@ -572,17 +568,15 @@ data HsExpr p -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (XBracket p) (HsBracket p) + | HsBracket (HsBracket p) -- See Note [Pending Splices] | HsRnBracketOut - (XRnBracketOut p) (HsBracket GhcRn) -- Output of the renamer is the *original* renamed -- expression, plus [PendingRnSplice] -- _renamed_ splices to be type checked | HsTcBracketOut - (XTcBracketOut p) (HsBracket GhcRn) -- Output of the type checker is the *original* -- renamed expression, plus [PendingTcSplice] -- _typechecked_ splices to be @@ -592,7 +586,7 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (XSpliceE p) (HsSplice p) + | HsSpliceE (HsSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -603,8 +597,7 @@ data HsExpr p -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (XProc p) - (LPat p) -- arrow abstraction, proc + | HsProc (LPat p) -- arrow abstraction, proc (LHsCmdTop p) -- body of the abstraction -- always has an empty stack @@ -613,7 +606,7 @@ data HsExpr p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (XStatic p) -- Free variables of the body + | HsStatic (PostRn p NameSet) -- Free variables of the body (LHsExpr p) -- Body --------------------------------------- @@ -627,10 +620,10 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrApp -- Arrow tail, or arrow application (f -< arg) - (XArrApp p) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t (LHsExpr p) -- arrow expression, f (LHsExpr p) -- input expression, arg + (PostTc p 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) @@ -640,7 +633,6 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) - (XArrForm p) (LHsExpr p) -- the operator -- after type-checking, a type abstraction to be -- applied to the type of the local environment tuple @@ -652,12 +644,10 @@ data HsExpr p -- Haskell program coverage (Hpc) Support | HsTick - (XTick p) (Tickish (IdP p)) (LHsExpr p) -- sub-expression | HsBinTick - (XBinTick p) Int -- module-local tick number for True Int -- module-local tick number for False (LHsExpr p) -- sub-expression @@ -673,7 +663,6 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsTickPragma -- A pragma introduced tick - (XTickPragma p) SourceText -- Note [Pragma source text] in BasicTypes (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick @@ -686,26 +675,24 @@ data HsExpr p -- These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing. - | EWildPat (XEWildPat p) -- wildcard + | EWildPat -- wildcard -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (XEAsPat p) - (Located (IdP p)) -- as pattern + | EAsPat (Located (IdP p)) -- as pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (XEViewPat p) - (LHsExpr p) -- view pattern + | EViewPat (LHsExpr p) -- view pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern + | ELazyPat (LHsExpr p) -- ~ pattern --------------------------------------- @@ -714,138 +701,10 @@ data HsExpr p -- See Note [Detecting forced eta expansion] in DsExpr. This invariant -- is maintained by HsUtils.mkHsWrap. - | HsWrap (XWrap p) - HsWrapper -- TRANSLATION + | HsWrap HsWrapper -- TRANSLATION (HsExpr p) - | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor - -deriving instance (DataIdLR p p) => Data (HsExpr p) - --- | Extra data fields for a 'RecordCon', added by the type checker -data RecordConTc = RecordConTc - { rcon_con_like :: ConLike -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - } deriving Data - - --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] - } deriving Data - --- --------------------------------------------------------------------- - -type instance XVar (GhcPass _) = PlaceHolder -type instance XUnboundVar (GhcPass _) = PlaceHolder -type instance XConLikeOut (GhcPass _) = PlaceHolder -type instance XRecFld (GhcPass _) = PlaceHolder -type instance XOverLabel (GhcPass _) = PlaceHolder -type instance XIPVar (GhcPass _) = PlaceHolder -type instance XOverLitE (GhcPass _) = PlaceHolder -type instance XLitE (GhcPass _) = PlaceHolder -type instance XLam (GhcPass _) = PlaceHolder -type instance XLamCase (GhcPass _) = PlaceHolder -type instance XApp (GhcPass _) = PlaceHolder - -type instance XAppTypeE GhcPs = LHsWcType GhcPs -type instance XAppTypeE GhcRn = LHsWcType GhcRn -type instance XAppTypeE GhcTc = LHsWcType GhcRn - -type instance XOpApp GhcPs = PlaceHolder -type instance XOpApp GhcRn = Fixity -type instance XOpApp GhcTc = Fixity - -type instance XNegApp (GhcPass _) = PlaceHolder -type instance XPar (GhcPass _) = PlaceHolder -type instance XSectionL (GhcPass _) = PlaceHolder -type instance XSectionR (GhcPass _) = PlaceHolder -type instance XExplicitTuple (GhcPass _) = PlaceHolder - -type instance XExplicitSum GhcPs = PlaceHolder -type instance XExplicitSum GhcRn = PlaceHolder -type instance XExplicitSum GhcTc = [Type] - -type instance XCase (GhcPass _) = PlaceHolder -type instance XIf (GhcPass _) = PlaceHolder - -type instance XMultiIf GhcPs = PlaceHolder -type instance XMultiIf GhcRn = PlaceHolder -type instance XMultiIf GhcTc = Type - -type instance XLet (GhcPass _) = PlaceHolder - -type instance XDo GhcPs = PlaceHolder -type instance XDo GhcRn = PlaceHolder -type instance XDo GhcTc = Type - -type instance XExplicitList GhcPs = PlaceHolder -type instance XExplicitList GhcRn = PlaceHolder -type instance XExplicitList GhcTc = Type - -type instance XExplicitPArr GhcPs = PlaceHolder -type instance XExplicitPArr GhcRn = PlaceHolder -type instance XExplicitPArr GhcTc = Type - -type instance XRecordCon GhcPs = PlaceHolder -type instance XRecordCon GhcRn = PlaceHolder -type instance XRecordCon GhcTc = RecordConTc - -type instance XRecordUpd GhcPs = PlaceHolder -type instance XRecordUpd GhcRn = PlaceHolder -type instance XRecordUpd GhcTc = RecordUpdTc - -type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) -type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) -type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) - -type instance XArithSeq GhcPs = PlaceHolder -type instance XArithSeq GhcRn = PlaceHolder -type instance XArithSeq GhcTc = PostTcExpr - -type instance XPArrSeq GhcPs = PlaceHolder -type instance XPArrSeq GhcRn = PlaceHolder -type instance XPArrSeq GhcTc = PostTcExpr - -type instance XSCC (GhcPass _) = PlaceHolder -type instance XCoreAnn (GhcPass _) = PlaceHolder -type instance XBracket (GhcPass _) = PlaceHolder - -type instance XRnBracketOut (GhcPass _) = PlaceHolder -type instance XTcBracketOut (GhcPass _) = PlaceHolder - -type instance XSpliceE (GhcPass _) = PlaceHolder -type instance XProc (GhcPass _) = PlaceHolder - -type instance XStatic GhcPs = PlaceHolder -type instance XStatic GhcRn = NameSet -type instance XStatic GhcTc = NameSet - -type instance XArrApp GhcPs = PlaceHolder -type instance XArrApp GhcRn = PlaceHolder -type instance XArrApp GhcTc = Type - -type instance XArrForm (GhcPass _) = PlaceHolder -type instance XTick (GhcPass _) = PlaceHolder -type instance XBinTick (GhcPass _) = PlaceHolder -type instance XTickPragma (GhcPass _) = PlaceHolder -type instance XEWildPat (GhcPass _) = PlaceHolder -type instance XEAsPat (GhcPass _) = PlaceHolder -type instance XEViewPat (GhcPass _) = PlaceHolder -type instance XELazyPat (GhcPass _) = PlaceHolder -type instance XWrap (GhcPass _) = PlaceHolder -type instance XXExpr (GhcPass _) = PlaceHolder - --- --------------------------------------------------------------------- +deriving instance (DataId p) => Data (HsExpr p) -- | Located Haskell Tuple Argument -- @@ -860,23 +719,13 @@ type LHsTupArg id = Located (HsTupArg id) -- | Haskell Tuple Argument data HsTupArg id - = 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 + = Present (LHsExpr id) -- ^ The argument + | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type +deriving instance (DataId id) => Data (HsTupArg id) tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True tupArgPresent (L _ (Missing {})) = False -tupArgPresent (L _ (XTupArg {})) = False {- Note [Parens in HsSyn] @@ -950,19 +799,16 @@ RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsExpr (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -970,56 +816,56 @@ isQuietHsExpr :: HsExpr 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 (...) -isQuietHsExpr (HsPar {}) = True +isQuietHsExpr (HsPar _) = True -- applications don't display anything themselves -isQuietHsExpr (HsApp {}) = True -isQuietHsExpr (HsAppType {}) = True -isQuietHsExpr (OpApp {}) = True +isQuietHsExpr (HsApp _ _) = True +isQuietHsExpr (HsAppType _ _) = True +isQuietHsExpr (HsAppTypeOut _ _) = True +isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR) + => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c -ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l -ppr_expr (HsLit _ lit) = ppr lit -ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsPar _ e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) +ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc +ppr_expr (HsVar (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut c) = pprPrefixOcc c +ppr_expr (HsIPVar v) = ppr v +ppr_expr (HsOverLabel _ l)= char '#' <> ppr l +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsOverLit lit) = ppr lit +ppr_expr (HsPar e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn stc (StringLiteral sta s) e) = vcat [pprWithSourceText stc (text "{-# CORE") <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" , ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] +ppr_expr e@(HsAppTypeOut {}) = ppr_apps e [] -ppr_expr (OpApp _ e1 op e2) +ppr_expr (OpApp e1 op _ e2) | Just pp_op <- should_print_infix (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where - should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar _ h@TrueExprHole{}) + should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) + should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) + should_print_infix (HsRecFld f) = Just (pprInfixOcc f) + should_print_infix (HsUnboundVar h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix (EWildPat _) = Just (text "`_`") - should_print_infix (HsWrap _ _ e) = should_print_infix e + should_print_infix EWildPat = Just (text "`_`") + should_print_infix (HsWrap _ e) = should_print_infix e should_print_infix _ = Nothing pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens @@ -1031,67 +877,63 @@ ppr_expr (OpApp _ e1 op e2) pp_infixly pp_op = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) -ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr e +ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e -ppr_expr (SectionL _ expr op) +ppr_expr (SectionL expr op) = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly_n (conLikeName c) - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + HsConLikeOut c -> pp_infixly (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly_n v = (sep [pp_expr, pprInfixOcc v]) - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) -ppr_expr (SectionR _ op expr) +ppr_expr (SectionR op expr) = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly_n (conLikeName c) - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + HsConLikeOut c -> pp_infixly (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) - pp_infixly v = sep [pprInfixOcc v, pp_expr] - pp_infixly_n v = sep [pprInfixOcc v, pp_expr] + pp_infixly v = sep [pprInfixOcc v, pp_expr] -ppr_expr (ExplicitTuple _ exprs boxity) +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 (XTupArg x : es) = (ppr x <> 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 punc (Present {} : _) = comma <> space punc (Missing {} : _) = comma - punc (XTupArg {} : _) = comma <> space punc [] = empty -ppr_expr (ExplicitSum _ alt arity expr) +ppr_expr (ExplicitSum alt arity expr _) = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" where ppr_bars n = hsep (replicate n (char '|')) -ppr_expr (HsLam _ matches) +ppr_expr (HsLam matches) = pprMatches matches -ppr_expr (HsLamCase _ matches) +ppr_expr (HsLamCase matches) = sep [ sep [text "\\case"], nest 2 (pprMatches matches) ] -ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) +ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase _ expr matches) +ppr_expr (HsCase expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_expr (HsIf _ _ e1 e2 e3) +ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), text "else", @@ -1108,15 +950,15 @@ ppr_expr (HsMultiIf _ alts) , text "->" <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... -ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) +ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] -ppr_expr (HsLet _ (L _ binds) expr) +ppr_expr (HsLet (L _ binds) expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] -ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts +ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -1130,48 +972,49 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) -ppr_expr (ExprWithTySig sig expr) +ppr_expr (ExprWithTySig expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) +ppr_expr (ExprWithTySigOut expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = paBrackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) -ppr_expr (EWildPat _) = char '_' -ppr_expr (ELazyPat _ e) = char '~' <> ppr e -ppr_expr (EAsPat _ v e) = ppr v <> char '@' <> ppr e -ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e +ppr_expr EWildPat = char '_' +ppr_expr (ELazyPat e) = char '~' <> ppr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e +ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e -ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) +ppr_expr (HsSCC st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", ppr expr ] -ppr_expr (HsWrap _ co_fn e) +ppr_expr (HsWrap co_fn e) = pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) -ppr_expr (HsSpliceE _ s) = pprSplice s -ppr_expr (HsBracket _ b) = pprHsBracket b -ppr_expr (HsRnBracketOut _ e []) = ppr e -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 (HsSpliceE s) = pprSplice s +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsRnBracketOut e []) = ppr e +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] -ppr_expr (HsTick _ tickish exp) +ppr_expr (HsTick tickish exp) = pprTicks (ppr exp) $ ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) +ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ hcat [text "bintick<", ppr tickIdTrue, @@ -1179,7 +1022,7 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) ppr tickIdFalse, text ">(", ppr exp, text ")"] -ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) +ppr_expr (HsTickPragma _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ hcat [text "tickpragma<", pprExternalSrcLoc externalSrcLoc, @@ -1187,49 +1030,44 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) ppr exp, text ")"] -ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True) +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False) +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True) +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False) +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm _ op _ args) +ppr_expr (HsArrForm op _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x +ppr_expr (HsRecFld f) = ppr f -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case -- | Located Haskell Wildcard Type Expression -data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p) - , OutputableBndrId (GhcPass p)) - => LHsWcTypeX (LHsWcType (GhcPass p)) - -ppr_apps :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) - -- -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] - -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))] +data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p) + => LHsWcTypeX (LHsWcType p) + +ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p + -> [Either (LHsExpr p) LHsWcTypeX] -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args +ppr_apps (HsApp (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType arg (L _ fun)) args - = ppr_apps fun (Right arg : args) +ppr_apps (HsAppType (L _ fun) arg) args + = ppr_apps fun (Right (LHsWcTypeX arg) : args) +ppr_apps (HsAppTypeOut (L _ fun) arg) args + = ppr_apps fun (Right (LHsWcTypeX arg) : args) ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) where - -- pp :: Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p)) -> SDoc pp (Left arg) = ppr arg - -- pp (Right (HsWC { hswc_body = L _ arg })) - -- = char '@' <> pprHsType arg - pp (Right arg) - = char '@' <> ppr arg + pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + = char '@' <> pprHsType arg pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) @@ -1247,19 +1085,16 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1285,13 +1120,13 @@ hsExprNeedsParens (HsPar {}) = False hsExprNeedsParens (HsBracket {}) = False hsExprNeedsParens (HsRnBracketOut {}) = False hsExprNeedsParens (HsTcBracketOut {}) = False -hsExprNeedsParens (HsDo _ sc _) +hsExprNeedsParens (HsDo sc _ _) | isListCompExpr sc = False hsExprNeedsParens (HsRecFld{}) = False hsExprNeedsParens (RecordCon{}) = False hsExprNeedsParens (HsSpliceE{}) = False hsExprNeedsParens (RecordUpd{}) = False -hsExprNeedsParens (HsWrap _ _ e) = hsExprNeedsParens e +hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e hsExprNeedsParens _ = True @@ -1304,8 +1139,8 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr _ = False @@ -1330,10 +1165,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) @@ -1343,7 +1178,6 @@ 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 @@ -1353,26 +1187,22 @@ data HsCmd id -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands - | HsCmdApp (XCmdApp id) - (LHsCmd id) + | HsCmdApp (LHsCmd id) (LHsExpr id) - | HsCmdLam (XCmdLam id) - (MatchGroup id (LHsCmd id)) -- kappa + | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdPar (XCmdPar id) - (LHsCmd id) -- parenthesised command + | HsCmdPar (LHsCmd id) -- parenthesised command -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdCase (XCmdCase id) - (LHsExpr id) + | HsCmdCase (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, @@ -1380,8 +1210,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdIf (XCmdIf id) - (Maybe (SyntaxExpr id)) -- cond function + | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part @@ -1392,8 +1221,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdLet (XCmdLet id) - (LHsLocalBinds id) -- let(rec) + | HsCmdLet (LHsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, @@ -1401,8 +1229,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdDo (XCmdDo id) -- Type of the whole expression - (Located [CmdLStmt id]) + | HsCmdDo (Located [CmdLStmt id]) + (PostTc id Type) -- Type of the whole expression -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnVbar', @@ -1410,32 +1238,11 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdWrap (XCmdWrap id) - HsWrapper + | HsCmdWrap 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 +deriving instance (DataId id) => Data (HsCmd id) -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1452,36 +1259,22 @@ type LHsCmdTop p = Located (HsCmdTop p) -- | Haskell Top-level Command data HsCmdTop p - = 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 + = 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] +deriving instance (DataId p) => Data (HsCmdTop p) -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 +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsCmd (GhcPass p) -> SDoc +pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsCmd (GhcPass p) -> SDoc +pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1489,87 +1282,81 @@ 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 ----------------------- -ppr_lcmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc 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 :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc +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 :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc +pprCmdArg (HsCmdTop cmd _ _ _) = ppr_lcmd cmd -pprCmdArg (XCmdTop x) = ppr x -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsCmdTop (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where ppr = pprCmdArg {- @@ -1605,7 +1392,6 @@ 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 @@ -1614,14 +1400,13 @@ data MatchGroup p body -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns -deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body) +deriving instance (Data body,DataId p) => Data (MatchGroup p body) -- | Located Match 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 { @@ -1630,11 +1415,10 @@ data Match p body m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } -deriving instance (Data body,DataIdLR p p) => Data (Match p body) +deriving instance (Data body,DataId p) => Data (Match p body) -instance (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => Outputable (Match (GhcPass idR) body) where +instance (SourceTextX idR, OutputableBndrId idR, Outputable body) + => Outputable (Match idR body) where ppr = pprMatch {- @@ -1710,53 +1494,46 @@ 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 { grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } -deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body) +deriving instance (Data body,DataId 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 -deriving instance (Data body,DataIdLR id id) => Data (GRHS id body) +deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), - SourceTextX (GhcPass bndr), - OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + => LPat bndr -> GRHSs p body -> SDoc pprPatBind pat (grhss) - = sep [ppr pat, nest 2 - (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)] -pprMatch :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => Match (GhcPass idR) body -> SDoc +pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => Match idR body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 (pprGRHSs ctxt (m_grhss match)) ] @@ -1789,9 +1566,8 @@ pprMatch match (pat1:pats1) = m_pats match (pat2:pats2) = pats1 -pprGRHSs :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only @@ -1799,9 +1575,8 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds)) $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc +pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1895,7 +1670,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- | ApplicativeStmt [ ( SyntaxExpr idR - , ApplicativeArg idL) ] + , ApplicativeArg idL idR) ] -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] (Maybe (SyntaxExpr idR)) -- 'join', if necessary (PostTc idR Type) -- Type of the body @@ -1984,7 +1759,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } -deriving instance (Data body, DataIdLR idL idR) +deriving instance (Data body, DataId idL, DataId idR) => Data (StmtLR idL idR body) data TransForm -- The 'f' below is the 'using' function, 'e' is the by function @@ -1995,18 +1770,13 @@ 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 +deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) -- | Applicative Argument -data ApplicativeArg idL +data ApplicativeArg idL idR = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) (LPat idL) -- WildPat if it was a BodyStmt (see below) (LHsExpr idL) @@ -2018,7 +1788,8 @@ data ApplicativeArg idL [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) -deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL) + +deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) {- Note [The type of bind in Stmts] @@ -2185,24 +1956,19 @@ 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), - Outputable (XXParStmtBlock (GhcPass idL) idR)) - => Outputable (ParStmtBlock (GhcPass idL) idR) where - ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts - ppr (XParStmtBlock x) = ppr x +instance (SourceTextX idL, OutputableBndrId idL) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), - Outputable body) - => Outputable (StmtLR (GhcPass idL) (GhcPass idR) body) where +instance (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) + => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (SourceTextX (GhcPass idL), - SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc + => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> @@ -2236,17 +2002,17 @@ pprStmt (ApplicativeStmt args mb_join _) -- ppr directly rather than transforming here, because we need to -- inject a "return" which is hard when we're polymorphic in the id -- type. + flattenStmt :: ExprLStmt idL -> [SDoc] flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] - flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL))] + :: ExprStmt idL)] | otherwise = [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL))] + :: ExprStmt idL)] flattenArg (_, ApplicativeArgMany stmts _ _) = concatMap flattenStmt stmts @@ -2258,23 +2024,22 @@ pprStmt (ApplicativeStmt args mb_join _) then ap_expr else text "join" <+> parens ap_expr - pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL)) + :: ExprStmt idL) | otherwise = ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt (GhcPass idL)) + :: ExprStmt idL) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> text "<-" <+> - ppr (HsDo (panic "pprStmt") DoExpr (noLoc - (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))) + ppr (HsDo DoExpr (noLoc + (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) + (error "pprStmt")) -pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) - -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt :: (SourceTextX p, OutputableBndrId p) + => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) @@ -2290,9 +2055,8 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc +pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body) + => HsStmtContext any -> [LStmt p body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts @@ -2302,16 +2066,14 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), - Outputable body) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +ppr_do_stmts :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) + => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => [LStmt (GhcPass p) body] -> SDoc +pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals = if null initStmts @@ -2325,9 +2087,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => [LStmt (GhcPass p) body] -> SDoc +pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body) + => [LStmt p body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2342,44 +2103,30 @@ 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 - +deriving instance (DataId id) => Data (HsSplice id) -- | 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 @@ -2421,7 +2168,7 @@ data HsSplicedThing id | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern deriving Typeable -deriving instance (DataIdLR id id) => Data (HsSplicedThing id) +deriving instance (DataId id) => Data (HsSplicedThing id) -- See Note [Pending Splices] type SplicePointName = Name @@ -2445,6 +2192,7 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) deriving Data + {- Note [Pending Splices] ~~~~~~~~~~~~~~~~~~~~~~ @@ -2509,103 +2257,85 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsSplicedThing (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsSplicedThing p) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsSplice (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where ppr s = pprSplice s -pprPendingSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprPendingSplice :: (SourceTextX p, OutputableBndrId p) + => SplicePointName -> LHsExpr p -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice p -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" 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 :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc +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 :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc +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 (XSplice x) = ppr x +pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ thing) = ppr thing ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc +ppr_splice :: (SourceTextX p, OutputableBndrId p) + => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket -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 +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 ||] +deriving instance (DataId p) => Data (HsBracket p) isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsBracket (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where ppr = pprHsBracket -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 :: (SourceTextX p, OutputableBndrId p) => HsBracket 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) = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr _ False n) +pprHsBracket (VarBr False n) = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) -pprHsBracket (XBracket e) = ppr e +pprHsBracket (TExpBr e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> @@ -2638,11 +2368,10 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) -deriving instance (DataIdLR id id) => Data (ArithSeqInfo id) --- AZ: Sould ArithSeqInfo have a TTG extension? +deriving instance (DataId id) => Data (ArithSeqInfo id) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ArithSeqInfo (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (ArithSeqInfo p) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2858,21 +2587,19 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), +pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR, -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) - => Match (GhcPass idR) body -> SDoc + Outputable (NameOrRdrName (NameOrRdrName (IdP idR))), + Outputable body) + => Match idR body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), - OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR, + OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => HsStmtContext (IdP (GhcPass idL)) - -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc + => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 500d601477..bac8a5a183 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -5,7 +5,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} module HsExpr where @@ -13,7 +12,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import HsExtension ( OutputableBndrId, DataIdLR, SourceTextX, GhcPass ) +import HsExtension ( OutputableBndrId, DataId, SourceTextX ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -29,39 +28,32 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (DataIdLR p p) => Data (HsSplice p) -instance (DataIdLR p p) => Data (HsExpr p) -instance (DataIdLR p p) => Data (HsCmd p) -instance (Data body,DataIdLR p p) => Data (MatchGroup p body) -instance (Data body,DataIdLR p p) => Data (GRHSs p body) -instance (DataIdLR p p) => Data (SyntaxExpr p) +instance (DataId p) => Data (HsSplice p) +instance (DataId p) => Data (HsExpr p) +instance (DataId p) => Data (HsCmd p) +instance (Data body,DataId p) => Data (MatchGroup p body) +instance (Data body,DataId p) => Data (GRHSs p body) +instance (DataId p) => Data (SyntaxExpr p) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsExpr (GhcPass p)) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsCmd (GhcPass p)) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) +instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc -pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc +pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc -pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SDoc +pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc -pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) + => HsSplice p -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), - SourceTextX (GhcPass bndr), - OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, + OutputableBndrId bndr, + OutputableBndrId p, Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + => LPat bndr -> GRHSs p body -> SDoc -pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), - Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 86a0bd9431..80dfa67ea3 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -7,9 +7,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder module HsExtension where @@ -58,10 +55,6 @@ haskell-src-exts ASTs as well. -} --- | Used when constructing a term with an unused extension point. -noExt :: PlaceHolder -noExt = PlaceHolder - -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -83,8 +76,6 @@ type instance PostTc GhcPs ty = PlaceHolder type instance PostTc GhcRn ty = PlaceHolder type instance PostTc GhcTc ty = ty --- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty) - -- | Types that are not defined until after renaming type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder type instance PostRn GhcPs ty = PlaceHolder @@ -96,415 +87,88 @@ type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id --- type instance IdP (GHC x) = IdP x - -type LIdP p = Located (IdP p) --- --------------------------------------------------------------------- --- type families for the Pat extension points -type family XWildPat x -type family XVarPat x -type family XLazyPat x -type family XAsPat x -type family XParPat x -type family XBangPat x -type family XListPat x -type family XTuplePat x -type family XSumPat x -type family XPArrPat x -type family XConPat x -type family XViewPat x -type family XSplicePat x -type family XLitPat x -type family XNPat x -type family XNPlusKPat x -type family XSigPat x -type family XCoPat x -type family XXPat x - - -type ForallXPat (c :: * -> Constraint) (x :: *) = - ( c (XWildPat x) - , c (XVarPat x) - , c (XLazyPat x) - , c (XAsPat x) - , c (XParPat x) - , c (XBangPat x) - , c (XListPat x) - , c (XTuplePat x) - , c (XSumPat x) - , c (XPArrPat x) - , c (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) - ) --- --------------------------------------------------------------------- --- ValBindsLR type families -type family XValBinds x x' -type family XXValBindsLR x x' - -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XValBinds x x') - , c (XXValBindsLR x x') - ) - --- We define a type family for each HsLit extension point. This is based on --- prepending 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x type family XHsDoublePrim x -type family XXLit x --- | Helper to apply a constraint to all HsLit extension points. It has one +-- | Helper to apply a constraint to all extension points. It has one -- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsString x) +type ForallX (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsString x) , c (XHsStringPrim x) - , c (XHsInt x) - , c (XHsIntPrim x) - , c (XHsWordPrim x) - , c (XHsInt64Prim x) + , c (XHsInt x) + , c (XHsIntPrim x) + , c (XHsWordPrim x) + , c (XHsInt64Prim x) , c (XHsWord64Prim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsFloatPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsFloatPrim x) , c (XHsDoublePrim x) - , c (XXLit x) ) -type family XOverLit x -type family XXOverLit x - -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) - ) - --- --------------------------------------------------------------------- --- Type families for the Type type families - -type family XForAllTy x -type family XQualTy x -type family XTyVar x -type family XAppsTy x -type family XAppTy x -type family XFunTy x -type family XListTy x -type family XPArrTy x -type family XTupleTy x -type family XSumTy x -type family XOpTy x -type family XParTy x -type family XIParamTy x -type family XEqTy x -type family XKindSig x -type family XSpliceTy x -type family XDocTy x -type family XBangTy x -type family XRecTy x -type family XExplicitListTy x -type family XExplicitTupleTy x -type family XTyLit x -type family XWildCardTy x -type family XXType x - --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXType (c :: * -> Constraint) (x :: *) = - ( c (XForAllTy x) - , c (XQualTy x) - , c (XTyVar x) - , c (XAppsTy x) - , c (XAppTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XPArrTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XEqTy x) - , c (XKindSig x) - , c (XSpliceTy x) - , c (XDocTy x) - , c (XBangTy x) - , c (XRecTy x) - , c (XExplicitListTy x) - , c (XExplicitTupleTy x) - , c (XTyLit x) - , c (XWildCardTy x) - , c (XXType x) - ) - --- --------------------------------------------------------------------- - -type family XUserTyVar x -type family XKindedTyVar x -type family XXTyVarBndr x - -type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = - ( c (XUserTyVar x) - , c (XKindedTyVar x) - , c (XXTyVarBndr x) - ) - --- --------------------------------------------------------------------- - -type family XAppInfix x -type family XAppPrefix x -type family XXAppType x - -type ForallXAppType (c :: * -> Constraint) (x :: *) = - ( c (XAppInfix x) - , c (XAppPrefix x) - , c (XXAppType x) - ) - --- --------------------------------------------------------------------- - -type family XFieldOcc x -type family XXFieldOcc x - -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XFieldOcc x) - , c (XXFieldOcc x) - ) - --- --------------------------------------------------------------------- - -type family XUnambiguous x -type family XAmbiguous x -type family XXAmbiguousFieldOcc x - -type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XUnambiguous x) - , c (XAmbiguous x) - , c (XXAmbiguousFieldOcc x) - ) - --- --------------------------------------------------------------------- --- Type families for the HsExpr type families - -type family XVar x -type family XUnboundVar x -type family XConLikeOut x -type family XRecFld x -type family XOverLabel x -type family XIPVar x -type family XOverLitE x -type family XLitE x -type family XLam x -type family XLamCase x -type family XApp x -type family XAppTypeE x -type family XOpApp x -type family XNegApp x -type family XPar x -type family XSectionL x -type family XSectionR x -type family XExplicitTuple x -type family XExplicitSum x -type family XCase x -type family XIf x -type family XMultiIf x -type family XLet x -type family XDo x -type family XExplicitList x -type family XExplicitPArr x -type family XRecordCon x -type family XRecordUpd x -type family XExprWithTySig x -type family XArithSeq x -type family XPArrSeq x -type family XSCC x -type family XCoreAnn x -type family XBracket x -type family XRnBracketOut x -type family XTcBracketOut x -type family XSpliceE x -type family XProc x -type family XStatic x -type family XArrApp x -type family XArrForm x -type family XTick x -type family XBinTick x -type family XTickPragma x -type family XEWildPat x -type family XEAsPat x -type family XEViewPat x -type family XELazyPat x -type family XWrap x -type family XXExpr x - -type ForallXExpr (c :: * -> Constraint) (x :: *) = - ( c (XVar x) - , c (XUnboundVar x) - , c (XConLikeOut x) - , c (XRecFld x) - , c (XOverLabel x) - , c (XIPVar x) - , c (XOverLitE x) - , c (XLitE x) - , c (XLam x) - , c (XLamCase x) - , c (XApp x) - , c (XAppTypeE x) - , c (XOpApp x) - , c (XNegApp x) - , c (XPar x) - , c (XSectionL x) - , c (XSectionR x) - , c (XExplicitTuple x) - , c (XExplicitSum x) - , c (XCase x) - , c (XIf x) - , c (XMultiIf x) - , c (XLet x) - , c (XDo x) - , c (XExplicitList x) - , c (XExplicitPArr x) - , c (XRecordCon x) - , c (XRecordUpd x) - , c (XExprWithTySig x) - , c (XArithSeq x) - , c (XPArrSeq x) - , c (XSCC x) - , c (XCoreAnn x) - , c (XBracket x) - , c (XRnBracketOut x) - , c (XTcBracketOut x) - , c (XSpliceE x) - , c (XProc x) - , c (XStatic x) - , c (XArrApp x) - , c (XArrForm x) - , c (XTick x) - , c (XBinTick x) - , c (XTickPragma x) - , c (XEWildPat x) - , c (XEAsPat x) - , c (XEViewPat x) - , c (XELazyPat x) - , c (XWrap x) - , c (XXExpr 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) - ) +-- Provide the specific extension types for the parser phase. +type instance XHsChar GhcPs = SourceText +type instance XHsCharPrim GhcPs = SourceText +type instance XHsString GhcPs = SourceText +type instance XHsStringPrim GhcPs = SourceText +type instance XHsInt GhcPs = () +type instance XHsIntPrim GhcPs = SourceText +type instance XHsWordPrim GhcPs = SourceText +type instance XHsInt64Prim GhcPs = SourceText +type instance XHsWord64Prim GhcPs = SourceText +type instance XHsInteger GhcPs = SourceText +type instance XHsRat GhcPs = () +type instance XHsFloatPrim GhcPs = () +type instance XHsDoublePrim GhcPs = () + +-- Provide the specific extension types for the renamer phase. +type instance XHsChar GhcRn = SourceText +type instance XHsCharPrim GhcRn = SourceText +type instance XHsString GhcRn = SourceText +type instance XHsStringPrim GhcRn = SourceText +type instance XHsInt GhcRn = () +type instance XHsIntPrim GhcRn = SourceText +type instance XHsWordPrim GhcRn = SourceText +type instance XHsInt64Prim GhcRn = SourceText +type instance XHsWord64Prim GhcRn = SourceText +type instance XHsInteger GhcRn = SourceText +type instance XHsRat GhcRn = () +type instance XHsFloatPrim GhcRn = () +type instance XHsDoublePrim GhcRn = () + +-- Provide the specific extension types for the typechecker phase. +type instance XHsChar GhcTc = SourceText +type instance XHsCharPrim GhcTc = SourceText +type instance XHsString GhcTc = SourceText +type instance XHsStringPrim GhcTc = SourceText +type instance XHsInt GhcTc = () +type instance XHsIntPrim GhcTc = SourceText +type instance XHsWordPrim GhcTc = SourceText +type instance XHsInt64Prim GhcTc = SourceText +type instance XHsWord64Prim GhcTc = SourceText +type instance XHsInteger GhcTc = SourceText +type instance XHsRat GhcTc = () +type instance XHsFloatPrim GhcTc = () +type instance XHsDoublePrim GhcTc = () --- --------------------------------------------------------------------- - -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') - ) -- --------------------------------------------------------------------- @@ -548,6 +212,22 @@ instance HasSourceText SourceText where -- ---------------------------------------------------------------------- +-- | Defaults for each annotation, used to simplify creation in arbitrary +-- contexts +class HasDefault a where + def :: a + +instance HasDefault () where + def = () + +instance HasDefault SourceText where + def = NoSourceText + +-- | Provide a single constraint that captures the requirement for a default +-- across all the extension points. +type HasDefaultX x = ForallX HasDefault x + +-- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is @@ -574,69 +254,15 @@ type ConvertIdX a b = XHsStringPrim a ~ XHsStringPrim b, XHsString a ~ XHsString b, XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b, - XXLit a ~ XXLit b) - --- ---------------------------------------------------------------------- - --- | Provide a summary constraint that gives all am Outputable constraint to --- extension points needing one -type OutputableX p = - ( Outputable (XXPat p) - , Outputable (XXPat GhcRn) - - , Outputable (XSigPat p) - , Outputable (XSigPat GhcRn) - - , Outputable (XXLit p) + XHsChar a ~ XHsChar b) - , Outputable (XXOverLit p) - - , Outputable (XXType p) - - , Outputable (XExprWithTySig p) - , Outputable (XExprWithTySig GhcRn) - - , Outputable (XAppTypeE p) - , Outputable (XAppTypeE GhcRn) - - -- , Outputable (XXParStmtBlock (GhcPass idL) idR) - ) --- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- type DataId p = ( Data p - - , ForallXHsLit Data p - , ForallXPat Data p - - -- 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 - , ForallXTyVarBndr Data p - , ForallXAppType Data p - , ForallXFieldOcc Data p - , ForallXAmbiguousFieldOcc Data p - - , ForallXExpr Data p - , ForallXTupArg Data p - , ForallXSplice Data p - , ForallXBracket Data p - , ForallXCmdTop Data p - , ForallXCmd Data p - + , ForallX Data p , Data (NameOrRdrName (IdP p)) , Data (IdP p) @@ -656,23 +282,10 @@ type DataId p = , Data (PostTc p [Type]) ) -type DataIdLR pL pR = - ( DataId pL - , DataId 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 -- the @id@ and the 'NameOrRdrName' type for it type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) - , OutputableX id ) diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index a47b0ff4fe..7f0864eccc 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -28,7 +28,6 @@ import Type ( Type ) import Outputable import FastString import HsExtension -import PlaceHolder import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -78,25 +77,8 @@ data HsLit x | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double - | XLit (XXLit x) - deriving instance (DataId x) => Data (HsLit x) -type instance XHsChar (GhcPass _) = SourceText -type instance XHsCharPrim (GhcPass _) = SourceText -type instance XHsString (GhcPass _) = SourceText -type instance XHsStringPrim (GhcPass _) = SourceText -type instance XHsInt (GhcPass _) = PlaceHolder -type instance XHsIntPrim (GhcPass _) = SourceText -type instance XHsWordPrim (GhcPass _) = SourceText -type instance XHsInt64Prim (GhcPass _) = SourceText -type instance XHsWord64Prim (GhcPass _) = SourceText -type instance XHsInteger (GhcPass _) = SourceText -type instance XHsRat (GhcPass _) = PlaceHolder -type instance XHsFloatPrim (GhcPass _) = PlaceHolder -type instance XHsDoublePrim (GhcPass _) = PlaceHolder -type instance XXLit (GhcPass _) = PlaceHolder - instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -117,25 +99,11 @@ instance Eq (HsLit x) where -- | Haskell Overloaded Literal data HsOverLit p = OverLit { - ol_ext :: (XOverLit p), - ol_val :: OverLitVal, - ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] - - | XOverLit - (XXOverLit p) -deriving instance (DataIdLR p p) => Data (HsOverLit p) - -data OverLitTc - = OverLitTc { - ol_rebindable :: Bool, -- Note [ol_rebindable] - ol_type :: Type } - deriving Data - -type instance XOverLit GhcPs = PlaceHolder -type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] -type instance XOverLit GhcTc = OverLitTc - -type instance XXOverLit (GhcPass _) = PlaceHolder + ol_val :: OverLitVal, + ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable] + ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses] + ol_type :: PostTc p Type } +deriving instance (DataId p) => Data (HsOverLit p) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -151,9 +119,8 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -overLitType :: HsOverLit GhcTc -> Type -overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType XOverLit{} = panic "overLitType" +overLitType :: HsOverLit p -> PostTc p Type +overLitType = ol_type -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance @@ -171,7 +138,6 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b) convertLit (HsRat a x b) = (HsRat (convert a) x b) convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) -convertLit (XLit a) = (XLit (convert a)) {- Note [ol_rebindable] @@ -205,10 +171,8 @@ found to have. -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) -instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where - (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 - (XOverLit val1) == (XOverLit val2) = val1 == val2 - _ == _ = panic "Eq HsOverLit" +instance Eq (HsOverLit p) where + (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 instance Eq OverLitVal where (HsIntegral i1) == (HsIntegral i2) = i1 == i2 @@ -216,10 +180,8 @@ instance Eq OverLitVal where (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False -instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where - compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 - compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 - compare _ _ = panic "Ord HsOverLit" +instance Ord (HsOverLit p) where + compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 instance Ord OverLitVal where compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 @@ -233,7 +195,7 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText -instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where +instance (SourceTextX x) => Outputable (HsLit x) where ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c) ppr (HsCharPrim st c) = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c) @@ -255,18 +217,16 @@ instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i) ppr (HsWord64Prim st w) = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w) - ppr (XLit x) = ppr x pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsOverLit (GhcPass p)) where +instance (SourceTextX p, OutputableBndrId p) + => Outputable (HsOverLit p) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) - ppr (XOverLit x) = ppr x instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) @@ -279,7 +239,7 @@ instance Outputable OverLitVal where -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: (SourceTextX (GhcPass x)) => HsLit (GhcPass x) -> SDoc +pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st) @@ -294,4 +254,3 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d -pmPprHsLit (XLit x) = ppr x diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 863f00c99b..e05d8bbf68 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,7 +15,6 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, @@ -50,7 +49,6 @@ import HsExtension import HsTypes import TcEvidence import BasicTypes -import PlaceHolder -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn @@ -80,49 +78,42 @@ type LPat p = Located (Pat p) -- For details on above see note [Api annotations] in ApiAnnotation data Pat p = ------------ Simple patterns --------------- - WildPat (XWildPat p) -- ^ Wildcard Pattern + WildPat (PostTc p Type) -- ^ Wildcard Pattern -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type -- AZ:TODO above comment needs to be updated - | VarPat (XVarPat p) - (Located (IdP p)) -- ^ Variable Pattern + | VarPat (Located (IdP p)) -- ^ Variable Pattern -- See Note [Located RdrNames] in HsExpr - | LazyPat (XLazyPat p) - (LPat p) -- ^ Lazy Pattern + | LazyPat (LPat p) -- ^ Lazy Pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (XAsPat p) - (Located (IdP p)) (LPat p) -- ^ As pattern + | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | ParPat (XParPat p) - (LPat p) -- ^ Parenthesised pattern + | ParPat (LPat p) -- ^ Parenthesised pattern -- See Note [Parens in HsSyn] in HsExpr -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | BangPat (XBangPat p) - (LPat p) -- ^ Bang pattern + | BangPat (LPat p) -- ^ Bang pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation ------------ Lists, tuples, arrays --------------- - | ListPat (XListPat p) - [LPat p] + | ListPat [LPat p] (PostTc p Type) -- The type of the elements (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList --- function to convert the scrutinee to a list value - + -- function to convert the scrutinee to a list value -- ^ Syntactic List -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, @@ -130,13 +121,12 @@ data Pat p -- For details on above see note [Api annotations] in ApiAnnotation - | TuplePat (XTuplePat p) - -- after typechecking, holds the types of the tuple components - [LPat p] -- Tuple sub-patterns + | TuplePat [LPat p] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] - -- You might think that the post typechecking Type was redundant, - -- because we can get the pattern type by getting the types of the - -- sub-patterns. + [PostTc p Type] -- [] before typechecker, filled in afterwards + -- with the types of the tuple components + -- You might think that the PostTc p Type was redundant, because we can + -- get the pattern type by getting the types of the sub-patterns. -- But it's essential -- data T a where -- T1 :: Int -> T Int @@ -156,12 +146,12 @@ data Pat p -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative - (LPat p) -- Sum sub-pattern + | SumPat (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity (INVARIANT: ≥ 2) + (PostTc p [Type]) -- PlaceHolder before typechecker, filled in + -- afterwards with the types of the + -- alternative -- ^ Anonymous sum pattern -- -- - 'ApiAnnotation.AnnKeywordId' : @@ -169,8 +159,8 @@ data Pat p -- 'ApiAnnotation.AnnClose' @'#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | PArrPat (XPArrPat p) -- After typechecking, the type of the elements - [LPat p] -- Syntactic parallel array + | PArrPat [LPat p] -- Syntactic parallel array + (PostTc p Type) -- The type of the elements -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ @@ -205,11 +195,11 @@ data Pat p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (XViewPat p) -- The overall type of the pattern - -- (= the argument type of the view function) - -- for hsPatType. - (LHsExpr p) + | ViewPat (LHsExpr p) (LPat p) + (PostTc p Type) -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. -- ^ View Pattern ------------ Pattern splices --------------- @@ -217,34 +207,31 @@ data Pat p -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (XSplicePat p) - (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- - | LitPat (XLitPat p) - (HsLit p) -- ^ Literal Pattern + | LitPat (HsLit p) -- ^ Literal Pattern -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. | NPat -- Natural Pattern -- Used for all overloaded literals, -- including overloaded strings with -XOverloadedStrings - (XNPat p) -- Overall type of pattern. Might be - -- different than the literal's type - -- if (==) or negate changes the type (Located (HsOverLit p)) -- ALWAYS positive (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for -- negative patterns, Nothing -- otherwise (SyntaxExpr p) -- Equality checker, of type t->t->Bool + (PostTc p Type) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type -- ^ Natural Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ -- For details on above see note [Api annotations] in ApiAnnotation - | NPlusKPat (XNPlusKPat p) -- Type of overall pattern - (Located (IdP p)) -- n+k pattern + | NPlusKPat (Located (IdP p)) -- n+k pattern (Located (HsOverLit p)) -- It'll always be an HsIntegral (HsOverLit p) -- See Note [NPlusK patterns] in TcPat -- NB: This could be (PostTc ...), but that induced a @@ -252,22 +239,24 @@ data Pat p (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + (PostTc p Type) -- Type of overall pattern -- ^ n+k pattern ------------ Pattern type signatures --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SigPat (XSigPat p) -- Before typechecker - -- Signature can bind both - -- kind and type vars - -- After typechecker: Type - (LPat p) -- Pattern with a type signature + | SigPatIn (LPat p) -- Pattern with a type signature + (LHsSigWcType p) -- Signature can bind both + -- kind and type vars + -- ^ Pattern with a type signature + + | SigPatOut (LPat p) + Type -- ^ Pattern with a type signature ------------ Pattern coercions (translation only) --------------- - | CoPat (XCoPat p) - HsWrapper -- Coercion Pattern + | CoPat HsWrapper -- Coercion Pattern -- If co :: t1 ~ t2, p :: t2, -- then (CoPat co p) :: t1 (Pat p) -- Why not LPat? Ans: existing locn will do @@ -275,65 +264,7 @@ data Pat p -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' -- ^ Coercion Pattern - - -- | Trees that Grow extension point for new constructors - | XPat - (XXPat p) -deriving instance (DataIdLR p p) => Data (Pat p) - --- --------------------------------------------------------------------- - -type instance XWildPat GhcPs = PlaceHolder -type instance XWildPat GhcRn = PlaceHolder -type instance XWildPat GhcTc = Type - -type instance XVarPat (GhcPass _) = PlaceHolder -type instance XLazyPat (GhcPass _) = PlaceHolder -type instance XAsPat (GhcPass _) = PlaceHolder -type instance XParPat (GhcPass _) = PlaceHolder -type instance XBangPat (GhcPass _) = PlaceHolder - --- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap --- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for --- `SyntaxExpr` -type instance XListPat (GhcPass _) = PlaceHolder - -type instance XTuplePat GhcPs = PlaceHolder -type instance XTuplePat GhcRn = PlaceHolder -type instance XTuplePat GhcTc = [Type] - -type instance XSumPat GhcPs = PlaceHolder -type instance XSumPat GhcRn = PlaceHolder -type instance XSumPat GhcTc = [Type] - -type instance XPArrPat GhcPs = PlaceHolder -type instance XPArrPat GhcRn = PlaceHolder -type instance XPArrPat GhcTc = Type - -type instance XViewPat GhcPs = PlaceHolder -type instance XViewPat GhcRn = PlaceHolder -type instance XViewPat GhcTc = Type - -type instance XSplicePat (GhcPass _) = PlaceHolder -type instance XLitPat (GhcPass _) = PlaceHolder - -type instance XNPat GhcPs = PlaceHolder -type instance XNPat GhcRn = PlaceHolder -type instance XNPat GhcTc = Type - -type instance XNPlusKPat GhcPs = PlaceHolder -type instance XNPlusKPat GhcRn = PlaceHolder -type instance XNPlusKPat GhcTc = Type - -type instance XSigPat GhcPs = (LHsSigWcType GhcPs) -type instance XSigPat GhcRn = (LHsSigWcType GhcRn) -type instance XSigPat GhcTc = Type - -type instance XCoPat (GhcPass _) = PlaceHolder -type instance XXPat (GhcPass _) = PlaceHolder - --- --------------------------------------------------------------------- - +deriving instance (DataId p) => Data (Pat p) -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) @@ -451,24 +382,24 @@ data HsRecField' id arg = HsRecField { -- -- See also Note [Disambiguating record fields] in TcExpr. -hsRecFields :: HsRecFields p arg -> [XFieldOcc p] +hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)] hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) -- Probably won't typecheck at once, things have changed :/ hsRecFieldsArgs :: HsRecFields p arg -> [arg] hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) -hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass) -hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl +hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass)) +hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc +hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl @@ -482,8 +413,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Pat (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (Pat pass) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -495,12 +426,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LPat (GhcPass p) -> SDoc +pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> SDoc +pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -514,31 +443,29 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> SDoc -pprPat (VarPat _ (L _ var)) = pprPatBndr var +pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc +pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' -pprPat (LazyPat _ pat) = char '~' <> pprParendLPat pat -pprPat (BangPat _ pat) = char '!' <> pprParendLPat pat -pprPat (AsPat _ name pat) = hcat [ pprPrefixOcc (unLoc name), char '@' - , pprParendLPat pat] -pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat _ pat) = parens (ppr pat) -pprPat (LitPat _ s) = ppr s -pprPat (NPat _ l Nothing _) = ppr l -pprPat (NPat _ l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat _ n k _ _ _)= hcat [ppr n, char '+', ppr k] -pprPat (SplicePat _ splice) = pprSplice splice -pprPat (CoPat _ co pat _) = pprHsWrapper co (\parens -> if parens +pprPat (LazyPat pat) = char '~' <> pprParendLPat pat +pprPat (BangPat pat) = char '!' <> pprParendLPat pat +pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] +pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat pat) = parens (ppr pat) +pprPat (LitPat s) = ppr s +pprPat (NPat l Nothing _ _) = ppr l +pprPat (NPat l (Just _) _ _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k] +pprPat (SplicePat splice) = pprSplice splice +pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens then pprParendPat pat else pprPat pat) -pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty -pprPat (ListPat _ pats _ _) = brackets (interpp'SP pats) -pprPat (PArrPat _ pats) = paBrackets (interpp'SP pats) -pprPat (TuplePat _ pats bx) - = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) -pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) -pprPat (ConPatIn con details) = pprUserCon (unLoc con) details +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (ListPat pats _ _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) +pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity) +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) = sdocWithDynFlags $ \dflags -> @@ -551,16 +478,14 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, , ppr binds]) <+> pprConArgs details else pprUserCon (unLoc con) details -pprPat (XPat x) = ppr x -pprUserCon :: (SourceTextX (GhcPass p), OutputableBndr con, - OutputableBndrId (GhcPass p)) - => con -> HsConPatDetails (GhcPass p) -> SDoc + +pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p) + => con -> HsConPatDetails p -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsConPatDetails (GhcPass p) -> SDoc +pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats @@ -599,12 +524,9 @@ mkPrefixConPat dc pats tys mkNilPat :: Type -> OutPat p mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: (SourceTextX (GhcPass p)) - => SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat noExt - (HsCharPrim (setSourceText src) c)] - [] + [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] [] {- ************************************************************************ @@ -639,7 +561,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} isBangedLPat :: LPat p -> Bool -isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p +isBangedLPat (L _ (ParPat p)) = isBangedLPat p isBangedLPat (L _ (BangPat {})) = True isBangedLPat _ = False @@ -657,8 +579,8 @@ looksLazyPatBind _ = False looksLazyLPat :: LPat p -> Bool -looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p -looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p +looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p +looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p looksLazyLPat (L _ (BangPat {})) = False looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False @@ -685,14 +607,15 @@ isIrrefutableHsPat pat go1 (WildPat {}) = True go1 (VarPat {}) = True go1 (LazyPat {}) = True - go1 (BangPat _ pat) = go pat - go1 (CoPat _ _ pat _) = go1 pat - go1 (ParPat _ pat) = go pat - go1 (AsPat _ _ pat) = go pat - go1 (ViewPat _ _ pat) = go pat - go1 (SigPat _ pat) = go pat - go1 (TuplePat _ pats _) = all go pats - go1 (SumPat {}) = False + go1 (BangPat pat) = go pat + go1 (CoPat _ pat _) = go1 pat + go1 (ParPat pat) = go pat + go1 (AsPat _ pat) = go pat + go1 (ViewPat _ pat _) = go pat + go1 (SigPatIn pat _) = go pat + go1 (SigPatOut pat _) = go pat + go1 (TuplePat pats _ _) = all go pats + go1 (SumPat _ _ _ _) = False -- See Note [Unboxed sum patterns aren't irrefutable] go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? @@ -714,8 +637,6 @@ isIrrefutableHsPat pat -- since we cannot know until the splice is evaluated. go1 (SplicePat {}) = False - go1 (XPat {}) = False - {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as @@ -743,9 +664,10 @@ hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (SplicePat {}) = False hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) -hsPatNeedsParens (SigPat {}) = True +hsPatNeedsParens (SigPatIn {}) = True +hsPatNeedsParens (SigPatOut {}) = True hsPatNeedsParens (ViewPat {}) = True -hsPatNeedsParens (CoPat _ _ p _) = hsPatNeedsParens p +hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p hsPatNeedsParens (WildPat {}) = False hsPatNeedsParens (VarPat {}) = False hsPatNeedsParens (LazyPat {}) = False @@ -758,7 +680,6 @@ hsPatNeedsParens (ListPat {}) = False hsPatNeedsParens (PArrPat {}) = False hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False -hsPatNeedsParens (XPat {}) = True -- conservative default conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon {}) = False @@ -770,29 +691,30 @@ conPatNeedsParens (RecCon {}) = False -} -- May need to add more cases -collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar +collectEvVarsPats :: [Pat p] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat -collectEvVarsLPat :: LPat GhcTc -> Bag EvVar +collectEvVarsLPat :: LPat p -> Bag EvVar collectEvVarsLPat (L _ pat) = collectEvVarsPat pat -collectEvVarsPat :: Pat GhcTc -> Bag EvVar +collectEvVarsPat :: Pat p -> Bag EvVar collectEvVarsPat pat = case pat of - LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ p -> collectEvVarsLPat p - ParPat _ p -> collectEvVarsLPat p - BangPat _ p -> collectEvVarsLPat p - ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps - TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps - SumPat _ p _ _ -> collectEvVarsLPat p - PArrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps + LazyPat p -> collectEvVarsLPat p + AsPat _ p -> collectEvVarsLPat p + ParPat p -> collectEvVarsLPat p + BangPat p -> collectEvVarsLPat p + ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps + TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps + SumPat p _ _ _ -> collectEvVarsLPat p + PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps ConPatOut {pat_dicts = dicts, pat_args = args} - -> unionBags (listToBag dicts) + -> unionBags (listToBag dicts) $ unionManyBags $ map collectEvVarsLPat $ hsConPatArgs args - SigPat _ p -> collectEvVarsLPat p - CoPat _ _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" - _other_pat -> emptyBag + SigPatOut p _ -> collectEvVarsLPat p + CoPat _ p _ -> collectEvVarsPat p + ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn" + _other_pat -> emptyBag diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index eb090bdd8f..8cb82ed22e 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -4,19 +4,17 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE FlexibleInstances #-} module HsPat where import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import HsExtension ( SourceTextX, DataIdLR, OutputableBndrId, GhcPass ) +import HsExtension ( SourceTextX, DataId, OutputableBndrId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) -instance (DataIdLR p p) => Data (Pat p) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (Pat (GhcPass p)) +instance (DataId p) => Data (Pat p) +instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 4a3eca31c6..62bfa2e5c5 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -15,7 +15,6 @@ therefore, is almost nothing but re-exporting. {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} module HsSyn ( module HsBinds, @@ -111,10 +110,10 @@ data HsModule name -- hsmodImports,hsmodDecls if this style is used. -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR name name) => Data (HsModule name) +deriving instance (DataId name) => Data (HsModule name) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsModule (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsModule pass) where ppr (HsModule Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index be70fe8ec8..f5b4149f99 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -15,10 +15,9 @@ HsTypes: Abstract syntax: user-defined types -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} module HsTypes ( - HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, + HsType(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsImplicitBndrs(..), @@ -45,7 +44,7 @@ module HsTypes ( rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, - HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard, + HsWildCardInfo(..), mkAnonWildCardTy, wildCardName, sameWildCard, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, @@ -74,9 +73,8 @@ import GhcPrelude import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PlaceHolder, placeHolder ) +import PlaceHolder ( PlaceHolder(..) ) import HsExtension -import HsLit () -- for instances import Id ( Id ) import Name( Name ) @@ -112,11 +110,11 @@ type LBangType pass = Located (BangType pass) type BangType pass = HsType pass -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a -getBangType (L _ (HsBangTy _ _ ty)) = ty -getBangType ty = ty +getBangType (L _ (HsBangTy _ ty)) = ty +getBangType ty = ty getBangStrictness :: LHsType a -> HsSrcBang -getBangStrictness (L _ (HsBangTy _ s _)) = s +getBangStrictness (L _ (HsBangTy s _)) = s getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) {- @@ -272,11 +270,11 @@ data LHsQTyVars pass -- See Note [HsType binders] -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass) +deriving instance (DataId 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 +364,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? @@ -407,11 +405,9 @@ instance OutputableBndr HsIPName where -- | Haskell Type Variable Binder data HsTyVarBndr pass = UserTyVar -- no explicit kinding - (XUserTyVar pass) (Located (IdP pass)) -- See Note [Located RdrNames] in HsExpr | KindedTyVar - (XKindedTyVar pass) (Located (IdP pass)) (LHsKind pass) -- The user-supplied kind signature -- ^ @@ -419,20 +415,12 @@ data HsTyVarBndr pass -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - - | XTyVarBndr - (XXTyVarBndr pass) -deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass) - -type instance XUserTyVar (GhcPass _) = PlaceHolder -type instance XKindedTyVar (GhcPass _) = PlaceHolder -type instance XXTyVarBndr (GhcPass _) = PlaceHolder +deriving instance (DataId pass) => Data (HsTyVarBndr pass) -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar" -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars pass -> Bool @@ -441,22 +429,19 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] - { hst_xforall :: XForAllTy pass, - hst_bndrs :: [LHsTyVarBndr pass] + { hst_bndrs :: [LHsTyVarBndr pass] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType pass -- body type + , hst_body :: LHsType pass -- body type } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation | HsQualTy -- See Note [HsType binders] - { hst_xqual :: XQualTy pass - , hst_ctxt :: LHsContext pass -- Context C => blah - , hst_body :: LHsType pass } + { hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } - | HsTyVar (XTyVar pass) - Promoted -- whether explicitly promoted, for the pretty + | HsTyVar Promoted -- whether explicitly promoted, for the pretty -- printer (Located (IdP pass)) -- Type variable, type constructor, or data constructor @@ -466,62 +451,53 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy (XAppsTy pass) - [LHsAppType pass] -- Used only before renaming, + | HsAppsTy [LHsAppType pass] -- Used only before renaming, -- Note [HsAppsTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None - | HsAppTy (XAppTy pass) - (LHsType pass) + | HsAppTy (LHsType pass) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsFunTy (XFunTy pass) - (LHsType pass) -- function type + | HsFunTy (LHsType pass) -- function type (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsListTy (XListTy pass) - (LHsType pass) -- Element type + | HsListTy (LHsType pass) -- Element type -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPArrTy (XPArrTy pass) - (LHsType pass) -- Elem. type of parallel array: [:t:] + | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsTupleTy (XTupleTy pass) - HsTupleSort + | HsTupleTy HsTupleSort [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, -- 'ApiAnnotation.AnnClose' @')' or '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSumTy (XSumTy pass) - [LHsType pass] -- Element types (length gives arity) + | HsSumTy [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (XOpTy pass) - (LHsType pass) (Located (IdP pass)) (LHsType pass) + | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsParTy (XParTy pass) - (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr + | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, @@ -529,8 +505,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsIParamTy (XIParamTy pass) - (Located HsIPName) -- (?x :: ty) + | HsIParamTy (Located HsIPName) -- (?x :: ty) (LHsType pass) -- Implicit parameters as they occur in -- contexts -- ^ @@ -540,8 +515,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsEqTy (XEqTy pass) - (LHsType pass) -- ty1 ~ ty2 + | HsEqTy (LHsType pass) -- ty1 ~ ty2 (LHsType pass) -- Always allowed even without -- TypeOperators, and has special -- kinding rule @@ -552,8 +526,7 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsKindSig (XKindSig pass) - (LHsType pass) -- (ty :: kind) + | HsKindSig (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) @@ -563,21 +536,19 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes + | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes + (PostTc pass Kind) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type + | HsDocTy (LHsType pass) LHsDocString -- A documented type -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsBangTy (XBangTy pass) - HsSrcBang (LHsType pass) -- Bang-style type annotations + | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, -- 'ApiAnnotation.AnnClose' @'#-}'@ @@ -585,22 +556,21 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsRecTy (XRecTy pass) - [LConDeclField pass] -- Only in data type declarations + | HsRecTy [LConDeclField pass] -- Only in data type declarations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* - -- -- Core Type through HsSyn. - -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None + | HsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitListTy -- A promoted explicit list - (XExplicitListTy pass) Promoted -- whether explcitly promoted, for pretty printer + (PostTc pass Kind) -- See Note [Promoted lists and tuples] [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, -- 'ApiAnnotation.AnnClose' @']'@ @@ -608,78 +578,24 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitTupleTy -- A promoted explicit tuple - (XExplicitTupleTy pass) + [PostTc pass Kind] -- See Note [Promoted lists and tuples] [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + | HsTyLit HsTyLit -- A promoted numeric literal. -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (XWildCardTy pass) -- A type wildcard + | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard -- See Note [The wildcard story for types] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - - -- For adding new constructors via Trees that Grow - | XHsType - (XXType pass) -deriving instance (DataIdLR pass pass) => Data (HsType pass) - -data NewHsTypeX - = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. - deriving Data - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - -instance Outputable NewHsTypeX where - ppr (NHsCoreTy ty) = ppr ty - -type instance XForAllTy (GhcPass _) = PlaceHolder -type instance XQualTy (GhcPass _) = PlaceHolder -type instance XTyVar (GhcPass _) = PlaceHolder -type instance XAppsTy (GhcPass _) = PlaceHolder -type instance XAppTy (GhcPass _) = PlaceHolder -type instance XFunTy (GhcPass _) = PlaceHolder -type instance XListTy (GhcPass _) = PlaceHolder -type instance XPArrTy (GhcPass _) = PlaceHolder -type instance XTupleTy (GhcPass _) = PlaceHolder -type instance XSumTy (GhcPass _) = PlaceHolder -type instance XOpTy (GhcPass _) = PlaceHolder -type instance XParTy (GhcPass _) = PlaceHolder -type instance XIParamTy (GhcPass _) = PlaceHolder -type instance XEqTy (GhcPass _) = PlaceHolder -type instance XKindSig (GhcPass _) = PlaceHolder - -type instance XSpliceTy GhcPs = PlaceHolder -type instance XSpliceTy GhcRn = PlaceHolder -type instance XSpliceTy GhcTc = Kind - -type instance XDocTy (GhcPass _) = PlaceHolder -type instance XBangTy (GhcPass _) = PlaceHolder -type instance XRecTy (GhcPass _) = PlaceHolder - -type instance XExplicitListTy GhcPs = PlaceHolder -type instance XExplicitListTy GhcRn = PlaceHolder -type instance XExplicitListTy GhcTc = Kind - -type instance XExplicitTupleTy GhcPs = PlaceHolder -type instance XExplicitTupleTy GhcRn = PlaceHolder -type instance XExplicitTupleTy GhcTc = [Kind] - -type instance XTyLit (GhcPass _) = PlaceHolder - -type instance XWildCardTy GhcPs = PlaceHolder -type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn -type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc - -type instance XXType (GhcPass _) = NewHsTypeX - +deriving instance (DataId pass) => Data (HsType pass) -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -689,8 +605,7 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data --- AZ: fold this into the XWildCardTy completely, removing the type -newtype HsWildCardInfo pass -- See Note [The wildcard story for types] +newtype HsWildCardInfo pass -- See Note [The wildcard story for types] = AnonWildCard (PostRn pass (Located Name)) -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming @@ -702,21 +617,12 @@ type LHsAppType pass = Located (HsAppType pass) -- | Haskell Application Type data HsAppType pass - = HsAppInfix (XAppInfix pass) - (Located (IdP pass)) -- either a symbol or an id in backticks - | HsAppPrefix (XAppPrefix pass) - (LHsType pass) -- anything else, including things like (+) - - | XAppType - (XXAppType pass) -deriving instance (DataIdLR pass pass) => Data (HsAppType pass) - -type instance XAppInfix (GhcPass _) = PlaceHolder -type instance XAppPrefix (GhcPass _) = PlaceHolder -type instance XXAppType (GhcPass _) = PlaceHolder + = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks + | HsAppPrefix (LHsType pass) -- anything else, including things like (+) +deriving instance (DataId pass) => Data (HsAppType pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsAppType (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsAppType pass) where ppr = ppr_app_ty {- @@ -858,10 +764,10 @@ data ConDeclField pass -- Record fields have Haddoc docs on them -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (ConDeclField pass) +deriving instance (DataId pass) => Data (ConDeclField pass) -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (ConDeclField (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (ConDeclField pass) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -883,11 +789,11 @@ instance (Outputable arg, Outputable rec) -- parser and rejigs them using information about fixities from the renamer. -- See Note [Sorting out the result type] in RdrHsSyn updateGadtResult - :: (Monad m, OutputableX GhcRn) + :: (Monad m) => (SDoc -> m ()) -> SDoc -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -- ^ Original details + -- ^ Original details -> LHsType GhcRn -- ^ Original result type -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), LHsType GhcRn) @@ -968,9 +874,8 @@ I don't know if this is a good idea, but there it is. --------------------- hsTyVarName :: HsTyVarBndr pass -> IdP pass -hsTyVarName (UserTyVar _ (L _ n)) = n -hsTyVarName (KindedTyVar _ (L _ n) _) = n -hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName" +hsTyVarName (UserTyVar (L _ n)) = n +hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr pass -> IdP pass hsLTyVarName = hsTyVarName . unLoc @@ -991,17 +896,15 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) +hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n - cvt (KindedTyVar _ (L name_loc n) kind) - = HsKindSig noExt - (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType" + where cvt (UserTyVar n) = HsTyVar NotPromoted n + cvt (KindedTyVar (L name_loc n) kind) + = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] +hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- @@ -1014,9 +917,9 @@ sameWildCard :: Located (HsWildCardInfo pass) sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 ignoreParens :: LHsType pass -> LHsType pass -ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty -ignoreParens (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = ignoreParens ty -ignoreParens ty = ty +ignoreParens (L _ (HsParTy ty)) = ignoreParens ty +ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty +ignoreParens ty = ty {- ************************************************************************ @@ -1027,17 +930,15 @@ ignoreParens ty = ty -} mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExt +mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) -mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) - -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2 +mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass +mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 -mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExt t1 t2) +mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass +mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) -mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] - -> LHsType (GhcPass p) +mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass mkHsAppTys = foldl mkHsAppTy @@ -1056,37 +957,36 @@ mkHsAppTys = foldl mkHsAppTy -- Also deals with (->) t1 t2; that is why it only works on LHsType Name -- (see Trac #9096) splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) -splitHsFunType (L _ (HsParTy _ ty)) +splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty -splitHsFunType (L _ (HsFunTy _ x y)) +splitHsFunType (L _ (HsFunTy x y)) | (args, res) <- splitHsFunType y = (x:args, res) -splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) +splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName + go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) - go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy _ ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match + go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match splitHsFunType other = ([], other) -------------------------------- -- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, -- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType (GhcPass p)] - -> Maybe ( LHsType (GhcPass p) - , [LHsType (GhcPass p)], LexicalFixity) +getAppsTyHead_maybe :: [LHsAppType pass] + -> Maybe (LHsType pass, [LHsType pass], LexicalFixity) getAppsTyHead_maybe tys = case splitHsAppsTy tys of ([app1:apps], []) -> -- no symbols, some normal types Just (mkHsAppTys app1 apps, [], Prefix) ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator - Just ( L loc (HsTyVar noExt NotPromoted (L loc op)) + Just ( L loc (HsTyVar NotPromoted (L loc op)) , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) _ -> -- can't figure it out Nothing @@ -1101,36 +1001,35 @@ splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)]) splitHsAppsTy = go [] [] [] where go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) - go acc acc_non acc_sym (L _ (HsAppPrefix _ ty) : rest) + go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest) = go (ty : acc) acc_non acc_sym rest - go acc acc_non acc_sym (L _ (HsAppInfix _ op) : rest) + go acc acc_non acc_sym (L _ (HsAppInfix op) : rest) = go [] (reverse acc : acc_non) (op : acc_sym) rest - go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy" -- Retrieve the name of the "head" of a nested type application -- somewhat like splitHsAppTys, but a little more thorough -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)]) +hsTyGetAppHead_maybe :: LHsType pass + -> Maybe (Located (IdP pass), [LHsType pass]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys) - go tys (L _ (HsAppsTy _ apps)) + go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) + go tys (L _ (HsAppsTy apps)) | Just (head, args, _) <- getAppsTyHead_maybe apps - = go (args ++ tys) head - go tys (L _ (HsAppTy _ l r)) = go (r : tys) l - go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys) - go tys (L _ (HsParTy _ t)) = go tys t - go tys (L _ (HsKindSig _ t _)) = go tys t + = go (args ++ tys) head + go tys (L _ (HsAppTy l r)) = go (r : tys) l + go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys) + go tys (L _ (HsParTy t)) = go tys t + go tys (L _ (HsKindSig t _)) = go tys t go _ _ = Nothing splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn] -> (LHsType GhcRn, [LHsType GhcRn]) -- no need to worry about HsAppsTy here -splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as) -splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as -splitHsAppTys f as = (f,as) +splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) +splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as +splitHsAppTys f as = (f,as) -------------------------------- splitLHsPatSynTy :: LHsType pass @@ -1155,12 +1054,12 @@ splitLHsSigmaTy ty splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy (L _ (HsParTy _ t)) = splitLHsForAllTy t +splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t splitLHsForAllTy body = ([], body) splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy (L _ (HsParTy _ t)) = splitLHsQualTy t +splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t splitLHsQualTy body = (noLoc [], body) splitLHsInstDeclTy :: LHsSigType GhcRn @@ -1178,8 +1077,7 @@ getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty) = body_ty -getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) +getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass)) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -1202,28 +1100,19 @@ type LFieldOcc pass = Located (FieldOcc pass) -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass - , rdrNameFieldOcc :: Located RdrName +data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr + , selectorFieldOcc :: PostRn pass (IdP pass) } - - | XFieldOcc - (XXFieldOcc pass) -deriving instance (Eq (XFieldOcc (GhcPass p))) => Eq (FieldOcc (GhcPass p)) -deriving instance (Ord (XFieldOcc (GhcPass p))) => Ord (FieldOcc (GhcPass p)) +deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass) +deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass) deriving instance (DataId pass) => Data (FieldOcc pass) -type instance XFieldOcc GhcPs = PlaceHolder -type instance XFieldOcc GhcRn = Name -type instance XFieldOcc GhcTc = Id - -type instance XXFieldOcc (GhcPass _) = PlaceHolder - instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc placeHolder rdr +mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- | Ambiguous Field Occurrence @@ -1239,51 +1128,34 @@ mkFieldOcc rdr = FieldOcc placeHolder rdr -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (Located RdrName) - | Ambiguous (XAmbiguous pass) (Located RdrName) - | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) + = Unambiguous (Located RdrName) (PostRn pass (IdP pass)) + | Ambiguous (Located RdrName) (PostTc pass (IdP pass)) deriving instance DataId pass => Data (AmbiguousFieldOcc pass) -type instance XUnambiguous GhcPs = PlaceHolder -type instance XUnambiguous GhcRn = Name -type instance XUnambiguous GhcTc = Id - -type instance XAmbiguous GhcPs = PlaceHolder -type instance XAmbiguous GhcRn = PlaceHolder -type instance XAmbiguous GhcTc = Id - -type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder - -instance Outputable (AmbiguousFieldOcc (GhcPass p)) where +instance Outputable (AmbiguousFieldOcc pass) where ppr = ppr . rdrNameAmbiguousFieldOcc -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where +instance OutputableBndr (AmbiguousFieldOcc pass) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr +mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "rdrNameAmbiguousFieldOcc" +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous sel _) = sel -selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "selectorAmbiguousFieldOcc" +selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel +selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc" -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" +ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass +ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel {- ************************************************************************ @@ -1293,22 +1165,21 @@ ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" ************************************************************************ -} -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsType (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsType pass) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (LHsQTyVars (GhcPass p)) where +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (LHsQTyVars pass) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Outputable (HsTyVarBndr (GhcPass p)) where - ppr (UserTyVar _ n) = ppr n - ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] - ppr (XTyVarBndr n) = ppr n +instance (SourceTextX pass, OutputableBndrId pass) + => Outputable (HsTyVarBndr pass) where + ppr (UserTyVar n) = ppr n + ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where ppr (HsIB { hsib_body = ty }) = ppr ty @@ -1319,11 +1190,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where instance Outputable (HsWildCardInfo pass) where ppr (AnonWildCard _) = char '_' -pprAnonWildCard :: SDoc -pprAnonWildCard = char '_' - -pprHsForAll :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc +pprHsForAll :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints @@ -1333,44 +1201,44 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc +pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass) + => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass + -> SDoc pprHsForAllExtra extra qtvs cxt = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where show_extra = isJust extra -pprHsForAllTvs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LHsTyVarBndr (GhcPass p)] -> SDoc +pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass) + => [LHsTyVarBndr pass] -> SDoc pprHsForAllTvs qtvs | null qtvs = whenPprDebug (forAllLit <+> dot) | otherwise = forAllLit <+> interppSP qtvs <> dot -pprHsContext :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContext :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> Maybe SDoc +pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc +pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass) + => HsContext pass -> SDoc pprHsContextAlways [] = parens empty <+> darrow pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Bool -> HsContext (GhcPass p) -> SDoc +pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass) + => Bool -> HsContext pass -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1381,8 +1249,8 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => [LConDeclField (GhcPass p)] -> SDoc +pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass) + => [LConDeclField pass] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1406,79 +1274,76 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsType (GhcPass p) -> SDoc +pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsType (GhcPass p) -> SDoc +ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass) + => HsType pass -> SDoc ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = sep [pprHsForAllTvs tvs, ppr_mono_lty ty] ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) = sep [pprHsContextAlways ctxt, ppr_mono_lty ty] -ppr_mono_ty (XHsType t) = ppr t -ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty -ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds -ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name -ppr_mono_ty (HsTyVar _ Promoted (L _ name)) +ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty +ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds +ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name +ppr_mono_ty (HsTyVar Promoted (L _ name)) = space <> quote (pprPrefixOcc name) -- We need a space before the ' above, so the parser -- does not attach it to the previous symbol -ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 -ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys) +ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2 +ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple -ppr_mono_ty (HsSumTy _ tys) - = tupleParens UnboxedTuple (pprWithBars ppr tys) -ppr_mono_ty (HsKindSig _ ty kind) - = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind) -ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) -ppr_mono_ty (HsPArrTy _ ty) = paBrackets (ppr_mono_lty ty) -ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy _ s) = pprSplice s -ppr_mono_ty (HsExplicitListTy _ Promoted tys) +ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind) +ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy s _) = pprSplice s +ppr_mono_ty (HsCoreTy ty) = ppr ty +ppr_mono_ty (HsExplicitListTy Promoted _ tys) = quote $ brackets (interpp'SP tys) -ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) +ppr_mono_ty (HsExplicitListTy NotPromoted _ tys) = brackets (interpp'SP tys) ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) -ppr_mono_ty (HsTyLit _ t) = ppr_tylit t -ppr_mono_ty (HsWildCardTy {}) = char '_' +ppr_mono_ty (HsTyLit t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' -ppr_mono_ty (HsEqTy _ ty1 ty2) +ppr_mono_ty (HsEqTy ty1 ty2) = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2 -ppr_mono_ty (HsAppsTy _ tys) +ppr_mono_ty (HsAppsTy tys) = hsep (map (ppr_app_ty . unLoc) tys) -ppr_mono_ty (HsAppTy _ fun_ty arg_ty) +ppr_mono_ty (HsAppTy fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) +ppr_mono_ty (HsOpTy ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] -ppr_mono_ty (HsParTy _ ty) +ppr_mono_ty (HsParTy ty) = parens (ppr_mono_lty ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them -ppr_mono_ty (HsDocTy _ ty doc) +ppr_mono_ty (HsDocTy ty doc) -- AZ: Should we add parens? Should we introduce "-- ^"? = ppr_mono_lty ty <+> ppr (unLoc doc) -- we pretty print Haddock comments on types as if they were -- postfix operators -------------------------- -ppr_fun_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass) + => LHsType pass -> LHsType pass -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 @@ -1486,17 +1351,16 @@ ppr_fun_ty ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => HsAppType (GhcPass p) -> SDoc -ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n -ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n)))) +ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass) + => HsAppType pass -> SDoc +ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n +ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) = pprPrefixOcc n -ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ Promoted (L _ n)))) +ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n)))) = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so -- the parser does not attach it to the -- previous symbol -ppr_app_ty (HsAppPrefix _ ty) = ppr_mono_lty ty -ppr_app_ty (XAppType ty) = ppr ty +ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty -------------------------- ppr_tylit :: HsTyLit -> SDoc diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index e5f0fb6187..8e17994993 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -50,7 +50,7 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlTuplePat, mkParPat, nlParPat, + nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types @@ -140,8 +140,8 @@ from their components, compared with the nl* functions below which just attach noSrcSpan to everything. -} -mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = L (getLoc e) (HsPar noExt e) +mkHsPar :: LHsExpr id -> LHsExpr id +mkHsPar e = L (getLoc e) (HsPar e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id)) -> [LPat id] -> Located (body id) @@ -174,21 +174,20 @@ mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms -mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) +mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) -mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType t e) +mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name +mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t) -mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn +mkHsAppTypes :: LHsExpr name -> [LHsWcType name] -> LHsExpr name mkHsAppTypes = foldl mkHsAppType --- AZ:TODO this can go, in favour of mkHsAppType. ? mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc -mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppType t e) +mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats body] @@ -203,35 +202,35 @@ mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) -nlHsTyApp fun_id tys - = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id))) +nlHsTyApp :: IdP name -> [Type] -> LHsExpr name +nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) -nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) +nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- -mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsPar :: LHsExpr name -> LHsExpr name -- Wrap in parens if hsExprNeedsParens says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le) +mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) | otherwise = le -mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp) +mkParPat :: LPat name -> LPat name +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) | otherwise = lp -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLoc (ParPat noExt p) +nlParPat :: LPat name -> LPat name +nlParPat p = noLoc (ParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: IntegralLit -> HsOverLit GhcPs -mkHsFractional :: FractionalLit -> HsOverLit GhcPs -mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs +mkHsIntegral :: IntegralLit -> PostTc GhcPs Type + -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type + -> HsOverLit GhcPs mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs @@ -240,72 +239,60 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: SourceTextX (GhcPass idR) - => Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkLastStmt :: SourceTextX idR + => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR idL GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => LPat idL -> Located (bodyR idR) + -> StmtLR idL idR (Located (bodyR idR)) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) -emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmt :: StmtLR idL GhcPs bodyR emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR -mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr -mkHsFractional f = OverLit noExt (HsFractional f) noExpr -mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr +mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr +mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr noRebindableInfo :: PlaceHolder -noRebindableInfo = placeHolder -- Just another placeholder; +noRebindableInfo = PlaceHolder -- Just another placeholder; -mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) +mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: SourceTextX (GhcPass p) - => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) - -> HsExpr (GhcPass p) -mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b - -mkNPat lit neg = NPat noExt lit neg noSyntaxExpr -mkNPlusKPat id lit - = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr - -mkTransformStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkTransformByStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkGroupUsingStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkGroupByUsingStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) - -emptyTransStmt :: (SourceTextX (GhcPass idR), - PostTc (GhcPass idR) Type ~ PlaceHolder) - => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR)) +mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p +mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b + +mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType +mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType + +mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) + +emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) + => StmtLR idL idR (LHsExpr idR) 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,12 +301,12 @@ 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 -emptyRecStmt' :: forall idL idR body. SourceTextX (GhcPass idR) => - PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body +emptyRecStmt' :: forall idL idR body. SourceTextX idR => + PostTc idR Type -> StmtLR idL idR body emptyRecStmt' tyVal = RecStmt { recS_stmts = [], recS_later_ids = [] @@ -338,29 +325,28 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2 +mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) + (error "mkOpApp:fixity") e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e +mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e) +mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceTE hasParen e - = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e) +mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs -mkHsSpliceTy hasParen e = HsSpliceTy noExt - (HsUntypedSplice noExt hasParen unqualSplice e) +mkHsSpliceTy hasParen e + = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote - = HsQuasiQuote noExt unqualSplice quoter span quote +mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) @@ -375,15 +361,13 @@ mkHsStringPrimLit fs = HsStringPrim noSourceText (fastStringToByteString fs) ------------- -userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] - -> [LHsTyVarBndr (GhcPass p)] +userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name] -- Caller sets location -userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ] +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] -userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] +userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) - | v <- bndrs ] +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] {- @@ -394,30 +378,29 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) ************************************************************************ -} -nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) -nlHsVar n = noLoc (HsVar noExt (noLoc n)) +nlHsVar :: IdP id -> LHsExpr id +nlHsVar n = noLoc (HsVar (noLoc n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con)) +nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) -nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLoc (HsLit noExt n) +nlHsLit :: HsLit p -> LHsExpr p +nlHsLit n = noLoc (HsLit n) -nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) +nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p +nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n))) -nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) -nlVarPat n = noLoc (VarPat noExt (noLoc n)) +nlVarPat :: IdP id -> LPat id +nlVarPat n = noLoc (VarPat (noLoc n)) -nlLitPat :: HsLit GhcPs -> LPat GhcPs -nlLitPat l = noLoc (LitPat noExt l) +nlLitPat :: HsLit p -> LPat p +nlLitPat l = noLoc (LitPat l) -nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x)) +nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsApp f x = noLoc (HsApp f (mkLHsPar x)) -nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) +nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id nlHsSyntaxApps (SyntaxExpr { syn_expr = fun , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) args @@ -429,14 +412,13 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) -nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs -nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f)) - (map ((HsVar noExt) . noLoc) xs)) +nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id +nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) where - mk f a = HsApp noExt (noLoc f) (noLoc a) + mk f a = HsApp (noLoc f) (noLoc a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -462,49 +444,50 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat))) nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking +nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking +nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking + +nlWildPatId :: LPat GhcTc +nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) -nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) - -> LHsExpr (GhcPass id) +nlHsPar :: LHsExpr id -> LHsExpr id +nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar noExt e) +nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar e) -- Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false) +nlHsIf cond true false = noLoc (HsIf Nothing cond true false) -nlHsCase expr matches - = noLoc (HsCase noExt expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList noExt Nothing exprs) +nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) -nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) -nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsAppTy :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: IdP name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name +nlHsParTy :: LHsType name -> LHsType name -nlHsAppTy f t = noLoc (HsAppTy noExt f t) -nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExt a b) -nlHsParTy t = noLoc (HsParTy noExt t) +nlHsAppTy f t = noLoc (HsAppTy f t) +nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) +nlHsFunTy a b = noLoc (HsFunTy a b) +nlHsParTy t = noLoc (HsParTy t) -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys {- @@ -512,38 +495,37 @@ Tuples. All these functions are *pre-typechecker* because they lack types on the tuple. -} -mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) +mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e -mkLHsTupleExpr es - = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed +mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed -mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) +mkLHsVarTuple :: [IdP a] -> LHsExpr a mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) -nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs -nlTuplePat pats box = noLoc (TuplePat noExt pats box) +nlTuplePat :: [LPat id] -> Boxity -> LPat id +nlTuplePat pats box = noLoc (TuplePat pats box []) missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing noExt +missingTupArg = Missing placeHolderType -mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed +mkLHsPatTup :: [LPat id] -> LPat id +mkLHsPatTup [] = noLoc $ TuplePat [] Boxed [] mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed +mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed [] -- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsVarTup :: [IdP id] -> LHsExpr id mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) -mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsTup :: [LHsExpr id] -> LHsExpr id mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn +mkBigLHsVarPatTup :: [IdP id] -> LPat id mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) -mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkBigLHsPatTup :: [LPat id] -> LPat id mkBigLHsPatTup = mkChunkified mkLHsPatTup -- $big_tuples @@ -650,18 +632,16 @@ typeToLHsType ty | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_xqual = noExt , hst_body = go tau }) go (FunTy arg res) = nlHsFunTy (go arg) (go res) go ty@(ForAllTy {}) | (tvs, tau) <- tcSplitForAllTys ty = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs - , hst_xforall = noExt , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) - go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExt (HsNumTy noSourceText n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOutInvisibleTypes tc args @@ -672,7 +652,7 @@ typeToLHsType ty -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv)) + go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) (go (tyVarKind tv)) @@ -682,41 +662,41 @@ typeToLHsType ty * * ********************************************************************* -} -mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr -mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap noExt co_fn e +mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = HsWrap co_fn e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr id -> HsExpr id mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr id -> HsExpr id mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) -mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) +mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExt w cmd + | otherwise = HsCmdWrap w cmd -mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) +mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExt co_fn p ty + | otherwise = CoPat co_fn p ty -mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExt (mkWpCastN co) pat ty + | otherwise = CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -789,16 +769,14 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) - -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) - -> Located (HsLocalBinds (GhcPass p)) - -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) +mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p + -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p) mkMatch ctxt pats expr lbinds = noLoc (Match { m_ctxt = ctxt , m_pats = map paren pats , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp) + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) | otherwise = lp {- @@ -886,15 +864,13 @@ isBangedHsBind (PatBind {pat_lhs = pat}) isBangedHsBind _ = False -collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) - -> [IdP (GhcPass idL)] +collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL] collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsIdBinders, collectHsValBinders - :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] +collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL] -- Collect Id binders only, or Ids + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False @@ -910,11 +886,9 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] -- Same as collectHsBindsBinders, but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) - -> [IdP (GhcPass idL)] -collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] -collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) - = collect_out_binds ps binds +collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL] +collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] @@ -929,7 +903,7 @@ collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds - + -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc @@ -944,27 +918,23 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] +collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] +collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] +collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] +collectStmtBinders :: StmtLR idL idR body -> [IdP idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? 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{} = [] @@ -982,33 +952,33 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass] collect_lpat (L _ pat) bndrs = go pat where - go (VarPat _ (L _ var)) = var : bndrs + go (VarPat (L _ var)) = var : bndrs go (WildPat _) = bndrs - go (LazyPat _ pat) = collect_lpat pat bndrs - go (BangPat _ pat) = collect_lpat pat bndrs - go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs - go (ViewPat _ _ pat) = collect_lpat pat bndrs - go (ParPat _ pat) = collect_lpat pat bndrs + go (LazyPat pat) = collect_lpat pat bndrs + go (BangPat pat) = collect_lpat pat bndrs + go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (ViewPat _ pat _) = collect_lpat pat bndrs + go (ParPat pat) = collect_lpat pat bndrs - go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats - go (PArrPat _ pats) = foldr collect_lpat bndrs pats - go (TuplePat _ pats _) = foldr collect_lpat bndrs pats - go (SumPat _ pat _ _) = collect_lpat pat bndrs + go (ListPat pats _ _) = foldr collect_lpat bndrs pats + go (PArrPat pats _) = foldr collect_lpat bndrs pats + go (TuplePat pats _ _) = foldr collect_lpat bndrs pats + go (SumPat pat _ _ _) = collect_lpat pat bndrs go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs + go (LitPat _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs - go (SigPat _ pat) = collect_lpat pat bndrs + go (SigPatIn pat _) = collect_lpat pat bndrs + go (SigPatOut 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 - go (XPat {}) = bndrs + go (SplicePat _) = bndrs + go (CoPat _ pat _) = go pat {- Note [Dictionary binders in ConPatOut] See also same Note in DsArrows @@ -1057,7 +1027,7 @@ hsTyClForeignBinders tycl_decls foreign_decls foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs + getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs ------------------- hsLTyClDeclBinders :: Located (TyClDecl pass) @@ -1092,11 +1062,11 @@ hsForeignDeclsBinders foreign_decls ------------------- -hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] +hsPatSynSelectors :: HsValBinds p -> [IdP p] -- Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" -hsPatSynSelectors (XValBindsLR (NValBinds binds _)) +hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBindsOut binds _) = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] @@ -1153,11 +1123,11 @@ hsConDeclsBinders cons = go id cons L loc (ConDeclGADT { con_names = names , con_type = HsIB { hsib_body = res_ty}}) -> case tau of - L _ (HsFunTy _ - (L _ (HsAppsTy _ - [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) _) + L _ (HsFunTy + (L _ (HsAppsTy + [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty) -> record_gadt flds - L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty) + L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) -> record_gadt flds _other -> (map (L loc . unLoc) names ++ ns, fs) @@ -1218,16 +1188,13 @@ The main purpose is to find names introduced by record wildcards so that we can warning the user when they don't use those names (#4404) -} -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> NameSet +lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> NameSet + hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet - hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) - -> NameSet + hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) where do_arg (_, ApplicativeArgOne pat _ _) = lPatImplicits pat @@ -1235,8 +1202,7 @@ 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 @@ -1244,10 +1210,10 @@ lStmtsImplicits = hs_lstmts hs_local_binds (HsIPBinds _) = emptyNameSet hs_local_binds EmptyLocalBinds = emptyNameSet -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet -hsValBindsImplicits (XValBindsLR (NValBinds binds _)) +hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBinds _ binds _) +hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet @@ -1263,17 +1229,18 @@ lPatImplicits = hs_lpat hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet - hs_pat (LazyPat _ pat) = hs_lpat pat - hs_pat (BangPat _ pat) = hs_lpat pat - hs_pat (AsPat _ _ pat) = hs_lpat pat - hs_pat (ViewPat _ _ pat) = hs_lpat pat - hs_pat (ParPat _ pat) = hs_lpat pat - hs_pat (ListPat _ pats _ _) = hs_lpats pats - hs_pat (PArrPat _ pats) = hs_lpats pats - hs_pat (TuplePat _ pats _) = hs_lpats pats - - hs_pat (SigPat _ pat) = hs_lpat pat - hs_pat (CoPat _ _ pat _) = hs_pat pat + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _ _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat hs_pat (ConPatIn _ ps) = details ps hs_pat (ConPatOut {pat_args=ps}) = details ps diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 9d99c9a3cb..0b4711a364 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -6,9 +6,10 @@ module PlaceHolder where -import GhcPrelude ( Eq(..), Ord(..) ) +import GhcPrelude () -import Outputable hiding ( (<>) ) +import Type ( Type ) +import Outputable import Name import NameSet import RdrName @@ -30,23 +31,29 @@ import Data.Data hiding ( Fixity ) -- | used as place holder in PostTc and PostRn values data PlaceHolder = PlaceHolder - deriving (Data,Eq,Ord) + deriving (Data) -instance Outputable PlaceHolder where - ppr _ = text "PlaceHolder" +placeHolderKind :: PlaceHolder +placeHolderKind = PlaceHolder -placeHolder :: PlaceHolder -placeHolder = PlaceHolder +placeHolderFixity :: PlaceHolder +placeHolderFixity = 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] diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 23e5c9289a..48b8eccaca 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -102,7 +102,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1012c25b28..e63d6e3a95 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -871,8 +871,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc let_stmt = L loc . LetStmt . L loc . HsValBinds $ - ValBinds noExt - (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt updateFixityEnv fix_env @@ -895,7 +894,7 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 51ce8637a4..d4a26895d6 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1739,15 +1739,13 @@ ctype :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 - , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1, mj AnnDot $3] } | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 - , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) [mu AnnDcolon $2] } | type { $1 } @@ -1766,15 +1764,13 @@ ctypedoc :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 - , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1,mj AnnDot $3] } | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 - , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) [mu AnnDcolon $2] } | typedoc { $1 } @@ -1826,32 +1822,31 @@ is connected to the first type too. type :: { LHsType GhcPs } : btype { $1 } | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExt $1 $3) + >> ams (sLL $1 $> $ HsFunTy $1 $3) [mu AnnRarrow $2] } typedoc :: { LHsType GhcPs } : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy noExt $1 $3) + | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } + | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ - HsFunTy noExt (L (comb2 $1 $2) - (HsDocTy noExt $1 $2)) + HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4) [mu AnnRarrow $3] } -- See Note [Parsing ~] btype :: { LHsType GhcPs } : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ HsAppsTy noExt ts } + \ts -> return $ sL1 $1 $ HsAppsTy ts } -- Used for parsing Haskell98-style data constructors, -- in order to forbid the blasphemous -- > data Foo = Int :+ Char :* Bool -- See also Note [Parsing data constructors is hard] in RdrHsSyn btype_no_ops :: { LHsType GhcPs } - : btype_no_ops atype { sLL $1 $> $ HsAppTy noExt $1 $2 } + : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } | atype { $1 } tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed @@ -1860,57 +1855,58 @@ tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed -- See Note [HsAppsTy] in HsTypes tyapp :: { LHsAppType GhcPs } - : atype { sL1 $1 $ HsAppPrefix noExt $1 } - | qtyconop { sL1 $1 $ HsAppInfix noExt $1 } - | tyvarop { sL1 $1 $ HsAppInfix noExt $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix noExt $2) + : atype { sL1 $1 $ HsAppPrefix $1 } + | qtyconop { sL1 $1 $ HsAppInfix $1 } + | tyvarop { sL1 $1 $ HsAppInfix $1 } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2) [mj AnnSimpleQuote $1] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix noExt $2) + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) [mj AnnSimpleQuote $1] } atype :: { LHsType GhcPs } - : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples]) - | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2)) + : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) + | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy noExt $2)) + (sLL $1 $> $ HsRecTy $2)) -- Constructor sigs only [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExt + | '(' ')' {% ams (sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple []) [mop $1,mcp $2] } | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsTupleTy noExt + ams (sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple ($2 : $4)) [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple []) + | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2) + | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExt $2) + | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2) [mo $1,mc $3] } - | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy noExt $2) [mos $1,mcs $3] } - | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy noExt $2) [mo $1,mc $3] } - | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy noExt $2) [mop $1,mcp $3] } - | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig noExt $2 $4) + | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } + | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } + | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } + | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) [mop $1,mu AnnDcolon $3,mcp $5] } - | quasiquote { sL1 $1 (HsSpliceTy noExt (unLoc $1)) } + | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $ + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $ (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5)) + ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3) + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted + placeHolderKind $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -1919,12 +1915,13 @@ atype :: { LHsType GhcPs } -- so you have to quote those.) | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4)) + ams (sLL $1 $> $ HsExplicitListTy NotPromoted + placeHolderKind ($2 : $4)) [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1) - (il_value (getINTEGER $1)) } - | STRING { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1) - (getSTRING $1) } + | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) + (il_value (getINTEGER $1)) } + | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } | '_' { sL1 $1 $ mkAnonWildCardTy } -- An inst_type is what occurs in the head of an instance decl @@ -1959,8 +1956,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr GhcPs } - : tyvar { sL1 $1 (UserTyVar noExt $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExt $2 $4)) + : tyvar { sL1 $1 (UserTyVar $1) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) [mop $1,mu AnnDcolon $3 ,mcp $5] } @@ -2131,7 +2128,7 @@ fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev {% ams (L (comb2 $2 $4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) + (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2202,7 +2199,7 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) -- Turn it all into an expression so that -- checkPattern can check that bangs are enabled ; l = comb2 $1 $> }; @@ -2355,47 +2352,47 @@ quasiquote :: { Located (HsSplice GhcPs) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr GhcPs } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1) + : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) [mu AnnDcolon $2] } - | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 + | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 + | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 + | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 + | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } infixexp :: { LHsExpr GhcPs } : exp10 { $1 } - | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator infixexp_top :: { LHsExpr GhcPs } : exp10_top { $1 } | infixexp_top qop exp10_top - {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) [mj AnnVal $2] } exp10_top :: { LHsExpr GhcPs } : '\\' apat apats '->' exp - {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource + {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource [sLL $1 $> $ Match { m_ctxt = LambdaExpr , m_pats = $2:$3 , m_grhss = unguardedGRHSs $5 }])) [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4) + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase noExt + {% ams (sLL $1 $> $ HsLamCase (mkMatchGroup FromSource (snd $ unLoc $3))) (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp @@ -2406,14 +2403,15 @@ exp10_top :: { LHsExpr GhcPs } :(map (\l -> mj AnnSemi l) (fst $3)) ++(map (\l -> mj AnnSemi l) (fst $6))) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf noExt + ams (sLL $1 $> $ HsMultiIf + placeHolderType (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase noExt $2 (mkMatchGroup + | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) + | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) [mj AnnMinus $1] } | 'do' stmtlist {% ams (L (comb2 $1 $2) @@ -2423,18 +2421,19 @@ exp10_top :: { LHsExpr GhcPs } (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) - (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) + (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) + ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType + placeHolderType [])) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation @@ -2442,7 +2441,7 @@ exp10_top :: { LHsExpr GhcPs } exp10 :: { LHsExpr GhcPs } : exp10_top { $1 } - | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } optSemi :: { ([Located a],Bool) } @@ -2485,19 +2484,19 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In } fexp :: { LHsExpr GhcPs } - : fexp aexp { sLL $1 $> $ HsApp noExt $1 $2 } - | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1) + : fexp aexp { sLL $1 $> $ HsApp $1 $2 } + | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2) + | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) [mj AnnStatic $1] } | aexp { $1 } aexp :: { LHsExpr GhcPs } - : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } + : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } + | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } | aexp1 { $1 } aexp1 :: { LHsExpr GhcPs } @@ -2508,70 +2507,72 @@ aexp1 :: { LHsExpr GhcPs } | aexp2 { $1 } aexp2 :: { LHsExpr GhcPs } - : qvar { sL1 $1 (HsVar noExt $! $1) } - | qcon { sL1 $1 (HsVar noExt $! $1) } - | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) } - | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } - | literal { sL1 $1 (HsLit noExt $! unLoc $1) } + : qvar { sL1 $1 (HsVar $! $1) } + | qcon { sL1 $1 (HsVar $! $1) } + | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } + | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) } + | literal { sL1 $1 (HsLit $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) placeHolderType) } - | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } - | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } + | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral + (getINTEGER $1) placeHolderType) } + | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional + (getRATIONAL $1) placeHolderType) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] } + | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) - (Present noExt $2)] Unboxed)) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) + (Present $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]) } } | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } - | '_' { sL1 $1 $ EWildPat noExt } + | '_' { sL1 $1 EWildPat } -- Template Haskell Extension | splice_exp { $1 } - | 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)) + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $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 noExt $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) + ams (sLL $1 $> $ HsBracket (PatBr p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) } + | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2 + | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2 Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } splice_exp :: { LHsExpr GhcPs } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar - (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar - (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) @@ -2583,7 +2584,8 @@ cmdargs :: { [LHsCmdTop GhcPs] } acmd :: { LHsCmdTop GhcPs } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (sL1 $1 $ HsCmdTop noExt cmd) } + return (sL1 $1 $ HsCmdTop cmd + placeHolderType placeHolderType []) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 @@ -2614,17 +2616,17 @@ texp :: { LHsExpr GhcPs } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 } - | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 } + | infixexp qop { sLL $1 $> $ SectionL $1 $2 } + | qopm infixexp { sLL $1 $> $ SectionR $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } + | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. tup_exprs :: { ([AddAnn],SumOrTuple) } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } } | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } @@ -2647,8 +2649,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 noExt $1)) : snd $2) } - | texp { [L (gl $1) (Present noExt $1)] } + return ((L (gl $1) (Present $1)) : snd $2) } + | texp { [L (gl $1) (Present $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2657,18 +2659,19 @@ tup_tail :: { [LHsTupArg GhcPs] } -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. list :: { ([AddAnn],HsExpr GhcPs) } - : texp { ([],ExplicitList noExt Nothing [$1]) } - | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } + : texp { ([],ExplicitList placeHolderType Nothing [$1]) } + | lexps { ([],ExplicitList placeHolderType Nothing + (reverse (unLoc $1))) } | texp '..' { ([mj AnnDotdot $2], - ArithSeq noExt Nothing (From $1)) } + ArithSeq noPostTcExpr Nothing (From $1)) } | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing + ArithSeq noPostTcExpr Nothing (FromThen $1 $3)) } | texp '..' exp { ([mj AnnDotdot $2], - ArithSeq noExt Nothing + ArithSeq noPostTcExpr Nothing (FromTo $1 $3)) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing + ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5)) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> @@ -2691,7 +2694,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 noExt qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr placeHolderType] -- We actually found some actual parallel lists so @@ -2748,14 +2751,15 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- constructor in the list case). parr :: { ([AddAnn],HsExpr GhcPs) } - : { ([],ExplicitPArr noExt []) } - | texp { ([],ExplicitPArr noExt [$1]) } - | lexps { ([],ExplicitPArr noExt (reverse (unLoc $1))) } + : { ([],ExplicitPArr placeHolderType []) } + | texp { ([],ExplicitPArr placeHolderType [$1]) } + | lexps { ([],ExplicitPArr placeHolderType + (reverse (unLoc $1))) } | texp '..' exp { ([mj AnnDotdot $2] - ,PArrSeq noExt (FromTo $1 $3)) } + ,PArrSeq noPostTcExpr (FromTo $1 $3)) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4] - ,PArrSeq noExt (FromThenTo $1 $3 $5)) } + ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) } | texp '|' flattenedpquals { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) } @@ -2841,8 +2845,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } pat : exp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR + (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } bindpat :: { LPat GhcPs } @@ -2850,14 +2854,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apat :: { LPat GhcPs } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty - (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR + (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -3135,8 +3139,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) } + : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } + | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } @@ -3169,15 +3173,15 @@ varop :: { Located RdrName } ,mj AnnBackquote $3] } qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } - | '`' '_' '`' {% ams (sLL $1 $> (EWildPat noExt)) + : qvarop { sL1 $1 $ HsVar $1 } + | qconop { sL1 $1 $ HsVar $1 } + | '`' '_' '`' {% ams (sLL $1 $> EWildPat) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } + : qvaropm { sL1 $1 $ HsVar $1 } + | qconop { sL1 $1 $ HsVar $1 } qvarop :: { Located RdrName } : qvarsym { $1 } @@ -3334,8 +3338,8 @@ literal :: { Located (HsLit GhcPs) } $ getPRIMCHAR $1 } | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1) $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExt $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 } ----------------------------------------------------------------------------- -- Layout diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 7285f5fef9..126e92e7ad 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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 @@ -286,10 +286,10 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr + | HsSpliceE splice@(HsUntypedSplice {}) <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr + | HsSpliceE splice@(HsQuasiQuote {}) <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) | otherwise @@ -349,7 +349,7 @@ cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBinds noExt mbs sigs } + return $ ValBindsIn mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] @@ -476,15 +476,15 @@ splitCon ty = split ty [] where -- This is used somewhere where HsAppsTy is not used - split (L _ (HsAppTy _ t u)) ts = split t (u : ts) - split (L l (HsTyVar _ _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) - split (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) [] + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) + split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) - mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds) - mk_rest ts = PrefixCon ts + mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) + mk_rest ts = PrefixCon ts tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) -- See Note [Parsing data constructors is hard] @@ -695,16 +695,15 @@ checkTyVars pp_what equals_or_where tc tparms ; return (mkHsQTvs tvs) } where - chk (L _ (HsParTy _ ty)) = chk ty - chk (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = chk ty + chk (L _ (HsParTy ty)) = chk ty + chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty -- Check that the name space is correct! - chk (L l (HsKindSig _ - (L _ (HsAppsTy _ [L _ (HsAppPrefix _ (L lv (HsTyVar _ _ (L _ tv))))])) - k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k)) - chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv))) + chk (L l (HsKindSig + (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) + | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) + chk (L l (HsTyVar _ (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) chk t@(L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -753,23 +752,23 @@ checkTyClHdr is_cls ty where goL (L l ty) acc ann fix = go l ty acc ann fix - go l (HsTyVar _ _ (L _ tc)) acc ann fix + go l (HsTyVar _ (L _ tc)) acc ann fix | isRdrTc tc = return (L l tc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix + go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) - go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix - go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix - go _ (HsAppsTy _ ts) acc ann _fix + go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix + go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix + go _ (HsAppsTy ts) acc ann _fix | Just (head, args, fixity) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann fixity - go _ (HsAppsTy _ [L _ (HsAppInfix _ (L loc star))]) [] ann fix + go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix | isStar star = return (L loc (nameRdrName starKindTyConName), [], fix, ann) | isUniStar star = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) - go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix + go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix = return (L l (nameRdrName tup_name), ts, fix, ann) where arity = length ts @@ -784,15 +783,14 @@ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (L l orig_t) = check [] (L l orig_t) where - check anns (L lp (HsTupleTy _ _ ts)) -- (Eq a, Ord b) shows up as a tuple type + check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () -- don't let HsAppsTy get in the way - check anns (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) + check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = check anns ty - check anns (L lp1 (HsParTy _ ty)) - -- to be sure HsParTy doesn't get into the way + check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) @@ -817,7 +815,7 @@ checkLPat msg e@(L l _) = checkPat msg l e [] checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs) -checkPat _ loc (L l e@(HsVar _ (L _ c))) args +checkPat _ loc (L l e@(HsVar (L _ c))) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = patFail (text "Perhaps you intended to use RecursiveDo") l e @@ -827,7 +825,7 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns | Just (e', args') <- splitBang e = do { args'' <- checkPatterns msg args' ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (L _ (HsApp _ f e)) args +checkPat msg loc (L _ (HsApp f e)) args = do p <- checkLPat msg e checkPat msg loc f (p : args) checkPat msg loc (L _ e) [] @@ -841,76 +839,76 @@ checkAPat msg loc e0 = do pState <- getPState let opts = options pState case e0 of - EWildPat _ -> return (WildPat noExt) - HsVar _ x -> return (VarPat noExt x) - HsLit _ (HsStringPrim _ _) -- (#13260) + EWildPat -> return (WildPat placeHolderType) + HsVar x -> return (VarPat x) + HsLit (HsStringPrim _ _) -- (#13260) -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) - HsLit _ l -> return (LitPat noExt l) + HsLit l -> return (LitPat l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing) - NegApp _ (L l (HsOverLit _ pos_lit)) _ + HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + NegApp (L l (HsOverLit pos_lit)) _ -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) - SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x) + SectionR (L lb (HsVar (L _ bang))) e -- (! x) | bang == bang_RDR -> do { bang_on <- extension bangPatEnabled ; if bang_on then do { e' <- checkLPat msg e ; addAnnotation loc AnnBang lb - ; return (BangPat noExt e') } + ; return (BangPat e') } else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } - ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt)) - EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n) + ELazyPat e -> checkLPat msg e >>= (return . LazyPat) + EAsPat n e -> checkLPat msg e >>= (return . AsPat n) -- view pattern is well-formed if the pattern is - EViewPat _ expr patE -> checkLPat msg patE >>= - (return . (\p -> ViewPat noExt expr p)) - ExprWithTySig t e -> do e <- checkLPat msg e - return (SigPat t e) + EViewPat expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat expr p placeHolderType)) + ExprWithTySig e t -> do e <- checkLPat msg e + return (SigPatIn e t) -- n+k patterns - OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus))) - (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ + (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - OpApp _ l op r -> do l <- checkLPat msg l - r <- checkLPat msg r - case op of - L cl (HsVar _ (L _ c)) | isDataOcc (rdrNameOcc c) - -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail msg loc e0 + OpApp l op _fix r -> do l <- checkLPat msg l + r <- checkLPat msg r + case op of + L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail msg loc e0 - HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) + HsPar e -> checkLPat msg e >>= (return . ParPat) ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat noExt ps placeHolderType Nothing) + return (ListPat ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es - return (PArrPat noExt ps) + return (PArrPat ps placeHolderType) - ExplicitTuple _ es b + ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | L _ (Present _ e) <- es] - return (TuplePat noExt ps b) + [e | L _ (Present e) <- es] + return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) - ExplicitSum _ alt arity expr -> do + ExplicitSum alt arity expr _ -> do p <- checkLPat msg expr - return (SumPat noExt p alt arity) + return (SumPat p alt arity placeHolderType) RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } -> do fs <- mapM (checkPatField msg) fs return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE _ s | not (isTypedSplice s) - -> return (SplicePat noExt s) + HsSpliceE s | not (isTypedSplice s) + -> return (SplicePat s) _ -> patFail msg loc e0 placeHolderPunRhs :: LHsExpr GhcPs -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) +placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack @@ -944,7 +942,7 @@ checkValDef :: SDoc checkValDef msg _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) - (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss + (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss checkValDef msg strictness lhs Nothing g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -997,7 +995,7 @@ checkPatBind msg lhs (L _ (_,grhss)) ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) +checkValSigLhs (L _ (HsVar lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr @@ -1019,9 +1017,9 @@ checkValSigLhs lhs@(L l _) -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar _ (L _ v))) = v == s - looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs - looks_like _ _ = False + looks_like s (L _ (HsVar (L _ v))) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") default_RDR = mkUnqual varName (fsLit "default") @@ -1054,13 +1052,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- not be any OpApps inside the e's splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg)) - | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns) +splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) + | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] - split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es) - split_bang e es = (e,es) + split_bang (L _ (HsApp f e)) es = split_bang f (e:es) + split_bang e es = (e,es) splitBang _ = Nothing isFunLhs :: LHsExpr GhcPs @@ -1079,15 +1077,14 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (L loc (HsVar _ (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) - go (L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (L loc (HsVar (L _ f))) es ann + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + go (L _ (HsApp f e)) es ann = go f (e:es) ann + go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var))))) - [] ann + go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann | bang == bang_RDR , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann)) @@ -1104,7 +1101,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann + go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann @@ -1118,8 +1115,7 @@ isFunLhs e = go e [] [] Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = L loc (OpApp noExt k - (L loc' (HsVar noExt (L loc' op))) r) + op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1128,24 +1124,23 @@ isFunLhs e = go e [] [] -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d splitTilde :: LHsType GhcPs -> P (LHsType GhcPs) splitTilde t = go t - where go (L loc (HsAppTy _ t1 t2)) - | L lo (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') + where go (L loc (HsAppTy t1 t2)) + | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') <- t2 = do moveAnnotations lo loc t1' <- go t1 - return (L loc (HsEqTy noExt t1' t2')) + return (L loc (HsEqTy t1' t2')) | otherwise = do t1' <- go t1 case t1' of - (L lo (HsEqTy _ tl tr)) -> do + (L lo (HsEqTy tl tr)) -> do let lr = combineLocs tr t2 moveAnnotations lo loc - return (L loc (HsEqTy noExt tl - (L lr (HsAppTy noExt tr t2)))) + return (L loc (HsEqTy tl (L lr (HsAppTy tr t2)))) t -> do - return (L loc (HsAppTy noExt t t2)) + return (L loc (HsAppTy t t2)) go t = return t @@ -1157,14 +1152,14 @@ splitTildeApps [] = return [] splitTildeApps (t : rest) = do rest' <- concatMapM go rest return (t : rest') - where go (L l (HsAppPrefix _ - (L loc (HsBangTy noExt + where go (L l (HsAppPrefix + (L loc (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) ty)))) = addAnnotation l AnnTilde tilde_loc >> return - [L tilde_loc (HsAppInfix noExt (L tilde_loc eqTyCon_RDR)), - L l (HsAppPrefix noExt ty)] + [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)), + L l (HsAppPrefix ty)] -- NOTE: no annotation is attached to an HsAppPrefix, so the -- surrounding SrcSpan is not critical where @@ -1200,35 +1195,34 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) 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 noExt e1 e2 haat b -checkCmd _ (HsArrForm _ e mf args) = - return $ HsCmdArrForm noExt e Prefix mf args -checkCmd _ (HsApp _ e1 e2) = - checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2) -checkCmd _ (HsLam _ mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg') -checkCmd _ (HsPar _ e) = - checkCommand e >>= (\c -> return $ HsCmdPar noExt c) -checkCmd _ (HsCase _ e mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg') -checkCmd _ (HsIf _ cf ep et ee) = do +checkCmd _ (HsArrApp e1 e2 ptt haat b) = + return $ HsCmdArrApp e1 e2 ptt haat b +checkCmd _ (HsArrForm e mf args) = + return $ HsCmdArrForm e Prefix mf args +checkCmd _ (HsApp e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) +checkCmd _ (HsLam mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') +checkCmd _ (HsPar e) = + checkCommand e >>= (\c -> return $ HsCmdPar c) +checkCmd _ (HsCase e mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') +checkCmd _ (HsIf cf ep et ee) = do pt <- checkCommand et pe <- checkCommand ee - return $ HsCmdIf noExt cf ep pt pe -checkCmd _ (HsLet _ lb e) = - checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) -checkCmd _ (HsDo _ DoExpr (L l stmts)) = - mapM checkCmdLStmt stmts >>= - (\ss -> return $ HsCmdDo noExt (L l ss) ) - -checkCmd _ (OpApp _ eLeft op eRight) = do + return $ HsCmdIf cf ep pt pe +checkCmd _ (HsLet lb e) = + checkCommand e >>= (\c -> return $ HsCmdLet lb c) +checkCmd _ (HsDo DoExpr (L l stmts) ty) = + mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty) + +checkCmd _ (OpApp eLeft op _fixity eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop noExt c1 - arg2 = L (getLoc c2) $ HsCmdTop noExt c2 - return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] + let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] + return $ HsCmdArrForm op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e @@ -1292,7 +1286,7 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) -> P (HsExpr GhcPs) -mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) @@ -1301,23 +1295,23 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds - = RecordUpd { rupd_ext = noExt - , rupd_expr = exp - , rupd_flds = flds } + = RecordUpd { rupd_expr = exp + , rupd_flds = flds + , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder + , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds } + = RecordCon { rcon_con_name = con, rcon_flds = flds + , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) - = HsRecField (L loc (Unambiguous noExt rdr)) arg pun -mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _) - = panic "mk_rec_upd_field" +mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun) + = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -1569,11 +1563,11 @@ data SumOrTuple mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) -- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) +mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) -- Sum mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum noExt alt arity e) + return (ExplicitSum alt arity e PlaceHolder) mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index d8fcf4e690..02a37b20ef 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -183,10 +183,10 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) +rnTopBindsBoot bound_names (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } + ; return (ValBindsOut [] sigs', usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) {- @@ -274,9 +274,9 @@ rnLocalValBindsLHS fix_env binds rnValBindsLHS :: NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) +rnValBindsLHS topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } + ; return $ ValBindsIn mbinds' sigs } where bndrs = collectHsBindsBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs @@ -291,7 +291,7 @@ rnValBindsRHS :: HsSigCtxt -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) +rnValBindsRHS ctxt (ValBindsIn mbinds sigs) = do { (sigs', sig_fvs) <- renameSigs ctxt sigs ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus @@ -311,7 +311,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) -- so that the binders are removed from -- the uses in the sigs - ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } + ; return (ValBindsOut anal_binds sigs', valbind'_dus) } rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -336,7 +336,7 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside +rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = do { -- (A) Create the local fixity environment new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index c51b741944..dbc3baf887 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1557,10 +1557,10 @@ lookupSyntaxNames :: [Name] -- Standard names lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (map (HsVar noExt . noLoc) std_names, emptyFVs) + return (map (HsVar . noLoc) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } } + ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } -- Error messages diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 22e474b481..3cb24173ec 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -95,7 +95,7 @@ finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar noExt (L l name), unitFV name) } + ; return (HsVar (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v @@ -107,13 +107,13 @@ rnUnboundVar v ; uv <- if startsWithUnderscore occ then return (TrueExprHole occ) else OutOfScope occ <$> getGlobalRdrEnv - ; return (HsUnboundVar noExt uv, emptyFVs) } + ; return (HsUnboundVar uv, emptyFVs) } else -- Fail immediately (qualified name) do { n <- reportUnboundName v - ; return (HsVar noExt (noLoc n), emptyFVs) } } + ; return (HsVar (noLoc n), emptyFVs) } } -rnExpr (HsVar _ (L l v)) +rnExpr (HsVar (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v ; case mb_name of { @@ -121,57 +121,58 @@ rnExpr (HsVar _ (L l v)) Just (Left name) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly - -> rnExpr (ExplicitList noExt Nothing []) + -> rnExpr (ExplicitList placeHolderType Nothing []) | otherwise -> finishHsVar (L l name) ; Just (Right [s]) -> - return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ; + return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s)) + , unitFV s) ; Just (Right fs@(_:_:_)) -> - return ( HsRecFld noExt (Ambiguous noExt (L l v)) + return ( HsRecFld (Ambiguous (L l v) PlaceHolder) , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } -rnExpr (HsIPVar x v) - = return (HsIPVar x v, emptyFVs) +rnExpr (HsIPVar v) + = return (HsIPVar v, emptyFVs) -rnExpr (HsOverLabel x _ v) +rnExpr (HsOverLabel _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel x Nothing v, emptyFVs) } + ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) } + else return (HsOverLabel Nothing v, emptyFVs) } -rnExpr (HsLit x lit@(HsString src s)) +rnExpr (HsLit lit@(HsString src s)) = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings ; if opt_OverloadedStrings then - rnExpr (HsOverLit x (mkHsIsString src s)) + rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) else do { ; rnLit lit - ; return (HsLit x (convertLit lit), emptyFVs) } } + ; return (HsLit (convertLit lit), emptyFVs) } } -rnExpr (HsLit x lit) +rnExpr (HsLit lit) = do { rnLit lit - ; return (HsLit x(convertLit lit), emptyFVs) } + ; return (HsLit (convertLit lit), emptyFVs) } -rnExpr (HsOverLit x lit) +rnExpr (HsOverLit lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of - Nothing -> return (HsOverLit x lit', fvs) - Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) + Nothing -> return (HsOverLit lit', fvs) + Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit')) , fvs ) } -rnExpr (HsApp x fun arg) +rnExpr (HsApp fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } + ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType arg fun) +rnExpr (HsAppType fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) } + ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) } -rnExpr (OpApp _ e1 op e2) +rnExpr (OpApp e1 op _ e2) = do { (e1', fv_e1) <- rnLExpr e1 ; (e2', fv_e2) <- rnLExpr e2 ; (op', fv_op) <- rnLExpr op @@ -182,15 +183,15 @@ rnExpr (OpApp _ e1 op e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar _ (L _ n)) -> lookupFixityRn n - L _ (HsRecFld _ f) -> lookupFieldFixityRn f + L _ (HsVar (L _ n)) -> lookupFixityRn n + L _ (HsRecFld f) -> lookupFieldFixityRn f _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } -rnExpr (NegApp _ e _) +rnExpr (NegApp e _) = do { (e', fv_e) <- rnLExpr e ; (neg_name, fv_neg) <- lookupSyntaxName negateName ; final_e <- mkNegAppRn e' neg_name @@ -200,24 +201,24 @@ rnExpr (NegApp _ e _) -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. -rnExpr e@(HsBracket _ br_body) = rnBracket e br_body +rnExpr e@(HsBracket br_body) = rnBracket e br_body -rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice +rnExpr (HsSpliceE splice) = rnSpliceExpr splice --------------------------------------------- -- Sections -- See Note [Parsing sections] in Parser.y -rnExpr (HsPar x (L loc (section@(SectionL {})))) +rnExpr (HsPar (L loc (section@(SectionL {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } + ; return (HsPar (L loc section'), fvs) } -rnExpr (HsPar x (L loc (section@(SectionR {})))) +rnExpr (HsPar (L loc (section@(SectionR {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar x (L loc section'), fvs) } + ; return (HsPar (L loc section'), fvs) } -rnExpr (HsPar x e) +rnExpr (HsPar e) = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar x e', fvs_e) } + ; return (HsPar e', fvs_e) } rnExpr expr@(SectionL {}) = do { addErr (sectionErr expr); rnSection expr } @@ -225,72 +226,71 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn x src ann expr) +rnExpr (HsCoreAnn src ann expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn x src ann expr', fvs_expr) } + ; return (HsCoreAnn src ann expr', fvs_expr) } -rnExpr (HsSCC x src lbl expr) +rnExpr (HsSCC src lbl expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC x src lbl expr', fvs_expr) } -rnExpr (HsTickPragma x src info srcInfo expr) + ; return (HsSCC src lbl expr', fvs_expr) } +rnExpr (HsTickPragma src info srcInfo expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } + ; return (HsTickPragma src info srcInfo expr', fvs_expr) } -rnExpr (HsLam x matches) +rnExpr (HsLam matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam x matches', fvMatch) } + ; return (HsLam matches', fvMatch) } -rnExpr (HsLamCase x matches) +rnExpr (HsLamCase matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase x matches', fvs_ms) } + ; return (HsLamCase matches', fvs_ms) } -rnExpr (HsCase x expr matches) +rnExpr (HsCase expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet x (L l binds) expr) +rnExpr (HsLet (L l binds) expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet x (L l binds') expr', fvExpr) } + ; return (HsLet (L l binds') expr', fvExpr) } -rnExpr (HsDo x do_or_lc (L l stmts)) +rnExpr (HsDo do_or_lc (L l stmts) _) = do { ((stmts', _), fvs) <- rnStmtsWithPostProcessing do_or_lc rnLExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } + ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) } -rnExpr (ExplicitList x _ exps) +rnExpr (ExplicitList _ _ exps) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (exps', fvs) <- rnExprs exps ; if opt_OverloadedLists then do { ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList x (Just from_list_n_name) exps' + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' , fvs `plusFV` fvs') } else - return (ExplicitList x Nothing exps', fvs) } + return (ExplicitList placeHolderType Nothing exps', fvs) } -rnExpr (ExplicitPArr x exps) +rnExpr (ExplicitPArr _ exps) = do { (exps', fvs) <- rnExprs exps - ; return (ExplicitPArr x exps', fvs) } + ; return (ExplicitPArr placeHolderType exps', fvs) } -rnExpr (ExplicitTuple x tup_args boxity) +rnExpr (ExplicitTuple tup_args boxity) = do { checkTupleSection tup_args ; checkTupSize (length tup_args) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } + ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } where - rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present x e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing noExt) + 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) , emptyFVs) - rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg" -rnExpr (ExplicitSum x alt arity expr) +rnExpr (ExplicitSum alt arity expr _) = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum x alt arity expr', fvs) } + ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) } rnExpr (RecordCon { rcon_con_name = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) @@ -298,53 +298,53 @@ rnExpr (RecordCon { rcon_con_name = con_id ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } - ; return (RecordCon { rcon_ext = noExt - , rcon_con_name = con_lname, rcon_flds = rec_binds' } + ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds' + , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar noExt (L l n) + mk_hs_var l n = HsVar (L l n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = do { (expr', fvExpr) <- rnLExpr expr ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr' - , rupd_flds = rbinds' } + ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds' + , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder + , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } , fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig pty expr) +rnExpr (ExprWithTySig expr pty) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr - ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) } + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } -rnExpr (HsIf x _ p b1 b2) +rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnExpr (HsMultiIf x alts) +rnExpr (HsMultiIf _ty alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts -- ; return (HsMultiIf ty alts', fvs) } - ; return (HsMultiIf x alts', fvs) } + ; return (HsMultiIf placeHolderType alts', fvs) } -rnExpr (ArithSeq x _ seq) +rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq x (Just from_list_name) new_seq - , fvs `plusFV` fvs') } + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } else - return (ArithSeq x Nothing new_seq, fvs) } + return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } -rnExpr (PArrSeq x seq) +rnExpr (PArrSeq _ seq) = do { (new_seq, fvs) <- rnArithSeq seq - ; return (PArrSeq x new_seq, fvs) } + ; return (PArrSeq noPostTcExpr new_seq, fvs) } {- These three are pattern syntax appearing in expressions. @@ -352,7 +352,7 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. -} -rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole +rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole rnExpr e@(EAsPat {}) = do { opt_TypeApplications <- xoptM LangExt.TypeApplications ; let msg | opt_TypeApplications @@ -407,11 +407,11 @@ rnExpr e@(HsStatic _ expr) = do ************************************************************************ -} -rnExpr (HsProc x pat body) +rnExpr (HsProc pat body) = newArrowScope $ rnPat ProcExpr pat $ \ pat' -> do { (body',fvBody) <- rnCmdTop body - ; return (HsProc x pat' body', fvBody) } + ; return (HsProc pat' body', fvBody) } -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. rnExpr e@(HsArrApp {}) = arrowFail e @@ -420,8 +420,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) +hsHoleExpr :: HsExpr id +hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) arrowFail e @@ -434,17 +434,17 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSection section@(SectionR x op expr) +rnSection section@(SectionR op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr ; checkSectionPrec InfixR section op' expr' - ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } + ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } -rnSection section@(SectionL x expr op) +rnSection section@(SectionL expr op) = do { (expr', fvs_expr) <- rnLExpr expr ; (op', fvs_op) <- rnLExpr op ; checkSectionPrec InfixL section op' expr' - ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } + ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) @@ -466,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_names `zip` cmd_names') cmd', + ; return (HsCmdTop cmd' placeHolderType placeHolderType + (cmd_names `zip` cmd_names'), 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 x arrow arg ho rtl) +rnCmd (HsCmdArrApp arrow arg _ ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp x arrow' arg' ho rtl, + ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -498,9 +498,9 @@ rnCmd (HsCmdArrApp x 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' + ; let L _ (HsVar (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity @@ -508,48 +508,47 @@ 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 x op f fixity cmds) +rnCmd (HsCmdArrForm op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } -rnCmd (HsCmdApp x fun arg) +rnCmd (HsCmdApp fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } + ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam x matches) +rnCmd (HsCmdLam matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam x matches', fvMatch) } + ; return (HsCmdLam matches', fvMatch) } -rnCmd (HsCmdPar x e) +rnCmd (HsCmdPar e) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar x e', fvs_e) } + ; return (HsCmdPar e', fvs_e) } -rnCmd (HsCmdCase x expr matches) +rnCmd (HsCmdCase expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdIf x _ 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 x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnCmd (HsCmdLet x (L l binds) cmd) +rnCmd (HsCmdLet (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet x (L l binds') cmd', fvExpr) } + ; return (HsCmdLet (L l binds') cmd', fvExpr) } -rnCmd (HsCmdDo x (L l stmts)) +rnCmd (HsCmdDo (L l stmts) _) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo x (L l stmts'), fvs ) } + ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) -rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -561,28 +560,26 @@ 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. @@ -866,7 +863,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) }} @@ -949,7 +946,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{}) _ = @@ -974,7 +971,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 x 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 @@ -982,9 +979,8 @@ rnParallelStmts ctxt return_op segs thing_inside ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - ; let seg' = ParStmtBlock x 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:" @@ -1004,12 +1000,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar noExt (noLoc fm), unitFV fm) } + ; return (HsVar (noLoc fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar noExt (noLoc name), emptyFVs) + not_rebindable = return (HsVar (noLoc name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp/PArrComp are never rebindable @@ -1099,7 +1095,7 @@ rnRecStmtsAndThen rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt (L _ (HsValBinds (ValBinds _ _ sigs))))) -> + (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1200,7 +1196,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) @@ -1704,7 +1700,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do return (unLoc tup, emptyNameSet) | otherwise -> do (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp noExt (noLoc ret) tup, fvs) + return (HsApp (noLoc ret) tup, fvs) return ( ApplicativeArgMany stmts' mb_ret pat , fvs1 `plusFV` fvs2) @@ -1790,24 +1786,25 @@ can do with the rest of the statements in the same "do" expression. isStrictPattern :: LPat id -> Bool isStrictPattern (L _ pat) = case pat of - WildPat{} -> False - VarPat{} -> False - LazyPat{} -> False - AsPat _ _ p -> isStrictPattern p - ParPat _ p -> isStrictPattern p - ViewPat _ _ p -> isStrictPattern p - SigPat _ p -> isStrictPattern p - BangPat{} -> True - ListPat{} -> True - TuplePat{} -> True - SumPat{} -> True - PArrPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True - LitPat{} -> True - NPat{} -> True - NPlusKPat{} -> True - SplicePat{} -> True + WildPat{} -> False + VarPat{} -> False + LazyPat{} -> False + AsPat _ p -> isStrictPattern p + ParPat p -> isStrictPattern p + ViewPat _ p _ -> isStrictPattern p + SigPatIn p _ -> isStrictPattern p + SigPatOut p _ -> isStrictPattern p + BangPat{} -> True + ListPat{} -> True + TuplePat{} -> True + SumPat{} -> True + PArrPat{} -> True + ConPatIn{} -> True + ConPatOut{} -> True + LitPat{} -> True + NPat{} -> True + NPlusKPat{} -> True + SplicePat{} -> True _otherwise -> panic "isStrictPattern" isLetStmt :: LStmt a b -> Bool @@ -1879,8 +1876,8 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt :: HsStmtContext Name - -> [ApplicativeArg GhcRn] -- ^ The args - -> Bool -- ^ True <=> need a join + -> [ApplicativeArg GhcRn GhcRn] -- ^ The args + -> Bool -- ^ True <=> need a join -> [ExprLStmt GhcRn] -- ^ The body statements -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts @@ -1915,15 +1912,15 @@ needJoin _monad_names stmts = (True, stmts) isReturnApp :: MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn) -isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of - OpApp _ l op r | is_return l, is_dollar op -> Just r - HsApp _ f arg | is_return f -> Just arg + OpApp l op _ r | is_return l, is_dollar op -> Just r + HsApp f arg | is_return f -> Just arg _otherwise -> Nothing where - is_var f (L _ (HsPar _ e)) = is_var f e - is_var f (L _ (HsAppType _ e)) = is_var f e - is_var f (L _ (HsVar _ (L _ r))) = f r + is_var f (L _ (HsPar e)) = is_var f e + is_var f (L _ (HsAppType e _)) = is_var f e + is_var f (L _ (HsVar (L _ r))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False @@ -2105,7 +2102,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation) - ; return (EWildPat noExt, emptyFVs) } + ; return (EWildPat, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index f1bfb380a5..b1305f55f3 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -179,9 +179,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are -- multiple possible selectors with different fixities, generate an error. lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (Unambiguous n (L _ rdr)) +lookupFieldFixityRn (Unambiguous (L _ rdr) n) = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr +lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr where get_ambiguous_fixity :: RdrName -> RnM Fixity get_ambiguous_fixity rdr_name = do @@ -209,4 +209,3 @@ lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr format_ambig (elt, fix) = hang (ppr fix) 2 (pprNameProvenance elt) -lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn" diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index f4962d55ef..b1dc8877b5 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -604,7 +604,7 @@ getLocalNonValBinders fixity_env ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } where - ValBinds _ _val_binds val_sigs = binds + ValBindsIn _val_binds val_sigs = binds for_hs_bndrs :: [Located RdrName] for_hs_bndrs = hsForeignDeclsBinders foreign_decls @@ -652,13 +652,11 @@ getLocalNonValBinders fixity_env where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty cdflds = case tau of - L _ (HsFunTy _ - (L _ (HsAppsTy _ - [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) - _) -> flds - L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _) - -> flds - _ -> [] + L _ (HsFunTy + (L _ (HsAppsTy + [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds + L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds + _ -> [] find_con_flds _ = [] find_con_name rdr @@ -666,11 +664,10 @@ getLocalNonValBinders fixity_env find (\ n -> nameOccName n == rdrNameOcc rdr) names find_con_decl_flds (L _ x) = map find_con_decl_fld (cd_fld_names x) - find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) + find_con_decl_fld (L _ (FieldOcc (L _ rdr) _)) = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders" new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -710,8 +707,7 @@ getLocalNonValBinders fixity_env newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector" -newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) +newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ qualFieldLbl { flSelector = selName } } where diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 7d31a87ad3..2846754f11 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -11,8 +11,6 @@ free variables. -} {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -385,20 +383,17 @@ 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 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 - ; return (LazyPat x pat') } -rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat x (L l name)) } +rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) +rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } +rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } +rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } +rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPat sig pat ) +rnPatAndThen mk (SigPatIn pat sig) -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is -- important to rename its type signature _before_ renaming the rest of the -- pattern, so that type variables are first bound by the _outermost_ pattern @@ -410,21 +405,21 @@ rnPatAndThen mk (SigPat sig pat ) -- ~~~~~~~~~~~~~~~^ the same `a' then used here = do { sig' <- rnHsSigCps sig ; pat' <- rnLPatAndThen mk pat - ; return (SigPat sig' pat' ) } + ; return (SigPatIn pat' sig') } -rnPatAndThen mk (LitPat x lit) +rnPatAndThen mk (LitPat lit) | HsString src s <- lit = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) ; if ovlStr then rnPatAndThen mk - (mkNPat (noLoc (mkHsIsString src s)) + (mkNPat (noLoc (mkHsIsString src s placeHolderType)) Nothing) else normal_lit } | otherwise = normal_lit where - normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } + normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) } -rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) +rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -436,9 +431,9 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (L l lit') mb_neg' eq') } + ; return (NPat (L l lit') mb_neg' eq' placeHolderType) } -rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -446,16 +441,16 @@ rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus) } + ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus placeHolderType) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat x rdr pat) +rnPatAndThen mk (AsPat rdr pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat x new_name pat') } + ; return (AsPat new_name pat') } -rnPatAndThen mk p@(ViewPat x expr pat) +rnPatAndThen mk p@(ViewPat expr pat _ty) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns ; checkErr vp_flag (badViewPat p) } -- Because of the way we're arranging the recursive calls, @@ -464,46 +459,45 @@ rnPatAndThen mk p@(ViewPat x expr pat) ; pat' <- rnLPatAndThen mk pat -- Note: at this point the PreTcType in ty can only be a placeHolder -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat x expr' pat') } + ; return (ViewPat expr' pat' placeHolderType) } rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat noExt [] - placeHolderType Nothing) + ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff -rnPatAndThen mk (ListPat x pats _ _) +rnPatAndThen mk (ListPat pats _ _) = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat x pats' placeHolderType + ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))} - False -> return (ListPat x pats' placeHolderType Nothing) } + False -> return (ListPat pats' placeHolderType Nothing) } -rnPatAndThen mk (PArrPat x pats) +rnPatAndThen mk (PArrPat pats _) = do { pats' <- rnLPatsAndThen mk pats - ; return (PArrPat x pats') } + ; return (PArrPat pats' placeHolderType) } -rnPatAndThen mk (TuplePat x pats boxed) +rnPatAndThen mk (TuplePat pats boxed _) = do { liftCps $ checkTupSize (length pats) ; pats' <- rnLPatsAndThen mk pats - ; return (TuplePat x pats' boxed) } + ; return (TuplePat pats' boxed []) } -rnPatAndThen mk (SumPat x pat alt arity) +rnPatAndThen mk (SumPat pat alt arity _) = do { pat <- rnLPatAndThen mk pat - ; return (SumPat x pat alt arity) + ; return (SumPat pat alt arity PlaceHolder) } -- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) - = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat +rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat))) + = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat -rnPatAndThen mk (SplicePat _ splice) +rnPatAndThen mk (SplicePat splice) = do { eith <- liftCpsFV $ rnSplicePat splice ; case eith of -- See Note [rnSplicePat] in RnSplice Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed @@ -546,7 +540,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExt (L l n) + mkVarPat l n = VarPat (L l n) rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' })) } @@ -608,7 +602,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) -> RnM (LHsRecField GhcRn (Located arg)) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc _ (L ll lbl)) + = L loc (FieldOcc (L ll lbl) _) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl @@ -619,11 +613,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; return (L loc (mk_arg loc arg_rdr)) } else return arg ; return (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel (L ll lbl)) + = L loc (FieldOcc (L ll lbl) sel) , hsRecFieldArg = arg' , hsRecPun = pun })) } - rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) - = panic "rnHsRecFields" rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat -> Maybe Name -- The constructor (Nothing for an @@ -664,7 +656,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs dot_dot_gres ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields @@ -772,7 +764,7 @@ rnHsRecUpdFields flds then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar noExt (L loc arg_rdr))) } + ; return (L loc (HsVar (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -782,10 +774,10 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - L loc (Unambiguous sel_name (L loc lbl)) + L loc (Unambiguous (L loc lbl) sel_name) Right [sel_name] -> - L loc (Unambiguous sel_name (L loc lbl)) - Right _ -> L loc (Ambiguous noExt (L loc lbl)) + L loc (Unambiguous (L loc lbl) sel_name) + Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder) ; return (L l (HsRecField { hsRecFieldLbl = lbl' , hsRecFieldArg = arg'' @@ -806,7 +798,7 @@ getFieldLbls :: [LHsRecField id arg] -> [RdrName] getFieldLbls flds = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds -getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] +getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc @@ -890,10 +882,11 @@ rnOverLit origLit ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar _ (L _ v) -> v /= std_name - _ -> panic "rnOverLit" + HsVar (L _ v) -> v /= std_name + _ -> panic "rnOverLit" ; let lit' = lit { ol_witness = from_thing_name - , ol_ext = rebindable } + , ol_rebindable = rebindable + , ol_type = placeHolderType } ; if isNegativeZeroOverLit lit' then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) <- lookupSyntaxName negateName diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 0ca811424e..b182382381 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -582,7 +582,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss , L _ EmptyLocalBinds <- lbinds - , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName + , L _ (HsVar (L _ rhsName)) <- body = Just rhsName isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different @@ -1039,11 +1039,10 @@ validRuleLhs foralls lhs where checkl (L _ e) = check e - check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 - `mplus` checkl_e e2 - check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e) = checkl e - check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing + check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType e _) = checkl e + check (HsVar (L _ v)) | v `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument @@ -1079,7 +1078,7 @@ badRuleLhsErr name lhs bad_e text "LHS must be of form (f e1 .. en) where f is not forall'd" where err = case bad_e of - HsUnboundVar _ uv -> text "Not in scope:" <+> ppr uv + HsUnboundVar uv -> text "Not in scope:" <+> ppr uv _ -> text "Illegal expression:" <+> ppr bad_e {- @@ -1093,7 +1092,7 @@ badRuleLhsErr name lhs bad_e rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. -rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _ _))) +rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) = do { var' <- lookupLocatedOccRn var ; (rhs', fv_rhs) <- rnLExpr rhs ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') @@ -2080,7 +2079,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] - new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds + new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2093,7 +2092,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name)) + mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) @@ -2252,9 +2251,9 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs -add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" -add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) -add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" +add_sig :: LSig a -> HsValBinds a -> HsValBinds a +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index fc7240ef44..36b1eda140 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -18,6 +18,7 @@ import NameSet import HsSyn import RdrName import TcRnMonad +import Kind import RnEnv import RnUtils ( HsDocContext(..), newLocalBndrRn ) @@ -102,7 +103,7 @@ rnBracket e br_body ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rn_bracket cur_stage br_body - ; return (HsBracket noExt body', fvs_e) } + ; return (HsBracket body', fvs_e) } False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar [] @@ -110,11 +111,11 @@ rnBracket e br_body setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ rn_bracket cur_stage br_body ; pendings <- readMutVar ps_var - ; return (HsRnBracketOut noExt body' pendings, fvs_e) } + ; return (HsRnBracketOut body' pendings, fvs_e) } } rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) -rn_bracket outer_stage br@(VarBr x flg rdr_name) +rn_bracket outer_stage br@(VarBr flg rdr_name) = do { name <- lookupOccRn rdr_name ; this_mod <- getModule @@ -136,18 +137,17 @@ rn_bracket outer_stage br@(VarBr x flg rdr_name) (quotedNameStageErr br) } } } - ; return (VarBr x flg name, unitFV name) } + ; return (VarBr flg name, unitFV name) } -rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr x e', fvs) } +rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr e', fvs) } -rn_bracket _ (PatBr x p) - = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) +rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr x t', fvs) } +rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr t', fvs) } -rn_bracket _ (DecBrL x decls) +rn_bracket _ (DecBrL decls) = do { group <- groupDecls decls ; gbl_env <- getGblEnv ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } @@ -159,7 +159,7 @@ rn_bracket _ (DecBrL x 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 x group', duUses (tcg_dus tcg_env)) } + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } where groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls decls @@ -173,12 +173,10 @@ rn_bracket _ (DecBrL x decls) } }} -rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" +rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr x e', fvs) } - -rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket" +rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr e', fvs) } quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body @@ -296,11 +294,10 @@ 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) - XSplice {} -> 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) -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -338,16 +335,14 @@ 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 @@ -355,13 +350,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = L q_span $ HsApp noExt (L q_span $ - HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector))) + = L q_span $ HsApp (L q_span $ + HsApp (L q_span (HsVar (L q_span quote_selector))) quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter) - quoteExpr = L q_span $! HsLit noExt $! HsString NoSourceText quote + quoterExpr = L q_span $! HsVar $! (L q_span quoter) + quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -371,21 +366,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote --------------------- rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all -rnSplice (HsTypedSplice x 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 x hasParen n' expr', fvs) } + ; return (HsTypedSplice hasParen n' expr', fvs) } -rnSplice (HsUntypedSplice x 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 x hasParen n' expr', fvs) } + ; return (HsUntypedSplice hasParen n' expr', fvs) } -rnSplice (HsQuasiQuote x 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) @@ -396,11 +391,9 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) ; when (nameIsLocalOrFrom this_mod quoter') $ checkThLocalName quoter' - ; return (HsQuasiQuote x splice_name' quoter' q_loc quote - , unitFV quoter') } + ; return (HsQuasiQuote 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) @@ -409,7 +402,7 @@ rnSpliceExpr splice where pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice) + = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice) run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice @@ -422,7 +415,7 @@ rnSpliceExpr splice , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) } + ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) } | otherwise -- Run it here, see Note [Running splices in the Renamer] = do { traceRn "rnSpliceExpr: untyped expression splice" empty @@ -430,8 +423,8 @@ rnSpliceExpr splice runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar noExt $ HsSpliceE noExt - . HsSpliced noExt (ThModFinalizers mod_finalizers) + ; return ( HsPar $ HsSpliceE + . HsSpliced (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 , fvs) @@ -528,13 +521,13 @@ References: -} ---------------------- -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) -rnSpliceType splice +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice k = rnSpliceGen run_type_splice pend_type_splice splice where pend_type_splice rn_splice - = ( makePending UntypedTypeSplice rn_splice - , HsSpliceTy noExt rn_splice) + = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k) run_type_splice rn_splice = do { traceRn "rnSpliceType: untyped type splice" empty @@ -544,8 +537,8 @@ rnSpliceType splice ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy noExt $ HsSpliceTy noExt - . HsSpliced noExt (ThModFinalizers mod_finalizers) + ; return ( HsParTy $ flip HsSpliceTy k + . HsSpliced (ThModFinalizers mod_finalizers) . HsSplicedTy <$> hs_ty3 , fvs @@ -601,18 +594,17 @@ rnSplicePat splice = rnSpliceGen run_pat_splice pend_pat_splice splice where pend_pat_splice rn_splice - = (makePending UntypedPatSplice rn_splice - , Right (SplicePat noExt rn_splice)) + = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice)) run_pat_splice rn_splice = do { traceRn "rnSplicePat: untyped pattern splice" empty ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat noExt $ (SplicePat noExt) - . HsSpliced noExt (ThModFinalizers mod_finalizers) - . HsSplicedPat <$> - pat + ; return ( Left $ ParPat $ SplicePat + . HsSpliced (ThModFinalizers mod_finalizers) + . HsSplicedPat <$> + pat , emptyFVs ) } -- Wrap the result of the quasi-quoter in parens so that we don't @@ -695,7 +687,6 @@ 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 diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot index 7844acd2c9..d8f0f1fc7f 100644 --- a/compiler/rename/RnSplice.hs-boot +++ b/compiler/rename/RnSplice.hs-boot @@ -4,9 +4,11 @@ import GhcPrelude import HsSyn import TcRnMonad import NameSet +import Kind -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars ) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 2e1b12d8e0..dd66cd3aec 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -156,27 +156,24 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs' - , hst_body = hs_body' }, fvs) } + ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) } rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; wc' <- setSrcSpan lx $ - do { checkExtraConstraintWildCard env - ; rnAnonWildCard } + do { checkExtraConstraintWildCard env wc + ; rnAnonWildCard wc } ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExt - , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_xqual = noExt - , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -184,16 +181,17 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) -checkExtraConstraintWildCard :: RnTyKiEnv -> RnM () +checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs + -> RnM () -- Rename the extra-constraint spot in a type signature -- (blah, _) => type -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard -checkExtraConstraintWildCard env +checkExtraConstraintWildCard env wc = checkWildCard env mb_bad where mb_bad | not (extraConstraintWildCardsAllowed env) - = Just (text "Extra-constraint wildcard" <+> quotes (pprAnonWildCard) + = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc) <+> text "not allowed") | otherwise = Nothing @@ -509,44 +507,43 @@ rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) Nothing tyvars $ \ tyvars' -> do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars' - , hst_body = tau' } + ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) = do { checkTypeInType env ty -- See Note [QualTy in kinds] ; (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau - ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' - , hst_body = tau' } + ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) +rnHsTyKi env (HsTyVar ip (L loc rdr_name)) = do { name <- rnTyVar env rdr_name - ; return (HsTyVar noExt ip (L loc name), unitFV name) } + ; return (HsTyVar ip (L loc name), unitFV name) } -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) +rnHsTyKi env ty@(HsOpTy ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ do { (l_op', fvs1) <- rnHsTyOp env ty l_op ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2) + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (unLoc l_op') fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } -rnHsTyKi env (HsParTy _ ty) +rnHsTyKi env (HsParTy ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy noExt ty', fvs) } + ; return (HsParTy ty', fvs) } -rnHsTyKi env (HsBangTy _ b ty) +rnHsTyKi env (HsBangTy b ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy noExt b ty', fvs) } -rnHsTyKi env ty@(HsRecTy _ flds) + ; return (HsBangTy b ty', fvs) } + +rnHsTyKi env ty@(HsRecTy flds) = do { let ctxt = rtke_ctxt env ; fls <- get_fields ctxt ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy noExt flds', fvs) } + ; return (HsRecTy flds', fvs) } where get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names @@ -555,7 +552,7 @@ rnHsTyKi env ty@(HsRecTy _ flds) 2 (ppr ty)) ; return [] } -rnHsTyKi env (HsFunTy _ ty1 ty2) +rnHsTyKi env (HsFunTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi env ty2 @@ -563,58 +560,58 @@ rnHsTyKi env (HsFunTy _ ty1 ty2) -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2' + ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi env listTy@(HsListTy _ ty) +rnHsTyKi env listTy@(HsListTy ty) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env listTy)) ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy noExt ty', fvs) } + ; return (HsListTy ty', fvs) } -rnHsTyKi env t@(HsKindSig _ ty k) +rnHsTyKi env t@(HsKindSig ty k) = do { checkTypeInType env t ; kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k - ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) } + ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsPArrTy _ ty) +rnHsTyKi env t@(HsPArrTy ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsPArrTy noExt ty', fvs) } + ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) +rnHsTyKi env tupleTy@(HsTupleTy tup_con tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy noExt tup_con tys', fvs) } + ; return (HsTupleTy tup_con tys', fvs) } -rnHsTyKi env sumTy@(HsSumTy _ tys) +rnHsTyKi env sumTy@(HsSumTy tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env sumTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy noExt tys', fvs) } + ; return (HsSumTy tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit _ t) +rnHsTyKi env tyLit@(HsTyLit t) = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr) ; checkTypeInType env tyLit - ; return (HsTyLit noExt t, emptyFVs) } + ; return (HsTyLit t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit -rnHsTyKi env overall_ty@(HsAppsTy _ tys) +rnHsTyKi env overall_ty@(HsAppsTy tys) = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions let (non_syms, syms) = splitHsAppsTy tys @@ -642,7 +639,7 @@ rnHsTyKi env overall_ty@(HsAppsTy _ tys) (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar noExt NotPromoted (L loc star)) + ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star)) : non_syms2) : non_syms) ops deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) @@ -663,60 +660,60 @@ rnHsTyKi env overall_ty@(HsAppsTy _ tys) build_res_ty (arg1 : args) (op1 : ops) = do { rhs <- build_res_ty args ops ; fix <- lookupTyFixityRn op1 - ; res <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 op1 t2) (unLoc op1) - fix arg1 rhs + ; res <- + mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) ; return (L loc res) } build_res_ty [arg] [] = return arg build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) -rnHsTyKi env (HsAppTy _ ty1 ty2) +rnHsTyKi env (HsAppTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } + ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsIParamTy _ n ty) +rnHsTyKi env t@(HsIParamTy n ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy noExt n ty', fvs) } + ; return (HsIParamTy n ty', fvs) } -rnHsTyKi env t@(HsEqTy _ ty1 ty2) +rnHsTyKi env t@(HsEqTy ty1 ty2) = do { checkTypeInType env t ; (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsEqTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } + ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi _ (HsSpliceTy _ sp) - = rnSpliceType sp +rnHsTyKi _ (HsSpliceTy sp k) + = rnSpliceType sp k -rnHsTyKi env (HsDocTy _ ty haddock_doc) +rnHsTyKi env (HsDocTy ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty ; haddock_doc' <- rnLHsDoc haddock_doc - ; return (HsDocTy noExt ty' haddock_doc', fvs) } + ; return (HsDocTy ty' haddock_doc', fvs) } -rnHsTyKi _ (XHsType (NHsCoreTy ty)) - = return (XHsType (NHsCoreTy ty), emptyFVs) +rnHsTyKi _ (HsCoreTy ty) + = return (HsCoreTy ty, emptyFVs) -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi env ty@(HsExplicitListTy _ ip tys) +rnHsTyKi env ty@(HsExplicitListTy ip k tys) = do { checkTypeInType env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy noExt ip tys', fvs) } + ; return (HsExplicitListTy ip k tys', fvs) } -rnHsTyKi env ty@(HsExplicitTupleTy _ tys) +rnHsTyKi env ty@(HsExplicitTupleTy kis tys) = do { checkTypeInType env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitTupleTy noExt tys', fvs) } + ; return (HsExplicitTupleTy kis tys', fvs) } -rnHsTyKi env (HsWildCardTy _) - = do { checkAnonWildCard env - ; wc' <- rnAnonWildCard +rnHsTyKi env (HsWildCardTy wc) + = do { checkAnonWildCard env wc + ; wc' <- rnAnonWildCard wc ; return (HsWildCardTy wc', emptyFVs) } -- emptyFVs: this occurrence does not refer to a -- user-written binding site, so don't treat @@ -763,22 +760,21 @@ checkWildCard env (Just doc) checkWildCard _ Nothing = return () -checkAnonWildCard :: RnTyKiEnv -> RnM () +checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () -- Report an error if an anonymous wildcard is illegal here -checkAnonWildCard env +checkAnonWildCard env wc = checkWildCard env mb_bad where mb_bad :: Maybe SDoc mb_bad | not (wildCardsAllowed env) - = Just (notAllowed pprAnonWildCard) + = Just (notAllowed (ppr wc)) | otherwise = case rtke_what env of RnTypeBody -> Nothing RnConstraint -> Just constraint_msg RnTopConstraint -> Just constraint_msg - constraint_msg = hang - (notAllowed pprAnonWildCard <+> text "in a constraint") + constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint") 2 hint_msg hint_msg = vcat [ text "except as the last top-level constraint of a type signature" , nest 2 (text "e.g f :: (Eq a, _) => blah") ] @@ -814,8 +810,8 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: RnM (HsWildCardInfo GhcRn) -rnAnonWildCard +rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn) +rnAnonWildCard (AnonWildCard _) = do { loc <- getSrcSpanM ; uniq <- newUnique ; let name = mkInternalName uniq (mkTyVarOcc "_") loc @@ -1061,23 +1057,20 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside +bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar x (L lv nm))) } + thing_inside (L loc (UserTyVar (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) - thing_inside +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ - thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + thing_inside (L loc (KindedTyVar (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr" - newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv @@ -1094,46 +1087,44 @@ collectAnonWildCards lty = go lty where go (L _ ty) = case ty of HsWildCardTy (AnonWildCard (L _ wc)) -> [wc] - HsAppsTy _ tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) - HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2 - HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2 - HsListTy _ ty -> go ty - HsPArrTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsEqTy _ ty1 ty2 -> go ty1 `mappend` go ty2 - HsKindSig _ ty kind -> go ty `mappend` go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys + HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) + HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 + HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 + HsListTy ty -> go ty + HsPArrTy ty -> go ty + HsTupleTy _ tys -> gos tys + HsSumTy tys -> gos tys + HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2 + HsParTy ty -> go ty + HsIParamTy _ ty -> go ty + HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2 + HsKindSig ty kind -> go ty `mappend` go kind + HsDocTy ty _ -> go ty + HsBangTy _ ty -> go ty + HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ tys -> gos tys HsForAllTy { hst_bndrs = bndrs , hst_body = ty } -> collectAnonWildCardsBndrs bndrs `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 + HsCoreTy{} -> mempty HsTyLit{} -> mempty HsTyVar{} -> mempty - XHsType{} -> mempty gos = mconcat . map go - prefix_types_only (HsAppPrefix _ ty) = Just ty - prefix_types_only (HsAppInfix _ _) = Nothing - prefix_types_only (XAppType _) = Nothing + prefix_types_only (HsAppPrefix ty) = Just ty + prefix_types_only (HsAppInfix _) = Nothing collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs where - go (UserTyVar _ _) = [] - go (KindedTyVar _ _ ki) = collectAnonWildCards ki - go (XTyVarBndr{}) = [] + go (UserTyVar _) = [] + go (KindedTyVar _ ki) = collectAnonWildCards ki {- ********************************************************* @@ -1168,11 +1159,10 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc)) ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr) + lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl - lookupField (XFieldOcc{}) = panic "rnField" {- ************************************************************************ @@ -1206,15 +1196,15 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy noExt t1 op2 t2) + (\t1 t2 -> HsOpTy t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2 + HsFunTy funTyConName funTyFixity ty21 ty22 loc2 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) @@ -1245,38 +1235,38 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) + return (OpApp e1 op2 fix2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (L loc' new_e)) + return (OpApp e11 op1 fix1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) - return (OpApp fix2 e1 op2 e2) + return (OpApp e1 op2 fix2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExt (L loc' new_e) neg_name) + return (NegApp (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) - return (OpApp fix1 e1 op1 e2) + return (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -1286,7 +1276,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - return (OpApp fix e1 op e2) + return (OpApp e1 op fix e2) ---------------------------- @@ -1306,16 +1296,16 @@ instance Outputable OpName where get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (L _ (HsVar _ (L _ n))) = NormalOp n -get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar (L _ n))) = NormalOp n +get_op (L _ (HsUnboundVar uv)) = UnboundOp uv +get_op (L _ (HsRecFld fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK right_op_ok :: Fixity -> HsExpr GhcRn -> Bool -right_op_ok fix1 (OpApp fix2 _ _ _) +right_op_ok fix1 (OpApp _ _ fix2 _) = not error_please && associate_right where (error_please, associate_right) = compareFixity fix1 fix2 @@ -1324,15 +1314,14 @@ right_op_ok _ _ -- Parser initially makes negation bind more tightly than any other operator -- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) - -> RnM (HsExpr (GhcPass id)) +mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) ) - return (NegApp noExt neg_arg neg_name) + return (NegApp neg_arg neg_name) not_op_app :: HsExpr id -> Bool -not_op_app (OpApp {}) = False -not_op_app _ = True +not_op_app (OpApp _ _ _ _) = False +not_op_app _ = True --------------------------- mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged @@ -1341,24 +1330,25 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1) - [a11,a12])))) +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) + [a11,a12])) _ _ _)) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm x 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 noExt op1 f (Just fix1) - [a11, L loc (HsCmdTop [] (L loc new_c))]) + return (HsCmdArrForm op1 f (Just fix1) + [a11, L loc (HsCmdTop (L loc new_c) + placeHolderType placeHolderType [])]) -- 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 noExt op Infix (Just fix) [arg1, arg2]) + = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2]) -------------------------------------- @@ -1436,8 +1426,8 @@ checkSectionPrec :: FixityDirection -> HsExpr GhcPs -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () checkSectionPrec direction section op arg = case unLoc arg of - OpApp fix _ op' _ -> go_for_it (get_op op') fix - NegApp _ _ _ -> go_for_it NegateOp negateFixity + OpApp _ op' fix _ -> go_for_it (get_op op') fix + NegApp _ _ -> go_for_it NegateOp negateFixity _ -> return () where op_name = get_op op @@ -1723,7 +1713,7 @@ rmDupsInRdrTyVars (FKTV kis tys) extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k + | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k | otherwise = return [] where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k @@ -1778,43 +1768,43 @@ extract_lkind = extract_lty KindLevel extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc - HsBangTy _ _ ty -> extract_lty t_or_k ty acc - HsRecTy _ flds -> foldrM (extract_lty t_or_k - . cd_fld_type . unLoc) acc - flds - HsAppsTy _ tys -> extract_apps t_or_k tys acc - HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsListTy _ ty -> extract_lty t_or_k ty acc - HsPArrTy _ ty -> extract_lty t_or_k ty acc - HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc - HsSumTy _ tys -> extract_ltys t_or_k tys acc - HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsIParamTy _ _ ty -> extract_lty t_or_k ty acc - HsEqTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<< - extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsParTy _ ty -> extract_lty t_or_k ty acc - HsSpliceTy {} -> return acc -- Type splices mention no tvs - HsDocTy _ ty _ -> extract_lty t_or_k ty acc - HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc - HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc - HsTyLit _ _ -> return acc - HsKindSig _ ty ki -> extract_lty t_or_k ty =<< - extract_lkind ki acc + HsTyVar _ ltv -> extract_tv t_or_k ltv acc + HsBangTy _ ty -> extract_lty t_or_k ty acc + HsRecTy flds -> foldrM (extract_lty t_or_k + . cd_fld_type . unLoc) acc + flds + HsAppsTy tys -> extract_apps t_or_k tys acc + HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsListTy ty -> extract_lty t_or_k ty acc + HsPArrTy ty -> extract_lty t_or_k ty acc + HsTupleTy _ tys -> extract_ltys t_or_k tys acc + HsSumTy tys -> extract_ltys t_or_k tys acc + HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsIParamTy _ ty -> extract_lty t_or_k ty acc + HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<< + extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsParTy ty -> extract_lty t_or_k ty acc + HsCoreTy {} -> return acc -- The type is closed + HsSpliceTy {} -> return acc -- Type splices mention no tvs + HsDocTy ty _ -> extract_lty t_or_k ty acc + HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc + HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc + HsTyLit _ -> return acc + HsKindSig ty ki -> extract_lty t_or_k ty =<< + extract_lkind ki acc HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc =<< - extract_lty t_or_k ty emptyFKTV + -> extract_hs_tv_bndrs tvs acc =<< + extract_lty t_or_k ty emptyFKTV HsQualTy { hst_ctxt = ctxt, hst_body = ty } - -> extract_lctxt t_or_k ctxt =<< - extract_lty t_or_k ty acc - XHsType {} -> return acc + -> extract_lctxt t_or_k ctxt =<< + extract_lty t_or_k ty acc -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy {} -> return acc + HsWildCardTy {} -> return acc extract_apps :: TypeOrKind -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars @@ -1822,9 +1812,8 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars -extract_app t_or_k (L _ (HsAppInfix _ tv)) acc = extract_tv t_or_k tv acc -extract_app t_or_k (L _ (HsAppPrefix _ ty)) acc = extract_lty t_or_k ty acc -extract_app _ (L _ (XAppType _ )) _ = panic "extract_app" +extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc +extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars @@ -1864,7 +1853,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName] -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = do { fktvs <- foldrM extract_lkind emptyFKTV - [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + [k | L _ (KindedTyVar _ k) <- tv_bndrs] ; return (freeKiTyVarsKindVars fktvs) } -- There will /be/ no free tyvars! diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 9675fdda22..6d656fefc3 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -97,7 +97,7 @@ newMethodFromName origin name inst_ty ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin [inst_ty] theta - ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) } + ; return (mkHsWrap wrap (HsVar (noLoc id))) } {- ************************************************************************ @@ -530,7 +530,7 @@ newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTcId) newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty + lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty | not rebindable -- all built-in overloaded lits are tau-types, so we can just -- tauify the ExpType @@ -541,8 +541,8 @@ newOverloadedLit -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) + Just expr -> return (lit { ol_witness = expr, ol_type = res_ty + , ol_rebindable = False }) Nothing -> newNonTrivialOverloadedLit orig lit (mkCheckExpType res_ty) } @@ -550,7 +550,6 @@ newOverloadedLit = newNonTrivialOverloadedLit orig lit res_ty where orig = LiteralOrigin lit -newOverloadedLit XOverLit{} _ = panic "newOverloadedLit" -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify @@ -559,8 +558,8 @@ newNonTrivialOverloadedLit :: CtOrigin -> ExpRhoType -> TcM (HsOverLit GhcTcId) newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) - , ol_ext = rebindable }) res_ty + lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) + , ol_rebindable = rebindable }) res_ty = do { hs_lit <- mkOverLit val ; let lit_ty = hsLitType hs_lit ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) @@ -569,12 +568,13 @@ newNonTrivialOverloadedLit orig ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness - , ol_ext = OverLitTc rebindable res_ty }) } + , ol_type = res_ty + , ol_rebindable = rebindable }) } newNonTrivialOverloadedLit _ lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ -mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) +mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p) mkOverLit (HsIntegral i) = do { integer_ty <- tcMetaTy integerTyConName ; return (HsInteger (setSourceText $ il_text i) @@ -582,7 +582,7 @@ mkOverLit (HsIntegral i) mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat noExt r rat_ty) } + ; return (HsRat def r rat_ty) } mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s) @@ -626,7 +626,7 @@ tcSyntaxName :: CtOrigin -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in HsExpr -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) +tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm)) | std_nm == user_nm = do rhs <- newMethodFromName orig std_nm ty return (std_nm, rhs) diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 3463750d7e..edf696e3c9 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -72,7 +72,6 @@ annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod -annCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => AnnDecl (GhcPass p) -> SDoc +annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 318e4c683b..96750f7260 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -121,13 +121,11 @@ tcCmdTop :: CmdEnv -> CmdType -> TcM (LHsCmdTop GhcTcId) -tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) +tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) 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 (CmdTopTc cmd_stk res_ty names') cmd') } -tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop" - + ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) -- The main recursive function @@ -137,35 +135,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 x cmd) res_ty +tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x cmd') } + ; return (HsCmdPar cmd') } -tc_cmd env (HsCmdLet x (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 x (L l binds') (L body_loc body')) } + ; return (HsCmdLet (L l binds') (L body_loc body')) } -tc_cmd env in_cmd@(HsCmdCase x 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 x 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 x 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 x Nothing pred' b1' b2') + ; return (HsCmdIf Nothing pred' b1' b2') } -tc_cmd env (HsCmdIf x (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 @@ -181,7 +179,7 @@ tc_cmd env (HsCmdIf x (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 x (Just fun') pred' b1' b2') + ; return (HsCmdIf (Just fun') pred' b1' b2') } ------------------------------------------- @@ -200,7 +198,7 @@ tc_cmd env (HsCmdIf x (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 @@ -208,7 +206,7 @@ tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -227,12 +225,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 x 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 x fun' arg') } + ; return (HsCmdApp fun' arg') } ------------------------------------------- -- Lambda @@ -242,9 +240,9 @@ tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam x (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 @@ -257,9 +255,8 @@ 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 x (MG { mg_alts = L l [match'] - , mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) + cmd' = HsCmdLam (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 @@ -280,10 +277,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 res_ty (L l stmts') )) } + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) } ----------------------------------------------------------------- @@ -300,7 +297,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 x 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' @@ -308,7 +305,7 @@ tc_cmd env cmd@(HsCmdArrForm x 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 x expr' f fixity cmd_args') } + ; return (HsCmdArrForm expr' f fixity cmd_args') } where tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) @@ -320,8 +317,6 @@ tc_cmd env cmd@(HsCmdArrForm x 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 diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 515eb4df35..6a9b22a9bb 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -308,13 +308,13 @@ tcCompleteSigs sigs = in mapMaybeM (addLocM doOne) sigs tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv -tcRecSelBinds (XValBindsLR (NValBinds binds sigs)) +tcRecSelBinds (ValBindsOut binds sigs) = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds ; return tcg_env' } -tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds" +tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type @@ -342,10 +342,10 @@ tcLocalBinds EmptyLocalBinds thing_inside = do { thing <- thing_inside ; return (EmptyLocalBinds, thing) } -tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside +tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) } -tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds" + ; return (HsValBinds (ValBindsOut binds' sigs), thing) } +tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside = do { ipClass <- tcLookupClass ipClassName @@ -1178,9 +1178,9 @@ tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId) tcVect (HsVect s name rhs) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name - ; let L rhs_loc (HsVar noExt (L lv rhs_var_name)) = rhs + ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar noExt (L lv rhs_id))) + ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id))) } tcVect (HsNoVect s name) @@ -1742,8 +1742,7 @@ isClosedBndrGroup type_env binds -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), - Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body) + => LPat p -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 3012801856..33ce5810ca 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -336,7 +336,7 @@ renameDeriv is_boot inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs) + ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; let bndrs = collectHsValBinders rn_aux_lhs ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 8d11fed65c..21b895eea3 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -884,12 +884,10 @@ data InstBindings a -- Used only to improve error messages } -instance (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) - => Outputable (InstInfo (GhcPass a)) where +instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) - => InstInfo (GhcPass a) -> SDoc +pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index a9d8b64515..4eb5dd1562 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -167,43 +167,43 @@ NB: The res_ty is always deeply skolemised. -} tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty +tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty +tcExpr e@(HsUnboundVar uv) res_ty = tcUnboundId e uv res_ty tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsLit x lit) res_ty +tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } + ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x expr') } +tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar expr') } -tcExpr (HsSCC x src lbl expr) res_ty +tcExpr (HsSCC src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC x src lbl expr') } + ; return (HsSCC src lbl expr') } -tcExpr (HsTickPragma x src info srcInfo expr) res_ty +tcExpr (HsTickPragma src info srcInfo expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma x src info srcInfo expr') } + ; return (HsTickPragma src info srcInfo expr') } -tcExpr (HsCoreAnn x src lbl expr) res_ty +tcExpr (HsCoreAnn src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn x src lbl expr') } + ; return (HsCoreAnn src lbl expr') } -tcExpr (HsOverLit x lit) res_ty +tcExpr (HsOverLit lit) res_ty = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } + ; return (HsOverLit lit') } -tcExpr (NegApp x expr neg_expr) res_ty +tcExpr (NegApp expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ \[arg_ty] -> tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp x expr' neg_expr') } + ; return (NegApp expr' neg_expr') } -tcExpr e@(HsIPVar _ x) res_ty +tcExpr e@(HsIPVar x) res_ty = do { {- Implicit parameters must have a *tau-type* not a type scheme. We enforce this by creating a fresh type variable as its type. (Because res_ty may not @@ -212,16 +212,15 @@ tcExpr e@(HsIPVar _ x) res_ty ; let ip_name = mkStrLitTy (hsIPNameFS x) ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var))) - ip_ty res_ty } + ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) + ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty +tcExpr e@(HsOverLabel mb_fromLabel l) res_ty = do { -- See Note [Type-checking overloaded labels] loc <- getSrcSpanM ; case mb_fromLabel of @@ -231,8 +230,7 @@ tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty ; let pred = mkClassPred isLabelClass [lbl, alpha] ; loc <- getSrcSpanM ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExt (L loc var))) + ; tcWrapResult e (fromDict pred (HsVar (L loc var))) alpha res_ty } } where -- Coerces a dictionary for `IsLabel "x" t` into `t`, @@ -242,13 +240,12 @@ tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty lbl = mkStrLitTy l applyFromLabel loc fromLabel = - HsAppType - (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l)))) - (L loc (HsVar noExt (L loc fromLabel))) + L loc (HsVar (L loc fromLabel)) `HsAppType` + mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l))) -tcExpr (HsLam x match) res_ty +tcExpr (HsLam match) res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } + ; return (mkHsWrap wrap (HsLam match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> @@ -257,23 +254,23 @@ tcExpr (HsLam x match) res_ty -- The pprSetDepth makes the abstraction print briefly text "has"] -tcExpr e@(HsLamCase x matches) res_ty +tcExpr e@(HsLamCase matches) res_ty = do { (matches', wrap) <- tcMatchLambda msg match_ctxt matches res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase x matches') } + ; return (mkHsWrap wrap $ HsLamCase matches') } where msg = sep [ text "The function" <+> quotes (ppr e) , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr e@(ExprWithTySig sig_ty expr) res_ty +tcExpr e@(ExprWithTySig expr sig_ty) res_ty = do { let loc = getLoc (hsSigWcType sig_ty) ; sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc sig_ty Nothing ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySig sig_ty expr' + ; let expr'' = ExprWithTySigOut expr' sig_ty ; tcWrapResult e expr'' poly_ty res_ty } {- @@ -352,8 +349,8 @@ construct. See also Note [seqId magic] in MkId -} -tcExpr expr@(OpApp fix arg1 op arg2) res_ty - | (L loc (HsVar _ (L lv op_name))) <- op +tcExpr expr@(OpApp arg1 op fix arg2) res_ty + | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_exp_ty = res_ty @@ -363,10 +360,10 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty ; arg2_ty <- readExpType arg2_exp_ty ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty]) - (HsVar noExt (L lv op_id))) - ; return $ OpApp fix arg1' op' arg2' } + (HsVar (L lv op_id))) + ; return $ OpApp arg1' op' fix arg2' } - | (L loc (HsVar _ (L lv op_name))) <- op + | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 @@ -389,8 +386,7 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty -- -- The *result* type can have any kind (Trac #8739), -- so we don't need to check anything for that - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) - (typeKind arg2_sigma) liftedTypeKind + ; _ <- unifyKind (Just (HsCoreTy arg2_sigma)) (typeKind arg2_sigma) liftedTypeKind -- ignore the evidence. arg2_sigma must have type * or #, -- because we know arg2_sigma -> or_res_ty is well-kinded -- (because otherwise matchActualFunTys would fail) @@ -404,7 +400,7 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty , arg2_sigma , res_ty]) - (HsVar noExt (L lv op_id))) + (HsVar (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- wrap_res :: op_res_ty "->" res_ty @@ -415,15 +411,15 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty <.> wrap_arg1 doc = text "When looking at the argument to ($)" - ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') } + ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } - | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op + | (L loc (HsRecFld (Ambiguous lbl _))) <- op , Just sig_ty <- obviousSig (unLoc arg1) -- See Note [Disambiguating record fields] = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl)) - ; tcExpr (OpApp fix arg1 op' arg2) res_ty + ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name)) + ; tcExpr (OpApp arg1 op' fix arg2) res_ty } | otherwise @@ -431,12 +427,12 @@ tcExpr expr@(OpApp fix arg1 op arg2) res_ty ; (wrap, op', [HsValArg arg1', HsValArg arg2']) <- tcApp (Just $ mk_op_msg op) op [HsValArg arg1, HsValArg arg2] res_ty - ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } + ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr -tcExpr expr@(SectionR x op arg2) res_ty +tcExpr expr@(SectionR op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty @@ -444,14 +440,14 @@ tcExpr expr@(SectionR x op arg2) res_ty (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op arg2 arg2_ty 2 ; return ( mkHsWrap wrap_res $ - SectionR x (mkLHsWrap wrap_fun op') arg2' ) } + SectionR (mkLHsWrap wrap_fun op') arg2' ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(SectionL x arg1 op) res_ty +tcExpr expr@(SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 @@ -464,14 +460,14 @@ tcExpr expr@(SectionL x arg1 op) res_ty (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op arg1 arg1_ty 1 ; return ( mkHsWrap wrap_res $ - SectionL x arg1' (mkLHsWrap wrap_fn op') ) } + SectionL arg1' (mkLHsWrap wrap_fn op') ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty +tcExpr expr@(ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args = do { let arity = length tup_args tup_tc = tupleTyCon boxity arity @@ -483,7 +479,7 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@ -503,16 +499,16 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } + ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) } -tcExpr (ExplicitSum _ alt arity expr) res_ty +tcExpr (ExplicitSum alt arity expr _) res_ty = do { let sum_tc = sumTyCon arity ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty ; -- Drop levity vars, we don't care about them here let arg_tys' = drop arity arg_tys ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } + ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') } tcExpr (ExplicitList _ witness exprs) res_ty = case witness of @@ -550,12 +546,12 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty ************************************************************************ -} -tcExpr (HsLet x (L l binds) expr) res_ty +tcExpr (HsLet (L l binds) expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } + ; return (HsLet (L l binds') expr') } -tcExpr (HsCase x scrut matches) res_ty +tcExpr (HsCase scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -569,12 +565,12 @@ tcExpr (HsCase x scrut matches) res_ty ; traceTc "HsCase" (ppr scrut_ty) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase x scrut' matches') } + ; return (HsCase scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; res_ty <- tauifyExpType res_ty -- Just like Note [Case branches must never infer a non-tau type] @@ -582,9 +578,9 @@ tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf x Nothing pred' b1' b2') } + ; return (HsIf Nothing pred' b1' b2') } -tcExpr (HsIf x (Just fun) pred b1 b2) res_ty +tcExpr (HsIf (Just fun) pred b1 b2) res_ty = do { ((pred', b1', b2'), fun') <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ \ [pred_ty, b1_ty, b2_ty] -> @@ -592,7 +588,7 @@ tcExpr (HsIf x (Just fun) pred b1 b2) res_ty ; b1' <- tcPolyExpr b1 b1_ty ; b2' <- tcPolyExpr b2 b2_ty ; return (pred', b1', b2') } - ; return (HsIf x (Just fun') pred' b1' b2') } + ; return (HsIf (Just fun') pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts @@ -606,13 +602,13 @@ tcExpr (HsMultiIf _ alts) res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } -tcExpr (HsDo _ do_or_lc stmts) res_ty +tcExpr (HsDo do_or_lc stmts _) res_ty = do { expr' <- tcDoStmts do_or_lc stmts res_ty ; return expr' } -tcExpr (HsProc x pat cmd) res_ty +tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. -- See Note [Grand plan for static forms] in StaticPtrTable for an overview. @@ -653,8 +649,7 @@ tcExpr (HsStatic fvs expr) res_ty ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExt - (L loc $ mkHsWrap wrap fromStaticPtr) + ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr) (L loc (HsStatic fvs expr')) } @@ -688,10 +683,9 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name ; rbinds' <- tcRecordBinds con_like arg_tys rbinds ; return $ mkHsWrap res_wrap $ - RecordCon { rcon_ext = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } - , rcon_con_name = L loc con_id + RecordCon { rcon_con_name = L loc con_id + , rcon_con_expr = mkHsWrap con_wrap con_expr + , rcon_con_like = con_like , rcon_flds = rbinds' } } } {- @@ -976,16 +970,12 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Phew! ; return $ mkHsWrap wrap_res $ - RecordUpd { rupd_expr - = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') + RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') , rupd_flds = rbinds' - , rupd_ext = RecordUpdTc - { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap }} } + , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys + , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } } -tcExpr e@(HsRecFld _ f) res_ty +tcExpr e@(HsRecFld f) res_ty = tcCheckRecSelId e f res_ty {- @@ -1022,9 +1012,10 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) (idName enumFromThenToP) elt_ty -- !!!FIXME: chak ; return $ - mkHsWrapCo coi $ PArrSeq eft (FromThenTo expr1' expr2' expr3') } + mkHsWrapCo coi $ + PArrSeq eft (FromThenTo expr1' expr2' expr3') } -tcExpr (PArrSeq {}) _ +tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -1041,15 +1032,15 @@ 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 -tcExpr (HsSpliceE _ splice) res_ty +tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket _ brack) res_ty +tcExpr e@(HsBracket brack) res_ty = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut _ brack ps) res_ty +tcExpr e@(HsRnBracketOut brack ps) res_ty = tcUntypedBracket e brack ps res_ty {- @@ -1166,11 +1157,11 @@ tcApp m_herald orig_fun orig_args res_ty where go :: LHsExpr GhcRn -> [LHsExprArgIn] -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - go (L _ (HsPar _ e)) args = go e args - go (L _ (HsApp _ e1 e2)) args = go e1 (HsValArg e2:args) - go (L _ (HsAppType t e)) args = go e (HsTypeArg t:args) + go (L _ (HsPar e)) args = go e args + go (L _ (HsApp e1 e2)) args = go e1 (HsValArg e2:args) + go (L _ (HsAppType e t)) args = go e (HsTypeArg t:args) - go (L loc (HsVar _ (L _ fun))) args + go (L loc (HsVar (L _ fun))) args | fun `hasKey` tagToEnumKey , count isHsValArg args == 1 = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty @@ -1181,11 +1172,11 @@ tcApp m_herald orig_fun orig_args res_ty = do { (wrap, expr, args) <- tcSeq loc fun args res_ty ; return (wrap, expr, args) } - go (L loc (HsRecFld _ (Ambiguous _ lbl))) args@(HsValArg (L _ arg) : _) + go (L loc (HsRecFld (Ambiguous lbl _))) args@(HsValArg (L _ arg) : _) | Just sig_ty <- obviousSig arg = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; go (L loc (HsRecFld noExt (Unambiguous sel_name lbl))) args } + ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args } -- See Note [Visible type application for the empty list constructor] go (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] @@ -1255,12 +1246,12 @@ which is better than before. ---------------- tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) -- Infer type of a function -tcInferFun (L loc (HsVar _ (L _ name))) +tcInferFun (L loc (HsVar (L _ name))) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } -tcInferFun (L loc (HsRecFld _ f)) +tcInferFun (L loc (HsRecFld f)) = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } @@ -1392,9 +1383,8 @@ 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 x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present x expr')) } - go (L _ (XTupArg{}), _) = panic "tcTupArgs" + go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (L l (Present expr')) } --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1417,7 +1407,7 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, SyntaxExpr GhcTcId) -tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar _ (L _ op) }) +tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferId op ; (result, expr_wrap, arg_wraps, res_wrap) @@ -1690,31 +1680,27 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr - actual_res_ty res_ty } + ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) (HsVar (noLoc name)) expr actual_res_ty res_ty } tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty +tcCheckRecSelId rn_expr f@(Unambiguous (L _ lbl) _) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $ + ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } -tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty +tcCheckRecSelId rn_expr (Ambiguous lbl _) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of Nothing -> ambiguousSelector lbl Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) - res_ty } -tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId" + ; tcCheckRecSelId rn_expr (Unambiguous lbl sel_name) res_ty } ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous sel (L _ lbl)) +tcInferRecSelId (Unambiguous (L _ lbl) sel) = do { (expr', ty) <- tc_infer_id lbl sel ; return (expr', ty) } -tcInferRecSelId (Ambiguous _ lbl) +tcInferRecSelId (Ambiguous lbl _) = ambiguousSelector lbl -tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId" ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1743,7 +1729,7 @@ tc_infer_assert assert_name = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho) + ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) } tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1769,12 +1755,12 @@ tc_infer_id lbl id_name _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where - return_id id = return (HsVar noExt (noLoc id), idType id) + return_id id = return (HsVar (noLoc id), idType id) return_data_con con -- For data constructors, must perform the stupid-theta check | null stupid_theta - = return (HsConLikeOut noExt (RealDataCon con), con_ty) + = return (HsConLikeOut (RealDataCon con), con_ty) | otherwise -- See Note [Instantiating stupid theta] @@ -1785,8 +1771,7 @@ tc_infer_id lbl id_name rho' = substTy subst rho ; wrap <- instCall (OccurrenceOf id_name) tys' theta' ; addDataConStupidTheta con tys' - ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con)) - , rho') } + ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') } where con_ty = dataConUserType con @@ -1818,8 +1803,7 @@ tcUnboundId rn_expr unbound res_ty , ctev_loc = loc} , cc_hole = ExprHole unbound } ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev)) - ty res_ty } + ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar (noLoc ev)) ty res_ty } {- @@ -1901,7 +1885,7 @@ tcSeq loc fun_name args res_ty ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty) ; arg2' <- tcMonoExpr arg2 arg2_exp_ty ; res_ty <- readExpType res_ty -- by now, it's surely filled in - ; let fun' = L loc (mkHsWrap ty_args (HsVar noExt (L loc fun))) + ; let fun' = L loc (mkHsWrap ty_args (HsVar (L loc fun))) ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty ; return (idHsWrapper, fun', [HsValArg arg1', HsValArg arg2']) } @@ -1943,7 +1927,7 @@ tcTagToEnum loc fun_name args res_ty (mk_error ty' doc2) ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun))) + ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args ; return (mkWpCastR (mkTcSymCo coi), fun', [HsValArg arg']) } @@ -2021,7 +2005,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] - ; return (HsVar noExt (noLoc sid)) } + ; return (HsVar (noLoc sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -2231,9 +2215,8 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Extract the selector name of a field update if it is unambiguous isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) + Unambiguous _ sel_name -> Just (x, sel_name) Ambiguous{} -> Nothing - XAmbiguousFieldOcc{} -> Nothing -- Look up the possible parents and selector GREs for each field getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn @@ -2301,7 +2284,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ; let L loc af = hsRecFieldLbl upd lbl = rdrNameAmbiguousFieldOcc af ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } + = L loc (Unambiguous (L loc lbl) i) } } -- Extract the outermost TyCon of a type, if there is one; for @@ -2337,8 +2320,8 @@ lookupParents rdr -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig ty _) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig (ExprWithTySig _ ty) = Just ty +obviousSig (HsPar p) = obviousSig (unLoc p) obviousSig _ = Nothing @@ -2401,22 +2384,21 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + f = L loc (FieldOcc (L loc lbl) (idName sel_id)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl - = L loc (Unambiguous - (extFieldOcc (unLoc f')) - (L loc lbl)) + = L loc (Unambiguous (L loc lbl) + (selectorFieldOcc (unLoc f'))) , hsRecFieldArg = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs +tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcPolyExprNC rhs field_ty @@ -2427,13 +2409,12 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } + ; return (Just (L loc (FieldOcc lbl field_id), rhs')) } | otherwise = do { addErrTc (badFieldCon con_like field_lbl) ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField" checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 9140de69f7..d9166e5e00 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -447,7 +447,7 @@ gen_Ord_binds loc tycon = do , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag))) + tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -614,8 +614,7 @@ gen_Enum_binds loc tycon = do (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt noExt - (mkIntegralLit (-1 :: Int)))])) + , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))])) to_enum dflags = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ @@ -775,7 +774,7 @@ gen_Ix_binds loc tycon = do enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR - [noLoc (AsPat noExt (noLoc c_RDR) + [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( @@ -1143,7 +1142,7 @@ gen_Show_binds get_fixity loc tycon | otherwise = ([a_Pat, con_pat], showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt noExt (mkIntegralLit con_prec_plus_one)))) + (HsInt def (mkIntegralLit con_prec_plus_one)))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con @@ -1227,7 +1226,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x] + = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x] -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -1700,12 +1699,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys) nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType hs_ty e) +nlHsAppType e s = noLoc (e `HsAppType` hs_ty) where hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc (ExprWithTySig hs_ty e) +nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) where hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -1759,7 +1758,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) where rdr_name = con2tag_RDR dflags tycon - sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ + sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ mkParentType tycon `mkFunTy` intPrimTy @@ -1784,7 +1783,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) L loc (TypeSig [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ - XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR dflags tycon @@ -1794,7 +1793,7 @@ genAuxBindSpec dflags loc (DerivMaxTag tycon) L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) + sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim NoSourceText max_tag)) max_tag = case (tyConDataCons tycon) of @@ -2093,8 +2092,8 @@ illegal_toEnum_tag tp maxtag = (nlHsLit (mkHsString ")")))))) parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _ _)) = e -parenify e = mkHsPar e +parenify e@(L _ (HsVar _)) = e +parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index ab6220e9b5..61e2864c13 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -8,7 +8,6 @@ The deriving code for the Functor, Foldable, and Traversable classes {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} module TcGenFunctor ( FFoldType(..), functorLikeTraverse, diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 29dfefbab2..01b7176a6e 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -10,8 +10,7 @@ checker. -} {-# LANGUAGE CPP, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP, TypeFamilies #-} module TcHsSyn ( -- * Extracting types from HsSyn @@ -89,28 +88,28 @@ hsLPatType :: OutPat GhcTc -> Type hsLPatType (L _ pat) = hsPatType pat hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat _ (L _ var)) = idType var -hsPatType (BangPat _ pat) = hsLPatType pat -hsPatType (LazyPat _ pat) = hsLPatType pat -hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) -hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat _ _ ty Nothing) = mkListTy ty -hsPatType (ListPat _ _ _ (Just (ty,_))) = ty -hsPatType (PArrPat ty _) = mkPArrTy ty -hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys -hsPatType (SumPat tys _ _ _ ) = mkSumTy tys +hsPatType (ParPat pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat (L _ var)) = idType var +hsPatType (BangPat pat) = hsLPatType pat +hsPatType (LazyPat pat) = hsLPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var _) = idType (unLoc var) +hsPatType (ViewPat _ _ ty) = ty +hsPatType (ListPat _ ty Nothing) = mkListTy ty +hsPatType (ListPat _ _ (Just (ty,_))) = ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys +hsPatType (SumPat _ _ _ tys) = mkSumTy tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) - = conLikeResTy con tys -hsPatType (SigPat ty _) = ty -hsPatType (NPat ty _ _ _) = ty -hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (CoPat _ _ _ ty) = ty -hsPatType p = pprPanic "hsPatType" (ppr p) - -hsLitType :: HsLit (GhcPass p) -> TcType + = conLikeResTy con tys +hsPatType (SigPatOut _ ty) = ty +hsPatType (NPat _ _ _ ty) = ty +hsPatType (NPlusKPat _ _ _ _ _ ty) = ty +hsPatType (CoPat _ _ ty) = ty +hsPatType p = pprPanic "hsPatType" (ppr p) + +hsLitType :: HsLit p -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy @@ -124,15 +123,14 @@ hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy -hsLitType (XLit p) = pprPanic "hsLitType" (ppr p) -- Overloaded literals. Here mainly because it uses isIntTy etc shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit noExt (HsInt noExt int)) + | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt def int)) | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty)) + | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, @@ -141,16 +139,16 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty -- literals, compiled without -O shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExt f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f)) + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim def f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim def f)) | otherwise = Nothing shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExt (HsString src s)) + | isStringTy ty = Just (HsLit (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -310,9 +308,7 @@ zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel -zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc" +zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) zonkEvBndrsX = mapAccumLM zonkEvBndrX @@ -397,12 +393,12 @@ zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId zonkLocalBinds env EmptyLocalBinds = return (env, EmptyLocalBinds) -zonkLocalBinds _ (HsValBinds (ValBinds {})) +zonkLocalBinds _ (HsValBinds (ValBindsIn {})) = panic "zonkLocalBinds" -- Not in typechecker output -zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs))) +zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs)) = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) } + ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } where go env [] = return (env, []) @@ -607,116 +603,115 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (L l id)) +zonkExpr env (HsVar (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (L l (zonkIdOcc env id))) + return (HsVar (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e -zonkExpr _ (HsIPVar x id) - = return (HsIPVar x id) +zonkExpr _ (HsIPVar id) + = return (HsIPVar id) zonkExpr _ e@HsOverLabel{} = return e -zonkExpr env (HsLit x (HsRat e f ty)) +zonkExpr env (HsLit (HsRat e f ty)) = do new_ty <- zonkTcTypeToType env ty - return (HsLit x (HsRat e f new_ty)) + return (HsLit (HsRat e f new_ty)) -zonkExpr _ (HsLit x lit) - = return (HsLit x lit) +zonkExpr _ (HsLit lit) + = return (HsLit lit) -zonkExpr env (HsOverLit x lit) +zonkExpr env (HsOverLit lit) = do { lit' <- zonkOverLit env lit - ; return (HsOverLit x lit') } + ; return (HsOverLit lit') } -zonkExpr env (HsLam x matches) +zonkExpr env (HsLam matches) = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam x new_matches) + return (HsLam new_matches) -zonkExpr env (HsLamCase x matches) +zonkExpr env (HsLamCase matches) = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x new_matches) + return (HsLamCase new_matches) -zonkExpr env (HsApp x e1 e2) +zonkExpr env (HsApp e1 e2) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 - return (HsApp x new_e1 new_e2) + return (HsApp new_e1 new_e2) -zonkExpr env (HsAppType t e) +zonkExpr env (HsAppTypeOut e t) = do new_e <- zonkLExpr env e - return (HsAppType t new_e) + return (HsAppTypeOut new_e t) -- NB: the type is an HsType; can't zonk that! -zonkExpr _ e@(HsRnBracketOut _ _ _) +zonkExpr _ e@(HsRnBracketOut _ _) = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) -zonkExpr env (HsTcBracketOut x body bs) +zonkExpr env (HsTcBracketOut body bs) = do bs' <- mapM zonk_b bs - return (HsTcBracketOut x body bs') + return (HsTcBracketOut body bs') where zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e return (PendingTcSplice n e') -zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen - return (HsSpliceE x s) +zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen + return (HsSpliceE s) -zonkExpr env (OpApp fixity e1 op e2) +zonkExpr env (OpApp e1 op fixity e2) = do new_e1 <- zonkLExpr env e1 new_op <- zonkLExpr env op new_e2 <- zonkLExpr env e2 - return (OpApp fixity new_e1 new_op new_e2) + return (OpApp new_e1 new_op fixity new_e2) -zonkExpr env (NegApp x expr op) +zonkExpr env (NegApp expr op) = do (env', new_op) <- zonkSyntaxExpr env op new_expr <- zonkLExpr env' expr - return (NegApp x new_expr new_op) + return (NegApp new_expr new_op) -zonkExpr env (HsPar x e) +zonkExpr env (HsPar e) = do new_e <- zonkLExpr env e - return (HsPar x new_e) + return (HsPar new_e) -zonkExpr env (SectionL x expr op) +zonkExpr env (SectionL expr op) = do new_expr <- zonkLExpr env expr new_op <- zonkLExpr env op - return (SectionL x new_expr new_op) + return (SectionL new_expr new_op) -zonkExpr env (SectionR x op expr) +zonkExpr env (SectionR op expr) = do new_op <- zonkLExpr env op new_expr <- zonkLExpr env expr - return (SectionR x new_op new_expr) + return (SectionR new_op new_expr) -zonkExpr env (ExplicitTuple x tup_args boxed) +zonkExpr env (ExplicitTuple tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple x new_tup_args boxed) } + ; return (ExplicitTuple new_tup_args boxed) } where - zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (L l (Present x e')) } + zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e + ; return (L l (Present 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) +zonkExpr env (ExplicitSum alt arity expr args) = do new_args <- mapM (zonkTcTypeToType env) args new_expr <- zonkLExpr env expr - return (ExplicitSum new_args alt arity new_expr) + return (ExplicitSum alt arity new_expr new_args) -zonkExpr env (HsCase x expr ms) +zonkExpr env (HsCase expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase x new_expr new_ms) + return (HsCase new_expr new_ms) -zonkExpr env (HsIf x Nothing e1 e2 e3) +zonkExpr env (HsIf Nothing e1 e2 e3) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 new_e3 <- zonkLExpr env e3 - return (HsIf x Nothing new_e1 new_e2 new_e3) + return (HsIf Nothing new_e1 new_e2 new_e3) -zonkExpr env (HsIf x (Just fun) e1 e2 e3) +zonkExpr env (HsIf (Just fun) e1 e2 e3) = do (env1, new_fun) <- zonkSyntaxExpr env fun new_e1 <- zonkLExpr env1 e1 new_e2 <- zonkLExpr env1 e2 new_e3 <- zonkLExpr env1 e3 - return (HsIf x (Just new_fun) new_e1 new_e2 new_e3) + return (HsIf (Just new_fun) new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts @@ -727,15 +722,15 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS guard' expr' } -zonkExpr env (HsLet x (L l binds) expr) +zonkExpr env (HsLet (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) new_expr) + return (HsLet (L l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (L l stmts)) +zonkExpr env (HsDo do_or_lc (L l stmts) ty) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToType env ty - return (HsDo new_ty do_or_lc (L l new_stmts)) + return (HsDo do_or_lc (L l new_stmts) new_ty) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -750,31 +745,27 @@ zonkExpr env (ExplicitPArr ty exprs) new_exprs <- zonkLExprs env exprs return (ExplicitPArr new_ty new_exprs) -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) +zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env con_expr ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + ; return (expr { rcon_con_expr = new_con_expr , rcon_flds = new_rbinds }) } -zonkExpr env (RecordUpd { rupd_flds = rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) +zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds + , rupd_cons = cons, rupd_in_tys = in_tys + , rupd_out_tys = out_tys, rupd_wrap = req_wrap }) = do { new_expr <- zonkLExpr env expr ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys ; new_rbinds <- zonkRecUpdFields env rbinds ; (_, new_recwrap) <- zonkCoFn env req_wrap ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } + , rupd_cons = cons, rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) } -zonkExpr env (ExprWithTySig ty e) +zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e - ; return (ExprWithTySig ty e') } + ; return (ExprWithTySigOut e' ty) } zonkExpr env (ArithSeq expr wit info) = do (env1, new_wit) <- zonkWit env wit @@ -789,33 +780,33 @@ zonkExpr env (PArrSeq expr info) new_info <- zonkArithSeq env info return (PArrSeq new_expr new_info) -zonkExpr env (HsSCC x src lbl expr) +zonkExpr env (HsSCC src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsSCC x src lbl new_expr) + return (HsSCC src lbl new_expr) -zonkExpr env (HsTickPragma x src info srcInfo expr) +zonkExpr env (HsTickPragma src info srcInfo expr) = do new_expr <- zonkLExpr env expr - return (HsTickPragma x src info srcInfo new_expr) + return (HsTickPragma src info srcInfo new_expr) -- hdaume: core annotations -zonkExpr env (HsCoreAnn x src lbl expr) +zonkExpr env (HsCoreAnn src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsCoreAnn x src lbl new_expr) + return (HsCoreAnn src lbl new_expr) -- arrow notation extensions -zonkExpr env (HsProc x pat body) +zonkExpr env (HsProc pat body) = do { (env1, new_pat) <- zonkPat env pat ; new_body <- zonkCmdTop env1 body - ; return (HsProc x new_pat new_body) } + ; return (HsProc new_pat new_body) } -- StaticPointers extension zonkExpr env (HsStatic fvs expr) = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (HsWrap x co_fn expr) +zonkExpr env (HsWrap co_fn expr) = do (env1, new_co_fn) <- zonkCoFn env co_fn new_expr <- zonkExpr env1 expr - return (HsWrap x new_co_fn new_expr) + return (HsWrap new_co_fn new_expr) zonkExpr _ e@(HsUnboundVar {}) = return e @@ -862,60 +853,60 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd -zonkCmd env (HsCmdWrap x w cmd) +zonkCmd env (HsCmdWrap w cmd) = do { (env1, w') <- zonkCoFn env w ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap x w' cmd') } -zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) + ; return (HsCmdWrap w' cmd') } +zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 new_ty <- zonkTcTypeToType env ty - return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) + return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) -zonkCmd env (HsCmdArrForm x 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 x new_op f fixity new_args) + return (HsCmdArrForm new_op f fixity new_args) -zonkCmd env (HsCmdApp x c e) +zonkCmd env (HsCmdApp c e) = do new_c <- zonkLCmd env c new_e <- zonkLExpr env e - return (HsCmdApp x new_c new_e) + return (HsCmdApp new_c new_e) -zonkCmd env (HsCmdLam x matches) +zonkCmd env (HsCmdLam matches) = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam x new_matches) + return (HsCmdLam new_matches) -zonkCmd env (HsCmdPar x c) +zonkCmd env (HsCmdPar c) = do new_c <- zonkLCmd env c - return (HsCmdPar x new_c) + return (HsCmdPar new_c) -zonkCmd env (HsCmdCase x expr ms) +zonkCmd env (HsCmdCase expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase x new_expr new_ms) + return (HsCmdCase new_expr new_ms) -zonkCmd env (HsCmdIf x 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 x 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 x (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 x (L l new_binds) new_cmd) + return (HsCmdLet (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (L l stmts)) +zonkCmd env (HsCmdDo (L l stmts) ty) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToType env ty - return (HsCmdDo new_ty (L l new_stmts)) + return (HsCmdDo (L l new_stmts) new_ty) + -zonkCmd _ (XCmd{}) = panic "zonkCmd" @@ -923,7 +914,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 (CmdTopTc stack_tys ty ids) cmd) +zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) = do new_cmd <- zonkLCmd env cmd new_stack_tys <- zonkTcTypeToType env stack_tys new_ty <- zonkTcTypeToType env ty @@ -934,8 +925,7 @@ zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) -- but indeed it should always be lifted due to the typing -- rules for arrows - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) -zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top" + return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) @@ -963,12 +953,10 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) +zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) = do { ty' <- zonkTcTypeToType env ty ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } - -zonkOverLit _ XOverLit{} = panic "zonkOverLit" + ; return (lit { ol_witness = e', ol_type = ty' }) } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) @@ -1012,18 +1000,15 @@ 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 x 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 x new_stmts (zonkIdOccs env3 bndrs) - new_return) } - zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt" + ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) } 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 @@ -1188,9 +1173,9 @@ zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) zonkPat env pat = wrapLocSndM (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x p) +zonk_pat env (ParPat p) = do { (env', p') <- zonkPat env p - ; return (env', ParPat x p') } + ; return (env', ParPat p') } zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToType env ty @@ -1198,55 +1183,55 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (L l v)) +zonk_pat env (VarPat (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } + ; return (extendIdZonkEnv1 env v', VarPat (L l v')) } -zonk_pat env (LazyPat x pat) +zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat x pat') } + ; return (env', LazyPat pat') } -zonk_pat env (BangPat x pat) +zonk_pat env (BangPat pat) = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat x pat') } + ; return (env', BangPat pat') } -zonk_pat env (AsPat x (L loc v) pat) +zonk_pat env (AsPat (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat x (L loc v') pat') } + ; return (env', AsPat (L loc v') pat') } -zonk_pat env (ViewPat ty expr pat) +zonk_pat env (ViewPat expr pat ty) = do { expr' <- zonkLExpr env expr ; (env', pat') <- zonkPat env pat ; ty' <- zonkTcTypeToType env ty - ; return (env', ViewPat ty' expr' pat') } + ; return (env', ViewPat expr' pat' ty') } -zonk_pat env (ListPat x pats ty Nothing) +zonk_pat env (ListPat pats ty Nothing) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat x pats' ty' Nothing) } + ; return (env', ListPat pats' ty' Nothing) } -zonk_pat env (ListPat x pats ty (Just (ty2,wit))) +zonk_pat env (ListPat pats ty (Just (ty2,wit))) = do { (env', wit') <- zonkSyntaxExpr env wit ; ty2' <- zonkTcTypeToType env' ty2 ; ty' <- zonkTcTypeToType env' ty ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat x pats' ty' (Just (ty2',wit'))) } + ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) } -zonk_pat env (PArrPat ty pats) +zonk_pat env (PArrPat pats ty) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', PArrPat ty' pats') } + ; return (env', PArrPat pats' ty') } -zonk_pat env (TuplePat tys pats boxed) +zonk_pat env (TuplePat pats boxed tys) = do { tys' <- mapM (zonkTcTypeToType env) tys ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat tys' pats' boxed) } + ; return (env', TuplePat pats' boxed tys') } -zonk_pat env (SumPat tys pat alt arity ) +zonk_pat env (SumPat pat alt arity tys) = do { tys' <- mapM (zonkTcTypeToType env) tys ; (env', pat') <- zonkPat env pat - ; return (env', SumPat tys' pat' alt arity) } + ; return (env', SumPat pat' alt arity tys') } zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds @@ -1280,14 +1265,14 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars where doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p -zonk_pat env (LitPat x lit) = return (env, LitPat x lit) +zonk_pat env (LitPat lit) = return (env, LitPat lit) -zonk_pat env (SigPat ty pat) +zonk_pat env (SigPatOut pat ty) = do { ty' <- zonkTcTypeToType env ty ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat') } + ; return (env', SigPatOut pat' ty') } -zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) +zonk_pat env (NPat (L l lit) mb_neg eq_expr ty) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1295,9 +1280,9 @@ zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToType env2 ty - ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } + ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') } -zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) +zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1305,13 +1290,13 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToType env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } + NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') } -zonk_pat env (CoPat x co_fn pat ty) +zonk_pat env (CoPat co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn ; (env'', pat') <- zonkPat env' (noLoc pat) ; ty' <- zonkTcTypeToType env'' ty - ; return (env'', CoPat x co_fn' (unLoc pat') ty') } + ; return (env'', CoPat co_fn' (unLoc pat') ty') } zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 762efbf5c8..6908d16dfc 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -484,20 +484,19 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv -tc_infer_hs_type mode (HsAppTy _ ty1 ty2) +tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv +tc_infer_hs_type mode (HsAppTy ty1 ty2) = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty ; fun_kind' <- zonkTcType fun_kind ; tcTyApps mode fun_ty fun_ty' fun_kind' arg_tys } -tc_infer_hs_type mode (HsParTy _ t) = tc_infer_lhs_type mode t -tc_infer_hs_type mode (HsOpTy _ lhs (L loc_op op) rhs) +tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t +tc_infer_hs_type mode (HsOpTy lhs (L loc_op op) rhs) | not (op `hasKey` funTyConKey) = do { (op', op_kind) <- tcTyVar mode op ; op_kind' <- zonkTcType op_kind - ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted (L loc_op op)) - op' op_kind' [lhs, rhs] } -tc_infer_hs_type mode (HsKindSig _ ty sig) + ; tcTyApps mode (noLoc $ HsTyVar NotPromoted (L loc_op op)) op' op_kind' [lhs, rhs] } +tc_infer_hs_type mode (HsKindSig ty sig) = do { sig' <- tc_lhs_kind (kindLevel mode) sig ; ty' <- tc_lhs_type mode ty sig' ; return (ty', sig') } @@ -507,10 +506,10 @@ 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) +tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty +tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty) tc_infer_hs_type mode other_ty = do { kv <- newMetaKindVar ; ty' <- tc_hs_type mode other_ty kv @@ -532,25 +531,23 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of ; res_k <- newOpenTypeKind ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') - liftedTypeKind exp_kind } + ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') - liftedTypeKind exp_kind } + ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } ------------------------------------------ -- See also Note [Bidirectional type checking] tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind tc_hs_type _ ty@(HsBangTy {}) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty) -tc_hs_type _ ty@(HsRecTy _ _) _ +tc_hs_type _ ty@(HsRecTy _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) @@ -560,7 +557,9 @@ 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 @@ -570,10 +569,10 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind = failWithTc (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications -tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind +tc_hs_type mode (HsFunTy ty1 ty2) exp_kind = tc_fun_type mode ty1 ty2 exp_kind -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind +tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey = tc_fun_type mode ty1 ty2 exp_kind @@ -607,12 +606,12 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind ; return (mkPhiTy ctxt' ty') } --------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind +tc_hs_type mode rn_ty@(HsListTy elt_ty) exp_kind = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon listTyCon ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } -tc_hs_type mode rn_ty@(HsPArrTy _ elt_ty) exp_kind +tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind = do { MASSERT( isTypeLevel (mode_level mode) ) ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon parrTyCon @@ -620,7 +619,7 @@ tc_hs_type mode rn_ty@(HsPArrTy _ elt_ty) exp_kind -- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind +tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind -- (NB: not zonking before looking at exp_k, to avoid left-right bias) | Just tup_sort <- tupKindSort_maybe exp_kind = traceTc "tc_hs_type tuple" (ppr hs_tys) >> @@ -648,7 +647,7 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } -tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind +tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind = tc_tuple rn_ty mode tup_sort tys exp_kind where tup_sort = case hs_tup_sort of -- Fourth case dealt with above @@ -657,7 +656,7 @@ tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind HsConstraintTuple -> ConstraintTuple _ -> panic "tc_hs_type HsTupleTy" -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind +tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind = do { let arity = length hs_tys ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds @@ -670,7 +669,7 @@ tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind } --------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind +tc_hs_type mode rn_ty@(HsExplicitListTy _ _k tys) exp_kind = do { tks <- mapM (tc_infer_lhs_type mode) tys ; (taus', kind) <- unifyKinds tys tks ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') @@ -692,7 +691,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind arity = length tys --------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind +tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind = do { MASSERT( isTypeLevel (mode_level mode) ) ; ty' <- tc_lhs_type mode ty liftedTypeKind ; let n' = mkStrLitTy $ hsIPNameFS n @@ -700,7 +699,7 @@ tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) constraintKind exp_kind } -tc_hs_type mode rn_ty@(HsEqTy _ ty1 ty2) exp_kind +tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1 ; (ty2', kind2) <- tc_infer_lhs_type mode ty2 ; ty2'' <- checkExpectedKind (unLoc ty2) ty2' kind2 kind1 @@ -709,11 +708,11 @@ tc_hs_type mode rn_ty@(HsEqTy _ ty1 ty2) exp_kind ; checkExpectedKind rn_ty ty' constraintKind exp_kind } --------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind +tc_hs_type _ rn_ty@(HsTyLit (HsNumTy _ n)) exp_kind = do { checkWiredInTyCon typeNatKindCon ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind +tc_hs_type _ rn_ty@(HsTyLit (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } @@ -723,7 +722,7 @@ tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type _ (HsWildCardTy wc) exp_kind = do { wc_tv <- tcWildCardOcc wc exp_kind @@ -1497,20 +1496,19 @@ kcHsTyVarBndrs name flav cusk all_kind_vars = tcExtendTyVarEnv [tv] thing_inside kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool) - kc_hs_tv (UserTyVar _ lname@(L _ name)) + kc_hs_tv (UserTyVar lname@(L _ name)) = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name -- Open type/data families default their variables to kind *. ; when (open_fam && not scoped) $ -- (don't default class tyvars) - discardResult $ unifyKind (Just (HsTyVar noExt NotPromoted lname)) - liftedTypeKind (tyVarKind tv) + discardResult $ unifyKind (Just (HsTyVar NotPromoted lname)) liftedTypeKind + (tyVarKind tv) ; return tv_pair } - kc_hs_tv (KindedTyVar _ (L _ name) lhs_kind) + kc_hs_tv (KindedTyVar (L _ name) lhs_kind) = do { kind <- tcLHsKindSig lhs_kind ; tcHsTyVarName (Just kind) name } - kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv" report_non_cusk_tvs all_tvs = do { all_tvs <- mapM zonkTyCoVarKind all_tvs @@ -1628,16 +1626,14 @@ tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) -- -- See also Note [Associated type tyvar names] in Class -- -tcHsTyVarBndr new_tv (UserTyVar _(L _ name)) +tcHsTyVarBndr new_tv (UserTyVar (L _ name)) = do { kind <- newMetaKindVar ; new_tv name kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ name) kind) +tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind) = do { kind <- tcLHsKindSig kind ; new_tv name kind } -tcHsTyVarBndr _ (XTyVarBndr{}) = panic "tcHsTyVarBndr" - newWildTyVar :: Name -> TcM TcTyVar -- ^ New unification variable for a wildcard newWildTyVar _name @@ -1660,8 +1656,7 @@ tcHsTyVarName m_kind name Just (ATyVar _ tv) -> do { whenIsJust m_kind $ \ kind -> discardResult $ - unifyKind (Just (HsTyVar noExt NotPromoted (noLoc name))) - kind (tyVarKind tv) + unifyKind (Just (HsTyVar NotPromoted (noLoc name))) kind (tyVarKind tv) ; return (tv, True) } _ -> do { kind <- case m_kind of Just kind -> return kind diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index f88a11619a..89a0ec6272 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -870,15 +870,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_scs = MkD ty1 ty2 sc1 sc2 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut noExt (RealDataCon dict_constr)) + (HsConLikeOut (RealDataCon dict_constr)) -- NB: We *can* have covars in inst_tys, in the case of -- promoted GADT constructors. con_app_args = foldl app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExt (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) + app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys @@ -941,8 +940,8 @@ addDFunPrags dfun_id sc_meth_ids [dict_con] = tyConDataCons clas_tc is_newtype = isNewTyCon clas_tc -wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id) -wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id)) +wrapId :: HsWrapper -> IdP id -> HsExpr id +wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1335,12 +1334,12 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys mkLHsWrap lam_wrapper (error_rhs dflags) ; return (meth_id, meth_bind, Nothing) } where - error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags) + error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim noSourceText + error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags @@ -1606,8 +1605,8 @@ mkDefMethBind clas inst_tys sel_id dm_name ; return (bind, inline_prags) } where mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType $ NHsCoreTy ty) fun) + mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs + $ nlHsParTy $ noLoc $ HsCoreTy ty)) -- NB: use visible type application -- See Note [Default methods in instances] diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 1863a2fdda..d938de0e22 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -296,7 +296,7 @@ tcDoStmts ListComp (L l stmts) res_ty ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } + ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) } tcDoStmts PArrComp (L l stmts) res_ty = do { res_ty <- expTypeToType res_ty @@ -304,22 +304,22 @@ tcDoStmts PArrComp (L l stmts) res_ty ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo parr_ty PArrComp (L l stmts')) } + ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) } tcDoStmts DoExpr (L l stmts) res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo res_ty DoExpr (L l stmts')) } + ; return (HsDo DoExpr (L l stmts') res_ty) } tcDoStmts MDoExpr (L l stmts) res_ty = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MDoExpr (L l stmts')) } + ; return (HsDo MDoExpr (L l stmts') res_ty) } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MonadComp (L l stmts')) } + ; return (HsDo MonadComp (L l stmts') res_ty) } tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) @@ -468,14 +468,13 @@ 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 x 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 x stmts' ids noSyntaxExpr : pairs', thing ) } - loop (XParStmtBlock{}:_) = panic "tcLcStmt" + ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap @@ -762,7 +761,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 ] @@ -792,7 +791,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 x 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) $ @@ -805,7 +804,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 x stmts' ids return_op' : pairs', thing) } + ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } loop _ _ _ _ = panic "tcMcStmt.loop" tcMcStmt _ stmt _ _ @@ -1012,10 +1011,10 @@ join :: tn -> res_ty tcApplicativeStmts :: HsStmtContext Name - -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) + -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t) tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind @@ -1053,7 +1052,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; ops' <- goOps t_i ops ; return (op' : ops') } - goArg :: (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId) + goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type) + -> TcM (ApplicativeArg GhcTcId GhcTcId) goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ @@ -1074,7 +1074,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } ; return (ApplicativeArgMany stmts' ret' pat') } - get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] + get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id] get_arg_bndrs (ApplicativeArgOne pat _ _) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 05aa489b55..c5e367e3be 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -324,21 +324,21 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (L l name)) pat_ty thing_inside +tc_pat penv (VarPat (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) } -tc_pat penv (ParPat x pat) pat_ty thing_inside +tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat x pat', res) } + ; return (ParPat pat', res) } -tc_pat penv (BangPat x pat) pat_ty thing_inside +tc_pat penv (BangPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat x pat', res) } + ; return (BangPat pat', res) } -tc_pat penv (LazyPat x pat) pat_ty thing_inside +tc_pat penv (LazyPat pat) pat_ty thing_inside = do { (pat', (res, pat_ct)) <- tc_lpat pat pat_ty (makeLazy penv) $ captureConstraints thing_inside @@ -352,14 +352,14 @@ tc_pat penv (LazyPat x pat) pat_ty thing_inside ; pat_ty <- readExpType pat_ty ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind - ; return (LazyPat x pat', res) } + ; return (LazyPat pat', res) } tc_pat _ (WildPat _) pat_ty thing_inside = do { res <- thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -372,10 +372,9 @@ tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, - res) } + ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } -tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside +tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside = do { -- Expr must have type `forall a1...aN. OPT' -> B` -- where overall_pat_ty is an instance of OPT'. @@ -402,30 +401,30 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside -- (overall_pat_ty -> inf_res_ty) expr_wrap = expr_wrap2' <.> expr_wrap1 doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} + ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } -- Type signatures in patterns -- See Note [Pattern coercions] below -tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside +tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty ; (pat', res) <- tcExtendTyVarEnv2 wcs $ tcExtendTyVarEnv2 tv_binds $ tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) } + ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat x pats _ Nothing) pat_ty thing_inside +tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat x pats' elt_ty Nothing) pat_ty, res) -} + ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + } -tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside +tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside = do { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] @@ -434,18 +433,18 @@ tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; return (pats', res, elt_ty) } - ; return (ListPat x pats' elt_ty (Just (tau_pat_ty,e')), res) -} + ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res) + } -tc_pat penv (PArrPat _ pats ) pat_ty thing_inside +tc_pat penv (PArrPat pats _) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (PArrPat elt_ty pats') pat_ty, res) + ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) } -tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside +tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside = do { let arity = length pats tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) @@ -464,19 +463,19 @@ tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside -- This is a pretty odd place to make the switch, but -- it was easy to do. ; let - unmangled_result = TuplePat con_arg_tys pats' boxity + unmangled_result = TuplePat pats' boxity con_arg_tys -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExt (noLoc unmangled_result) - | otherwise = unmangled_result + isBoxed boxity = LazyPat (noLoc unmangled_result) + | otherwise = unmangled_result ; pat_ty <- readExpType pat_ty ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } -tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside +tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside = do { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv pat_ty @@ -485,8 +484,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty - , res) + ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res) } ------------------------ @@ -496,12 +494,12 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside ------------------------ -- Literal patterns -tc_pat penv (LitPat x simple_lit) pat_ty thing_inside +tc_pat penv (LitPat simple_lit) pat_ty thing_inside = do { let lit_ty = hsLitType simple_lit ; wrap <- tcSubTypePat penv pat_ty lit_ty ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty + ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty , res) } ------------------------ @@ -522,7 +520,7 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -540,7 +538,7 @@ tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } + ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) } {- Note [NPlusK patterns] @@ -571,8 +569,7 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty - thing_inside +tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit ; (lit1', ge') @@ -601,15 +598,15 @@ tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' + pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' pat_ty ; return (pat', res) } -- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. -- 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 @@ -985,16 +982,14 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv + tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' + ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat' pun), res) } - tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ - = panic "tcConArgs" find_field_ty :: Name -> FieldLabelString -> TcM TcType find_field_ty sel lbl diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 2035abc1ba..283127215c 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -474,14 +474,14 @@ tcPatSynMatcher (L loc name) lpat mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ - HsCase noExt (nlHsVar scrutinee) $ + HsCase (nlHsVar scrutinee) $ MG{ mg_alts = L (getLoc lpat) cases , mg_arg_tys = [pat_ty] , mg_res_ty = res_ty , mg_origin = Generated } body' = noLoc $ - HsLam noExt $ + HsLam $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] , mg_arg_tys = [pat_ty, cont_ty, fail_ty] @@ -515,7 +515,7 @@ mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels -> HsValBinds GhcRn mkPatSynRecSelBinds ps fields - = XValBindsLR (NValBinds selector_binds sigs) + = ValBindsOut selector_binds sigs where (sigs, selector_binds) = unzip (map mkRecSel fields) mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl @@ -608,11 +608,11 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) - builder_args body - (noLoc EmptyLocalBinds) + where + builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args body + (noLoc EmptyLocalBinds) args = case details of PrefixPatSyn args -> args @@ -630,7 +630,7 @@ tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut noExt (PatSynCon ps) + , let builder_expr = HsConLikeOut (PatSynCon ps) builder_ty = idType builder_id = return $ if add_void_arg @@ -669,14 +669,14 @@ tcPatToExpr name args pat = go pat -> Either MsgDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; return (foldl (\x y -> HsApp noExt (L loc x) y) - (HsVar noExt lcon) exprs) } + ; return (foldl (\x y -> HsApp (L loc x) y) + (HsVar lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) -> Either MsgDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields - ; return (RecordCon noExt con exprFields) } + ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p @@ -688,52 +688,48 @@ tcPatToExpr name args pat = go pat InfixCon l r -> mkPrefixConExpr con [l,r] RecCon fields -> mkRecordConExpr con fields - go1 (SigPat _ pat) = go1 (unLoc pat) + go1 (SigPatIn pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (L l var)) + go1 (VarPat (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExt (L l var) + = return $ HsVar (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat - go1 (PArrPat _ pats) = do { exprs <- mapM go pats - ; return $ ExplicitPArr noExt exprs } - go1 p@(ListPat _ pats _ty reb) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExt Nothing exprs } + go1 (ParPat pat) = fmap HsPar $ go pat + go1 (PArrPat pats ptt) = do { exprs <- mapM go pats + ; return $ ExplicitPArr ptt exprs } + go1 p@(ListPat pats ptt reb) + | Nothing <- reb = do { exprs <- mapM go pats + ; return $ ExplicitList ptt Nothing exprs } | otherwise = notInvertibleListPat p - go1 (TuplePat _ pats box) = do { exprs <- mapM go pats - ; return $ ExplicitTuple noExt - (map (noLoc . (Present noExt)) exprs) - box } - go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum noExt alt arity - (noLoc expr) + go1 (TuplePat pats box _) = do { exprs <- mapM go pats + ; return $ ExplicitTuple + (map (noLoc . Present) exprs) box } + go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder } - go1 (LitPat _ lit) = return $ HsLit noExt lit - go1 (NPat _ (L _ n) mb_neg _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg - [noLoc (HsOverLit noExt n)] - | otherwise = return $ HsOverLit noExt n + go1 (LitPat lit) = return $ HsLit lit + go1 (NPat (L _ n) mb_neg _ _) + | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] + | otherwise = return $ HsOverLit n go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" + go1 (SigPatOut{}) = panic "SigPatOut 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" + go1 (SplicePat (HsSpliced{})) = panic "Invalid splice variety" -- The following patterns are not invertible. - go1 p@(BangPat {}) = notInvertible p -- #14112 - go1 p@(LazyPat {}) = notInvertible p - go1 p@(WildPat {}) = notInvertible p - go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p - go1 p@(NPlusKPat {}) = notInvertible p - go1 p@(XPat {}) = notInvertible p - go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p - go1 p@(SplicePat _ (XSplice {})) = notInvertible p + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(ViewPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(SplicePat (HsTypedSplice {})) = notInvertible p + go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p + go1 p@(SplicePat (HsQuasiQuote {})) = notInvertible p notInvertible p = Left (not_invertible_msg p) @@ -845,41 +841,39 @@ tcCheckPatSynPat = go go1 :: Pat GhcRn -> TcM () -- See Note [Bad patterns] - go1 p@(AsPat _ _ _) = asPatInPatSynErr p - go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p - - go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) - go1 VarPat{} = return () - go1 WildPat{} = return () - go1 (LazyPat _ pat) = go pat - go1 (ParPat _ pat) = go pat - go1 (BangPat _ pat) = go pat - go1 (PArrPat _ pats) = mapM_ go pats - go1 (ListPat _ pats _ _) = mapM_ go pats - go1 (TuplePat _ pats _) = mapM_ go pats - go1 (SumPat _ pat _ _) = go pat - go1 LitPat{} = return () - go1 NPat{} = return () - go1 (SigPat _ pat) = go pat - go1 (ViewPat _ _ pat) = go pat - go1 (SplicePat _ splice) - | HsSpliced _ mod_finalizers (HsSplicedPat pat) <- splice + go1 p@(AsPat _ _) = asPatInPatSynErr p + go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p + + go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) + go1 VarPat{} = return () + go1 WildPat{} = return () + go1 (LazyPat pat) = go pat + go1 (ParPat pat) = go pat + go1 (BangPat pat) = go pat + go1 (PArrPat pats _) = mapM_ go pats + go1 (ListPat pats _ _) = mapM_ go pats + go1 (TuplePat pats _ _) = mapM_ go pats + go1 (SumPat pat _ _ _) = go pat + go1 LitPat{} = return () + go1 NPat{} = return () + go1 (SigPatIn pat _) = go pat + go1 (ViewPat _ pat _) = go pat + go1 (SplicePat splice) + | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice = do addModFinalizersWithLclEnv mod_finalizers go1 pat | otherwise = panic "non-pattern from spliced thing" go1 ConPatOut{} = panic "ConPatOut in output of renamer" + go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" - go1 XPat{} = panic "XPat in output of renamer" -asPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> TcM a +asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -nPlusKPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) - => Pat (GhcPass p) -> TcM a +nPlusKPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") @@ -925,20 +919,20 @@ tcCollectEx pat = go pat go = go1 . unLoc go1 :: Pat GhcTc -> ([TyVar], [EvVar]) - go1 (LazyPat _ p) = go p - go1 (AsPat _ _ p) = go p - go1 (ParPat _ p) = go p - go1 (BangPat _ p) = go p - go1 (ListPat _ ps _ _) = mergeMany . map go $ ps - go1 (TuplePat _ ps _) = mergeMany . map go $ ps - go1 (SumPat _ p _ _) = go p - go1 (PArrPat _ ps) = mergeMany . map go $ ps - go1 (ViewPat _ _ p) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ + go1 (LazyPat p) = go p + go1 (AsPat _ p) = go p + go1 (ParPat p) = go p + go1 (BangPat p) = go p + go1 (ListPat ps _ _) = mergeMany . map go $ ps + go1 (TuplePat ps _ _) = mergeMany . map go $ ps + go1 (SumPat p _ _ _) = go p + go1 (PArrPat ps _) = mergeMany . map go $ ps + go1 (ViewPat _ p _) = go p + go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ goConDetails $ pat_args con - go1 (SigPat _ p) = go p - go1 (CoPat _ _ p _) = go1 p - go1 (NPlusKPat _ n k _ geq subtract) + go1 (SigPatOut p _) = go p + go1 (CoPat _ p _) = go1 p + go1 (NPlusKPat n k _ geq subtract _) = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract go1 _ = empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 58fb78be14..fd63effbe6 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -13,7 +13,6 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} module TcRnDriver ( tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, @@ -577,8 +576,7 @@ tcRnHsBootDecls hsc_src decls , hs_ruleds = rule_decls , hs_vects = vect_decls , hs_annds = _ - , hs_valds - = XValBindsLR (NValBinds val_binds val_sigs) }) + , hs_valds = ValBindsOut val_binds val_sigs }) <- rnTopSrcDecls first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource @@ -1324,8 +1322,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, hs_vects = vect_decls, - hs_valds = hs_val_binds@(XValBindsLR - (NValBinds val_binds val_sigs)) }) + hs_valds = hs_val_binds@(ValBindsOut val_binds val_sigs) }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; @@ -1333,7 +1330,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)) + (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { @@ -1678,7 +1675,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar noExt (L loc main_name))) + tcMonoExpr (L loc (HsVar (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -1998,16 +1995,15 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) + let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ + ValBindsOut [(NonRecursive,unitBag the_bind)] [] -- [it <- e] - bind_stmt = L loc $ BindStmt - (L loc (VarPat noExt (L loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - placeHolder + bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it))) + (nlHsApp ghciStep rn_expr) + (mkRnSyntaxExpr bindIOName) + noSyntaxExpr + PlaceHolder -- [; print it] print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) @@ -2124,8 +2120,7 @@ tcGhciStmts stmts -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy Nothing - (map mk_item ids)) ; + (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; mk_item id = let ty_args = [idType id, unitTy] in nlHsApp (nlHsTyApp unsafeCoerceId (map getRuntimeRep ty_args ++ ty_args)) @@ -2133,7 +2128,7 @@ tcGhciStmts stmts stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) + noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty)) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) @@ -2144,15 +2139,13 @@ getGhciStepIO = do let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - step_ty = noLoc $ HsForAllTy - { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)] - , hst_xforall = noExt - , hst_body = nlHsFunTy ghciM ioM } + step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] + , hst_body = nlHsFunTy ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName)) + return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy) isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 7e347ffe2c..5f7498fa16 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3380,57 +3380,58 @@ lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin -exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv) -exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l -exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip -exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit -exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms -exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType _ e1) = lexprCtOrigin e1 -exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op -exprCtOrigin (NegApp _ e _) = lexprCtOrigin e -exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (SectionL _ _ _) = SectionOrigin -exprCtOrigin (SectionR _ _ _) = SectionOrigin -exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" -exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" -exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) -exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" -exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e -exprCtOrigin (HsDo {}) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" -exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array" -exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" -exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin -exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence" -exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" +exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name +exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) +exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" +exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) +exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l +exprCtOrigin (HsIPVar ip) = IPOccOrigin ip +exprCtOrigin (HsOverLit lit) = LiteralOrigin lit +exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" +exprCtOrigin (HsLam matches) = matchesCtOrigin matches +exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms +exprCtOrigin (HsApp e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut" +exprCtOrigin (OpApp _ op _ _) = lexprCtOrigin op +exprCtOrigin (NegApp e _) = lexprCtOrigin e +exprCtOrigin (HsPar e) = lexprCtOrigin e +exprCtOrigin (SectionL _ _) = SectionOrigin +exprCtOrigin (SectionR _ _) = SectionOrigin +exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" +exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches +exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) +exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" +exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs +exprCtOrigin (HsLet _ e) = lexprCtOrigin e +exprCtOrigin (HsDo _ _ _) = DoOrigin +exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" +exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array" +exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" +exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" +exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin +exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut" +exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" +exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence" +exprCtOrigin (HsSCC _ _ e) = lexprCtOrigin e +exprCtOrigin (HsCoreAnn _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" -exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" -exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e -exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat" +exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" +exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" +exprCtOrigin (HsTick _ e) = lexprCtOrigin e +exprCtOrigin (HsBinTick _ _ e) = lexprCtOrigin e +exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e +exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat" exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" -exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 1543b7f085..45e18e69fe 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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 [] @@ -182,7 +182,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) - (noLoc (HsTcBracketOut noExt brack ps')))) + (noLoc (HsTcBracketOut brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) @@ -194,19 +194,17 @@ tcUntypedBracket rn_expr brack ps res_ty ; meta_ty <- tcBrackTy brack ; traceTc "tc_bracket done untyped" (ppr meta_ty) ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket") - rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty } + rn_expr (HsTcBracketOut brack ps') meta_ty 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 (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket" +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" --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice @@ -434,7 +432,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 @@ -584,9 +582,8 @@ runAnnotation target expr = do ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] ; let specialised_to_annotation_wrapper_expr = L loc (mkHsWrap wrapper - (HsVar noExt (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExt - specialised_to_annotation_wrapper_expr expr')) } + (HsVar (L loc to_annotation_wrapper_id))) + ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } -- Run the appropriately wrapped expression to get the value of -- the annotation and its dictionaries. The return value is of diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index b0b90d910f..97981836ae 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -526,9 +526,9 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name where -- Keep this synchronized with 'hsDeclHasCusk'. kind_annotation (L _ ty) = case ty of - HsParTy _ lty -> kind_annotation lty - HsKindSig _ _ k -> Just k - _ -> Nothing + HsParTy lty -> kind_annotation lty + HsKindSig _ k -> Just k + _ -> Nothing --------------------------------- getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class @@ -548,8 +548,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name = do { (tycon, _) <- kcHsTyVarBndrs name flav cusk True ktvs $ do { res_k <- case resultSig of - KindSig ki -> tcLHsKindSig ki - TyVarSig (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ki + KindSig ki -> tcLHsKindSig ki + TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return liftedTypeKind -- closed type families have their return kind inferred @@ -1403,7 +1403,7 @@ tc_fam_ty_pats tc_fam_tc mb_clsinfo tv_names arg_pats -- See Note [Quantifying over family patterns] ; (arg_tvs, (args, stuff)) <- tcImplicitTKBndrs tv_names $ do { let loc = nameSrcSpan name - lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name)) + lhs_fun = L loc (HsTyVar NotPromoted (L loc name)) fun_ty = mkTyConApp tc_fam_tc [] fun_kind = tyConKind tc_fam_tc mb_kind_env = thdOf3 <$> mb_clsinfo diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 7d8a004041..6b77cc7b7b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -827,7 +827,7 @@ mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications mkRecSelBinds tycons - = XValBindsLR (NValBinds binds sigs) + = ValBindsOut binds sigs where (sigs, binds) = unzip rec_sels rec_sels = map mkRecSelBind [ (tc,fld) @@ -882,14 +882,13 @@ mkOneRecordSelector all_cons idDetails fl | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) [L loc (mk_sel_pat con)] - (L loc (HsVar noExt (L loc field_var))) + (L loc (HsVar (L loc field_var))) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl)) - , hsRecFieldArg - = L loc (VarPat noExt (L loc field_var)) + = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name) + , hsRecFieldArg = L loc (VarPat (L loc field_var)) , hsRecPun = False }) sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -899,10 +898,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExt)] - (mkHsApp (L loc (HsVar noExt + [L loc (WildPat placeHolderType)] + (mkHsApp (L loc (HsVar (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExt msg_lit)))] + (L loc (HsLit msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 0fccffa229..01c8505562 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1514,7 +1514,7 @@ defineMacro overwrite s = do body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) - new_expr = L (getLoc expr) $ ExprWithTySig tySig body + new_expr = L (getLoc expr) $ ExprWithTySig body tySig hv <- GHC.compileParsedExprRemote new_expr let newCmd = Command { cmdName = macro_name @@ -1578,7 +1578,7 @@ getGhciStepIO = do ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) - return $ noLoc $ ExprWithTySig tySig body + return $ noLoc $ ExprWithTySig body tySig ----------------------------------------------------------------------------- -- :check diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index bd555916a2..fd8749a3e1 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -321,19 +321,19 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing - unwrapVar (HsWrap _ _ var) = var - unwrapVar e' = e' + unwrapVar (HsWrap _ var) = var + unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat _ (L _ vid)) = Just vid - getMaybeId _ = Nothing + getMaybeId (VarPat (L _ vid)) = Just vid + getMaybeId _ = Nothing -- | Get ALL source spans in the source. listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs index b04be775c3..3a8a29abd4 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.hs +++ b/testsuite/tests/ghc-api/annotations/parseTree.hs @@ -51,10 +51,8 @@ testOneFile libdir fileName = do gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)] - doLHsTupArg (L l arg@(Present {})) - = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)] - doLHsTupArg (L l arg@(Missing {})) - = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)] + doLHsTupArg (L l arg@(Present _)) = [(l,"p",ExplicitTuple [L l arg] Boxed)] + doLHsTupArg (L l arg@(Missing _)) = [(l,"m",ExplicitTuple [L l arg] Boxed)] showAnns anns = "[\n" ++ (intercalate "\n" diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index 4089d4a88a..b89911d6c7 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -80,9 +80,9 @@ testOneFile libdir fileName = do doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])] - doHsExpr (HsSCC _ src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] + doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] + doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] + doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] doHsExpr _ = [] conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index 40d23b5712..4b8119459b 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -67,7 +67,7 @@ testOneFile libdir fileName = do doRuleDecl (HsRule _ _ _ _ _ _ _) = [] doHsExpr :: HsExpr GhcPs -> [(String,[String])] - doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])] + doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])] doHsExpr _ = [] doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index b80ab62507..46ab21412e 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -49,7 +49,6 @@ (PrefixCon [({ DumpParsedAst.hs:5:26-30 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:5:26-30 } (Unqual @@ -74,32 +73,25 @@ {OccName: Length})) [({ DumpParsedAst.hs:8:10-17 } (HsParTy - (PlaceHolder) ({ DumpParsedAst.hs:8:11-16 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:8:11 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:11 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:11 } (Unqual {OccName: a})))))) ,({ DumpParsedAst.hs:8:13 } (HsAppInfix - (PlaceHolder) ({ DumpParsedAst.hs:8:13 } (Exact {Name: :})))) ,({ DumpParsedAst.hs:8:15-16 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:15-16 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:15-16 } (Unqual @@ -107,42 +99,32 @@ (Prefix) ({ DumpParsedAst.hs:8:21-36 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:8:21-24 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:21-24 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:21-24 } (Unqual {OccName: Succ})))))) ,({ DumpParsedAst.hs:8:26-36 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:26-36 } (HsParTy - (PlaceHolder) ({ DumpParsedAst.hs:8:27-35 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:8:27-32 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:27-32 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:27-32 } (Unqual {OccName: Length})))))) ,({ DumpParsedAst.hs:8:34-35 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:8:34-35 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:34-35 } (Unqual @@ -157,19 +139,16 @@ {OccName: Length})) [({ DumpParsedAst.hs:9:10-12 } (HsExplicitListTy - (PlaceHolder) (Promoted) + (PlaceHolder) []))] (Prefix) ({ DumpParsedAst.hs:9:21-24 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:9:21-24 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:9:21-24 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:9:21-24 } (Unqual @@ -182,28 +161,21 @@ (PlaceHolder) [({ DumpParsedAst.hs:7:20-30 } (KindedTyVar - (PlaceHolder) ({ DumpParsedAst.hs:7:21-22 } (Unqual {OccName: as})) ({ DumpParsedAst.hs:7:27-29 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:7:27-29 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:7:27-29 } (HsListTy - (PlaceHolder) ({ DumpParsedAst.hs:7:28 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:7:28 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:7:28 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:7:28 } (Unqual @@ -214,13 +186,10 @@ (KindSig ({ DumpParsedAst.hs:7:35-39 } (HsAppsTy - (PlaceHolder) [({ DumpParsedAst.hs:7:35-39 } (HsAppPrefix - (PlaceHolder) ({ DumpParsedAst.hs:7:35-39 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:7:35-39 } (Unqual @@ -249,16 +218,13 @@ [] ({ DumpParsedAst.hs:11:8-23 } (HsApp - (PlaceHolder) ({ DumpParsedAst.hs:11:8-15 } (HsVar - (PlaceHolder) ({ DumpParsedAst.hs:11:8-15 } (Unqual {OccName: putStrLn})))) ({ DumpParsedAst.hs:11:17-23 } (HsLit - (PlaceHolder) (HsString (SourceText "\"hello\"") diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index fbc30626fa..c7daf90ff0 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -4,54 +4,50 @@ (Just ((,,,) (HsGroup - (XValBindsLR - (NValBinds - [((,) - (NonRecursive) - {Bag(Located (HsBind Name)): - [({ DumpRenamedAst.hs:18:1-23 } - (FunBind - ({ DumpRenamedAst.hs:18:1-4 } - {Name: DumpRenamedAst.main}) - (MG - ({ DumpRenamedAst.hs:18:1-23 } - [({ DumpRenamedAst.hs:18:1-23 } - (Match - (FunRhs - ({ DumpRenamedAst.hs:18:1-4 } - {Name: DumpRenamedAst.main}) - (Prefix) - (NoSrcStrict)) - [] - (GRHSs - [({ DumpRenamedAst.hs:18:6-23 } - (GRHS - [] - ({ DumpRenamedAst.hs:18:8-23 } - (HsApp - (PlaceHolder) - ({ DumpRenamedAst.hs:18:8-15 } - (HsVar - (PlaceHolder) - ({ DumpRenamedAst.hs:18:8-15 } - {Name: System.IO.putStrLn}))) - ({ DumpRenamedAst.hs:18:17-23 } - (HsLit - (PlaceHolder) - (HsString - (SourceText - "\"hello\"") - {FastString: "hello"})))))))] - ({ <no location info> } - (EmptyLocalBinds)))))]) - [] - (PlaceHolder) - (FromSource)) - (WpHole) - {NameSet: - []} - []))]})] - [])) + (ValBindsOut + [((,) + (NonRecursive) + {Bag(Located (HsBind Name)): + [({ DumpRenamedAst.hs:18:1-23 } + (FunBind + ({ DumpRenamedAst.hs:18:1-4 } + {Name: DumpRenamedAst.main}) + (MG + ({ DumpRenamedAst.hs:18:1-23 } + [({ DumpRenamedAst.hs:18:1-23 } + (Match + (FunRhs + ({ DumpRenamedAst.hs:18:1-4 } + {Name: DumpRenamedAst.main}) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + [({ DumpRenamedAst.hs:18:6-23 } + (GRHS + [] + ({ DumpRenamedAst.hs:18:8-23 } + (HsApp + ({ DumpRenamedAst.hs:18:8-15 } + (HsVar + ({ DumpRenamedAst.hs:18:8-15 } + {Name: System.IO.putStrLn}))) + ({ DumpRenamedAst.hs:18:17-23 } + (HsLit + (HsString + (SourceText + "\"hello\"") + {FastString: "hello"})))))))] + ({ <no location info> } + (EmptyLocalBinds)))))]) + [] + (PlaceHolder) + (FromSource)) + (WpHole) + {NameSet: + []} + []))]})] + []) [] [(TyClGroup [({ DumpRenamedAst.hs:6:1-30 } @@ -92,7 +88,6 @@ (PrefixCon [({ DumpRenamedAst.hs:6:26-30 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:6:26-30 } {Name: DumpRenamedAst.Peano})))]) @@ -119,13 +114,10 @@ {Name: DumpRenamedAst.Length}) [({ DumpRenamedAst.hs:9:10-17 } (HsParTy - (PlaceHolder) ({ DumpRenamedAst.hs:9:11-16 } (HsOpTy - (PlaceHolder) ({ DumpRenamedAst.hs:9:11 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:11 } {Name: a}))) @@ -133,35 +125,28 @@ {Name: :}) ({ DumpRenamedAst.hs:9:15-16 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:15-16 } {Name: as})))))))] (Prefix) ({ DumpRenamedAst.hs:9:21-36 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:9:21-24 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:21-24 } {Name: DumpRenamedAst.Succ}))) ({ DumpRenamedAst.hs:9:26-36 } (HsParTy - (PlaceHolder) ({ DumpRenamedAst.hs:9:27-35 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:9:27-32 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:27-32 } {Name: DumpRenamedAst.Length}))) ({ DumpRenamedAst.hs:9:34-35 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:34-35 } {Name: as})))))))))) @@ -174,13 +159,12 @@ {Name: DumpRenamedAst.Length}) [({ DumpRenamedAst.hs:10:10-12 } (HsExplicitListTy - (PlaceHolder) (Promoted) + (PlaceHolder) []))] (Prefix) ({ DumpRenamedAst.hs:10:21-24 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:10:21-24 } {Name: DumpRenamedAst.Zero})))) @@ -191,15 +175,12 @@ [{Name: k}] [({ DumpRenamedAst.hs:8:20-30 } (KindedTyVar - (PlaceHolder) ({ DumpRenamedAst.hs:8:21-22 } {Name: as}) ({ DumpRenamedAst.hs:8:27-29 } (HsListTy - (PlaceHolder) ({ DumpRenamedAst.hs:8:28 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:8:28 } {Name: k})))))))] @@ -210,7 +191,6 @@ (KindSig ({ DumpRenamedAst.hs:8:35-39 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:8:35-39 } {Name: DumpRenamedAst.Peano}))))) @@ -234,25 +214,20 @@ (KindSig ({ DumpRenamedAst.hs:12:20-30 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:12:20 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:20 } {Name: k}))) ({ DumpRenamedAst.hs:12:25-30 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:12:25 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:25 } {Name: k}))) ({ DumpRenamedAst.hs:12:30 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:30 } {Name: GHC.Types.*}))))))))) @@ -269,25 +244,20 @@ {Name: DumpRenamedAst.Nat}) [({ DumpRenamedAst.hs:15:22-34 } (HsKindSig - (PlaceHolder) ({ DumpRenamedAst.hs:15:23 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:23 } {Name: a}))) ({ DumpRenamedAst.hs:15:28-33 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:15:28 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:28 } {Name: k}))) ({ DumpRenamedAst.hs:15:33 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:33 } {Name: GHC.Types.*})))))))] @@ -300,28 +270,22 @@ (Just ({ DumpRenamedAst.hs:15:39-51 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:15:39-46 } (HsParTy - (PlaceHolder) ({ DumpRenamedAst.hs:15:40-45 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:15:40 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:40 } {Name: k}))) ({ DumpRenamedAst.hs:15:45 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:45 } {Name: GHC.Types.*}))))))) ({ DumpRenamedAst.hs:15:51 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:51 } {Name: GHC.Types.*})))))) @@ -334,72 +298,56 @@ ,{Name: g}] ({ DumpRenamedAst.hs:16:10-45 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:10-34 } (HsParTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:11-33 } (HsForAllTy - (PlaceHolder) [({ DumpRenamedAst.hs:16:18-19 } (UserTyVar - (PlaceHolder) ({ DumpRenamedAst.hs:16:18-19 } {Name: xx})))] ({ DumpRenamedAst.hs:16:22-33 } (HsFunTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:22-25 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:22 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:22 } {Name: f}))) ({ DumpRenamedAst.hs:16:24-25 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:24-25 } {Name: xx}))))) ({ DumpRenamedAst.hs:16:30-33 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:30 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:30 } {Name: g}))) ({ DumpRenamedAst.hs:16:32-33 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:32-33 } {Name: xx}))))))))))) ({ DumpRenamedAst.hs:16:39-45 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:39-43 } (HsAppTy - (PlaceHolder) ({ DumpRenamedAst.hs:16:39-41 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:39-41 } {Name: DumpRenamedAst.Nat}))) ({ DumpRenamedAst.hs:16:43 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:43 } {Name: f}))))) ({ DumpRenamedAst.hs:16:45 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:45 } {Name: g}))))))) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index b888067af1..e0d810d4b4 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -7,63 +7,47 @@ {Var: DumpTypecheckedAst.$tcPeano} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (14073232900889011755) (NoSourceText)})))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (2739668351064589274) (NoSourceText)})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) (HsStringPrim (NoSourceText) "Peano"))))))))) ({ <no location info> } (HsLit - (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: GHC.Types.krep$*}))))) (False))) @@ -72,63 +56,47 @@ {Var: DumpTypecheckedAst.$tc'Zero} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (13760111476013868540) (NoSourceText)})))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (12314848029315386153) (NoSourceText)})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) (HsStringPrim (NoSourceText) "'Zero"))))))))) ({ <no location info> } (HsLit - (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -137,63 +105,47 @@ {Var: DumpTypecheckedAst.$tc'Succ} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (1143980031331647856) (NoSourceText)})))) ({ <no location info> } (HsLit - (PlaceHolder) {HsWord{64}Prim (14802086722010293686) (NoSourceText)})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) (HsStringPrim (NoSourceText) "'Succ"))))))))) ({ <no location info> } (HsLit - (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -202,22 +154,17 @@ {Var: $krep} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: $krep}))))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -226,28 +173,22 @@ {Var: $krep} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsVar - (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$tcPeano}))))) ({ <no location info> } (HsWrap - (PlaceHolder) (WpTyApp (TyConApp ({abstract:TyCon}) [])) (HsConLikeOut - (PlaceHolder) ({abstract:ConLike})))))) (False))) ,({ <no location info> } @@ -255,43 +196,32 @@ {Var: DumpTypecheckedAst.$trModule} ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsPar - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) (HsStringPrim (NoSourceText) "main"))))))))) ({ <no location info> } (HsPar - (PlaceHolder) ({ <no location info> } (HsApp - (PlaceHolder) ({ <no location info> } (HsConLikeOut - (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit - (PlaceHolder) (HsStringPrim (NoSourceText) "DumpTypecheckedAst"))))))))) @@ -328,15 +258,12 @@ [] ({ DumpTypecheckedAst.hs:11:8-23 } (HsApp - (PlaceHolder) ({ DumpTypecheckedAst.hs:11:8-15 } (HsVar - (PlaceHolder) ({ <no location info> } {Var: putStrLn}))) ({ DumpTypecheckedAst.hs:11:17-23 } (HsLit - (PlaceHolder) (HsString (SourceText "\"hello\"") diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 4965410e65..53e4a6f941 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -4,10 +4,9 @@ (Just ((,,,) (HsGroup - (XValBindsLR - (NValBinds - [] - [])) + (ValBindsOut + [] + []) [] [(TyClGroup [({ T14189.hs:6:1-42 } @@ -37,7 +36,6 @@ (PrefixCon [({ T14189.hs:6:18-20 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ T14189.hs:6:18-20 } {Name: GHC.Types.Int})))]) @@ -67,13 +65,12 @@ (ConDeclField [({ T14189.hs:6:33 } (FieldOcc - {Name: T14189.f} ({ T14189.hs:6:33 } (Unqual - {OccName: f}))))] + {OccName: f})) + {Name: T14189.f}))] ({ T14189.hs:6:38-40 } (HsTyVar - (PlaceHolder) (NotPromoted) ({ T14189.hs:6:38-40 } {Name: GHC.Types.Int}))) diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 4d7c171393..b7e6b215ca 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -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), 102142130576, 10) + [(wordsize(64), 51592019560, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) @@ -166,9 +166,6 @@ test('haddock.compiler', # 2017-06-05: 65378619232 (amd64/Linux) Desugar modules compiled with -fno-code # 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-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) diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index 9cf060937e..42bb1b05c8 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -29,19 +29,19 @@ traverse a = gmapM traverse a where showVar :: Maybe (HsExpr GhcTc) -> Traverse () - showVar (Just (HsVar _ (L _ v))) = + showVar (Just (HsVar (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showVar _ = return () showTyVar :: Maybe (HsType GhcRn) -> Traverse () - showTyVar (Just (HsTyVar _ _ (L _ v))) = + showTyVar (Just (HsTyVar _ (L _ v))) = modify $ \(loc, ids) -> (loc, (v, loc) : ids) showTyVar _ = return () showPatVar :: Maybe (Pat GhcTc) -> Traverse () - showPatVar (Just (VarPat _ (L _ v))) = + showPatVar (Just (VarPat (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showPatVar _ = return () diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 059692622e..f74c7514db 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -254,7 +254,7 @@ boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing] -- ^Finds all the top-level definitions in a module boundValues mod group = let vals = case hs_valds group of - XValBindsLR (NValBinds nest _sigs) -> + ValBindsOut nest _sigs -> [ x | (_rec, binds) <- nest , bind <- bagToList binds , x <- boundThings mod bind ] @@ -291,20 +291,21 @@ boundThings modname lbinding = lid id = FoundThing modname (getOccString id) loc in case unLoc lpat of WildPat _ -> tl - VarPat _ (L _ name) -> lid name : tl - LazyPat _ p -> patThings p tl - AsPat _ id p -> patThings p (thing id : tl) - ParPat _ p -> patThings p tl - BangPat _ p -> patThings p tl - ListPat _ ps _ _ -> foldr patThings tl ps - TuplePat _ ps _ -> foldr patThings tl ps - PArrPat _ ps -> foldr patThings tl ps + VarPat (L _ name) -> lid name : tl + LazyPat p -> patThings p tl + AsPat id p -> patThings p (thing id : tl) + ParPat p -> patThings p tl + BangPat p -> patThings p tl + ListPat ps _ _ -> foldr patThings tl ps + TuplePat ps _ _ -> foldr patThings tl ps + PArrPat ps _ -> foldr patThings tl ps ConPatIn _ conargs -> conArgs conargs tl ConPatOut{ pat_args = conargs } -> conArgs conargs tl - LitPat _ _ -> tl + LitPat _ -> tl NPat {} -> tl -- form of literal pattern? - NPlusKPat _ id _ _ _ _ -> thing id : tl - SigPat _ p -> patThings p tl + NPlusKPat id _ _ _ _ _ -> thing id : tl + SigPatIn p _ -> patThings p tl + SigPatOut p _ -> patThings p tl _ -> error "boundThings" conArgs (PrefixCon ps) tl = foldr patThings tl ps conArgs (RecCon (HsRecFields { rec_flds = flds })) tl diff --git a/utils/haddock b/utils/haddock -Subproject 04fd3e021cfe04eaaa470be4ae8408a41782186 +Subproject ae0d140334fff57f2737dbd7c5804b4868d9c3a |