ifacePragmas
) where
-import Ubiq{-uitous-}
+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, dataConSig, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
-import Name ( nameOrigName, origName, nameOf,
+import Maybes ( maybeToBool )
+import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- ltLexical, isExported, getExportFlag,
- isLexSym, isLocallyDefined,
+ isLexSym, isLexCon, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
+ OrigName(..){-instance Ord-},
Name{-instance NamedThing-}
)
import ParseUtils ( UsagesMap(..), VersionsMap(..) )
import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
+--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)
ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
ppr_name n
- = let
- on = origName n
- s = nameOf on
- pp = prettyToUn (ppr PprInterface on)
- in
- (if isLexSym s then uppParens else id) pp
-ppr_unq_name n
- = let
- on = origName n
- s = nameOf on
- pp = uppPStr s
- in
- (if isLexSym s then uppParens else id) pp
+ = case (origName "ppr_name" n) of { OrigName m s ->
+ uppBesides [uppPStr m, uppChar '.', uppPStr s] }
\end{code}
We have a function @startIface@ to open the output file and put
-> 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 = 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...
upp_uses (m, (mv, versions))
- = uppBesides [uppPStr m, uppSP, uppPStr SLIT(" :: "),
+ = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
upp_versions (fmToList versions), uppSemi]
upp_versions nvs
- = uppIntersperse upp'SP{-'-} [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
+ = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
| otherwise
= hPutStr if_hdl "\n__versions__\n" >>
hPutStr if_hdl (uppShow 0 (upp_versions version_list))
+ -- NB: when compiling Prelude.hs, this will spew out
+ -- stuff for [], (), (,), etc. [i.e., builtins], which
+ -- we'd rather it didn't. The version-mangling in
+ -- the driver will ignore them.
where
version_list = fmToList version_info
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 (Name, 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 (Name, ExportFlag) -> RnName -> Bag (Name, 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` (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,_) = nameOrigName n1 < nameOrigName n2
+ lexical_lt (n1,_) (n2,_) = n1 < n2
--------------
- upp_pair (n, ef)
- = uppBeside (ppr_name n) (upp_export ef)
+ upp_pair (OrigName m n, ef)
+ = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
where
upp_export ExportAll = uppPStr SLIT("(..)")
upp_export ExportAbs = uppNil
ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
= let
- local_fixities = filter from_here fixities
+ pp_fixities = foldr go [] fixities
in
- if null local_fixities then
+ if null pp_fixities then
return ()
else
hPutStr if_hdl "\n__fixities__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities)))
+ hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
where
- from_here (InfixL v _) = isLocallyDefined v
- from_here (InfixR v _) = isLocallyDefined v
- from_here (InfixN v _) = isLocallyDefined v
+ go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
+ go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
+ go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc
+
+ print_fix suff prec var
+ = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
\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, _)
- = let
--- exported_classes = filter isExported classes
--- exported_tycons = filter isExported tycons
- exported_vals = filter isExported vals
-
- sorted_classes = sortLt ltLexical classes
- sorted_tycons = sortLt ltLexical tycons
- sorted_vals = sortLt ltLexical exported_vals
+ = ASSERT(all isLocallyDefined vals)
+ ASSERT(all isLocallyDefined tycons)
+ ASSERT(all isLocallyDefined classes)
+ let
+ nonwired_classes = filter non_wired classes
+ nonwired_tycons = filter non_wired tycons
+ nonwired_vals = filter non_wired vals
+
+ lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
+
+ sorted_classes = sortLt lt_lexical nonwired_classes
+ sorted_tycons = sortLt lt_lexical nonwired_tycons
+ 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" >>
ifaceInstances (Just if_hdl) (_, _, _, insts)
= let
- exported_insts = filter is_exported_inst (bagToList insts)
+ togo_insts = filter is_togo_inst (bagToList insts)
- sorted_insts = sortLt lt_inst exported_insts
+ sorted_insts = sortLt lt_inst togo_insts
in
- if null exported_insts then
+ if null togo_insts then
return ()
else
hPutStr if_hdl "\n__instances__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
where
- is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
+ is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
= from_here -- && ...
-------
tycon1 = fst (getAppTyCon ty1)
tycon2 = fst (getAppTyCon ty2)
in
- case (origName clas1 `cmp` origName clas2) of
+ case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
LT_ -> True
GT_ -> False
- EQ_ -> origName tycon1 < origName tycon2
+ EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
-------
pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
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}
%************************************************************************
case (initNmbr (nmbrClass c)) of { -- renumber it!
Class _ n tyvar super_classes sdsels ops sels defms insts links ->
- uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes,
+ uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
ppr_name n, ppr_tyvar tyvar,
if null ops
then uppSemi
else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
}
where
- ppr_theta :: TyVar -> [Class] -> Unpretty
+ ppr_context :: TyVar -> [Class] -> Unpretty
- ppr_theta tv [] = uppNil
- ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
- ppr_theta tv super_classes
- = uppBesides [uppLparen,
+ ppr_context tv [] = uppNil
+-- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
+ ppr_context tv super_classes
+ = uppBesides [uppStr "{{",
uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
- uppStr ") =>"]
+ uppStr "}} =>"]
ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
- ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
+ clas_mod = moduleOf (origName "ppr_class" c)
+
+ ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
\end{code}
\begin{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}
ppr_tc (initNmbr (nmbrTyCon tycon))
------------------------
-ppr_tc (PrimTyCon _ n _)
+ppr_tc (PrimTyCon _ n _ _)
= uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
ppr_tc FunTyCon
ppr_context ctxt,
ppr_name n,
uppIntersperse uppSP (map ppr_tyvar tvs),
- pp_unabstract_condecls,
+ uppEquals, pp_condecls,
uppSemi]
-- NB: we do not print deriving info in interfaces
where
NewType -> uppPStr SLIT("newtype")
ppr_context [] = uppNil
- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
+-- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
ppr_context cs
- = uppBesides[uppLparen,
+ = uppBesides[uppStr "{{",
uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
- uppRparen, uppPStr SLIT(" =>")]
-
- yes_we_print_condecls
- = case (getExportFlag n) of
- ExportAbs -> False
- other -> True
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then uppCat [uppEquals, pp_condecls]
- else uppNil
+ uppStr "}}", uppPStr SLIT(" =>")]
pp_condecls
= let
ppr_con con
= let
- (_, _, con_arg_tys, _) = dataConSig con
+ con_arg_tys = dataConRawArgTys con
labels = dataConFieldLabels con -- none if not a record
strict_marks = dataConStrictMarks con
in
- uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
+ uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
ppr_fields labels strict_marks con_arg_tys
= if null labels then -- not a record thingy
(prettyToUn (pprParendType PprInterface t))
ppr_field l b t
- = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "),
+ = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
ppr_ty t]
\end{code}
projects / ghc-hetmet.git / blobdiff