) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
-import Bag ( emptyBag, snocBag, bagToList )
+import Bag ( bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
-import FiniteMap ( fmToList )
+import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
-import Id ( idType, dataConRawArgTys, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
+import Maybes ( maybeToBool )
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- isExported, getExportFlag,
- isLexSym, isLocallyDefined, isWiredInName,
+ isLexSym, isLexCon, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
OrigName(..){-instance Ord-},
Name{-instance NamedThing-}
import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
-import PrelMods ( modulesWithBuiltins )
+--import PrelMods ( modulesWithBuiltins )
+import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
import Pretty ( prettyToUn )
import Unpretty -- ditto
-import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
-import TcModule ( TcIfaceInfo(..) )
+import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
+import RnUtils ( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} )
+import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
-import Type ( mkSigmaTy, mkDictTy, getAppTyCon )
-import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
+import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
+import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} )
uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
ppr_ty ty = prettyToUn (pprType PprInterface ty)
-> IO ()
ifaceExportList
:: Maybe Handle
- -> RenamedHsModule
+ -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
+ -> RnEnv
-> IO ()
ifaceFixities
:: Maybe Handle
Nothing -> return Nothing -- not producing any .hi file
Just fn ->
openFile fn WriteMode >>= \ if_hdl ->
- hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
+ hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >>
return (Just if_hdl)
endIface Nothing = return ()
= hPutStr if_hdl "\n__usages__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
where
- usages_list = filter has_no_builtins (fmToList usages)
+ usages_list = fmToList usages -- NO: filter has_no_builtins (...)
- has_no_builtins (m, _)
- = m `notElem` modulesWithBuiltins
- -- Don't *have* to do this; save gratuitous spillage in
- -- every interface. Could be flag-controlled...
+-- has_no_builtins (m, _)
+-- = m `notElem` modulesWithBuiltins
+-- -- Don't *have* to do this; save gratuitous spillage in
+-- -- every interface. Could be flag-controlled...
upp_uses (m, (mv, versions))
= uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
Export list: grab the Names of things that are marked Exported, sort
(so the interface file doesn't ``wobble'' from one compilation to the
-next...), and print. Note that the ``module'' now contains all the
-imported things that we are dealing with, thus including any entities
-that we are re-exporting from somewhere else.
+next...), and print. We work from the renamer's final ``RnEnv'',
+which has all the names we might possibly be interested in.
+(Note that the ``module X'' export items can cause a lot of grief.)
\begin{code}
-ifaceExportList Nothing{-no iface handle-} _ = return ()
+ifaceExportList Nothing{-no iface handle-} _ _ = return ()
ifaceExportList (Just if_hdl)
- (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
+ (export_fn, (dotdot_vals, dotdot_tcs))
+ rn_env@((qual, unqual, tc_qual, tc_unqual), _)
= let
- name_flag_pairs :: Bag (OrigName, ExportFlag)
+ name_flag_pairs :: FiniteMap OrigName ExportFlag
name_flag_pairs
- = foldr from_ty
- (foldr from_cls
- (foldr from_sig
- (from_binds binds emptyBag{-init accum-})
- sigs)
- classdecls)
- typedecls
-
- sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
+ = foldr (from_wired True{-val-ish-})
+ (foldr (from_wired False{-tycon-ish-})
+ (foldr (from_dotdot True{-val-ish-})
+ (foldr (from_dotdot False{-tycon-ish-})
+ (foldr from_val
+ (foldr from_val
+ (foldr from_tc
+ (foldr from_tc emptyFM{-init accum-}
+ (eltsFM tc_unqual))
+ (eltsFM tc_qual))
+ (eltsFM unqual))
+ (eltsFM qual))
+ dotdot_tcs)
+ dotdot_vals)
+ (eltsFM builtinTcNamesMap))
+ (eltsFM builtinValNamesMap)
+
+ sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
in
+ --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
hPutStr if_hdl "\n__exports__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
where
- from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TySynonym n _ _ _) acc = maybe_add acc n
-
- from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
+ from_val rn acc
+ | fun_looking rn && exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_val" n
- from_sig (Sig n _ _ _) acc = maybe_add acc n
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
- from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
+ from_tc rn acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_tc" n
- --------------
- maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag)
+ from_dotdot is_valish (n,ef) acc
+ | is_valish && isLexCon str = acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ on = origName "from_dotdot" n
+ (OrigName _ str) = on
- maybe_add acc rn
- | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
+ from_wired is_val_ish rn acc
+ | is_val_ish && not (fun_looking rn)
+ = acc -- these things don't cause export-ery
+ | exportFlagOn ef = addToFM acc on ef
| otherwise = acc
where
n = getName rn
- ef = nameExportFlag n
-
- --------------
- maybe_add_list acc [] = acc
- maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
+ ef = export_fn n
+ on = origName "from_wired" n
--------------
lexical_lt (n1,_) (n2,_) = n1 < n2
\end{code}
\begin{code}
+non_wired x = not (isWiredInName (getName x)) --ToDo:move?
+
ifaceDecls Nothing{-no iface handle-} _ = return ()
ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
ASSERT(all isLocallyDefined tycons)
ASSERT(all isLocallyDefined classes)
let
- non_wired x = not (isWiredInName (getName x))
-
nonwired_classes = filter non_wired classes
nonwired_tycons = filter non_wired tycons
nonwired_vals = filter non_wired vals
sorted_vals = sortLt lt_lexical nonwired_vals
in
if (null sorted_classes && null sorted_tycons && null sorted_vals) then
- -- You could have a module with just instances in it
+ -- You could have a module with just (re-)exports/instances in it
return ()
else
hPutStr if_hdl "\n__declarations__\n" >>
forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
renumbered_ty = initNmbr (nmbrType forall_ty)
in
- uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi]
+ case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
+ uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
\end{code}
%************************************************************************
pp_sig v (initNmbr (nmbrType ty))
pp_sig op ty
- = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi]
+ = case (splitForAllTy ty) of { (tvs, rho_ty) ->
+ uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }
+
+ppr_forall [] = uppNil
+ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff