From a3e01707ebc2e7180840b5ab3534f818b43c2873 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 15 Oct 2004 15:29:00 +0000 Subject: [PATCH] [project @ 2004-10-15 15:28:48 by simonmar] Add a SrcSpan to the DataCon in a ConPatOut. --- ghc/compiler/deSugar/Check.lhs | 18 +++++++++--------- ghc/compiler/deSugar/DsExpr.lhs | 2 +- ghc/compiler/deSugar/Match.lhs | 4 ++-- ghc/compiler/deSugar/MatchCon.lhs | 6 +++--- ghc/compiler/hsSyn/HsPat.lhs | 4 ++-- ghc/compiler/main/HscMain.lhs | 17 ++++++----------- ghc/compiler/typecheck/TcPat.lhs | 12 ++++++------ 7 files changed, 29 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index e03dd43..1e4a186 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -357,7 +357,7 @@ is transformed in: remove_first_column :: Pat Id -- Constructor -> [(EqnNo, EquationInfo)] -> [(EqnNo, EquationInfo)] -remove_first_column (ConPatOut con _ _ _ (PrefixCon con_pats) _) qs +remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs = ASSERT2( okGroup qs, pprGroup qs ) [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)] where @@ -383,7 +383,7 @@ make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) = takeList (tail pats) (repeat nlWildPat) compare_cons :: Pat Id -> Pat Id -> Bool -compare_cons (ConPatOut id1 _ _ _ _ _) (ConPatOut id2 _ _ _ _ _) = id1 == id2 +compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ id2) _ _ _ _ _) = id1 == id2 remove_dups :: [Pat Id] -> [Pat Id] remove_dups [] = [] @@ -423,7 +423,7 @@ get_unused_cons used_cons = unused_cons (ConPatOut _ _ _ _ _ ty) = head used_cons ty_con = tcTyConAppTyCon ty -- Newtype observable all_cons = tyConDataCons ty_con - used_cons_as_id = map (\ (ConPatOut d _ _ _ _ _) -> d) used_cons + used_cons_as_id = map (\ (ConPatOut (L _ d) _ _ _ _ _) -> d) used_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) @@ -471,7 +471,7 @@ is_var _ = False is_var_con :: DataCon -> Pat Id -> Bool is_var_con con (WildPat _) = True -is_var_con con (ConPatOut id _ _ _ _ _) | id == con = True +is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True is_var_con con _ = False is_var_lit :: HsLit -> Pat Id -> Bool @@ -534,12 +534,12 @@ make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat -make_con (ConPatOut id _ _ _ _ _) (lp:lq:ps, constraints) +make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints) | return_list id q = (noLoc (make_list lp q) : ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) where q = unLoc lq -make_con (ConPatOut id _ _ _ (PrefixCon pats) _) (ps, constraints) +make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints) | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | otherwise = (nlConPat name pats_con : rest_pats, constraints) @@ -584,8 +584,8 @@ simplify_pat (LazyPat p) = unLoc (simplify_lpat p) simplify_pat (AsPat id p) = unLoc (simplify_lpat p) simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right -simplify_pat (ConPatOut id tvs dicts binds ps ty) - = ConPatOut id tvs dicts binds (simplify_con id ps) ty +simplify_pat (ConPatOut (L loc id) tvs dicts binds ps ty) + = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) ty simplify_pat (ListPat ps ty) = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) @@ -632,7 +632,7 @@ simplify_pat (DictPat dicts methods) num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) -mk_simple_con_pat con args ty = ConPatOut con [] [] emptyLHsBinds args ty +mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty ----------------- simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 03c3710..58a3cdd 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -477,7 +477,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) out_inst_tys) val_args in - returnDs (mkSimpleMatch [noLoc $ ConPatOut con [] [] emptyLHsBinds + returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds (PrefixCon (map nlVarPat arg_ids)) record_in_ty] rhs) in diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 150cdc6..7626360 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -430,8 +430,8 @@ tidy1 v (LazyPat pat) rhs -- re-express as (ConPat ...) [directly] -tidy1 v (ConPatOut con ex_tvs dicts binds ps pat_ty) rhs - = returnDs (ConPatOut con ex_tvs dicts binds tidy_ps pat_ty, rhs) +tidy1 v (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) rhs + = returnDs (ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty, rhs) where tidy_ps = PrefixCon (tidy_con con pat_ty ps) diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 62ed087..c7e2b93 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -22,7 +22,7 @@ import DsUtils import Id ( Id ) import Type ( Type ) import ListSetOps ( equivClassesByUniq ) -import SrcLoc ( unLoc ) +import SrcLoc ( unLoc, Located(..) ) import Unique ( Uniquable(..) ) import Outputable \end{code} @@ -87,7 +87,7 @@ matchConFamily (var:vars) ty eqns_info -- Sort into equivalence classes by the unique on the constructor -- All the EqnInfos should start with a ConPat eqn_groups = equivClassesByUniq get_uniq eqns_info - get_uniq (EqnInfo { eqn_pats = ConPatOut data_con _ _ _ _ _ : _}) = getUnique data_con + get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con in -- Now make a case alternative out of each group mappM (match_con vars ty) eqn_groups `thenDs` \ alts -> @@ -118,7 +118,7 @@ match_con vars ty eqns ; return (data_con, tvs1 ++ dicts1 ++ arg_vars, match_result') } where pats@(pat1 : other_pats) = map firstPat eqns - ConPatOut data_con tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1 + ConPatOut (L _ data_con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1 ds_binds bind = do { prs <- dsHsNestedBinds bind; return (Rec prs) } diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 82ab6e3..912dc4c 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -67,7 +67,7 @@ data Pat id | ConPatIn (Located id) (HsConDetails id (LPat id)) - | ConPatOut DataCon + | ConPatOut (Located DataCon) [TyVar] -- Existentially bound type variables [id] -- Ditto dictionaries (DictBinds id) -- Bindings involving those dictionaries @@ -214,7 +214,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id -- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc [] [] emptyLHsBinds (PrefixCon pats) ty +mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] ty diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index e269af7..d273105 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), HscCheckResult(..) , + HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd #ifdef GHCI , hscStmt, hscTcExpr, hscKcType @@ -132,7 +132,9 @@ data HscResult = HscFail -- In IDE mode: we just do the static/dynamic checks - | HscChecked HscCheckResult + | HscChecked + (Located (HsModule RdrName)) -- parse tree + (Maybe TcGblEnv) -- typechecker output, if succeeded -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -147,13 +149,6 @@ data HscResult (Maybe CompiledByteCode) --- The result when we're just checking (in an IDE editor, for example) -data HscCheckResult - = HscParsed (Located (HsModule RdrName)) - -- renaming/typechecking failed, here's the parse tree - | HscTypechecked TcGblEnv - -- renaming/typechecking succeeded - -- What to do when we have compiler error or warning messages type MessageAction = Messages -> IO () @@ -389,9 +384,9 @@ hscBufferTypecheck hsc_env rdr_module msg_act = do tcRnModule hsc_env rdr_module msg_act tc_msgs case maybe_tc_result of - Nothing -> return (HscChecked (HscParsed rdr_module)) + Nothing -> return (HscChecked rdr_module Nothing) + Just r -> return (HscChecked rdr_module (Just r)) -- space leak on rdr_module! - Just r -> return (HscChecked (HscTypechecked r)) hscFrontEnd hsc_env msg_act rdr_module = do { diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 625bd12..6cedb81 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -40,7 +40,7 @@ import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys import PrelNames ( eqStringName, eqName, geName, negateName, minusName, integralClassName ) import BasicTypes ( isBoxed ) -import SrcLoc ( Located(..), noLoc, unLoc ) +import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc, getLoc ) import ErrUtils ( Message ) import Outputable import FastString @@ -283,7 +283,7 @@ tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside = do { data_con <- tcLookupDataCon con_name ; let tycon = dataConTyCon data_con ; ty_args <- zapToTyConApp tycon pat_ty - ; (pat', tvs, res) <- tcConPat ctxt data_con tycon ty_args arg_pats thing_inside + ; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside ; return (pat', tvs, res) } @@ -361,16 +361,16 @@ tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pa %************************************************************************ \begin{code} -tcConPat :: PatCtxt -> DataCon -> TyCon -> [TcTauType] +tcConPat :: PatCtxt -> SrcSpan -> DataCon -> TyCon -> [TcTauType] -> HsConDetails Name (LPat Name) -> TcM a -> TcM (Pat TcId, [TcTyVar], a) -tcConPat ctxt data_con tycon ty_args arg_pats thing_inside +tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside | isVanillaDataCon data_con = do { let arg_tys = dataConInstOrigArgTys data_con ty_args ; tcInstStupidTheta data_con ty_args ; traceTc (text "tcConPat" <+> vcat [ppr data_con, ppr ty_args, ppr arg_tys]) ; (arg_pats', tvs, res) <- tcConArgs ctxt data_con arg_pats arg_tys thing_inside - ; return (ConPatOut data_con [] [] emptyLHsBinds + ; return (ConPatOut (L span data_con) [] [] emptyLHsBinds arg_pats' (mkTyConApp tycon ty_args), tvs, res) } @@ -400,7 +400,7 @@ tcConPat ctxt data_con tycon ty_args arg_pats thing_inside ; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req - ; return (ConPatOut data_con + ; return (ConPatOut (L span data_con) tvs' (map instToId dicts) dict_binds arg_pats' (mkTyConApp tycon ty_args), tvs' ++ inner_tvs, res) } } -- 1.7.10.4