Skip to content

GitLab

Commit a3e01707 authored by simonmar's avatar simonmar
Browse files

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

Add a SrcSpan to the DataCon in a ConPatOut.
parent 7763a8e4
Hide whitespace changes
Inline Side-by-side
ghc/compiler/deSugar/Check.lhs
View file @ a3e01707
......@@ -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)
......
ghc/compiler/deSugar/DsExpr.lhs
View file @ a3e01707
......@@ -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
......
ghc/compiler/deSugar/Match.lhs
View file @ a3e01707
......@@ -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)
......
ghc/compiler/deSugar/MatchCon.lhs
View file @ a3e01707
......@@ -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) }
......
ghc/compiler/hsSyn/HsPat.lhs
View file @ a3e01707
......@@ -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
......
ghc/compiler/main/HscMain.lhs
View file @ a3e01707
......@@ -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 {
......
ghc/compiler/typecheck/TcPat.lhs
View file @ a3e01707
......@@ -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) } }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment