Add a SrcSpan to the DataCon in a ConPatOut.
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
= 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 [] = []
(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)
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
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)
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)
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)
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
-- 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)
import Id ( Id )
import Type ( Type )
import ListSetOps ( equivClassesByUniq )
-import SrcLoc ( unLoc )
+import SrcLoc ( unLoc, Located(..) )
import Unique ( Uniquable(..) )
import Outputable
\end{code}
-- 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 ->
; 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) }
| 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
\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
\begin{code}
module HscMain (
- HscResult(..), HscCheckResult(..) ,
+ HscResult(..),
hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType
= 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)
(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 ()
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 {
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
= 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) }
%************************************************************************
\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) }
; 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) } }