diff options
| author | simonpj <unknown> | 2000-10-24 07:35:03 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2000-10-24 07:35:03 +0000 |
| commit | 4a91d102be99778efcab80211ca5de3f2cf6619a (patch) | |
| tree | 9a4250e4b1bfa90f117efb47d565cbdd14e271e0 | |
| parent | ebef357f943e8fce48adb73053082204cc892f99 (diff) | |
| download | haskell-4a91d102be99778efcab80211ca5de3f2cf6619a.tar.gz | |
[project @ 2000-10-24 07:35:00 by simonpj]
Mainly MkIface
33 files changed, 751 insertions, 816 deletions
diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 943934fb35..063fe130d8 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -1,7 +1,7 @@ % % (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 % --------------------------------------------------------------------------- @@ -71,9 +71,6 @@ data CostRes = Cost (Int, Int, Int, Int, Int) 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 @@ -367,9 +364,6 @@ gmpOps = ] -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 diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 6a8c58333a..16ab432d94 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -83,8 +83,10 @@ type Version = Int 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 diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 75c556fb13..d4fc31fd2a 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (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} @@ -23,7 +23,7 @@ import CgMonad 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 ) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 29c8d1bc6e..0a4f8a9a01 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -15,7 +15,7 @@ module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), HsIdInfo(..), - IfaceSig(..), + IfaceSig(..), ifaceSigName, eq_ufExpr, eq_ufBinders, pprUfExpr, @@ -37,8 +37,7 @@ import Var ( varType, isId ) 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) ) @@ -104,7 +103,7 @@ data UfBinder name %************************************************************************ \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) @@ -112,7 +111,7 @@ toUfExpr (Lit l) = case maybeLitLit l of 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) @@ -127,11 +126,11 @@ toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) 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 @@ -141,15 +140,15 @@ toUfCon (LitAlt l) = case maybeLitLit l of 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 @@ -167,7 +166,7 @@ mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) 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} @@ -330,6 +329,9 @@ instance Ord name => Eq (IfaceSig name) where 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} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 0767de0927..66fde2f102 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -13,12 +13,12 @@ module HsDecls ( 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" @@ -26,15 +26,15 @@ module HsDecls ( -- 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 ) @@ -84,7 +84,7 @@ hsDeclName :: (Outputable name, Outputable pat) #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 @@ -93,11 +93,6 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #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 @@ -188,7 +183,6 @@ data TyClDecl name pat -- (i.e., derive default); Just [] => derive -- *nothing*; Just <list> => as you would -- expect... - (DataPragmas name) SrcLoc name -- generic converter functions name -- generic converter functions @@ -204,30 +198,62 @@ data TyClDecl name pat [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 -> @@ -240,8 +266,8 @@ instance Ord name => Eq (TyClDecl name pat) where = 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 && @@ -271,21 +297,10 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) 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} @@ -296,7 +311,8 @@ instance (Outputable name, Outputable pat) = 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) @@ -306,7 +322,7 @@ instance (Outputable name, Outputable pat) 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 @@ -319,7 +335,6 @@ instance (Outputable name, Outputable pat) 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] @@ -335,22 +350,6 @@ pp_tydecl pp_head pp_decl_rhs derivings ]) \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} %************************************************************************ %* * @@ -383,7 +382,30 @@ data ConDetails name | 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 && @@ -400,8 +422,9 @@ eq_ConDetails env (RecCon fs1) (RecCon fs2) 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) @@ -642,11 +665,11 @@ toHsRule id (BuiltinRule _) = 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} @@ -656,17 +679,14 @@ bogusIfaceRule id %* * %************************************************************************ -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} diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index 013129dcff..0cf86ea6e8 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -8,51 +8,16 @@ %************************************************************************ 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} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index ed945331c7..952c07fd9b 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -10,7 +10,7 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - -- NB: don't reexport HsCore or HsPragmas; + -- NB: don't reexport HsCore -- this module tells about "real Haskell" module HsSyn, diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 919bc945bb..956b02f3dc 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -32,7 +32,7 @@ import Type ( Type, Kind, PredType(..), ClassContext, 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 ) @@ -272,19 +272,19 @@ user-friendly as possible. Notably, it uses synonyms where possible, and 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) @@ -295,11 +295,11 @@ toHsType' (PredTy p) = HsPredTy (toHsPred p) 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 @@ -309,14 +309,14 @@ toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of (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} diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index 6278a70d8e..716492991e 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -53,11 +53,10 @@ import Name ( NamedThing(..), getOccString, isGlobalName, isLocalName , 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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 63dabf0520..797c850462 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -282,3 +282,145 @@ initRules = foldl add emptyVarEnv builtinRules 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} + + diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8d115aebce..bb75ae16e7 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -8,7 +8,6 @@ module HscStats ( ppSourceStats ) where #include "HsVersions.h" -import IO ( hPutStr, stderr ) import HsSyn import Outputable import Char ( isSpace ) @@ -124,11 +123,11 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) 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)) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index a5d58169d4..ee3c9e2a2a 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -11,7 +11,9 @@ module HscTypes ( HomeSymbolTable, PackageSymbolTable, HomeIfaceTable, PackageIfaceTable, - VersionInfo(..), + IfaceDecls(..), + + VersionInfo(..), initialVersionInfo, TyThing(..), groupTyThings, @@ -50,16 +52,16 @@ import OccName ( OccName ) 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 ) @@ -116,9 +118,10 @@ data ModIface 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 @@ -126,10 +129,14 @@ data ModIface 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 @@ -263,6 +270,12 @@ data VersionInfo -- 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 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5ab757fad4..5b6373a27a 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -4,29 +4,26 @@ \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(..), @@ -40,33 +37,26 @@ 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} @@ -77,275 +67,160 @@ import Monad ( when ) %************************************************************************ \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 @@ -359,117 +234,14 @@ ifaceRules rules emitted -- 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} - %************************************************************************ %* * @@ -481,7 +253,7 @@ ifaceClass clas 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 @@ -532,7 +304,7 @@ ifaceBinds needed_ids final_ids binds 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, @@ -554,10 +326,10 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> 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 @@ -625,7 +397,7 @@ ifaceId get_idinfo is_rec id rhs other -> False - wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)] + wrkr_hsinfo | has_worker = [HsWorker (getName work_id)] | otherwise = [] ------------ Unfolding -------------- @@ -671,3 +443,98 @@ ifaceId get_idinfo is_rec id rhs 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} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d067c64510..f228ea874b 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$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. @@ -451,7 +451,7 @@ deprecations :: { RdrBinding } -- 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 ] } @@ -876,6 +876,14 @@ dbind : ipvar '=' exp { ($1, $3) } ----------------------------------------------------------------------------- -- 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 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 2726ef27c9..f2b0d8a81c 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -14,7 +14,6 @@ module RdrHsSyn ( RdrNameConDecl, RdrNameConDetails, RdrNameContext, - RdrNameSpecDataSig, RdrNameDefaultDecl, RdrNameForeignDecl, RdrNameGRHS, @@ -44,11 +43,6 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - RdrNameClassOpPragmas, - RdrNameClassPragmas, - RdrNameDataPragmas, - RdrNameGenPragmas, - RdrNameInstancePragmas, extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsTysRdrTyVars, extractPatsTyVars, @@ -84,7 +78,6 @@ import PrelNames ( pRELUDE_Name, mkTupNameStr ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, mkUnqual, mkPreludeQual ) -import HsPragmas import List ( nub ) import BasicTypes ( Boxity(..), RecFlag(..) ) import Class ( DefMeth (..) ) @@ -105,7 +98,6 @@ type RdrNameConDecl = ConDecl RdrName 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 @@ -130,12 +122,6 @@ type RdrNameDeprecation = DeprecDecl RdrName 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} @@ -233,8 +219,8 @@ file (which would be equally good). 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 @@ -250,15 +236,15 @@ mkClassDecl cxt cname tyvars fds sigs mbinds prags loc -- 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 diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 70cbf6bd96..94f29f12f8 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -43,13 +43,12 @@ import BasicTypes ( Fixity(..), FixityDirection(..), ) 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 ) @@ -207,9 +206,7 @@ iface_stuff :: { IfaceStuff } 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 @@ -220,7 +217,7 @@ 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 @@ -369,12 +366,11 @@ decl : src_loc var_name '::' type maybe_idinfo | 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 -} { \_ -> [] } @@ -394,26 +390,23 @@ pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#, ----------------------------------------------------------------------------- -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 } @@ -427,18 +420,24 @@ rule_forall : '__forall' '{' core_bndrs '}' { $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 } ----------------------------------------------------------------------------- @@ -925,11 +924,10 @@ checkVersion :: { () } 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 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 8790ef0843..0cc7b3f040 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -9,9 +9,8 @@ module Rename ( renameModule ) where #include "HsVersions.h" import HsSyn -import HsPragmas ( DataPragmas(..) ) import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation ) -import RnHsSyn ( RenamedHsModule, RenamedHsDecl, +import RnHsSyn ( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) @@ -22,24 +21,24 @@ import RnSource ( rnSourceDecls, rnDecl ) 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 @@ -51,23 +50,20 @@ import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, ) 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} @@ -105,7 +101,7 @@ renameModule dflags finder hit hst old_pcs this_module \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 -> @@ -114,12 +110,13 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls 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 -> @@ -165,34 +162,28 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls 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 @@ -201,10 +192,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls 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 @@ -240,7 +228,7 @@ implicitFVs mod_name decls 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 = [] @@ -279,17 +267,6 @@ isOrphanDecl other = False \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} @@ -464,8 +441,8 @@ slurpDeferredDecls decls 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! @@ -498,7 +475,7 @@ vars of the source program, and extracts from the decl the gate names. 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) @@ -523,7 +500,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) (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 @@ -600,7 +577,7 @@ fixitiesFromLocalDecls gbl_env decls 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 @@ -608,13 +585,13 @@ fixitiesFromLocalDecls gbl_env decls 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 { @@ -638,23 +615,24 @@ gather them together. \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} @@ -933,6 +911,10 @@ dupFixityDecl rdr_name loc1 loc2 = 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} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index bfc67adc57..f27407afee 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -38,9 +38,8 @@ import NameSet 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 diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index d4ff303608..adcdb82b11 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -11,7 +11,7 @@ module RnEnv where -- Export everything 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, @@ -223,6 +223,15 @@ lookupGlobalOccRn rdr_name 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} % diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 3cf439db09..134a5405ef 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -39,7 +39,7 @@ import PrelNames ( hasKey, assertIdKey, import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import TysWiredIn ( intTyCon, integerTyCon ) +import TysWiredIn ( intTyCon ) import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 58e86b0db2..7ef1cc3e39 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -9,8 +9,6 @@ module RnHsSyn where #include "HsVersions.h" import HsSyn -import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas ) - import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet @@ -27,7 +25,6 @@ type RenamedContext = HsContext Name 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 @@ -47,12 +44,7 @@ type RenamedStmt = Stmt 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} %************************************************************************ diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 62993fd30f..4452723002 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -22,17 +22,16 @@ where #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 @@ -47,23 +46,21 @@ import Name ( Name {-instance NamedThing-}, nameOccName, 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} @@ -436,16 +433,16 @@ loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) -- 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} @@ -501,7 +498,7 @@ getNonWiredInDecl needed_name 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 @@ -914,36 +911,16 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> 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 @@ -954,30 +931,15 @@ getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) = 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. @@ -990,11 +952,10 @@ and the dict fun of an instance decl, because both of these have 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 diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 1b3bcfc8ef..17c5c716e3 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -51,7 +51,7 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ) 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, @@ -193,7 +193,11 @@ type ExportAvails = (FiniteMap ModuleName Avails, %=================================================== \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 { @@ -202,11 +206,11 @@ data 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} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index fb0b5c623a..9a61325d9b 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -10,7 +10,7 @@ module RnNames ( #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_NoImplicitPrelude ) +import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), collectTopBinders @@ -19,7 +19,7 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, - recordLocalSlurps, findAndReadIface ) + recordLocalSlurps ) import RnEnv import RnMonad @@ -33,8 +33,7 @@ import Name ( Name, nameSrcLoc, 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 diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index b0d5e4669d..86729ae527 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -10,7 +10,6 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where import RnExpr import HsSyn -import HsPragmas import HsTypes ( hsTyVarNames, pprHsContext ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, @@ -36,22 +35,20 @@ import FunDeps ( oclose ) 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. @@ -136,7 +133,7 @@ and then go over it again to rename the tyvars! 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' -> @@ -146,9 +143,8 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivin 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) @@ -169,8 +165,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) 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' -> @@ -232,9 +227,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas -- 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` diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 1b1a7b0177..782c1dc9a7 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -14,7 +14,7 @@ import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), mkSimpleMatch, andMonoBinds, andMonoBindList, isClassDecl, isClassOpSig, isPragSig, - fromClassDeclNameList, tyClDeclName + getClassDeclSysNames, tyClDeclName ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, @@ -103,7 +103,7 @@ Death to "ExpandingDicts". 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 -> @@ -116,7 +116,7 @@ tcClassDecl1 rec_env 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 $ @@ -400,7 +400,7 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> 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 $ diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 9c15b24ed1..a4a13d0a40 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -46,7 +46,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, isEnumerationTyCon, isAlgTyCon, TyCon ) import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, - mkSigmaTy, splitSigmaTy, splitDictTy, mkDictTy, + mkSigmaTy, splitDFunTy, mkDictTy, isUnboxedType, splitAlgTyConApp, classesToPreds ) import TysWiredIn ( voidTy ) @@ -258,8 +258,7 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons 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 diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index b24476505b..4d345fa713 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -65,7 +65,6 @@ import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) import Module ( Module ) import HscTypes ( InstEnv, lookupTypeEnv, TyThing(..), GlobalSymbolTable ) -import UniqFM import Util ( zipEqual ) import SrcLoc ( SrcLoc ) import Outputable diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 73bbe5932d..245e76200c 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -56,8 +56,8 @@ import NameSet ( emptyNameSet, nameSetToList ) 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 @@ -247,10 +247,7 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) -- 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 @@ -324,7 +321,7 @@ getGenericInstances mod class_decls 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: @@ -521,7 +518,7 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, -- 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 @@ -777,10 +774,10 @@ tcAddDeclCtxt decl thing_inside 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)] diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index da1ad9f13a..7952aca9bc 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -47,7 +47,7 @@ import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import ErrUtils ( Message ) import Unique ( Unique, Uniquable(..) ) -import HsDecls ( fromClassDeclNameList ) +import HsDecls ( getClassDeclSysNames ) import Generics ( mkTyConGenInfo ) import CmdLineOpts ( DynFlags ) \end{code} @@ -183,11 +183,11 @@ getInitialKind (TySynonym name tyvars _ _) 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) @@ -223,7 +223,7 @@ kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc) 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_` @@ -237,7 +237,7 @@ kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _) 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_` @@ -292,7 +292,7 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details 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 @@ -314,11 +314,11 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details 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 @@ -397,7 +397,7 @@ Edges in Type/Class decls 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 @@ -405,7 +405,7 @@ mk_cls_edges other_decl ---------------------------------------------------- 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)) @@ -413,7 +413,7 @@ mk_edges decl@(TyData _ ctxt name _ condecls _ 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)) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index b5973f722c..0392d34cda 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -78,7 +78,7 @@ tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) 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 diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index d0541787ec..ed9797576d 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -31,8 +31,8 @@ import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) 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 ) @@ -99,9 +99,8 @@ simpleDFunClassTyCon :: DFunId -> (Class, TyCon) 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 @@ -354,8 +353,7 @@ addToInstEnv dflags inst_env dfun_id 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) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 183b6c1548..6ad66a4e34 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -33,7 +33,7 @@ module Type ( -- Predicates and the like mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, - splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, + splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, mkSynTy, isSynTy, deNoteType, @@ -79,13 +79,13 @@ import TypeRep -- 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 @@ -698,6 +698,13 @@ splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty) 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 |