Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a3e01707
Commit
a3e01707
authored
Oct 15, 2004
by
simonmar
Browse files
[project @ 2004-10-15 15:28:48 by simonmar]
Add a SrcSpan to the DataCon in a ConPatOut.
parent
7763a8e4
Changes
7
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) } }
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment