[project @ 2004-10-15 15:28:48 by simonmar]

Add a SrcSpan to the DataCon in a ConPatOut.

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index e03dd43..1e4a186 100644 (file)
--- 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 (file)
--- 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 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -430,8 +430,8 @@ tidy1 v (LazyPat pat) rhs
 
 -- re-express <con-something> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) } }