diff options
author | Shayan-Najd <sh.najd@gmail.com> | 2018-11-22 01:23:29 +0000 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-11-24 12:30:21 +0200 |
commit | 509d5be69c7507ba5d0a5f39ffd1613a59e73eea (patch) | |
tree | b3db08f371014cbf235525843a312f67dea77354 /compiler/typecheck/TcTyDecls.hs | |
parent | ad2d7612dbdf0e928318394ec0606da3b85a8837 (diff) | |
download | haskell-509d5be69c7507ba5d0a5f39ffd1613a59e73eea.tar.gz |
[TTG: Handling Source Locations] Foundation and Pat
This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).
- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)
Phab diff: D5036
Trac Issues #15495
Updates haddock submodule
Diffstat (limited to 'compiler/typecheck/TcTyDecls.hs')
-rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 35 |
1 files changed, 19 insertions, 16 deletions
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index f64b9f3e73..a973cafa8d 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -11,6 +11,7 @@ files for imported data types. {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcTyDecls( RolesInfo, @@ -224,8 +225,9 @@ checkSynCycles this_uid tcs tyclds = do mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" + Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl + Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n + <+> text "from external module" where n = tyConName tc @@ -484,7 +486,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ _ annots)) + Just (dL->L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots @@ -828,12 +830,12 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs + sigs = [ cL loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] @@ -854,7 +856,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (sel_id, L loc sel_bind) + = (sel_id, cL loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl @@ -892,17 +894,18 @@ mkOneRecordSelector all_cons idDetails fl [] unit_rhs] | 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))) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + [cL loc (mk_sel_pat con)] + (cL loc (HsVar noExt (cL loc field_var))) + mk_sel_pat con = ConPatIn (cL 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)) + = cL loc (FieldOcc sel_name + (cL loc $ mkVarUnqual lbl)) , hsRecFieldArg - = L loc (VarPat noExt (L loc field_var)) + = cL loc (VarPat noExt (cL loc field_var)) , hsRecPun = False }) - sel_lname = L loc sel_name + sel_lname = cL loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -910,10 +913,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 (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExt msg_lit)))] + [cL loc (WildPat noExt)] + (mkHsApp (cL loc (HsVar noExt + (cL loc (getName rEC_SEL_ERROR_ID)))) + (cL loc (HsLit noExt msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we |