#include "HsVersions.h"
-import IO ( Handle, hPutStr, openFile,
- hClose, hPutStrLn, IOMode(..) )
+import IO ( openFile, hClose, IOMode(..) )
import HsSyn
import HsCore ( HsIdInfo(..), toUfExpr )
-import RdrHsSyn ( RdrNameRuleDecl )
+import RdrHsSyn ( RdrNameRuleDecl, mkTyData )
import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
import HsTypes ( toHsTyVars )
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
+import BasicTypes ( Fixity(..), NewOrData(..),
Version, bumpVersion, initialVersion, isLoopBreaker
)
import RnMonad
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
idSpecialisation
)
-import Var ( isId )
+import Var ( isId, varName )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..),
+import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
CprInfo(..), CafInfo(..),
inlinePragInfo, arityInfo, arityLowerBound,
strictnessInfo, isBottomingStrictness,
cafInfo, specInfo, cprInfo,
occInfo, isNeverInlinePrag,
- workerExists, workerInfo, WorkerInfo(..)
+ workerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
-import Module ( moduleString, pprModule, pprModuleName, moduleUserString )
+import Module ( pprModuleName, moduleUserString )
import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
Name, NamedThing(..)
)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
)
-import Class ( Class, classExtraBigSig )
-import FieldLabel ( fieldLabelName, fieldLabelType )
+import Class ( classExtraBigSig, DefMeth(..) )
+import FieldLabel ( fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
- deNoteType, classesToPreds,
- Type, ThetaType, PredType(..), ClassContext
+ deNoteType, classesToPreds
)
-import PprType
-import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
+import Rules ( ProtoCoreRule(..) )
-import Bag ( bagToList, isEmptyBag )
-import Maybes ( catMaybes, maybeToBool )
+import Bag ( bagToList )
import UniqFM ( lookupUFM, listToUFM )
-import Util ( sortLt, mapAccumL )
+import Util ( sortLt )
import SrcLoc ( noSrcLoc )
import Bag
import Outputable
+import ErrUtils ( dumpIfSet )
import Maybe ( isNothing )
import List ( partition )
}}
in
- case checkIface old_iface full_new_iface of {
- Nothing -> when opt_D_dump_rn_trace $
- putStrLn "Interface file unchanged" ; -- No need to update .hi file
+ 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 ->
+ 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"
+ 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
+ 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
\begin{code}
checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
-> ParsedIface -- The new interface; but with all version numbers = 1
- -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface
+ -> 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
checkIface Nothing new_iface
-- No old interface, so definitely write a new one!
- = Just new_iface
+ = return (Just new_iface)
checkIface (Just iface) new_iface
| no_output_change && no_usage_change
- = Nothing
+ = return Nothing
| otherwise -- Add updated version numbers
- =
-{- pprTrace "checkIface" (
- vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
- text "--------",
- vcat (map ppr (pi_decls iface)),
- text "--------",
- vcat (map ppr (pi_decls new_iface))
- ]) $
--}
- Just (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
- })
+ = 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_rules_vers | rules == new_rules = rules_vers
| otherwise = bumpVersion rules_vers
- (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)
+ (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
-- 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 acc [] [] = (ok_so_far, reverse acc)
- merge_decls ok_so_far acc old [] = (False, reverse acc)
- merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
- merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
+ 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 acc vds (nvd:nvds)
- GT -> merge_decls False (nvd:acc) (vd:vds) nvds
- EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds
- | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds
+ 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
+
+ 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}
-- 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 (classesToPreds theta)
- (deNoteType (mkDictTy clas tys))
+ 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
ifaceTyCon tycon
| isAlgTyCon tycon
- = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
+ = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
(toRdrName tycon)
(toHsTyVars tyvars)
(map ifaceConDecl (tyConDataCons tycon))
(toHsFDs clas_fds)
(map toClassOpSig op_stuff)
EmptyMonoBinds NoClassPragmas
- bogus bogus bogus [] noSrcLoc
+ [] noSrcLoc
)
where
bogus = error "ifaceClass"
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- toClassOpSig (sel_id, dm_id, explicit_dm)
- = ASSERT( sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
+ 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}
%************************************************************************
%* *
\subsection{Value bindings}
-%* *
+%* *
%************************************************************************
\begin{code}
find_fvs expr = exprSomeFreeVars interestingId expr
- ------------ Sanity checking --------------
- -- The arity of a wrapper function should match its strictness,
- -- or else an importing module will get very confused indeed.
- arity_matches_strictness
- = case work_info of
- HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
- other -> True
-
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
\end{code}
projects / ghc-hetmet.git / blobdiff