%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: Costs.lhs,v 1.26 2000/09/27 14:03:12 simonpj Exp $
+% $Id: Costs.lhs,v 1.27 2000/10/24 07:35:00 simonpj Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes
-errorCosts = Cost (-1, -1, -1, -1, -1) -- just for debugging
-
-oneArithm = Cost (1, 0, 0, 0, 0) :: CostRes
instance Eq CostRes where
(==) t1 t2 = i && b && l && s && f
]
-abs_costs = nullCosts -- NB: This is normal STG code with costs already
- -- included; no need to add costs again.
-
umul_costs = Cost (21,4,0,0,0) -- due to spy counts
rem_costs = Cost (30,15,0,0,0) -- due to spy counts
div_costs = Cost (30,15,0,0,0) -- due to spy counts
bogusVersion :: Version -- Shouldn't look at these
bogusVersion = error "bogusVersion"
-bumpVersion :: Version -> Version
-bumpVersion v = v+1
+bumpVersion :: Bool -> Version -> Version
+-- Bump if the predicate (typically equality between old and new) is false
+bumpVersion False v = v+1
+bumpVersion True v = v+1
initialVersion :: Version
initialVersion = 1
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.14 2000/01/14 11:45:21 hwloidl Exp $
+% $Id: CgStackery.lhs,v 1.15 2000/10/24 07:35:00 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
import AbsCSyn
import CgUsages ( getRealSp )
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import Panic ( panic )
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
HsIdInfo(..),
- IfaceSig(..),
+ IfaceSig(..), ifaceSigName,
eq_ufExpr, eq_ufBinders, pprUfExpr,
import IdInfo ( ArityInfo, InlinePragInfo,
pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
)
-import RdrName ( RdrName )
-import Name ( toRdrName )
+import Name ( Name, getName )
import CoreSyn
import CostCentre ( pprCostCentreCore )
import PrimOp ( PrimOp(CCallOp) )
%************************************************************************
\begin{code}
-toUfExpr :: CoreExpr -> UfExpr RdrName
+toUfExpr :: CoreExpr -> UfExpr Name
toUfExpr (Var v) = toUfVar v
toUfExpr (Lit l) = case maybeLitLit l of
Just (s,ty) -> UfLitLit s (toHsType ty)
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
-toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
+toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
---------------------
-toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
+toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
---------------------
-toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
- | otherwise = UfDataAlt (toRdrName dc)
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
+ | otherwise = UfDataAlt (getName dc)
where
tc = dataConTyCon dc
toUfCon DEFAULT = UfDefault
---------------------
-toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x))
- | otherwise = UfTyBinder (toRdrName x) (varType x)
+toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
+ | otherwise = UfTyBinder (getName x) (varType x)
---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
= case isDataConId_maybe v of
-- We convert the *worker* for tuples into UfTuples
- Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
+ Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
where
val_args = dropWhile isTypeArg as
saturated = length val_args == idArity v
toUfVar v = case isPrimOpId_maybe v of
-- Ccalls has special syntax
Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
- other -> UfVar (toRdrName v)
+ other -> UfVar (getName v)
\end{code}
instance (Outputable name) => Outputable (IfaceSig name) where
ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+
+ifaceSigName :: IfaceSig name -> name
+ifaceSigName (IfaceSig name _ _ _) = name
\end{code}
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
- IfaceSig(..), SpecDataSig(..),
+ IfaceSig(..),
DeprecDecl(..), DeprecTxt,
- hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
- toClassDeclNameList,
- fromClassDeclNameList
-
+ hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
+ isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
+ mkClassDeclSysNames,
+ getClassDeclSysNames
) where
#include "HsVersions.h"
-- friends:
import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
import HsExpr ( HsExpr )
-import HsPragmas ( DataPragmas, ClassPragmas )
-import HsImpExp ( IE(..) )
import HsTypes
import PprCore ( pprCoreRule )
-import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr )
+import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), ifaceSigName,
+ eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr
+ )
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
-import Name ( toRdrName )
+import Name ( getName )
-- others:
import FunDeps ( pprFundeps )
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (SigD decl) = ifaceSigName decl
hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#endif
-tyClDeclName :: TyClDecl name pat -> name
-tyClDeclName (TyData _ _ name _ _ _ _ _ _ _ _) = name
-tyClDeclName (TySynonym name _ _ _) = name
-tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ ) = name
-
instDeclName :: InstDecl name pat -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
-- expect...
- (DataPragmas name)
SrcLoc
name -- generic converter functions
name -- generic converter functions
[FunDep name] -- functional dependencies
[Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
- (ClassPragmas name)
- [name] -- The names of the tycon, datacon
- -- wrapper, datacon worker,
- -- and superclass selectors for this
- -- class (the first 3 are at the front
- -- of the list in this order)
- -- These are filled in as the
- -- ClassDecl is made.
+ (ClassDeclSysNames name)
SrcLoc
--- Put type signatures in and explain further!!
- -- The names of the tycon, datacon
- -- wrapper, datacon worker,
- -- and superclass selectors for this
- -- class (the first 3 are at the front
- -- of the list in this order)
- -- These are filled in as the
-toClassDeclNameList (a,b,c,ds) = a:b:c:ds
-fromClassDeclNameList (a:b:c:ds) = (a,b,c,ds)
+tyClDeclName :: TyClDecl name pat -> name
+tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
+tyClDeclName (TySynonym name _ _ _) = name
+tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
+
+
+tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
+-- Returns all the binding names of the decl, along with their SrcLocs
+-- The first one is guaranteed to be the name of the decl
+-- For record fields, the first one counts as the SrcLoc
+-- We use the equality to filter out duplicate field names
+
+tyClDeclNames (TySynonym name _ _ loc)
+ = [(name,loc)]
+
+tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc)
+ = (name,loc) : [(name,loc) | ClassOpSig n _ _ loc <- sigs]
+
+tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
+ = (name,loc) : conDeclsNames cons
+
+
+type ClassDeclSysNames name = [name]
+ -- [tycon, datacon wrapper, datacon worker,
+ -- superclass selector 1, ..., superclass selector n]
+ -- They are kept in a list rather than a tuple to make the
+ -- renamer easier.
+
+mkClassDeclSysNames :: (name, name, name, [name]) -> [name]
+getClassDeclSysNames :: [name] -> (name, name, name, [name])
+mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
+getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
+\end{code}
+
+
+\begin{code}
+isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+
+isSynDecl (TySynonym _ _ _ _) = True
+isSynDecl other = False
+isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
+isDataDecl other = False
+
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
+isClassDecl other = False
+\end{code}
+
+\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
- (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _ _)
- (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _ _)
+ (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
+ (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
= n1 == n2 &&
nd1 == nd2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
- (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ )
- (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ )
+ (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ )
+ (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ )
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
eq_hsContext env cxt1 cxt2 &&
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
- = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData DataType _ _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData NewType _ _ _ _ _ _ _ _ _ _ <- decls],
+ = (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
-
-isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
-
-isSynDecl (TySynonym _ _ _ _) = True
-isSynDecl other = False
-
-isDataDecl (TyData _ _ _ _ _ _ _ _ _ _ _) = True
-isDataDecl other = False
-
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ ) = True
-isClassDecl other = False
\end{code}
\begin{code}
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
- ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
+ ppr (TyData new_or_data context tycon tyvars condecls ncons
+ derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
= pp_tydecl
(ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
(pp_condecls condecls ncons)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
- ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ src_loc)
+ ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc)
| null sigs -- No "where" part
= top_matter
pp_methods = getPprStyle $ \ sty ->
if ifaceStyle sty then empty else ppr methods
-
pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
])
\end{code}
-A type for recording what types a datatype should be specialised to.
-It's called a ``Sig'' because it's sort of like a ``type signature''
-for an datatype declaration.
-
-\begin{code}
-data SpecDataSig name
- = SpecDataSig name -- tycon to specialise
- (HsType name)
- SrcLoc
-
-instance (Outputable name)
- => Outputable (SpecDataSig name) where
-
- ppr (SpecDataSig tycon ty _)
- = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
-\end{code}
%************************************************************************
%* *
| RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
+\end{code}
+
+\begin{code}
+conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)]
+ -- See tyClDeclNames for what this does
+ -- The function is boringly complicated because of the records
+ -- And since we only have equality, we have to be a little careful
+conDeclsNames cons
+ = snd (foldl do_one ([], []) cons)
+ where
+ do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
+ = do_details ((name,loc):acc) details
+ where
+ do_details acc (RecCon flds) = foldl do_fld (flds_seen, acc) flds
+ do_details acc other = (flds_seen, acc)
+
+ do_fld acc (flds, _) = foldl do_fld1 acc flds
+ do_fld1 (flds_seen, acc) fld
+ | fld `elem` flds_seen = (flds_seen,acc)
+ | otherwise = (fld:flds_seen, (fld,loc):acc)
+\end{code}
+
+\begin{code}
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
(ConDecl n2 _ tvs2 cxt2 cds2 _)
= n1 == n2 &&
eq_ConDetails env _ _ = False
eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
-
+\end{code}
+\begin{code}
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
toHsRule id (Rule name bndrs args rhs)
- = IfaceRule name (map toUfBndr bndrs) (toRdrName id)
+ = IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
- = IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc
+ = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
%* *
%************************************************************************
-We use exported entities for things to deprecate. Cunning trick (hack?):
-`IEModuleContents undefined' is used for module deprecation.
+We use exported entities for things to deprecate.
\begin{code}
-data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc
+data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
instance Outputable name => Outputable (DeprecDecl name) where
- ppr (Deprecation (IEModuleContents _) txt _)
- = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
- ppr (Deprecation thing txt _)
+ ppr (Deprecation thing txt _)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code}
%************************************************************************
See also: @Sig@ (``signatures'') which is where user-supplied pragmas
-for values show up; ditto @SpecInstSig@ (for instances) and
-@SpecDataSig@ (for data types).
+for values show up; ditto @SpecInstSig@ (for instances)
\begin{code}
module HsPragmas where
#include "HsVersions.h"
-import IdInfo
import Outputable
\end{code}
All the pragma stuff has changed. Here are some placeholders!
-\begin{code}
-data GenPragmas name = NoGenPragmas
-data DataPragmas name = NoDataPragmas
-data InstancePragmas name = NoInstancePragmas
-data ClassOpPragmas name = NoClassOpPragmas
-data ClassPragmas name = NoClassPragmas
-
-noClassPragmas = NoClassPragmas
-isNoClassPragmas NoClassPragmas = True
-
-noDataPragmas = NoDataPragmas
-isNoDataPragmas NoDataPragmas = True
-
-noGenPragmas = NoGenPragmas
-isNoGenPragmas NoGenPragmas = True
-
-noInstancePragmas = NoInstancePragmas
-isNoInstancePragmas NoInstancePragmas = True
-noClassOpPragmas = NoClassOpPragmas
-isNoClassOpPragmas NoClassOpPragmas = True
-
-instance Outputable name => Outputable (ClassPragmas name) where
- ppr NoClassPragmas = empty
-
-instance Outputable name => Outputable (ClassOpPragmas name) where
- ppr NoClassOpPragmas = empty
-
-instance Outputable name => Outputable (InstancePragmas name) where
- ppr NoInstancePragmas = empty
-
-instance Outputable name => Outputable (GenPragmas name) where
- ppr NoGenPragmas = empty
-\end{code}
\begin{code}
module HsSyn (
- -- NB: don't reexport HsCore or HsPragmas;
+ -- NB: don't reexport HsCore
-- this module tells about "real Haskell"
module HsSyn,
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity )
import RdrName ( RdrName )
-import Name ( toRdrName )
+import Name ( Name, getName )
import OccName ( NameSpace )
import Var ( TyVar, tyVarKind )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
expresses overloaded functions using the '=>' context part of a HsForAllTy.
\begin{code}
-toHsTyVar :: TyVar -> HsTyVarBndr RdrName
-toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv)
+toHsTyVar :: TyVar -> HsTyVarBndr Name
+toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv)
toHsTyVars tvs = map toHsTyVar tvs
-toHsType :: Type -> HsType RdrName
+toHsType :: Type -> HsType Name
toHsType ty = toHsType' (unUsgTy ty)
-- For now we just discard the usage
-toHsType' :: Type -> HsType RdrName
+toHsType' :: Type -> HsType Name
-- Called after the usage is stripped off
-- This function knows the representation of types
-toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv)
+toHsType' (TyVarTy tv) = HsTyVar (getName tv)
toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| not saturated = generic_case
- | isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
| otherwise = generic_case
where
- generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
+ generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
tys' = map toHsType tys
saturated = length tys == tyConArity tc
(toHsType tau)
-toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty)
+toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
+toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty)
-toHsContext :: ClassContext -> HsContext RdrName
-toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt]
+toHsContext :: ClassContext -> HsContext Name
+toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
-toHsFDs :: [FunDep TyVar] -> [FunDep RdrName]
-toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds]
+toHsFDs :: [FunDep TyVar] -> [FunDep Name]
+toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
\end{code}
, nameModule )
import PrimRep ( PrimRep(..) )
import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
-import qualified TypeRep
import qualified Type
import qualified CoreSyn
import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
- Bind(..), Alt, AltCon(..), collectBinders, isValArg
+ Bind(..), AltCon(..), collectBinders, isValArg
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import qualified CoreUtils
add env (name,rule) = extendNameEnv_C add1 env name [rule]
add1 rules _ = rule : rules
\end{code}
+
+
+
+\begin{code}
+writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids tidy_binds tidy_orphan_rules
+ =
+ if isNothing opt_HiDir && isNothing opt_HiFile
+ then return () -- not producing any .hi file
+ else
+
+ let
+ hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
+ filename = case opt_HiFile of {
+ Just f -> f;
+ Nothing ->
+ case opt_HiDir of {
+ Just dir -> dir ++ '/':moduleUserString this_mod
+ ++ '.':hi_suf;
+ Nothing -> panic "writeIface"
+ }}
+ in
+
+ do maybe_final_iface <- checkIface old_iface full_new_iface
+ case maybe_final_iface of {
+ Nothing -> when opt_D_dump_rn_trace $
+ putStrLn "Interface file unchanged" ; -- No need to update .hi file
+
+ Just final_iface ->
+
+ do let mod_vers_unchanged = case old_iface of
+ Just iface -> pi_vers iface == pi_vers final_iface
+ Nothing -> False
+ when (mod_vers_unchanged && opt_D_dump_rn_trace) $
+ putStrLn "Module version unchanged, but usages differ; hence need new hi file"
+
+ if_hdl <- openFile filename WriteMode
+ printForIface if_hdl (pprIface final_iface)
+ hClose if_hdl
+ }
+ where
+ full_new_iface = completeIface new_iface local_tycons local_classes
+ inst_info final_ids tidy_binds
+ tidy_orphan_rules
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Printing the interface}
+%* *
+%************************************************************************
+
+\begin{code}
+pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
+ pi_usages = usages, pi_exports = exports,
+ pi_fixity = (fix_vers, fixities),
+ pi_insts = insts, pi_decls = decls,
+ pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
+ = vcat [ ptext SLIT("__interface")
+ <+> doubleQuotes (ptext opt_InPackage)
+ <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
+ <+> (if orphan then char '!' else empty)
+ <+> int opt_HiVersion
+ <+> ptext SLIT("where")
+ , vcat (map pprExport exports)
+ , vcat (map pprUsage usages)
+ , pprFixities fixities
+ , vcat [ppr i <+> semi | i <- insts]
+ , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
+ , pprRules rules
+ , pprDeprecs deprecs
+ ]
+ where
+ ppr_vers v | v == initialVersion = empty
+ | otherwise = int v
+ pp_sub_vers
+ | fix_vers == initialVersion && rule_vers == initialVersion = empty
+ | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
+\end{code}
+
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+
+\begin{code}
+pprExport :: ExportItem -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
+ where
+ upp_avail :: RdrAvailInfo -> SDoc
+ upp_avail (Avail name) = pprOccName name
+ upp_avail (AvailTC name []) = empty
+ upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+ where
+ bang | name `elem` ns = empty
+ | otherwise = char '|'
+ ns' = filter (/= name) ns
+
+ upp_export [] = empty
+ upp_export names = braces (hsep (map pprOccName names))
+\end{code}
+
+
+\begin{code}
+pprUsage :: ImportVersion OccName -> SDoc
+pprUsage (m, has_orphans, is_boot, whats_imported)
+ = hsep [ptext SLIT("import"), pprModuleName m,
+ pp_orphan, pp_boot,
+ upp_import_versions whats_imported
+ ] <> semi
+ where
+ pp_orphan | has_orphans = char '!'
+ | otherwise = empty
+ pp_boot | is_boot = char '@'
+ | otherwise = empty
+
+ -- Importing the whole module is indicated by an empty list
+ upp_import_versions NothingAtAll = empty
+ upp_import_versions (Everything v) = dcolon <+> int v
+ upp_import_versions (Specifically vm vf vr nvs)
+ = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
+\end{code}
+
+
+\begin{code}
+pprFixities [] = empty
+pprFixities fixes = hsep (map ppr fixes) <> semi
+
+pprRules [] = empty
+pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
+
+pprDeprecs [] = empty
+pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
+ where
+ guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
+ | Deprecation ie txt _ <- deps ]
+\end{code}
+
+
#include "HsVersions.h"
-import IO ( hPutStr, stderr )
import HsSyn
import Outputable
import Char ( isSpace )
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _ _)
+ data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _)
= (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ )
+ class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ )
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
HomeSymbolTable, PackageSymbolTable,
HomeIfaceTable, PackageIfaceTable,
- VersionInfo(..),
+ IfaceDecls(..),
+
+ VersionInfo(..), initialVersionInfo,
TyThing(..), groupTyThings,
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv )
import VarSet ( TyVarSet )
-import VarEnv ( IdEnv, emptyVarEnv )
+import VarEnv ( emptyVarEnv )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
-import BasicTypes ( Version, Fixity )
+import BasicTypes ( Version, initialVersion, Fixity )
import HsSyn ( DeprecTxt )
import RdrHsSyn ( RdrNameHsDecl )
-import RnHsSyn ( RenamedHsDecl )
+import RnHsSyn ( RenamedTyClDecl, RenamedIfaceSig, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( CoreRule )
import Type ( Type )
mi_version :: VersionInfo, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
- mi_usages :: [ImportVersion Name], -- Usages
+ mi_usages :: [ImportVersion Name], -- Usages; kept sorted
- mi_exports :: Avails, -- What it exports; kept sorted by (mod,occ),
+ mi_exports :: Avails, -- What it exports
+ -- Kept sorted by (mod,occ),
-- to make version comparisons easier
mi_globals :: GlobalRdrEnv, -- Its top level environment
mi_fixities :: NameEnv Fixity, -- Fixities
mi_deprecs :: Deprecations, -- Deprecations
- mi_decls :: [RenamedHsDecl] -- types, classes
- -- inst decls, rules, iface sigs
+ mi_decls :: IfaceDecls -- The RnDecls form of ModDetails
}
+data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
+ dcl_sigs :: [RenamedIfaceSig], -- Sorted
+ dcl_rules :: [RenamedRuleDecl], -- Sorted
+ dcl_insts :: [RenamedInstDecl] } -- Unsorted
+
-- typechecker should only look at this, not ModIface
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
-- the parent class/tycon changes
}
+initialVersionInfo :: VersionInfo
+initialVersionInfo = VersionInfo { vers_module = initialVersion,
+ vers_exports = initialVersion,
+ vers_rules = initialVersion,
+ vers_decls = emptyNameEnv }
+
data Deprecations = NoDeprecs
| DeprecAll DeprecTxt -- Whole module deprecated
| DeprecSome (NameEnv DeprecTxt) -- Some things deprecated
\section[MkIface]{Print an interface for a module}
\begin{code}
-module MkIface ( writeIface ) where
+module MkIface ( completeIface ) where
#include "HsVersions.h"
-import IO ( openFile, hClose, IOMode(..) )
-
import HsSyn
-import HsCore ( HsIdInfo(..), toUfExpr )
-import RdrHsSyn ( RdrNameRuleDecl, mkTyData )
-import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
+import HsCore ( HsIdInfo(..), toUfExpr, ifaceSigName )
import HsTypes ( toHsTyVars )
import BasicTypes ( Fixity(..), NewOrData(..),
- Version, bumpVersion, initialVersion, isLoopBreaker
+ Version, bumpVersion, isLoopBreaker
)
import RnMonad
-
-import InstEnv ( InstInfo(..) )
+import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedIfaceSig )
+import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
+ TyThing(..), DFunId )
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
idSpecialisation
)
-import Var ( isId, varName )
+import Var ( isId )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
-import Module ( pprModuleName, moduleUserString )
-import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
- Name, NamedThing(..)
+import Name ( isLocallyDefined, getName, nameModule,
+ Name, NamedThing(..),
+ plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
)
-import OccName ( OccName, pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
)
import Class ( classExtraBigSig, DefMeth(..) )
import FieldLabel ( fieldLabelType )
-import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
- deNoteType, classesToPreds
- )
+import Type ( splitSigmaTy, tidyTopType, deNoteType )
import Rules ( ProtoCoreRule(..) )
import Bag ( bagToList )
import UniqFM ( lookupUFM, listToUFM )
-import Util ( sortLt )
import SrcLoc ( noSrcLoc )
import Bag
import Outputable
-import ErrUtils ( dumpIfSet )
-import Maybe ( isNothing )
import List ( partition )
-import Monad ( when )
\end{code}
%************************************************************************
\begin{code}
-writeIface this_mod old_iface new_iface
- local_tycons local_classes inst_info
- final_ids tidy_binds tidy_orphan_rules
- =
- if isNothing opt_HiDir && isNothing opt_HiFile
- then return () -- not producing any .hi file
- else
-
- let
- hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
- filename = case opt_HiFile of {
- Just f -> f;
- Nothing ->
- case opt_HiDir of {
- Just dir -> dir ++ '/':moduleUserString this_mod
- ++ '.':hi_suf;
- Nothing -> panic "writeIface"
- }}
- in
-
- do maybe_final_iface <- checkIface old_iface full_new_iface
- case maybe_final_iface of {
- Nothing -> when opt_D_dump_rn_trace $
- putStrLn "Interface file unchanged" ; -- No need to update .hi file
-
- Just final_iface ->
-
- do let mod_vers_unchanged = case old_iface of
- Just iface -> pi_vers iface == pi_vers final_iface
- Nothing -> False
- when (mod_vers_unchanged && opt_D_dump_rn_trace) $
- putStrLn "Module version unchanged, but usages differ; hence need new hi file"
-
- if_hdl <- openFile filename WriteMode
- printForIface if_hdl (pprIface final_iface)
- hClose if_hdl
- }
- where
- full_new_iface = completeIface new_iface local_tycons local_classes
- inst_info final_ids tidy_binds
- tidy_orphan_rules
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Checking if the new interface is up to date
-%* *
-%************************************************************************
-
-\begin{code}
-checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
- -> ParsedIface -- The new interface; but with all version numbers = 1
- -> IO (Maybe ParsedIface) -- Nothing => no change; no need to write new Iface
- -- Just pi => Here is the new interface to write
- -- with correct version numbers
- -- The I/O part is just so it can print differences
-
--- NB: the fixities, declarations, rules are all assumed
--- to be sorted by increasing order of hsDeclName, so that
--- we can compare for equality
-
-checkIface Nothing new_iface
--- No old interface, so definitely write a new one!
- = return (Just new_iface)
-
-checkIface (Just iface) new_iface
- | no_output_change && no_usage_change
- = return Nothing
-
- | otherwise -- Add updated version numbers
- = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
- return (Just final_iface )}
-
- where
- final_iface = new_iface { pi_vers = new_mod_vers,
- pi_fixity = (new_fixity_vers, new_fixities),
- pi_rules = (new_rules_vers, new_rules),
- pi_decls = final_decls }
-
- no_usage_change = pi_usages iface == pi_usages new_iface
-
- no_output_change = no_decl_changed &&
- new_fixity_vers == fixity_vers &&
- new_rules_vers == rules_vers &&
- no_export_change
+completeIface :: Maybe ModIface -- The old interface, if we have it
+ -> ModIface -- The new one, minus the decls and versions
- no_export_change = pi_exports iface == pi_exports new_iface
+ -> ModDetails -- The ModDetails for this module
+ -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
+ -- code generator; they have authoritative arity info
+ -> [ProtoCoreRule] -- Tidy orphan rules
- new_mod_vers | no_output_change = mod_vers
- | otherwise = bumpVersion mod_vers
+ -> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions
+ -- The SDoc is a debug document giving differences
+ -- Nothing => no change
- mod_vers = pi_vers iface
-
- (fixity_vers, fixities) = pi_fixity iface
- (_, new_fixities) = pi_fixity new_iface
- new_fixity_vers | fixities == new_fixities = fixity_vers
- | otherwise = bumpVersion fixity_vers
-
- (rules_vers, rules) = pi_rules iface
- (_, new_rules) = pi_rules new_iface
- new_rules_vers | rules == new_rules = rules_vers
- | otherwise = bumpVersion rules_vers
+ -- NB: 'Nothing' means that even the usages havn't changed, so there's no
+ -- need to write a new interface file. But even if the usages have
+ -- changed, the module version may not have.
+ --
+ -- The IO in the type is solely for debug output
+ -- In particular, dumping a record of what has changed
+completeIface maybe_old_iface new_iface mod_details
+ tidy_binds final_ids tidy_orphan_rules
+ = let
+ new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
+ in
+ addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
+
+declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
+declsFromDetails details tidy_binds final_ids tidy_orphan_rules
+ = IfaceDecls { dcl_tycl = ty_cls_dcls,
+ dcl_insts = inst_dcls,
+ dcl_sigs = bagToList val_dcls,
+ dcl_rules = rule_dcls }
+ where
+ dfun_ids = md_insts details
+ inst_dcls = map ifaceInstance dfun_ids
+ ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
+
+ (val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
+ final_ids tidy_binds
- (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
+ rule_dcls | opt_OmitInterfacePragmas = []
+ | otherwise = ifaceRules tidy_orphan_rules emitted_ids
- -- Fill in the version number on the new declarations
- -- by looking at the old declarations.
- -- Set the flag if anything changes.
- -- Assumes that the decls are sorted by hsDeclName
- merge_decls ok_so_far pp acc [] [] = (ok_so_far, pp, reverse acc)
- merge_decls ok_so_far pp acc old [] = (False, pp, reverse acc)
- merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
- merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
- = case d_name `compare` nd_name of
- LT -> merge_decls False (pp $$ only_old vd) acc vds (nvd:nvds)
- GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
- EQ | d == nd -> merge_decls ok_so_far pp (vd:acc) vds nvds
- | otherwise -> merge_decls False (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
- where
- d_name = hsDeclName d
- nd_name = hsDeclName nd
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
+ | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
- only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
- only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
- changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
- (ptext SLIT("New:") <+> ppr nd))
\end{code}
-
-
%************************************************************************
%* *
-\subsection{Printing the interface}
+\subsection{Types and classes}
%* *
%************************************************************************
\begin{code}
-pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
- pi_usages = usages, pi_exports = exports,
- pi_fixity = (fix_vers, fixities),
- pi_insts = insts, pi_decls = decls,
- pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
- = vcat [ ptext SLIT("__interface")
- <+> doubleQuotes (ptext opt_InPackage)
- <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
- <+> (if orphan then char '!' else empty)
- <+> int opt_HiVersion
- <+> ptext SLIT("where")
- , vcat (map pprExport exports)
- , vcat (map pprUsage usages)
- , pprFixities fixities
- , vcat [ppr i <+> semi | i <- insts]
- , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
- , pprRules rules
- , pprDeprecs deprecs
- ]
+emitTyCls :: TyThing -> Bool
+emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not
+ -- strictly necessary, and it costs extra time
+emitTyCls (AClass cl) = True
+emitTyCls (AnId _) = False
+
+
+ifaceTyCls :: TyThing -> RenamedTyClDecl
+ifaceTyCls (AClass clas)
+ = ClassDecl (toHsContext sc_theta)
+ (getName clas)
+ (toHsTyVars clas_tyvars)
+ (toHsFDs clas_fds)
+ (map toClassOpSig op_stuff)
+ EmptyMonoBinds
+ [] noSrcLoc
where
- ppr_vers v | v == initialVersion = empty
- | otherwise = int v
- pp_sub_vers
- | fix_vers == initialVersion && rule_vers == initialVersion = empty
- | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
-\end{code}
+ (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
-When printing export lists, we print like this:
- Avail f f
- AvailTC C [C, x, y] C(x,y)
- AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+ toClassOpSig (sel_id, def_meth)
+ = ASSERT(sel_tyvars == clas_tyvars)
+ ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
+ where
+ (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+ def_meth' = case def_meth of
+ NoDefMeth -> NoDefMeth
+ GenDefMeth -> GenDefMeth
+ DefMeth id -> DefMeth (getName id)
-\begin{code}
-pprExport :: ExportItem -> SDoc
-pprExport (mod, items)
- = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
+ifaceTyCls (ATyCon tycon)
+ | isSynTyCon tycon
+ = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
where
- upp_avail :: RdrAvailInfo -> SDoc
- upp_avail (Avail name) = pprOccName name
- upp_avail (AvailTC name []) = empty
- upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
- where
- bang | name `elem` ns = empty
- | otherwise = char '|'
- ns' = filter (/= name) ns
-
- upp_export [] = empty
- upp_export names = braces (hsep (map pprOccName names))
-\end{code}
-
+ (tyvars, ty) = getSynTyConDefn tycon
-\begin{code}
-pprUsage :: ImportVersion OccName -> SDoc
-pprUsage (m, has_orphans, is_boot, whats_imported)
- = hsep [ptext SLIT("import"), pprModuleName m,
- pp_orphan, pp_boot,
- upp_import_versions whats_imported
- ] <> semi
+ifaceTyCls (ATyCon tycon)
+ | isAlgTyCon tycon
+ = TyData new_or_data (toHsContext (tyConTheta tycon))
+ (getName tycon)
+ (toHsTyVars tyvars)
+ (map ifaceConDecl (tyConDataCons tycon))
+ (tyConFamilySize tycon)
+ Nothing noSrcLoc (panic "gen1") (panic "gen2")
where
- pp_orphan | has_orphans = char '!'
- | otherwise = empty
- pp_boot | is_boot = char '@'
- | otherwise = empty
-
- -- Importing the whole module is indicated by an empty list
- upp_import_versions NothingAtAll = empty
- upp_import_versions (Everything v) = dcolon <+> int v
- upp_import_versions (Specifically vm vf vr nvs)
- = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
-\end{code}
+ tyvars = tyConTyVars tycon
+ new_or_data | isNewTyCon tycon = NewType
+ | otherwise = DataType
+ ifaceConDecl data_con
+ = ConDecl (getName data_con) (error "ifaceConDecl")
+ (toHsTyVars ex_tyvars)
+ (toHsContext ex_theta)
+ details noSrcLoc
+ where
+ (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
+ field_labels = dataConFieldLabels data_con
+ strict_marks = dataConStrictMarks data_con
+ details | null field_labels
+ = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
+ VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
-\begin{code}
-pprFixities [] = empty
-pprFixities fixes = hsep (map ppr fixes) <> semi
+ | otherwise
+ = RecCon (zipWith mk_field strict_marks field_labels)
-pprRules [] = empty
-pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
+ mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
+ mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
+ mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
-pprDeprecs [] = empty
-pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
- where
- guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
- | Deprecation ie txt _ <- deps ]
+ mk_field strict_mark field_label
+ = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+
+ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
\end{code}
%************************************************************************
%* *
-\subsection{Completing the new interface}
+\subsection{Instances and rules}
%* *
%************************************************************************
-\begin{code}
-completeIface new_iface local_tycons local_classes
- inst_info final_ids tidy_binds
- tidy_orphan_rules
- = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
- pi_insts = sortLt lt_inst_decl inst_dcls,
- pi_rules = (initialVersion, rule_dcls)
- }
+\begin{code}
+ifaceInstance :: DFunId -> RenamedInstDecl
+ifaceInstance dfun_id
+ = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
where
- all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
- (inst_dcls, inst_ids) = ifaceInstances inst_info
- cls_dcls = map ifaceClass local_classes
-
- ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
-
- (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
- final_ids tidy_binds
-
- rule_dcls | opt_OmitInterfacePragmas = []
- | otherwise = ifaceRules tidy_orphan_rules emitted_ids
-
- orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
- | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
-
-lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
-lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
- -- Even instance decls have names, namely the dfun name
+ tidy_ty = tidyTopType (deNoteType (idType dfun_id))
+ -- The deNoteType is very important. It removes all type
+ -- synonyms from the instance type in interface files.
+ -- That in turn makes sure that when reading in instance decls
+ -- from interface files that the 'gating' mechanism works properly.
+ -- Otherwise you could have
+ -- type Tibble = T Int
+ -- instance Foo Tibble where ...
+ -- and this instance decl wouldn't get imported into a module
+ -- that mentioned T but not Tibble.
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Completion stuff}
-%* *
-%************************************************************************
-
\begin{code}
-ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
+ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
ifaceRules rules emitted
= orphan_rules ++ local_rules
where
-- will have access to them anyway
-- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
- -- from coming out, and to make it work properly we need to add
- all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+ -- from coming out, and to make it work properly we need to add ????
+ -- (put it back in for now)
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- Spit out a rule only if all its lhs free vars are emitted
-- This is a good reason not to do it when we emit the Id itself
]
\end{code}
-\begin{code}
-ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
- -- The IdSet is the needed dfuns
-
-ifaceInstances inst_infos
- = (decls, needed_ids)
- where
- decls = map to_decl togo_insts
- togo_insts = filter is_togo_inst (bagToList inst_infos)
- needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
- is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
-
- -------
- to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
- = let
- -- The deNoteType is very important. It removes all type
- -- synonyms from the instance type in interface files.
- -- That in turn makes sure that when reading in instance decls
- -- from interface files that the 'gating' mechanism works properly.
- -- Otherwise you could have
- -- type Tibble = T Int
- -- instance Foo Tibble where ...
- -- and this instance decl wouldn't get imported into a module
- -- that mentioned T but not Tibble.
- forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
- tidy_ty = tidyTopType forall_ty
- in
- InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
-\end{code}
-
-\begin{code}
-ifaceTyCon :: TyCon -> RdrNameHsDecl
-ifaceTyCon tycon
- | isSynTyCon tycon
- = TyClD (TySynonym (toRdrName tycon)
- (toHsTyVars tyvars) (toHsType ty)
- noSrcLoc)
- where
- (tyvars, ty) = getSynTyConDefn tycon
-
-ifaceTyCon tycon
- | isAlgTyCon tycon
- = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
- (toRdrName tycon)
- (toHsTyVars tyvars)
- (map ifaceConDecl (tyConDataCons tycon))
- (tyConFamilySize tycon)
- Nothing NoDataPragmas noSrcLoc)
- where
- tyvars = tyConTyVars tycon
- new_or_data | isNewTyCon tycon = NewType
- | otherwise = DataType
-
- ifaceConDecl data_con
- = ConDecl (toRdrName data_con) (error "ifaceConDecl")
- (toHsTyVars ex_tyvars)
- (toHsContext ex_theta)
- details noSrcLoc
- where
- (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
- field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
- details
- | null field_labels
- = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
- VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
-
- | otherwise
- = RecCon (zipWith mk_field strict_marks field_labels)
-
- mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
- mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
- mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
-
- mk_field strict_mark field_label
- = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
-
-ifaceTyCon tycon
- = pprPanic "pprIfaceTyDecl" (ppr tycon)
-
-ifaceClass clas
- = TyClD (ClassDecl (toHsContext sc_theta)
- (toRdrName clas)
- (toHsTyVars clas_tyvars)
- (toHsFDs clas_fds)
- (map toClassOpSig op_stuff)
- EmptyMonoBinds NoClassPragmas
- [] noSrcLoc
- )
- where
- bogus = error "ifaceClass"
- (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
-
- toClassOpSig (sel_id, def_meth) =
- ASSERT(sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
- where
- (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
- def_meth' = case def_meth of
- NoDefMeth -> NoDefMeth
- GenDefMeth -> GenDefMeth
- DefMeth id -> DefMeth (toRdrName id)
-\end{code}
-
%************************************************************************
%* *
ifaceBinds :: IdSet -- These Ids are needed already
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
- -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out
+ -> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out
ifaceBinds needed_ids final_ids binds
= go needed_ids (reverse binds) emptyBag emptyVarSet
needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
emitted' = emitted `unionVarSet` new_emitted
- go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet)
go_rec needed pairs
| null decls = (emptyBag, emptyVarSet, emptyVarSet)
| otherwise = (more_decls `unionBags` listToBag decls,
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
- -> (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
+ -> (RenamedIfaceSig, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo is_rec id rhs
- = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), new_needed_ids)
+ = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
where
id_type = idType id
core_idinfo = idInfo id
other -> False
- wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
+ wrkr_hsinfo | has_worker = [HsWorker (getName work_id)]
| otherwise = []
------------ Unfolding --------------
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Checking if the new interface is up to date
+%* *
+%************************************************************************
+
+\begin{code}
+addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi
+ -> ModIface -- The new interface decls
+ -> Maybe (ModIface, SDoc) -- Nothing => no change; no need to write new Iface
+ -- Just mi => Here is the new interface to write
+ -- with correct version numbers
+
+-- NB: the fixities, declarations, rules are all assumed
+-- to be sorted by increasing order of hsDeclName, so that
+-- we can compare for equality
+
+addVersionInfo Nothing new_iface
+-- No old interface, so definitely write a new one!
+ = Just (new_iface, text "No old interface available")
+
+addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
+ mi_decls = old_decls,
+ mi_fixities = old_fixities }))
+ new_iface@(ModIface { mi_decls = new_decls,
+ mi_fixities = new_fixities })
+
+ | no_output_change && no_usage_change
+ = Nothing
+
+ | otherwise -- Add updated version numbers
+ = Just (final_iface, pp_tc_diffs $$ pp_sig_diffs)
+
+ where
+ final_iface = new_iface { mi_version = new_version }
+ new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
+ vers_exports = bumpVersion no_export_change (vers_exports old_version),
+ vers_rules = bumpVersion no_rule_change (vers_rules old_version),
+ vers_decls = sig_vers `plusNameEnv` tc_vers }
+
+ no_output_change = no_sig_change && no_tc_change && no_rule_change && no_export_change
+ no_usage_change = mi_usages old_iface == mi_usages new_iface
+
+ no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted
+ no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto
+
+ -- Fill in the version number on the new declarations by looking at the old declarations.
+ -- Set the flag if anything changes.
+ -- Assumes that the decls are sorted by hsDeclName.
+ old_vers_decls = vers_decls old_version
+ (no_sig_change, pp_sig_diffs, sig_vers) = diffDecls ifaceSigName eq_sig old_vers_decls
+ (dcl_sigs old_decls) (dcl_sigs new_decls)
+ (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls tyClDeclName eq_tc old_vers_decls
+ (dcl_tycl old_decls) (dcl_tycl new_decls)
+
+ -- When seeing if two decls are the same,
+ -- remember to check whether any relevant fixity has changed
+ eq_sig i1 i2 = i1 == i2 && same_fixity (ifaceSigName i1)
+ eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
+ same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
+
+
+diffDecls :: (Outputable decl)
+ => (decl->Name)
+ -> (decl->decl->Bool) -- True if no change
+ -> NameEnv Version -- Old version map
+ -> [decl] -> [decl] -- Old and new decls
+ -> (Bool, -- True <=> no change
+ SDoc, -- Record of differences
+ NameEnv Version) -- New version
+
+diffDecls get_name eq old_vers old new
+ = diff True empty emptyNameEnv old new
+ where
+ diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
+ diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
+ diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
+ diff ok_so_far pp new_vers (od:ods) (nd:nds)
+ = case od_name `compare` nd_name of
+ LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
+ GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
+ EQ | od `eq` nd -> diff ok_so_far pp new_vers ods nds
+ | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
+ where
+ od_name = get_name od
+ nd_name = get_name nd
+ new_vers' = extendNameEnv new_vers nd_name
+ (bumpVersion True (lookupNameEnv_NF old_vers od_name))
+
+ only_old d = ptext SLIT("Only in old iface:") <+> ppr d
+ only_new d = ptext SLIT("Only in new iface:") <+> ppr d
+ changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
+ (ptext SLIT("New:") <+> ppr nd))
+\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.41 2000/10/12 11:47:26 sewardj Exp $
+$Id: Parser.y,v 1.42 2000/10/24 07:35:01 simonpj Exp $
Haskell grammar.
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { RdrBinding }
- : srcloc exportlist STRING
+ : srcloc depreclist STRING
{ foldr RdrAndBindings RdrNullBind
[ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
+depreclist :: { [RdrName] }
+depreclist : deprec_var { [$1] }
+ | deprec_var ',' depreclist { $1 : $2 }
+
+deprec_var :: { RdrName }
+deprec_var : var { $1 }
+ | tycon { $1 }
+
gtycon :: { RdrName }
: qtycon { $1 }
| '(' qtyconop ')' { $2 }
RdrNameConDecl,
RdrNameConDetails,
RdrNameContext,
- RdrNameSpecDataSig,
RdrNameDefaultDecl,
RdrNameForeignDecl,
RdrNameGRHS,
RdrMatch(..),
SigConverter,
- RdrNameClassOpPragmas,
- RdrNameClassPragmas,
- RdrNameDataPragmas,
- RdrNameGenPragmas,
- RdrNameInstancePragmas,
extractHsTyRdrNames,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractPatsTyVars,
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
mkUnqual, mkPreludeQual
)
-import HsPragmas
import List ( nub )
import BasicTypes ( Boxity(..), RecFlag(..) )
import Class ( DefMeth (..) )
type RdrNameConDetails = ConDetails RdrName
type RdrNameContext = HsContext RdrName
type RdrNameHsDecl = HsDecl RdrName RdrNamePat
-type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameForeignDecl = ForeignDecl RdrName
type RdrNameGRHS = GRHS RdrName RdrNamePat
type RdrNameFixitySig = FixitySig RdrName
type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
-
-type RdrNameClassOpPragmas = ClassOpPragmas RdrName
-type RdrNameClassPragmas = ClassPragmas RdrName
-type RdrNameDataPragmas = DataPragmas RdrName
-type RdrNameGenPragmas = GenPragmas RdrName
-type RdrNameInstancePragmas = InstancePragmas RdrName
\end{code}
Similarly for mkConDecl, mkClassOpSig and default-method names.
\begin{code}
-mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
- = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc
+mkClassDecl cxt cname tyvars fds sigs mbinds loc
+ = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
where
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
- new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names)
+ new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
-- mkTyData :: ??
-mkTyData new_or_data context tname list_var list_con i maybe pragmas src =
- let t_occ = rdrNameOcc tname
+mkTyData new_or_data context tname list_var list_con i maybe src
+ = let t_occ = rdrNameOcc tname
name1 = mkRdrUnqual (mkGenOcc1 t_occ)
name2 = mkRdrUnqual (mkGenOcc2 t_occ)
in TyData new_or_data context
- tname list_var list_con i maybe pragmas src name1 name2
+ tname list_var list_con i maybe src name1 name2
mkClassOpSig (DefMeth x) op ty loc
= ClassOpSig op (Just (DefMeth dm_rn)) ty loc
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import CallConv ( cCallConv )
-import HsPragmas ( noDataPragmas, noClassPragmas )
import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
import IdInfo ( exactArity, InlinePragInfo(..) )
import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
-import RnMonad ( ParsedIface(..), ExportItem )
+import RnMonad ( ParsedIface(..), ExportItem, IfaceDeprecs )
import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
ImportVersion, WhatsImported(..),
RdrAvailInfo )
iface_stuff : iface { PIface $1 }
| type { PType $1 }
| id_info { PIdInfo $1 }
- | '__R' rules { PRules $2 }
- | '__D' deprecs { PDeprecs $2 }
-
+ | rules_and_deprecs { PRulesAndDeprecs $1 }
iface :: { ParsedIface }
iface : '__interface' package mod_name
fix_decl_part
instance_decl_part
decls_part
- rules_and_deprecs
+ rules_and_deprecs_part
{ ParsedIface {
pi_mod = mkModule $3 $2, -- Module itself
pi_vers = $4, -- Module version
| src_loc 'type' tc_name tv_bndrs '=' type
{ TyClD (TySynonym $3 $4 $6 $1) }
| src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
- { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) }
+ { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1) }
| src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
- { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) }
+ { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing $1) }
| src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
- { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds
- noClassPragmas $1) }
+ { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1) }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
-----------------------------------------------------------------------------
-rules_and_deprecs :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
-rules_and_deprecs : {- empty -} { ([], []) }
- | rules_and_deprecs rule_or_deprec
- { let
- append2 (xs1,ys1) (xs2,ys2) =
- (xs1 `app` xs2, ys1 `app` ys2)
- xs `app` [] = xs -- performance paranoia
- xs `app` ys = xs ++ ys
- in append2 $1 $2
- }
+rules_and_deprecs_part :: { ([RdrNameRuleDecl], IfaceDeprecs) }
+rules_and_deprecs_part : {- empty -} { ([], Nothing) }
+ | pragma { case $1 of
+ POk _ (PRulesAndDeprecs rds) -> rds
+ PFailed err -> pprPanic "Rules/Deprecations parse failed" err
+ }
-rule_or_deprec :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
-rule_or_deprec : pragma { case $1 of
- POk _ (PRules rules) -> (rules,[])
- POk _ (PDeprecs deprecs) -> ([],deprecs)
- PFailed err -> pprPanic "Rules/Deprecations parse failed" err
- }
+rules_and_deprecs :: { ([RdrNameRuleDecl], IfaceDeprecs) }
+rules_and_deprecs : rule_prag deprec_prag { ($1, $2) }
+
-----------------------------------------------------------------------------
+rule_prag :: { [RdrNameRuleDecl] }
+rule_prag : {- empty -} { [] }
+ | '__R' rules { $2 }
+
rules :: { [RdrNameRuleDecl] }
: {- empty -} { [] }
| rule ';' rules { $1:$3 }
-----------------------------------------------------------------------------
-deprecs :: { [RdrNameDeprecation] }
-deprecs : {- empty -} { [] }
- | deprec ';' deprecs { $1 : $3 }
+deprec_prag :: { IfaceDeprecs }
+deprec_prag : {- empty -} { Nothing }
+ | '__D' deprecs { Just $2 }
+
+deprecs :: { Either DeprecTxt [(RdrName,DeprecTxt)] }
+deprecs : STRING { Left $1 }
+ | deprec_list { Right $1 }
+
+deprec_list :: { [(RdrName,DeprecTxt)] }
+deprec_list : deprec { [$1] }
+ | deprec ';' deprec_list { $1 : $3 }
-deprec :: { RdrNameDeprecation }
-deprec : src_loc STRING { Deprecation (IEModuleContents undefined) $2 $1 }
- | src_loc deprec_name STRING { Deprecation $2 $3 $1 }
+deprec :: { (RdrName,DeprecTxt) }
+deprec : deprec_name STRING { ($1, $2) }
--- SUP: TEMPORARY HACK
-deprec_name :: { RdrNameIE }
- : var_name { IEVar $1 }
- | data_name { IEThingAbs $1 }
+deprec_name :: { RdrName }
+ : var_name { $1 }
+ | tc_name { $1 }
-----------------------------------------------------------------------------
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (ifaceParseErr buf loc)
-data IfaceStuff = PIface ParsedIface
- | PIdInfo [HsIdInfo RdrName]
- | PType RdrNameHsType
- | PRules [RdrNameRuleDecl]
- | PDeprecs [RdrNameDeprecation]
+data IfaceStuff = PIface ParsedIface
+ | PIdInfo [HsIdInfo RdrName]
+ | PType RdrNameHsType
+ | PRulesAndDeprecs ([RdrNameRuleDecl], IfaceDeprecs)
mk_con_decl name (ex_tvs, ex_ctxt) details loc = mkConDecl name ex_tvs ex_ctxt details loc
}
#include "HsVersions.h"
import HsSyn
-import HsPragmas ( DataPragmas(..) )
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
-import RnHsSyn ( RenamedHsModule, RenamedHsDecl,
+import RnHsSyn ( RenamedHsDecl,
extractHsTyNames, extractHsCtxtTyNames
)
import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo,
getInterfaceExports,
getImportedRules, getSlurped, removeContext,
- ImportDeclResult(..), findAndReadIface
+ ImportDeclResult(..)
)
import RnEnv ( availName, availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupOrigNames, unknownNameErr,
+ lookupOrigNames, lookupGlobalRn,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName, mkModuleInThisPackage,
+ moduleNameUserString, moduleName,
lookupModuleEnv
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameUnique, nameModule,
- isUserExportedName, toRdrName,
+ isUserExportedName,
mkNameEnv, nameEnvElts, extendNameEnv
)
-import OccName ( occNameFlavour, isValOcc )
+import OccName ( occNameFlavour )
import Id ( idType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
)
import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
import Type ( namesOfType, funTyCon )
-import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
-import BasicTypes ( Version, initialVersion )
+import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
import Bag ( isEmptyBag, bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
-import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
-import SrcLoc ( noSrcLoc )
-import Maybes ( maybeToBool, expectJust )
+import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
ModIface(..), TyThing(..),
GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
- Provenance(..), pprNameProvenance, ImportReason(..),
- lookupDeprec
+ Provenance(..), ImportReason(..), initialVersionInfo,
+ Deprecations(..), lookupDeprec
)
import List ( partition, nub )
\end{code}
\end{code}
\begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe ModIface, IO ())
+rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ())
rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further
rnDump [] [] `thenRn` \ dump_action ->
- returnRn (Nothing, dump_action) ;
+ returnRn (Nothing, [], dump_action) ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
-- DEAL WITH DEPRECATIONS
- rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs ->
+ rnDeprecs local_gbl_env mod_deprec
+ [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs ->
-- DEAL WITH LOCAL FIXITIES
fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env ->
direct_import_mods :: [ModuleName]
direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
- -- *don't* just pick the forward edges. It's entirely possible
- -- that a module is only reachable via back edges.
- user_import ImportByUser = True
- user_import ImportByUserSource = True
- user_import _ = False
-
- -- Export only those fixities that are for names that are
- -- (a) defined in this module
- -- (b) exported
- exported_fixities
- = mkNameEnv [ (name, fixity)
- | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
- isUserExportedName name
- ]
+ -- We record fixities even for things that aren't exported,
+ -- so that we can change into the context of this moodule easily
+ fixities = mkNameEnv [ (name, fixity)
+ | FixitySig name fixity loc <- nameEnvElts local_fixity_env
+ ]
-- Sort the exports to make them easier to compare for versions
my_exports = sortAvails export_avails
mod_iface = ModIface { mi_module = this_module,
- mi_version = panic "mi_version: not filled in yet",
+ mi_version = initialVersionInfo,
mi_orphan = any isOrphanDecl rn_local_decls,
mi_exports = my_exports,
+ mi_globals = gbl_env,
mi_usages = my_usages,
- mi_fixities = exported_fixities,
+ mi_fixities = fixities,
mi_deprecs = my_deprecs,
- mi_decls = rn_local_decls ++ rn_imp_decls
+ mi_decls = panic "mi_decls"
}
+
+ final_decls = rn_local_decls ++ rn_imp_decls
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
export_avails source_fvs
rn_imp_decls `thenRn_`
- returnRn (Just mod_iface, dump_action) }
- where
- trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
- trashed_imports = {-trace "rnSource:trashed_imports"-} []
+ returnRn (Just (mod_iface, final_decls), dump_action) }
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
eqString_RDR]
- get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
+ get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
= concat (map get_deriv deriv_classes)
get other = []
\end{code}
-\begin{code}
-dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
- = pushSrcLocRn locn1 $
- addErrRn msg
- where
- msg = hang (ptext SLIT("Multiple default declarations"))
- 4 (vcat (map pp dup_things))
- pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
-\end{code}
-
-
%*********************************************************
%* *
\subsection{Slurping declarations}
ASSERT( isEmptyFVs fvs )
returnRn decls1
-stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
- = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
name1 name2))
-- Nuke the context and constructors
-- But retain the *number* of constructors!
getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ ))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
(hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
+getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
getFixities warn_uu acc (FixD fix)
= fix_decl warn_uu acc fix
- getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
+ getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
= foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities warn_uu acc other_decl
fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
= -- Check for fixity decl for something not declared
- case lookupRdrEnv gbl_env rdr_name of {
- Nothing | warn_uu
- -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
- `thenRn_` returnRn acc
- | otherwise -> returnRn acc ;
-
- Just ((name,_):_) ->
+ pushSrcLocRn loc $
+ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
+ case maybe_name of {
+ Nothing -> checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity) `thenRn_`
+ returnRn acc ;
+
+ Just name ->
-- Check for duplicate fixity decl
case lookupNameEnv acc name of {
\begin{code}
rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
- -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
-rnDeprecs gbl_env mod_deprec decls
- = mapRn rn_deprec deprecs `thenRn_`
- returnRn (extra_deprec ++ deprecs)
+ -> [RdrNameDeprecation] -> RnMG Deprecations
+rnDeprecs gbl_env Nothing []
+ = returnRn NoDeprecs
+
+rnDeprecs gbl_env (Just txt) decls
+ = mapRn (addErrRn . badDeprec) decls `thenRn_`
+ returnRn (DeprecAll txt)
+
+rnDeprecs gbl_env Nothing decls
+ = mapRn rn_deprec decls `thenRn` \ pairs ->
+ returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
where
- deprecs = [d | DeprecD d <- decls]
- extra_deprec = case mod_deprec of
- Nothing -> []
- Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
-
- rn_deprec (Deprecation ie txt loc)
- = pushSrcLocRn loc $
- mapRn check (ieNames ie)
-
- check n = case lookupRdrEnv gbl_env n of
- Nothing -> addErrRn (unknownNameErr n)
- Just _ -> returnRn ()
+ rn_deprec (Deprecation rdr_name txt loc)
+ = pushSrcLocRn loc $
+ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
+ case maybe_name of
+ Just n -> returnRn (Just (n,txt))
+ Nothing -> returnRn Nothing
\end{code}
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
+
+badDeprec d
+ = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
+ nest 4 (ppr d)]
\end{code}
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..) )
import List ( partition )
-import Bag ( bagToList )
import Outputable
-import PrelNames ( mkUnboundName, isUnboundName )
+import PrelNames ( isUnboundName )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
import HsSyn
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
- mkRdrUnqual, qualifyRdrName
+ mkRdrUnqual, qualifyRdrName, lookupRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
}
+
+lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
+ -- Checks that there is exactly one
+lookupGlobalRn global_env rdr_name
+ = case lookupRdrEnv global_env rdr_name of
+ Just [(name,_)] -> returnRn (Just name)
+ Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
+ returnRn (Just name)
+ Nothing -> returnRn Nothing
\end{code}
%
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
-import TysWiredIn ( intTyCon, integerTyCon )
+import TysWiredIn ( intTyCon )
import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
import NameSet
import UniqFM ( isNullUFM )
#include "HsVersions.h"
import HsSyn
-import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
-
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
type RenamedHsDecl = HsDecl Name RenamedPat
type RenamedRuleDecl = RuleDecl Name RenamedPat
type RenamedTyClDecl = TyClDecl Name RenamedPat
-type RenamedSpecDataSig = SpecDataSig Name
type RenamedDefaultDecl = DefaultDecl Name
type RenamedForeignDecl = ForeignDecl Name
type RenamedGRHS = GRHS Name RenamedPat
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
type RenamedHsOverLit = HsOverLit Name
-
-type RenamedClassOpPragmas = ClassOpPragmas Name
-type RenamedClassPragmas = ClassPragmas Name
-type RenamedDataPragmas = DataPragmas Name
-type RenamedGenPragmas = GenPragmas Name
-type RenamedInstancePragmas = InstancePragmas Name
+type RenamedIfaceSig = IfaceSig Name
\end{code}
%************************************************************************
#include "HsVersions.h"
import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
+import HscTypes
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
- HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
+ HsType(..), ConDecl(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
- isClassOpSig, DeprecDecl(..)
+ tyClDeclNames
)
-import HsImpExp ( ImportDecl(..), ieNames )
-import CoreSyn ( CoreRule )
+import HsImpExp ( ImportDecl(..) )
import BasicTypes ( Version, defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl,
- RdrNameDeprecation, RdrNameIE,
extractHsTyRdrNames
)
import RnEnv
import Module ( Module, ModuleEnv,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
- emptyModuleEnv, extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName,
+ emptyModuleEnv, extendModuleEnv, lookupModuleEnvByName,
extendModuleEnv_C, lookupWithDefaultModuleEnv
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
import SrcLoc ( mkSrcLoc, SrcLoc )
-import PrelInfo ( cCallishTyKeys, wiredInThingEnv )
+import PrelInfo ( wiredInThingEnv )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
-import Util ( sortLt )
import Lex
import FiniteMap
import Outputable
import Bag
-import HscTypes
import List ( nub )
\end{code}
-- Loading Deprecations
-----------------------------------------------------
-loadDeprecs :: Module -> [RdrNameDeprecation] -> RnM d Deprecations
-loadDeprecs m [] = returnRn NoDeprecs
-loadDeprecs m [Deprecation (IEModuleContents _) txt _] = returnRn (DeprecAll txt)
-loadDeprecs m deprecs = setModuleRn m $
- foldlRn loadDeprec emptyNameEnv deprecs `thenRn` \ env ->
- returnRn (DeprecSome env)
-loadDeprec deprec_env (Deprecation ie txt _)
- = mapRn lookupOrigName (ieNames ie) `thenRn` \ names ->
- traceRn (text "Loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
+loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations
+loadDeprecs m Nothing = returnRn NoDeprecs
+loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
+loadDeprecs m (Just (Right prs)) = setModuleRn m $
+ foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
+ returnRn (DeprecSome env)
+loadDeprec deprec_env (n, txt)
+ = lookupOrigName n `thenRn` \ name ->
+ traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
+ returnRn (extendNameEnv deprec_env name txt)
\end{code}
case lookupNameEnv (iDecls ifaces) needed_name of
{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
-- This case deals with deferred import of algebraic data types
| not opt_NoPruneTyDecls
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
- -- The "nub" is because getConFieldNames can legitimately return duplicates,
- -- when a record declaration has the same field in multiple constructors
-
-getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (Just (AvailTC tycon_name [tycon_name]))
-
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc))
- = new_name cname src_loc `thenRn` \ class_name ->
-
- -- Record the names for the class ops
- let
- -- just want class-op sigs
- op_sigs = filter isClassOpSig sigs
- in
- mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names ->
-
- returnRn (Just (AvailTC class_name (class_name : sub_names)))
+getDeclBinders new_name (TyClD tycl_decl)
+ = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ returnRn (Just (AvailTC main_name (main_name : sub_names)))
+ where
+ do_one (name,loc) = new_name name loc
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
returnRn (Just (Avail var_name))
-getDeclBinders new_name (FixD _) = returnRn Nothing
-getDeclBinders new_name (DeprecD _) = returnRn Nothing
-
-- foreign declarations
getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
| binds_haskell_name kind dyn
= lookupOrigName nm `thenRn_`
returnRn Nothing
-getDeclBinders new_name (DefD _) = returnRn Nothing
-getDeclBinders new_name (InstD _) = returnRn Nothing
-getDeclBinders new_name (RuleD _) = returnRn Nothing
+getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (DeprecD _) = returnRn Nothing
+getDeclBinders new_name (DefD _) = returnRn Nothing
+getDeclBinders new_name (InstD _) = returnRn Nothing
+getDeclBinders new_name (RuleD _) = returnRn Nothing
binds_haskell_name (FoImport _) _ = True
binds_haskell_name FoLabel _ = True
binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm
-
-----------------
-getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest)
- = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (cfs ++ ns)
- where
- fields = concat (map fst fielddecls)
-
-getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n : ns)
-
-getConFieldNames new_name [] = returnRn []
-
-getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names
- src_loc))
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ names src_loc))
= sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
)
import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
RdrNameEnv, emptyRdrEnv, extendRdrEnv,
- lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts
+ addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
isLocallyDefinedName, nameModule, nameOccName,
%===================================================
\begin{code}
-type ExportItem = (ModuleName, [RdrAvailInfo])
+type ExportItem = (ModuleName, [RdrAvailInfo])
+type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
+ -- Nothing => NoDeprecs
+ -- Just (Left t) => DeprecAll
+ -- Just (Right p) => DeprecSome
data ParsedIface
= ParsedIface {
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
pi_exports :: (Version, [ExportItem]), -- Exports
- pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
+ pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
- pi_deprecs :: [RdrNameDeprecation] -- Deprecations
+ pi_deprecs :: IfaceDeprecs -- Deprecations
}
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_NoImplicitPrelude )
+import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
collectTopBinders
RdrNameHsModule, RdrNameHsDecl
)
import RnIfaces ( getInterfaceExports, getDeclBinders,
- recordLocalSlurps, findAndReadIface )
+ recordLocalSlurps )
import RnEnv
import RnMonad
setLocalNameSort, nameOccName, nameEnvElts )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
-import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual,
- isQual, isUnqual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual )
import OccName ( setOccNameSpace, dataName )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
import RnExpr
import HsSyn
-import HsPragmas
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
import Class ( FunDep, DefMeth (..) )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
-import OccName ( mkDefaultMethodOcc, isTvOcc )
import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
-import Bag ( bagToList )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
-import ListSetOps ( minusList, removeDupsEq )
+import ListSetOps ( removeDupsEq )
\end{code}
@rnDecl@ `renames' declarations.
However, we can also do some scoping checks at the same time.
\begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc gen_name1 gen_name2))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2))
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
lookupSysBinder gen_name1 `thenRn` \ name1' ->
lookupSysBinder gen_name2 `thenRn` \ name2' ->
rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
- ASSERT(isNoDataPragmas pragmas)
returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' noDataPragmas src_loc name1' name2'),
+ derivings' src_loc name1' name2'),
cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExys ty = ty
-rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
- names src_loc))
+rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc))
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- ASSERT(isNoClassPragmas pragmas)
returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
- NoClassPragmas names' src_loc),
+ names' src_loc),
sig_fvs `plusFV`
fix_fvs `plusFV`
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassDecl, isClassOpSig, isPragSig,
- fromClassDeclNameList, tyClDeclName
+ getClassDeclSysNames, tyClDeclName
)
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl,
tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 rec_env
(ClassDecl context class_name
- tyvar_names fundeps class_sigs def_methods pragmas
+ tyvar_names fundeps class_sigs def_methods
sys_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
tyvars = classTyVars clas
op_sigs = filter isClassOpSig class_sigs
op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
- (_, datacon_name, datacon_wkr_name, sc_sel_names) = fromClassDeclNameList sys_names
+ (_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names
in
tcExtendTyVarEnv tyvars $
-> NF_TcM (LIE, TcMonoBinds)
tcClassDecl2 (ClassDecl context class_name
- tyvar_names _ sigs default_binds pragmas _ src_loc)
+ tyvar_names _ sigs default_binds _ src_loc)
= -- A locally defined class
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc src_loc $
isEnumerationTyCon, isAlgTyCon, TyCon
)
import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
- mkSigmaTy, splitSigmaTy, splitDictTy, mkDictTy,
+ mkSigmaTy, splitDFunTy, mkDictTy,
isUnboxedType, splitAlgTyConApp, classesToPreds
)
import TysWiredIn ( voidTy )
iBinds = binds,
iLoc = getSrcLoc dfun, iPrags = [] }
where
- (tyvars, theta, tau) = splitSigmaTy (idType dfun)
- (clas, tys) = splitDictTy tau
+ (tyvars, theta, tau, clas, tys) = splitDFunTy (idType dfun)
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
import Module ( Module )
import HscTypes ( InstEnv, lookupTypeEnv, TyThing(..),
GlobalSymbolTable )
-import UniqFM
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
import Outputable
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint, pprPred )
import TyCon ( TyCon, isSynTyCon, tyConDerivings )
-import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe,
+import Type ( mkTyVarTys, splitDFunTy, isTyVarTy,
+ splitTyConApp_maybe, splitDictTy,
splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
-- Type-check all the stuff before the "where"
tcHsSigType poly_ty `thenTc` \ poly_ty' ->
let
- (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
- (clas, inst_tys) = case splitDictTy_maybe dict_ty of
- Just ct -> ct
- Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
+ (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
in
(case maybe_dfun_name of
returnTc gen_inst_info
get_generics mod decl@(ClassDecl context class_name tyvar_names
- fundeps class_sigs def_methods pragmas
+ fundeps class_sigs def_methods
name_list loc)
| null groups
= returnTc [] -- The comon case:
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+ (clas, inst_tys') = splitDictTy dict_ty'
origin = InstanceDeclOrigin
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
where
(name, loc, thing)
= case decl of
- (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ _ loc _ _) -> (name, loc, "newtype")
- (TyData DataType _ name _ _ _ _ _ loc _ _) -> (name, loc, "data type")
+ (ClassDecl _ name _ _ _ _ _ loc) -> (name, loc, "class")
+ (TySynonym name _ _ loc) -> (name, loc, "type synonym")
+ (TyData NewType _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
+ (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr name)]
unionManyUniqSets, uniqSetToList )
import ErrUtils ( Message )
import Unique ( Unique, Uniquable(..) )
-import HsDecls ( fromClassDeclNameList )
+import HsDecls ( getClassDeclSysNames )
import Generics ( mkTyConGenInfo )
import CmdLineOpts ( DynFlags )
\end{code}
newKindVar `thenNF_Tc` \ result_kind ->
returnNF_Tc (name, mk_kind arg_kinds result_kind)
-getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
+getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
= kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
-getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
+getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
= kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
kcHsType rhs `thenTc` \ rhs_kind ->
unifyKind result_kind rhs_kind
-kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
+kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _)
= tcAddDeclCtxt decl $
kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
kcHsContext context `thenTc_`
kcTyClDecl decl@(ClassDecl context class_name
hs_tyvars fundeps class_sigs
- _ _ _ loc)
+ _ _ loc)
= tcAddDeclCtxt decl $
kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
kcHsContext context `thenTc_`
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
+ (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
= (tycon_name, ATyCon tycon)
where
tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(ClassDecl context class_name
- tyvar_names fundeps class_sigs def_methods pragmas
+ tyvar_names fundeps class_sigs def_methods
name_list src_loc)
= (class_name, AClass clas)
where
- (tycon_name, _, _, _) = fromClassDeclNameList name_list
+ (tycon_name, _, _, _) = getClassDeclSysNames name_list
clas = mkClass class_name tyvars fds
sc_theta sc_sel_ids op_items
tycon
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _)
= Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
mk_cls_edges other_decl
= Nothing
----------------------------------------------------
mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
-mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _)
+mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_cons condecls `unionUniqSets`
get_deriv derivs))
mk_edges decl@(TySynonym name _ rhs _)
= (decl, getUnique name, uniqSetToList (get_ty rhs))
-mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _)
+mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2)
+tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
tyvars = tyConTyVars tycon
import Name ( getSrcLoc )
import SrcLoc ( SrcLoc )
import Type ( Type, ThetaType, splitTyConApp_maybe,
- splitSigmaTy, splitDictTy,
- tyVarsOfTypes )
+ splitSigmaTy, splitDFunTy, tyVarsOfTypes
+ )
import PprType ( )
import Class ( classTyCon )
import DataCon ( DataCon )
simpleDFunClassTyCon dfun
= (clas, tycon)
where
- (_,_,dict_ty) = splitSigmaTy (idType dfun)
- (clas, [ty]) = splitDictTy dict_ty
- tycon = case splitTyConApp_maybe ty of
+ (_,_,clas,[ty]) = splitDFunTy (idType dfun)
+ tycon = case splitTyConApp_maybe ty of
Just (tycon,_) -> tycon
classDataCon :: Class -> DataCon
Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
where
- (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id)
- (clas, ins_tys) = splitDictTy dict_ty
+ (ins_tvs, _, clas, ins_tys) = splitDFunTy (idType dfun_id)
ins_tv_set = mkVarSet ins_tvs
ins_item = (ins_tv_set, ins_tys, dfun_id)
-- Predicates and the like
mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
- splitDictTy, splitDictTy_maybe, isDictTy, predRepTy,
+ splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
mkSynTy, isSynTy, deNoteType,
-- Other imports:
-import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
+import {-# SOURCE #-} DataCon( DataCon )
import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
-import Var ( TyVar, Var, UVar,
- tyVarKind, tyVarName, setTyVarName, isId, idType,
+import Var ( TyVar, UVar,
+ tyVarKind, tyVarName, setTyVarName,
)
import VarEnv
import VarSet
splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
splitDictTy_maybe other = Nothing
+splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+-- Split the type of a dictionary function
+splitDFunTy ty
+ = case splitSigmaTy ty of { (tvs, theta, tau) ->
+ case splitDictTy tau of { (clas, tys) ->
+ (tvs, theta, clas, tys) }}
+
getClassTys_maybe :: PredType -> Maybe ClassPred
getClassTys_maybe (Class clas tys) = Just (clas, tys)
getClassTys_maybe _ = Nothing
projects / ghc-hetmet.git / commitdiff