import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isDataCon, isDictFunId,
isDefaultMethodId_maybe,
- isSuperDictSelId_maybe, fIRST_TAG,
- ConTag, GenId{-instance Outputable-},
+ fIRST_TAG,
+ ConTag,
Id
)
import Maybes ( maybeToBool )
isDictFunId,
isImportedId,
isRecordSelector,
- isMethodSelId_maybe,
+ isDictSelId_maybe,
isNullaryDataCon,
isSpecPragmaId,
- isSuperDictSelId_maybe,
isPrimitiveId_maybe,
isSysLocalId,
isTupleCon,
---------------- Things to do with overloading
- | SuperDictSelId -- Selector for superclass dictionary
- Class -- The class (input dict)
- Class -- The superclass (result dict)
-
- | MethodSelId Class -- An overloaded class operation, with
- -- a fully polymorphic type. Its code
- -- just selects a method from the
- -- dictionary.
-
- -- NB: The IdInfo for a MethodSelId has all the info about its
- -- related "constant method Ids", which are just
- -- specialisations of this general one.
+ | DictSelId -- Selector that extracts a method or superclass from a dictionary
+ Class -- The class
| DefaultMethodId -- Default method for a particular class op
Class -- same class, <blah-blah> info as MethodSelId
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _) = True
+ chk (DictSelId _) = True
chk (DefaultMethodId _) = True
chk (DictFunId _ _) = True
chk (SpecId unspec _ _) = toplevelishId unspec
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _) = True
+ chk (DictSelId _) = True
chk (DefaultMethodId _) = True
chk (DictFunId _ _) = True
chk (SpecId _ _ no_free_tvs) = no_free_tvs
(AlgConId _ _ _ _ _ _ _ _ _) -> True
(TupleConId _) -> True
(RecordSelId _) -> True
- (SuperDictSelId _ _) -> True
- (MethodSelId _) -> True
+ (DictSelId _) -> True
other -> False -- Don't omit!
-- NB DefaultMethodIds are not omitted
isSpecId_maybe other_id
= Nothing
-isMethodSelId_maybe (Id _ _ _ (MethodSelId cls) _ _) = Just cls
-isMethodSelId_maybe _ = Nothing
+isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls
+isDictSelId_maybe _ = Nothing
isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True
isDefaultMethodId other = False
isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
isDictFunId other = False
-isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
-isSuperDictSelId_maybe other_id = Nothing
-
isWrapperId id = workerExists (getIdStrictness id)
isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
%************************************************************************
\begin{code}
-mkSuperDictSelId u clas sc ty
+mkSuperDictSelId :: Unique -> Class -> Int -> Type -> Id
+ -- The Int is an arbitrary tag to say which superclass is selected
+ -- So, for
+ -- class (C a, C b) => Foo a b where ...
+ -- we get superclass selectors
+ -- Foo_sc1, Foo_sc2
+
+mkSuperDictSelId u clas index ty
= addStandardIdInfo $
Id u name ty details NoPragmaInfo noIdInfo
where
name = mkCompoundName name_fn u (getName clas)
- details = SuperDictSelId clas sc
- name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
- (mod,occ) = modAndOcc sc
+ details = DictSelId clas
+ name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
-- For method selectors the clean thing to do is
-- to give the method selector the same name as the class op itself.
-mkMethodSelId op_name rec_c ty
+mkMethodSelId op_name clas ty
= addStandardIdInfo $
- Id (uniqueOf op_name) op_name ty (MethodSelId rec_c) NoPragmaInfo noIdInfo
+ Id (uniqueOf op_name) op_name ty (DictSelId clas) NoPragmaInfo noIdInfo
mkDefaultMethodId dm_name rec_c ty
= Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo
SpecPragmaId _ _ -> "sp"
ImportedId -> "i"
RecordSelId _ -> "r"
- SuperDictSelId _ _ -> "sc"
- MethodSelId _ -> "m"
+ DictSelId _ -> "m"
DefaultMethodId _ -> "d"
DictFunId _ _ -> "di"
SpecId _ _ _ -> "spec"))
import CgMonad
import AbsCSyn
import StgSyn
+import BasicTypes ( TopLevelFlag(..) )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getCAddrMode, getArgAmodes,
`thenC`
-- BUILD VAP INFO TABLES IF NECESSARY
- -- Don't build Vap info tables etc for
- -- a function whose result is an unboxed type,
- -- because we can never have thunks with such a type.
- (if closureReturnsUnpointedType closure_info then
- nopC
- else
- let
+ let
bind_the_fun = addBindC name cg_id_info -- It's global!
- in
- cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
- ) `thenC`
+ in
+ cgVapInfoTables TopLevel bind_the_fun binder_info name args lf_info
+ `thenC`
-- BUILD THE OBJECT (IF NECESSARY)
(if staticClosureRequired name binder_info lf_info
) `thenC`
-- BUILD VAP INFO TABLES IF NECESSARY
- -- Don't build Vap info tables etc for
- -- a function whose result is an unboxed type,
- -- because we can never have thunks with such a type.
- (if closureReturnsUnpointedType closure_info then
- nopC
- else
- cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
- ) `thenC`
+ cgVapInfoTables NotTopLevel nopC binder_info binder args lf_info
+ `thenC`
-- BUILD THE OBJECT
let
)
where
- fun_in_payload = not top_level
+ fun_in_payload = case top_level of
+ TopLevel -> False
+ NotTopLevel -> True
+
cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
- = let
+ | closureReturnsUnpointedType closure_info
+ -- Don't build Vap info tables etc for
+ -- a function whose result is an unboxed type,
+ -- because we can never have thunks with such a type.
+ = nopC
+
+ | otherwise
+ = forkClosureBody (
+
+ -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
+ -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
+ perhaps_bind_the_fun `thenC`
+ mapCs bind_fv payload_bind_details `thenC`
+
+ -- Generate the info table and code
+ closureCodeBody NoStgBinderInfo
+ closure_info
+ useCurrentCostCentre
+ [] -- No args; it's a thunk
+ vap_entry_rhs
+ )
+ where
-- The vap_entry_rhs is a manufactured STG expression which
-- looks like the RHS of any binding which is going to use the vap-entry
-- point of the function. Each of these bindings will look like:
-- Id is just used for label construction, which is OK.
bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
- in
-
- -- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
-
- -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
- -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
- perhaps_bind_the_fun `thenC`
- mapCs bind_fv payload_bind_details `thenC`
-
- -- Generate the info table and code
- closureCodeBody NoStgBinderInfo
- closure_info
- useCurrentCostCentre
- [] -- No args; it's a thunk
- vap_entry_rhs
- )
\end{code}
%************************************************************************
%* *
import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
import TyCon ( TyCon, isNewTyCon )
-import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys, splitAlgTyConApp_maybe,
+import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys,
+ splitAlgTyConApp_maybe, applyTys,
Type
)
import Util ( isIn, mapAccumL )
Nothing -> pprPanic "fun_result_ty:" (hsep [int arity,
ppr ty])
- Just (tycon, _, [con]) | isNewTyCon tycon
+ Just (tycon, tycon_arg_tys, [con]) | isNewTyCon tycon
-> fun_result_ty (arity - n_arg_tys) rep_ty
where
- ([rep_ty], _) = splitFunTys rho_ty
- (_, rho_ty) = splitForAllTys (idType con)
+ ([rep_ty], _) = splitFunTys (applyTys (idType con) tycon_arg_tys)
where
(_, rho_ty) = splitForAllTys ty
(arg_tys, res_ty) = splitFunTys rho_ty
TyVar, GenTyVar
)
import Type ( mkFunTy, mkForAllTy, mkTyVarTy,
- splitFunTy_maybe, applyTy, isUnpointedType,
+ splitFunTy_maybe, applyTys, isUnpointedType,
splitSigmaTy, splitFunTys, instantiateTy,
Type
)
= mkForAllTy tyvar (coreExprType expr)
coreExprType (App expr (TyArg ty))
- =
--- pprTrace "appTy1" (hsep [ppr fun_ty, space, ppr ty]) $
- applyTy fun_ty ty
+ = -- Gather type args; more efficient to instantiate the type all at once
+ go expr [ty]
where
- fun_ty = coreExprType expr
+ go (App expr (TyArg ty)) tys = go expr (ty:tys)
+ go expr tys = applyTys (coreExprType expr) tys
coreExprType (App expr val_arg)
= ASSERT(isValArg val_arg)
\end{code}
\begin{code}
-applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
+applyTypeToArgs op_ty (TyArg ty : args)
+ = -- Accumulate type arguments so we can instantiate all at once
+ applyTypeToArgs (applyTys op_ty tys) rest_args
+ where
+ (tys, rest_args) = go [ty] args
+ go tys (TyArg ty : args) = go (ty:tys) args
+ go tys rest_args = (reverse tys, rest_args)
+
+applyTypeToArgs op_ty (val_or_lit_arg:args)
+ = case (splitFunTy_maybe op_ty) of
+ Just (_, res_ty) -> applyTypeToArgs res_ty args
-applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
-applyTypeToArg op_ty val_or_lit_arg = case (splitFunTy_maybe op_ty) of
- Just (_, res_ty) -> res_ty
+applyTypeToArgs op_ty [] = op_ty
\end{code}
coreExprCc gets the cost centre enclosing an expression, if any.
)
import TyVar ( zipTyVarEnv )
import TysPrim ( voidTy )
+import Outputable ( assertPanic )
\end{code}
%************************************************************************
Match, HsBinds, DoOrListComp, HsType, ArithSeqInfo )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedPat )
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) )
-import Id ( GenId {- instance Eq -}, Id )
+import Id ( Id )
import DsMonad
import DsUtils
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import Type ( Type )
+import Type ( Type, isUnpointedType )
import Util ( panic, assertPanic )
\end{code}
ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
- (pprExpr fun) <+> (sep (map pprExpr args))
+ (ppr_expr fun) <+> (sep (map ppr_expr args))
where
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
= parens (sep [ppr v, pp_expr])
ppr_expr (HsCase expr matches _)
- = sep [ sep [ptext SLIT("case"), nest 4 (ppr_expr expr), ptext SLIT("of")],
+ = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
nest 2 (pprMatches (True, empty) matches) ]
ppr_expr (HsIf e1 e2 e3 _)
- = sep [hsep [ptext SLIT("if"), nest 2 (ppr_expr e1), ptext SLIT("then")],
- nest 4 (ppr_expr e2),
+ = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
+ nest 4 (pprExpr e2),
ptext SLIT("else"),
- nest 4 (ppr_expr e3)]
+ nest 4 (pprExpr e3)]
-- special case: let ... in let ...
ppr_expr (HsLet binds expr@(HsLet _ _))
= sep [hang (ptext SLIT("let")) 2 (hsep [ppr binds, ptext SLIT("in")]),
- ppr_expr expr]
+ pprExpr expr]
ppr_expr (HsLet binds expr)
= sep [hang (ptext SLIT("let")) 2 (ppr binds),
ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList exprs)
- = brackets (fsep (punctuate comma (map pprExpr exprs)))
+ = brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitListOut ty exprs)
- = hcat [ brackets (fsep (punctuate comma (map pprExpr exprs))),
+ = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
ifNotPprForUser ((<>) space (parens (pprGenType ty))) ]
ppr_expr (ExplicitTuple exprs)
- = parens (sep (punctuate comma (map pprExpr exprs)))
+ = parens (sep (punctuate comma (map ppr_expr exprs)))
ppr_expr (HsCon con_id tys args)
= ppr con_id <+> sep (map pprParendGenType tys ++
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
- = hang (nest 2 (pprExpr expr) <+> ptext SLIT("::"))
+ = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::"))
4 (ppr sig)
ppr_expr (ArithSeqIn info)
ppr_expr (TyLam tyvars expr)
= hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")])
- 4 (pprExpr expr)
+ 4 (ppr_expr expr)
ppr_expr (TyApp expr [ty])
- = hang (pprExpr expr) 4 (pprParendGenType ty)
+ = hang (ppr_expr expr) 4 (pprParendGenType ty)
ppr_expr (TyApp expr tys)
- = hang (pprExpr expr)
+ = hang (ppr_expr expr)
4 (brackets (interpp'SP tys))
ppr_expr (DictLam dictvars expr)
= hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")])
- 4 (pprExpr expr)
+ 4 (ppr_expr expr)
ppr_expr (DictApp expr [dname])
- = hang (pprExpr expr) 4 (ppr dname)
+ = hang (ppr_expr expr) 4 (ppr dname)
ppr_expr (DictApp expr dnames)
- = hang (pprExpr expr)
+ = hang (ppr_expr expr)
4 (brackets (interpp'SP dnames))
\end{code}
import Literal
import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
import TysWiredIn ( tupleCon )
-import Id ( GenId, mkTemplateLocals, idType,
+import Id ( mkTemplateLocals, idType,
dataConStrictMarks, dataConFieldLabels, dataConArgTys,
recordSelectorFieldLabel, dataConSig,
StrictnessMark(..),
- isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
+ isAlgCon, isDictSelId_maybe,
isRecordSelector, isPrimitiveId_maybe,
addIdUnfolding, addIdArity,
Id
)
import IdInfo ( ArityInfo, exactArity )
import Class ( classBigSig, classTyCon )
-import TyCon ( isNewTyCon, tyConDataCons )
+import TyCon ( isNewTyCon, tyConDataCons, isDataTyCon )
import FieldLabel ( FieldLabel )
import PrelVals ( pAT_ERROR_ID )
import Maybes
%* *
%************************************************************************
+Selecting a field for a dictionary. If there is just one field, then
+there's nothing to do.
+
\begin{code}
addStandardIdInfo sel_id
- | maybeToBool maybe_sc_sel_id
- = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
+ | maybeToBool maybe_dict_sel_id
+ = sel_id `addIdUnfolding` unfolding
where
- maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
- Just (cls, _) = maybe_sc_sel_id
+ maybe_dict_sel_id = isDictSelId_maybe sel_id
+ Just clas = maybe_dict_sel_id
-addStandardIdInfo sel_id
- | maybeToBool maybe_meth_sel_id
- = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
- where
- maybe_meth_sel_id = isMethodSelId_maybe sel_id
- Just cls = maybe_meth_sel_id
+ unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
+ -- The always-inline thing means we don't need any other IdInfo
+
+ (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+
+ tycon = classTyCon clas
+ [data_con] = tyConDataCons tycon
+ tyvar_tys = mkTyVarTys tyvars
+ arg_tys = dataConArgTys data_con tyvar_tys
+ the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
+
+ (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
+
+ rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
+ Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
+ | otherwise = mkLam tyvars [dict_id] $
+ Case (Var dict_id) $
+ AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
\end{code}
= pprTrace "addStandardIdInfo missing:" (ppr id) id
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Dictionary selector help function
-%* *
-%************************************************************************
-
-Selecting a field for a dictionary. If there is just one field, then
-there's nothing to do.
-
-\begin{code}
-mk_selector_unfolding clas sel_id
- = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- -- The always-inline thing means we don't need any other IdInfo
- where
- (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
-
- tycon = classTyCon clas
- [data_con] = tyConDataCons tycon
- tyvar_tys = mkTyVarTys tyvars
- arg_tys = dataConArgTys data_con tyvar_tys
- the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
-
- (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
-
- rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
- Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
- | otherwise = mkLam tyvars [dict_id] $
- Case (Var dict_id) $
- AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
-\end{code}
}
mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
+ -- Ignore class decls, instance decls etc
\end{code}
\begin{code}
go acc (RdrInstDecl d) = InstD d : acc
go acc (RdrDefaultDecl d) = DefD d : acc
go acc other = acc
+ -- Ignore value bindings
\end{code}
isUnqual, isQual,
showRdr, rdrNameOcc, rdrNameModule, ieOcc,
cmpRdr, prefixRdrName,
- mkOpApp, mkClassDecl
+ mkOpApp, mkClassDecl, isClassDataConRdrName
) where
where
s1 = SLIT(":") _APPEND_ s
+-- This nasty little function tests for whether a RdrName was
+-- constructed by the above process. It's used only for filtering
+-- out duff error messages. Maybe there's a tidier way of doing this
+-- but I can't work up the energy to find it.
+
+isClassDataConRdrName rdr_name
+ = case rdrNameOcc rdr_name of
+ TCOcc s -> case _UNPK_ s of
+ ':' : c : _ -> isUpper c
+ other -> False
+ other -> False
\end{code}
%************************************************************************
getDeferredDataDecls,
mkSearchPath, getSlurpedNames, getRnStats
)
-import RnEnv ( addImplicitOccsRn )
+import RnEnv ( addImplicitOccsRn, availNames )
import Name ( Name, PrintUnqualified, Provenance, isLocallyDefined,
NameSet(..),
nameSetToList, minusNameSet, NamedThing(..),
doIfSet, dumpIfSet, ghcExit
)
import Bag ( isEmptyBag )
+import FiniteMap ( fmToList, delListFromFM )
import UniqSupply ( UniqSupply )
import Util ( equivClasses )
import Maybes ( maybeToBool )
returnRn Nothing
else
let
- Just (export_env, rn_env, explicit_names, print_unqual) = maybe_stuff
+ Just (export_env, rn_env, explicit_info, print_unqual) = maybe_stuff
in
-- RENAME THE SOURCE
getNameSupplyRn `thenRn` \ name_supply ->
-- REPORT UNUSED NAMES
- reportUnusedNames explicit_names `thenRn_`
+ reportUnusedNames export_env explicit_info `thenRn_`
-- GENERATE THE SPECIAL-INSTANCE MODULE LIST
-- The "special instance" modules are those modules that contain instance
\end{code}
\begin{code}
-reportUnusedNames explicit_avail_names
+reportUnusedNames (ExportEnv export_avails _) explicit_info
+ | not (opt_WarnUnusedBinds || opt_WarnUnusedImports)
+ = returnRn ()
+
+ | otherwise
= getSlurpedNames `thenRn` \ slurped_names ->
let
- unused = explicit_avail_names `minusNameSet` slurped_names
- (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused)
- imports_by_module = equivClasses cmp imported_unused
- name1 `cmp` name2 = nameModule name1 `compare` nameModule name2
-
- pp_imp = sep [text "Warning: the following unqualified imports are unused:",
- nest 4 (vcat (map pp_group imports_by_module))]
- pp_group (n:ns) = sep [hcat [text "Module ", pprModule (nameModule n), char ':'],
- nest 4 (sep (map (pprOccName . nameOccName) (n:ns)))]
-
- pp_local = sep [text "Warning: the following local top-level definitions are unused:",
- nest 4 (sep (map (pprOccName . nameOccName) local_unused))]
- in
- (if not opt_WarnUnusedImports || null imported_unused
- then returnRn ()
- else addWarnRn pp_imp) `thenRn_`
+ unused_info :: FiniteMap Name HowInScope
+ unused_info = foldl delListFromFM
+ (delListFromFM explicit_info (nameSetToList slurped_names))
+ (map availNames export_avails)
+ unused_list = fmToList unused_info
+
+ groups = filter wanted (equivClasses cmp unused_list)
+ where
+ (name1, his1) `cmp` (name2, his2) = his1 `cmph` his2
+
+ (FromLocalDefn _) `cmph` (FromImportDecl _ _) = LT
+ (FromLocalDefn _) `cmph` (FromLocalDefn _) = EQ
+ (FromImportDecl m1 _) `cmph` (FromImportDecl m2 _) = m1 `compare` m2
+ h1 `cmph` h2 = GT
+
+ wanted ((_,FromImportDecl _ _) : _) = opt_WarnUnusedImports
+ wanted ((_,FromLocalDefn _) : _) = opt_WarnUnusedImports
+
+ pp_imp = sep [text "Warning: the following are unused:",
+ nest 4 (vcat (map pp_group groups))]
+
+ pp_group group = sep [msg <> char ':',
+ nest 4 (sep (map (pprOccName . nameOccName . fst) group))]
+ where
+ his = case group of
+ ((_,his) : _) -> his
+
+ msg = case his of
+ FromImportDecl m _ -> text "Imported from" <+> pprModule m
+ FromLocalDefn _ -> text "Locally defined"
- (if not opt_WarnUnusedBinds || null local_unused
- then returnRn ()
- else addWarnRn pp_local)
+ in
+ if null groups
+ then returnRn ()
+ else addWarnRn pp_imp
rnStats :: [RenamedHsDecl] -> RnMG ()
rnStats all_decls
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
rnBindSigs top_lev binders sigs `thenRn` \ siglist ->
- flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
+ flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
-- Do the SCC analysis
- let edges = mkEdges mbinds_info
+ let edges = mkEdges (mbinds_info `zip` [0..])
scc_result = stronglyConnComp edges
final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
unique ``vertex tags'' on its output; minor plumbing required.
\begin{code}
-flattenMonoBinds :: Int -- Next free vertex tag
- -> [RenamedSig] -- Signatures
+flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
-> RnMS s (Int, [FlatMonoBindsInfo])
-flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
+flattenMonoBinds sigs EmptyMonoBinds = returnRn []
-flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
- = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) ->
- flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) ->
- returnRn (uniq2, flat1 ++ flat2)
+flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
+ = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
+ flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
+ returnRn (flat1 ++ flat2)
-flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
+flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
= pushSrcLocRn locn $
rnPat pat `thenRn` \ pat' ->
rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
- returnRn (
- uniq + 1,
- [(uniq,
- names_bound_here,
+ returnRn
+ [(names_bound_here,
fvs `unionNameSets` sigs_fvs,
PatMonoBind pat' grhss_and_binds' locn,
sigs_for_me
)]
- )
-flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
+flattenMonoBinds sigs (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
mapRn (checkPrecMatch inf name) matches `thenRn_`
lookupBndrRn name `thenRn` \ name' ->
sigs_for_me = filter ((name' ==) . sig_name) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
- returnRn (
- uniq + 1,
- [(uniq,
- unitNameSet name',
+ returnRn
+ [(unitNameSet name',
fvs `unionNameSets` sigs_fvs,
FunMonoBind name' inf new_matches locn,
sigs_for_me
)]
- )
\end{code}
\begin{code}
type FlatMonoBindsInfo
- = (VertexTag, -- Identifies the vertex
- NameSet, -- Set of names defined in this vertex
+ = (NameSet, -- Set of names defined in this vertex
NameSet, -- Set of names used in this vertex
- RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
+ RenamedMonoBinds,
[RenamedSig]) -- Signatures, if any, for this vertex
-
-mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
+mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
mkEdges flat_info
= [ (info, tag, dest_vertices (nameSetToList names_used))
- | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info
+ | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
]
where
-- An edge (v,v') indicates that v depends on v'
dest_vertices src_mentions = [ target_vertex
- | (target_vertex, names_defined, _, _, _) <- flat_info,
+ | ((names_defined, _, _, _), target_vertex) <- flat_info,
mentioned_name <- src_mentions,
mentioned_name `elemNameSet` names_defined
]
opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrName(..), RdrNameIE,
- rdrNameOcc, isQual, qual
+ rdrNameOcc, isQual, qual, isClassDataConRdrName
)
import HsTypes ( getTyVarName, replaceTyVarName )
import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
\begin{code}
plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
plusGlobalNameEnvRn env1 env2
- = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_`
+ = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_`
returnRn (env1 `plusFM` env2)
addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
addOneToGlobalNameEnv env rdr_name name
= case lookupFM env rdr_name of
Just name2 | conflicting_name name name2
- -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
+ -> addNameClashErrRn (rdr_name, (name, name2))) `thenRn_`
returnRn env
other -> returnRn (addToFM env rdr_name name)
unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
-nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
- = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
- 4 (vcat [ppr how_in_scope1,
- ppr how_in_scope2])
+addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
+ | isClassDataConRdrName rdr_name
+ -- Nasty hack to prevent error messages complain about conflicts for ":C",
+ -- where "C" is a class. There'll be a message about C, and :C isn't
+ -- the programmer's business. There may be a better way to filter this
+ -- out, but I couldn't get up the energy to find it.
+ = returnRn ()
+
+ | otherwise
+ = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
+ 4 (vcat [ppr how_in_scope1,
+ ppr how_in_scope2])
fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
= hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
\begin{code}
getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (ExportEnv, RnEnv, NameSet, Name -> PrintUnqualified))
- -- The NameSet is the set of names that are
- -- either locally defined,
- -- or explicitly imported
+ -> RnMG (Maybe (ExportEnv,
+ RnEnv,
+ FiniteMap Name HowInScope, -- Locally defined or explicitly imported
+ Name -> PrintUnqualified))
-- Nothing => no need to recompile
getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
-- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
-- into the global name cache.
- importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_avails) ->
+ importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_info) ->
-- PROCESS IMPORT DECLS
mapAndUnzip3Rn importsFromImportDecl all_imports
export_avails :: ExportAvails
export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
- explicit_names :: NameSet -- locally defined or explicitly imported
- explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s)
- add_on avails names = foldr (unionNameSets . mkNameSet . availNames) names avails
+ explicit_info :: FiniteMap Name HowInScope -- Locally defined or explicitly imported
+ explicit_info = foldr plusFM local_info explicit_imports_s
in
exportsFromAvail this_mod exports export_avails rn_env
`thenRn` \ (export_fn, export_env) ->
- -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
- mapRn (recordSlurp Nothing Compulsory) local_avails `thenRn_`
-
-- BUILD THE "IMPORT FN". It just tells whether a name is in
-- scope in an unqualified form.
let
print_unqual = mkImportFn imp_rn_env
in
- returnRn (export_fn, Just (export_env, rn_env, explicit_names, print_unqual))
+ returnRn (export_fn, Just (export_env, rn_env, explicit_info, print_unqual))
) `thenRn` \ (_, result) ->
returnRn result
where
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv, ExportAvails, [AvailInfo])
+ -> RnMG (RnEnv,
+ ExportAvails,
+ FiniteMap Name HowInScope) -- Records the explicitly-imported things
importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc)
= pushSrcLocRn loc $
filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
let
how_in_scope = FromImportDecl mod loc
+ explicit_info = listToFM [(name, how_in_scope)
+ | avail <- explicits,
+ name <- availNames avail
+ ]
in
qualifyImports mod
True -- Want qualified names
filtered_avails (\n -> how_in_scope)
[ (occ,(fixity,how_in_scope)) | (occ,fixity) <- fixities ]
`thenRn` \ (rn_env, mod_avails) ->
- returnRn (rn_env, mod_avails, explicits)
+ returnRn (rn_env, mod_avails, explicit_info)
\end{code}
\begin{code}
importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
= foldlRn getLocalDeclBinders [] decls `thenRn` \ avails ->
+
+ -- Record that locally-defined things are available
+ mapRn (recordSlurp Nothing Compulsory) avails `thenRn_`
+
+ -- Fixities
mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities ->
+
+ -- Record where the available stuff came from
+ let
+ explicit_info = listToFM [(name, FromLocalDefn (getSrcLoc name))
+ | avail <- avails,
+ name <- availNames avail
+ ]
+ in
qualifyImports mod
False -- Don't want qualified names
True -- Want unqualified names
avails (\n -> FromLocalDefn (getSrcLoc n))
fixities
`thenRn` \ (rn_env, mod_avails) ->
- returnRn (rn_env, mod_avails, avails)
+ returnRn (rn_env, mod_avails, explicit_info)
where
newLocalName rdr_name loc
= newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
import SimplVar ( completeVar )
import Unique ( Unique )
import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, splitAlgTyConApp_maybe,
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
+ mkFunTys, splitAlgTyConApp_maybe,
splitFunTys, splitFunTy_maybe, isUnpointedType
)
import TysPrim ( realWorldStatePrimTy )
mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
let
new_tys = mkTyVarTys tyvars'
- body_ty = foldl applyTy rhs_ty new_tys
+ body_ty = applyTys rhs_ty new_tys
lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
in
-- Deal with the little lambda part
import FiniteMap ( addListToFM_C, FiniteMap )
import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
- isSuperDictSelId_maybe, isBottomingId,
+ isBottomingId,
isDataCon,
isImportedId, mkIdWithNewUniq,
dataConTyCon, applyTypeEnvToId,
\begin{code}
pprOrigin :: Inst s -> SDoc
pprOrigin inst
- = hsep [text "arising from", pp_orig orig <> comma, text "at", ppr locn]
+ = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
(orig, locn) = case inst of
Dict _ _ _ orig loc -> (orig,loc)
= ptext SLIT("a class declaration")
pp_orig (InstanceSpecOrigin clas ty)
= hsep [text "a SPECIALIZE instance pragma; class",
- ppr clas, text "type:", ppr ty]
+ quotes (ppr clas), text "type:", ppr ty]
pp_orig (ValSpecOrigin name)
- = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr name]
+ = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
pp_orig (CCallOrigin clabel Nothing{-ccall result-})
- = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel]
+ = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
pp_orig (CCallOrigin clabel (Just arg_expr))
= hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
text "namely", quotes (ppr arg_expr)]
\begin{code}
module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
tcPragmaSigs, checkSigTyVars, tcBindWithSigs,
- sigCtxt, sigThetaCtxt, TcSigInfo(..) ) where
+ sigCtxt, TcSigInfo(..) ) where
#include "HsVersions.h"
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcType, TcThetaType, TcTauType,
TcTyVarSet, TcTyVar,
- newTyVarTy, newTcTyVar, tcInstSigType,
+ newTyVarTy, newTcTyVar, tcInstSigType, tcInstSigTcType,
zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar
)
import Unify ( unifyTauTy, unifyTauTyLists )
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcAddErrCtxt (bindSigsCtxt tysig_names) $
- tcAddErrCtxtM (sigThetaCtxt dicts_sig) $
tcSimplifyAndCheck
- (text "tcBinds2" <+> ppr binder_names)
+ (ptext SLIT("type signature for") <+>
+ hsep (punctuate comma (map (quotes . ppr) binder_names)))
real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) ->
returnTc (lie_free, dict_binds, dict_ids)
tcTySig prag_info_fn (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
tcHsType ty `thenTc` \ sigma_ty ->
- tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
+
+ -- Convert from Type to TcType
+ tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty ->
+ let
+ poly_id = mkUserId v sigma_tc_ty (prag_info_fn v)
+ in
+ -- Instantiate this type
+ -- It's important to do this even though in the error-free case
+ -- we could just split the sigma_tc_ty (since the tyvars don't
+ -- unified with anything). But in the case of an error, when
+ -- the tyvars *do* get unified with something, we want to carry on
+ -- typechecking the rest of the program with the function bound
+ -- to a pristine type, namely sigma_tc_ty
+ tcInstSigTcType sigma_tc_ty `thenNF_Tc` \ (tyvars, rho) ->
let
- poly_id = mkUserId v sigma_ty' (prag_info_fn v)
- (tyvars', theta', tau') = splitSigmaTy sigma_ty'
+ (theta, tau) = splitRhoTy rho
-- This splitSigmaTy tries hard to make sure that tau' is a type synonym
-- wherever possible, which can improve interface files.
in
- returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
+ returnTc (TySigInfo v poly_id tyvars theta tau src_loc)
\end{code}
@checkSigMatch@ does the next step in checking signature matching.
sigCtxt id
= sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)]
-sigThetaCtxt dicts_sig
- = mapNF_Tc zonkInst (bagToList dicts_sig) `thenNF_Tc` \ dicts' ->
- returnNF_Tc (ptext SLIT("Available context:") <+> pprInsts dicts')
-
bindSigsCtxt ids
= ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo,
tcLookupClass, tcLookupTyVar,
tcExtendGlobalTyVars )
-import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, sigThetaCtxt, TcSigInfo(..) )
+import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, TcSigInfo(..) )
import TcKind ( unifyKinds, TcKind )
import TcMonad
import TcMonoType ( tcHsType, tcContext )
in
-- Make super-class selector ids
- mapTc mk_super_id sc_theta `thenTc` \ sc_sel_ids ->
+ -- We number them off, 1, 2, 3 etc so that we can construct
+ -- names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
+ mapTc mk_super_id (sc_theta `zip` [1..]) `thenTc` \ sc_sel_ids ->
-- Done
returnTc (sc_theta, sc_tys, sc_sel_ids)
where
rec_tyvar_tys = mkTyVarTys rec_tyvars
- mk_super_id (super_class, tys)
+ mk_super_id ((super_class, tys), index)
= tcGetUnique `thenNF_Tc` \ uniq ->
let
ty = mkForAllTys rec_tyvars $
mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
in
- returnTc (mkSuperDictSelId uniq rec_class super_class ty)
+ returnTc (mkSuperDictSelId uniq rec_class index ty)
tcClassSig :: TcEnv s -- Knot tying only!
avail_insts = this_dict
in
tcAddErrCtxt (classDeclCtxt clas) $
- tcAddErrCtxtM (sigThetaCtxt avail_insts) $
mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
- tcSimplifyAndCheck (text "classDecl")
+ tcSimplifyAndCheck
+ (ptext SLIT("class") <+> ppr clas)
(mkTyVarSet clas_tyvars')
avail_insts
(unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
-import TcBinds ( tcBindsAndThen, checkSigTyVars, sigThetaCtxt )
+import TcBinds ( tcBindsAndThen, checkSigTyVars )
import TcEnv ( TcIdOcc(..), tcInstId,
tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
tcLookupGlobalValueByKey, newMonoIds,
-- Check overloading constraints
newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
- tcAddErrCtxtM (sigThetaCtxt sig_dicts) (
- tcSimplifyAndCheck
- (text "expr ty sig")
+ tcSimplifyAndCheck
+ (ptext SLIT("the type signature") <+> quotes (ppr sigma_sig))
(mkTyVarSet zonked_sig_tyvars)
sig_dicts lie
- ) `thenTc_`
+ `thenTc_`
-- Now match the signature type with res_ty.
-- We must not do this earlier, because res_ty might well
tcArg the_fun (arg, expected_arg_ty, arg_no)
= tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
- tcPolyExpr arg expected_arg_ty
+ tcPolyExpr (ptext SLIT("argument type of") <+> quotes (ppr the_fun))
+ arg expected_arg_ty
-- tcPolyExpr is like tcExpr, except that the expected type
-- can be a polymorphic one.
-tcPolyExpr arg expected_arg_ty
+tcPolyExpr str arg expected_arg_ty
| not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
= -- The ordinary, non-rank-2 polymorphic case
tcExpr arg expected_arg_ty
newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
- tcAddErrCtxtM (sigThetaCtxt sig_dicts) $
- tcSimplifyAndCheck (text "rank2")
+ tcSimplifyAndCheck
+ str
(mkTyVarSet zonked_sig_tyvars)
sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
Just (record_ty, field_ty) = splitFunTy_maybe tau
in
unifyTauTy expected_record_ty record_ty `thenTc_`
- tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) ->
+ tcPolyExpr (ptext SLIT("type of field") <+> quotes (ppr field_label))
+ rhs field_ty `thenTc` \ (rhs', lie) ->
returnTc ((RealId sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
= hang (ptext SLIT("Probable cause:") <+> ppr fun
<+> ptext SLIT("is applied to") <+> text too_many_or_few
<+> ptext SLIT("arguments in the call"))
- 4 (ppr the_app)
+ 4 (parens (ppr the_app))
where
the_app = foldl HsApp fun args -- Used in error messages
maybeBoxedPrimType
)
-import TcBinds ( tcPragmaSigs, sigThetaCtxt )
+import TcBinds ( tcPragmaSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
import RnMonad ( RnNameSupply )
import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE )
+ newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
import PragmaInfo ( PragmaInfo(..) )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo )
dfun_arg_dicts `plusLIE`
sc_dicts `plusLIE`
unionManyBags meth_lies
- in
- tcAddErrCtxt superClassCtxt $
- tcAddErrCtxtM (sigThetaCtxt sc_dicts) $
-
-
- -- Deal with the LIE arising from the method bindings
- tcSimplifyAndCheck (text "inst decl1a")
- inst_tyvars_set -- Local tyvars
- avail_insts
- (unionManyBags insts_needed_s) -- Need to get defns for all these
- `thenTc` \ (const_lie1, op_binds) ->
- -- Deal with the super-class bindings
- -- Ignore errors because they come from the *next* tcSimplify
- discardErrsTc (
- tcSimplifyAndCheck (text "inst decl1b")
- inst_tyvars_set
- dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
- -- get bound by just selecting from this_dict!!
- sc_dicts
- ) `thenTc` \ (const_lie2, sc_binds) ->
-
+ methods_lie = plusLIEs insts_needed_s
+ in
-- Check that we *could* construct the superclass dictionaries,
-- even though we are *actually* going to pass the superclass dicts in;
-- the check ensures that the caller will never have a problem building
-- them.
- tcSimplifyAndCheck (text "inst decl1c")
+ tcAddErrCtxt superClassCtxt (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
inst_tyvars_set -- Local tyvars
inst_decl_dicts -- The instance dictionaries available
sc_dicts -- The superclass dicationaries reqd
- `thenTc_`
- -- Ignore the result; we're only doing
+ ) `thenTc_`
+ -- Ignore the result; we're only doing
-- this to make sure it can be done.
+ -- Ditto method bindings
+ tcAddErrCtxt methodCtxt (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
+ inst_tyvars_set -- Local tyvars
+ avail_insts
+ methods_lie
+ ) `thenTc_`
+
+ -- Now do the simplification again, this time to get the
+ -- bindings; this time we use an enhanced "avails"
+ -- Ignore errors because they come from the *previous* tcSimplifys
+ discardErrsTc (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
+ inst_tyvars_set
+ dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
+ -- get bound by just selecting from this_dict!!
+ (sc_dicts `plusLIE` methods_lie)
+ ) `thenTc` \ (const_lie, lie_binds) ->
+
+
-- Create the result bindings
let
- const_lie = const_lie1 `plusLIE` const_lie2
- lie_binds = op_binds `AndMonoBinds` sc_binds
-
dict_constr = classDataCon clas
con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
--
-- We flag this separately to give a more precise error msg.
--
- (uniqueOf clas == cCallableClassKey && not constructors_visible) ||
- (uniqueOf clas == cReturnableClassKey && not constructors_visible)
+ (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
+ && is_alg_tycon_app && not constructors_visible
= failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
| -- CCALL CHECK (b)
-- DERIVING CHECK
-- It is obviously illegal to have an explicit instance
-- for something that we are also planning to `derive'
- | clas `elem` (tyConDerivings inst_tycon)
+ | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
= failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-- Kind check will have ensured inst_taus is of length 1
- -- ALL TYPE VARIABLES => bad
- | all isTyVarTy inst_taus
- = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
-
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | not opt_GlasgowExts
+ | not opt_GlasgowExts
&& not (length inst_taus == 1 &&
- maybeToBool tyconapp_maybe &&
- not (isSynTyCon inst_tycon) &&
- all isTyVarTy arg_tys &&
+ maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
+ not (isSynTyCon tycon) && -- ...but not a synonym
+ all isTyVarTy arg_tys && -- Applied to type variables
length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
-- This last condition checks that all the type variables are distinct
)
= returnTc ()
where
- tyconapp_maybe = splitTyConApp_maybe first_inst_tau
- Just (inst_tycon, arg_tys) = tyconapp_maybe
(first_inst_tau : _) = inst_taus
- constructors_visible =
- case splitAlgTyConApp_maybe first_inst_tau of
- Just (_,_,[]) -> False
- everything_else -> True
+ -- Stuff for algebraic or -> type
+ maybe_tycon_app = splitTyConApp_maybe first_inst_tau
+ Just (tycon, arg_tys) = maybe_tycon_app
+
+ -- Stuff for an *algebraic* data type
+ alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
+ -- The "Alg" part looks through synonyms
+ is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
+ Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
+
+ constructors_visible = not (null data_cons)
+
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
4 (hsep [text "(Try either importing", ppr inst_ty,
text "non-abstractly or compile using -fno-prune-tydecls ..)"])
-superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")
+methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}
listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
let
err = addShortErrLocLine loc $
- hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
in
writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
returnSST ()
listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
let
warn = addShortWarnLocLine loc $
- hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
in
writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
returnSST ()
-- for unfoldings, and instance decls, only:
tc_hs_type_kind (MonoDictTy class_name tys)
- = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
- tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
- let
- arity = length class_kinds
- n_args = length arg_kinds
- err = arityErr "Class" class_name arity n_args
- in
- checkTc (arity == n_args) err `thenTc_`
- unifyKinds class_kinds arg_kinds `thenTc_`
+ = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
\end{code}
\begin{code}
tcContext :: RenamedContext -> TcM s ThetaType
-tcContext context = tcAddErrCtxt (thetaCtxt context) $
- mapTc tcClassAssertion context
+tcContext context
+ = tcAddErrCtxt (thetaCtxt context) $
+
+ --Someone discovered that @CCallable@ and @CReturnable@
+ -- could be used in contexts such as:
+ -- foo :: CCallable a => a -> PrimIO Int
+ -- Doing this utterly wrecks the whole point of introducing these
+ -- classes so we specifically check that this isn't being done.
+ --
+ -- We *don't* do this check in tcClassAssertion, because that's
+ -- called when checking a HsDictTy, and we don't want to reject
+ -- instance CCallable Int
+ -- etc. Ugh!
+ mapTc check_naughty context `thenTc_`
+
+ mapTc tcClassAssertion context
+
+ where
+ check_naughty (class_name, _)
+ = checkTc (not (uniqueOf class_name `elem` cCallishClassKeys))
+ (naughtyCCallContextErr class_name)
tcClassAssertion (class_name, tys)
- = checkTc (canBeUsedInContext class_name)
- (naughtyCCallContextErr class_name) `thenTc_`
-
- tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
+ = tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) ->
+ -- Check with kind mis-match
+ let
+ arity = length class_kinds
+ n_tys = length ty_kinds
+ err = arityErr "Class" class_name arity n_tys
+ in
+ checkTc (arity == n_tys) err `thenTc_`
unifyKinds class_kinds ty_kinds `thenTc_`
returnTc (clas, tc_tys)
\end{code}
-HACK warning: Someone discovered that @CCallable@ and @CReturnable@
-could be used in contexts such as:
-\begin{verbatim}
-foo :: CCallable a => a -> PrimIO Int
-\end{verbatim}
-
-Doing this utterly wrecks the whole point of introducing these
-classes so we specifically check that this isn't being done.
-
-\begin{code}
-canBeUsedInContext :: Name -> Bool
-canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
-\end{code}
Type variables, with knot tying!
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+import Maybes ( maybeToBool )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
import Id ( GenId, idType, Id )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import PprType ( GenType, GenTyVar )
import Type ( splitFunTys, splitRhoTy,
- splitFunTy_maybe,
+ splitFunTy_maybe, splitAlgTyConApp_maybe,
Type, GenType
)
import TyVar ( GenTyVar )
:: SDoc
-> TopLevelFlag
-> TcTyVarSet s -- ``Local'' type variables
+ -- ASSERT: this tyvar set is already zonked
-> LIE s -- Wanted
-> TcM s (LIE s, -- Free
TcDictBinds s, -- Bindings
LIE s) -- Remaining wanteds; no dups
-tcSimplify str top_lvl local_tvs wanteds
- = tcSimpl str top_lvl local_tvs Nothing wanteds
+tcSimplify str top_lvl local_tvs wanted_lie
+ = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
+
+ -- Check for non-generalisable insts
+ let
+ cant_generalise = filter (not . instCanBeGeneralised) irreds
+ in
+ checkTc (null cant_generalise)
+ (genCantGenErr cant_generalise) `thenTc_`
+
+ -- Finished
+ returnTc (mkLIE frees, binds, mkLIE irreds)
+ where
+ wanteds = bagToList wanted_lie
+
+ try_me inst
+ -- Does not constrain a local tyvar
+ | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ = -- if is_top_level then
+ -- FreeIfTautological -- Special case for inference on
+ -- -- top-level defns
+ -- else
+ Free
+
+ -- We're infering (not checking) the type, and
+ -- the inst constrains a local type variable
+ | isDict inst = DontReduce -- Dicts
+ | otherwise = ReduceMe AddToIrreds -- Lits and Methods
\end{code}
@tcSimplifyAndCheck@ is similar to the above, except that it checks
\begin{code}
tcSimplifyAndCheck
:: SDoc
- -> TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
- -> LIE s -- Given
+ -> TcTyVarSet s -- ``Local'' type variables
+ -- ASSERT: this tyvar set is already zonked
+ -> LIE s -- Given; constrain only local tyvars
-> LIE s -- Wanted
-> TcM s (LIE s, -- Free
TcDictBinds s) -- Bindings
-tcSimplifyAndCheck str local_tvs givens wanteds
- = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) ->
- ASSERT( isEmptyBag new_wanteds )
- returnTc (free_insts, binds)
- where
- top_lvl = error "tcSimplifyAndCheck" -- Never needed
-\end{code}
-
-\begin{code}
-tcSimpl :: SDoc
- -> TopLevelFlag
- -> TcTyVarSet s -- ``Local'' type variables
- -- ASSERT: this tyvar set is already zonked
- -> Maybe (LIE s) -- Given; these constrain only local tyvars
- -- Nothing => just simplify
- -- Just g => check that g entails wanteds
- -> LIE s -- Wanted
- -> TcM s (LIE s, -- Free
- TcMonoBinds s, -- Bindings
- LIE s) -- Remaining wanteds; no dups
-
-tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie
- = -- ASSSERT: local_tvs are already zonked
- reduceContext str try_me
- givens
- (bagToList wanted_lie) `thenTc` \ (binds, frees, irreds) ->
+tcSimplifyAndCheck str local_tvs given_lie wanted_lie
+ = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
- -- Check for non-generalisable insts
- let
- cant_generalise = filter (not . instCanBeGeneralised) irreds
- in
- checkTc (null cant_generalise)
- (genCantGenErr cant_generalise) `thenTc_`
+ -- Complain about any irreducible ones
+ mapNF_Tc complain irreds `thenNF_Tc_`
- -- Finished
- returnTc (mkLIE frees, binds, mkLIE irreds)
+ -- Done
+ returnTc (mkLIE frees, binds)
where
- givens = case maybe_given_lie of
- Just given_lie -> bagToList given_lie
- Nothing -> []
-
- checking_against_signature = maybeToBool maybe_given_lie
- is_top_level = case top_lvl of { TopLevel -> True; other -> False }
+ givens = bagToList given_lie
+ wanteds = bagToList wanted_lie
try_me inst
-- Does not constrain a local tyvar
- | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs)
- = -- if not checking_against_signature && is_top_level then
- -- FreeIfTautological -- Special case for inference on
- -- -- top-level defns
- -- else
-
- Free
+ | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ = Free
-- When checking against a given signature we always reduce
-- until we find a match against something given, or can't reduce
- | checking_against_signature
- = ReduceMe CarryOn
-
- -- So we're infering (not checking) the type, and
- -- the inst constrains a local type variable
| otherwise
- = if isDict inst then
- DontReduce -- Dicts
- else
- ReduceMe CarryOn -- Lits and Methods
+ = ReduceMe AddToIrreds
- where
- inst_tyvars = tyVarsOfInst inst
+ complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
+ addNoInstanceErr str givens dict
\end{code}
-
%************************************************************************
%* *
\subsection{Data types for the reduction mechanism}
\begin{code}
data WhatToDo
- = ReduceMe -- Reduce this
+ = ReduceMe -- Try to reduce this
NoInstanceAction -- What to do if there's no such instance
| DontReduce -- Return as irreducible
-- if not, return as irreducible
data NoInstanceAction
- = CarryOn -- Produce an error message, but keep on with next inst
-
- | Stop -- Produce an error message and stop reduction
+ = Stop -- Fail; no error message
+ -- (Only used when tautology checking.)
| AddToIrreds -- Just add the inst to the irreductible ones; don't
-- produce an error message of any kind.
- -- It might be quite legitimate
- -- such as (Eq a)!
+ -- It might be quite legitimate such as (Eq a)!
\end{code}
reduceContext :: SDoc -> (Inst s -> WhatToDo)
-> [Inst s] -- Given
-> [Inst s] -- Wanted
- -> TcM s (TcDictBinds s, [Inst s], [Inst s])
+ -> TcM s (TcDictBinds s,
+ [Inst s], -- Free
+ [Inst s]) -- Irreducible
reduceContext str try_me givens wanteds
= -- Zonking first
NoInstance -> -- No such instance!
-- Decide what to do based on the no_instance_action requested
case no_instance_action of
- Stop -> -- Fail
- addNoInstanceErr wanted `thenNF_Tc_`
- failTc
-
- CarryOn -> -- Carry on.
- -- Add the bad guy to the avails to suppress similar
- -- messages from other insts in wanteds
- addNoInstanceErr wanted `thenNF_Tc_`
- addGiven avails wanted `thenNF_Tc` \ avails' ->
- reduce try_me wanteds (avails', frees, irreds) -- Carry on
-
- AddToIrreds -> -- Add the offending insts to the irreds
- add_to_irreds
-
-
+ Stop -> failTc -- Fail
+ AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
-- It's free and this isn't a top-level binding, so just chuck it upstairs
| case try_me_result of { Free -> True; _ -> False }
else
mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
failTc
-
-addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts)
\end{code}
local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them
-- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster
- try_me inst | isMethodFor local_id_set inst = ReduceMe CarryOn
+ try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds
| otherwise = Free
\end{code}
\begin{code}
tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
-tcSimplifyTop wanteds
- = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds) `thenTc` \ (binds1, frees, irreds) ->
+tcSimplifyTop wanted_lie
+ = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
ASSERT( null frees )
let
returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
where
- try_me inst = ReduceMe AddToIrreds
+ wanteds = bagToList wanted_lie
+ try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
- complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d
+ complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
| otherwise = addAmbigErr [d]
get_tv d = case getDictClassTys d of
returnTc EmptyMonoBinds
where
- try_me inst = ReduceMe CarryOn
+ try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
\end{code}
addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
nest 4 (pprInstsInFull dicts)])
-addNoInstanceErr dict
+-- Used for top-level irreducibles
+addTopInstanceErr dict
= tcAddSrcLoc (instLoc dict) $
- tcAddErrCtxt (pprOrigin dict) $
- addErrTc (noDictInstanceErr clas tys)
+ addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict),
+ nest 4 $ parens $ pprOrigin dict])
+
+addNoInstanceErr str givens dict
+ = tcAddSrcLoc (instLoc dict) $
+ addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict),
+ nest 4 $ parens $ pprOrigin dict],
+ nest 4 $ ptext SLIT("from the context") <+> pprInsts givens]
+ $$
+ ptext SLIT("Probable cause:") <+>
+ vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str,
+ if all_tyvars then empty else
+ ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)]
+ )
where
- (clas, tys) = getDictClassTys dict
+ all_tyvars = all isTyVarTy tys
+ (_, tys) = getDictClassTys dict
-noDictInstanceErr clas tys
- = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys)
-
-reduceSigCtxt lie
- = sep [ptext SLIT("When matching against a type signature with context"),
- nest 4 (quotes (pprInsts (bagToList lie)))
- ]
+-- Used for the ...Thetas variants; all top level
+addNoInstErr (c,ts)
+ = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
\end{code}
-
-
where
bind_fn = inst_sig_tyvar -- Note: inst_sig_tyvar, not inst_tyvar
-- I don't think that can lead to strange error messages
+ -- of the form can't match (T a) against (T a)
+ -- See notes with inst_tyvar
+
occ_fn env tyvar = case lookupTyVarEnv env tyvar of
Just ty -> returnNF_Tc ty
Nothing -> panic "tcInstType:2"-- (vcat [ppr ty_to_inst,
-> Subst
-> Maybe Subst
+uTysX (SynTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
uTysX ty1 (SynTy _ ty2) k subst = uTysX ty1 ty2 k subst
-- Variables; go for uVar
mkSynTy, isSynTy,
- mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy,
+ mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
+ applyTy, applyTys,
TauType, RhoType, SigmaType, ThetaType,
isTauTy,
import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
import Unique -- quite a few *Keys
-import Util ( thenCmp, panic )
+import Util ( thenCmp, panic, assertPanic )
\end{code}
splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty
\end{code}
-y"Dictionary" types are just ordinary data types, but you can
+"Dictionary" types are just ordinary data types, but you can
tell from the type constructor whether it's a dictionary or not.
\begin{code}
applyTy (SynTy _ fun) arg = applyTy fun arg
applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
applyTy other arg = panic "applyTy"
+
+applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
+applyTys fun_ty arg_tys
+ = go [] fun_ty arg_tys
+ where
+ go env ty [] = instantiateTy (mkTyVarEnv env) ty
+ go env (SynTy _ fun) args = go env fun args
+ go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
+ go env other args = panic "applyTys"
\end{code}
projects / ghc-hetmet.git / commitdiff