%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename1]{@Rename1@: gather up imported information}
+\section[RnPass1]{@RnPass1@: gather up imported information}
See the @Rename@ module for a basic description of the renamer.
\begin{code}
#include "HsVersions.h"
-module Rename1 (
- rnModule1,
+module RnPass1 (
+ rnModule1
-- for completeness
- Module, Bag, ProtoNamePat(..), InPat, Maybe,
- PprStyle, Pretty(..), PrettyRep, ProtoName, Name,
- PreludeNameFun(..), PreludeNameFuns(..)
) where
-IMPORT_Trace -- ToDo: rm
-import Pretty -- these two too
-import Outputable
-
-import AbsSyn
-import AbsSynFuns ( getMentionedVars ) -- *** not via AbsSyn ***
-import Bag ( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList )
-import Errors
-import HsPragmas
-import FiniteMap
-import Maybes ( maybeToBool, catMaybes, Maybe(..) )
---OLD: import NameEnv ( mkStringLookupFn )
-import ProtoName ( ProtoName(..), mkPreludeProtoName )
-import RenameAuxFuns
-import RenameMonad12
-import Util
+import Ubiq{-uitous-}
+
+import HsSyn
+import HsPragmas ( DataPragmas(..) )
+import RdrHsSyn -- ProtoName* instantiations...
+
+import Bag ( emptyBag, unitBag, snocBag, unionBags, Bag )
+import ErrUtils
+import FiniteMap ( lookupFM, listToFM, elementOf )
+import Maybes ( catMaybes, maybeToBool )
+import Name ( Name{-instances-} )
+import Outputable ( isAvarid, getLocalName, interpp'SP )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import ProtoName ( mkPreludeProtoName, ProtoName(..) )
+import RnMonad12
+import RnUtils
+import Util ( lengthExceeds, panic )
\end{code}
-
%************************************************************************
%* *
\subsection{Types and things used herein}
data Wantedness
= Wanted
| NotWanted
- | WantedWith IE
+ | WantedWith (IE ProtoName)
\end{code}
The @ProtoNames@ supplied to these ``name functions'' are always
@Unks@, unless they are fully-qualified names, which occur only in
interface pragmas (and, therefore, never on the {\em definitions} of
-things). That doesn't happen in @Rename1@!
+things). That doesn't happen in @RnPass1@!
\begin{code}
type IntNameFun = ProtoName -> ProtoName
type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
unused ones.
\begin{code}
-rnModule1 :: PreludeNameFuns
+rnModule1 :: PreludeNameMappers
-> Bool -- see use below
- -> ProtoNameModule
- -> Rn12M (ProtoNameModule, [FAST_STRING])
+ -> ProtoNameHsModule
+ -> Rn12M (ProtoNameHsModule, Bag FAST_STRING)
rnModule1 pnf@(v_pnf, tc_pnf)
use_mentioned_vars_heuristic
- (Module mod_name exports imports fixes
- ty_decls absty_sigs class_decls inst_decls specinst_sigs
- defaults binds _ src_loc)
+ (HsModule mod_name exports imports fixes
+ ty_decls absty_sigs class_decls inst_decls specinst_sigs
+ defaults binds _ src_loc)
= -- slurp through the *body* of the module, collecting names of
-- mentioned *variables*, 3+ letters long & not prelude names.
-- Note: we *do* have to pick up top-level binders,
-- so we can check for conflicts with imported guys!
let
-{- OLD:MENTIONED-}
+ is_mentioned_fn = \ x -> True -- wimp way out
+{- OLD:
(uses_Mdotdot_in_exports, mentioned_vars)
= getMentionedVars v_pnf exports fixes class_decls inst_decls binds
-- us this, and we act accordingly.
is_mentioned_maybe
- = lookupFM {-OLD: mkStringLookupFn-} (listToFM
+ = lookupFM (listToFM
[ (x, panic "is_mentioned_fn")
| x <- mentioned_vars ++ needed_for_deriving ]
)
- -- OLD: False{-not-sorted-}
where
needed_for_deriving -- is this a HACK or what?
= [ SLIT("&&"),
&& not (uses_Mdotdot_in_exports)
then \ x -> maybeToBool (is_mentioned_maybe x)
else \ x -> True
-{- OLD:MENTIONED-}
---O:M is_mentioned_fn = \ x -> True -- ToDo: delete altogether
+-}
in
-- OK, now do the business:
doImportedIfaces pnf is_mentioned_fn imports
inst_decls' = doRevoltingInstDecls tc_nf inst_decls
in
returnRn12
- ((Module mod_name
- exports imports -- passed along mostly for later checking
- (int_fixes ++ fixes)
- (int_ty_decls ++ ty_decls)
- absty_sigs
- (int_class_decls ++ class_decls)
- (int_inst_decls ++ inst_decls')
- specinst_sigs
- defaults
- binds
- int_sigs
- src_loc),
- bagToList import_names)
+ ((HsModule mod_name
+ exports imports -- passed along mostly for later checking
+ (int_fixes ++ fixes)
+ (int_ty_decls ++ ty_decls)
+ absty_sigs
+ (int_class_decls ++ class_decls)
+ (int_inst_decls ++ inst_decls')
+ specinst_sigs
+ defaults
+ binds
+ int_sigs
+ src_loc),
+ import_names)
where
-- This function just spots prelude names
tc_nf pname@(Unk s) = case (tc_pnf s) of
doRevoltingInstDecls tc_nf decls
= map revolt_me decls
where
- revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc)
+ revolt_me (InstDecl cname ty binds True modname uprags pragma src_loc)
= InstDecl
- context -- Context unchanged
(tc_nf cname) -- Look up the class
- (doIfaceMonoType1 tc_nf ty) -- Ditto the type
+ (doIfacePolyType1 tc_nf ty) -- Ditto the type
binds -- Binds unchanged
- True
+ True{-yes,defined in this module-}
modname
- imod
uprags
pragma
src_loc
module being renamed.
\begin{code}
-doImportedIfaces :: PreludeNameFuns
+doImportedIfaces :: PreludeNameMappers
-> (FAST_STRING -> Bool)
-> [ProtoNameImportedInterface]
-> Rn12M AllIntDecls
\end{code}
\begin{code}
-doOneIface pnfs is_mentioned_fn (ImportAll int renamings)
- = let
- renaming_fn = mkRenamingFun renamings
- -- if there are any renamings, then we don't use
- -- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns)
- revised_is_mentioned_fn
- = if null renamings
- then is_mentioned_fn
- else (\ x -> True) -- pretend everything is mentioned
- in
--- pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) (
- doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int
--- )
-
-doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings)
- = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) (
- doIface1 (mkRenamingFun renamings) pnfs si_fun int
- --)
+doOneIface :: PreludeNameMappers
+ -> (FAST_STRING -> Bool)
+ -> ProtoNameImportedInterface
+ -> Rn12M AllIntDecls
+
+doOneIface _ _ (ImportMod _ True{-qualified-} _ _)
+ = panic "RnPass1.doOneIface:can't grok `qualified'"
+
+doOneIface _ _ (ImportMod _ _ (Just _) _)
+ = panic "RnPass1.doOneIface:can't grok `as' module (blech)"
+
+doOneIface pnfs is_mentioned_fn (ImportMod iface qual asmod Nothing{-all-})
+ = doIface1 pnfs (selectAll is_mentioned_fn) iface
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (False{-unhidden-}, ies)))
+ = doIface1 pnfs si_fun iface
where
-- the `selective import' function should not be applied
-- to the Imps that occur on Ids in unfoldings.
- si_fun (Unk str) = check_ie str ie_list
- si_fun other = panic "si_fun in doOneIface"
+ si_fun (Unk n) = check_ie n ies
+ si_fun (Qunk _ n) = check_ie n ies
check_ie name [] = NotWanted
check_ie name (ie:ies)
= case ie of
- IEVar n | name == n -> Wanted
- IEThingAbs n | name == n -> WantedWith ie
- IEThingAll n | name == n -> WantedWith ie
- IEConWithCons n ns | name == n -> WantedWith ie
- IEClsWithOps n ns | name == n -> WantedWith ie
- IEModuleContents _ -> panic "Module.. in import list?"
- other -> check_ie name ies
-
-doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings)
- = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) (
- doIface1 (mkRenamingFun renamings) pnfs si_fun int
- --)
+ IEVar (Unk n) | name == n -> Wanted
+ IEThingAbs (Unk n) | name == n -> WantedWith ie
+ IEThingAll (Unk n) | name == n -> WantedWith ie
+ IEModuleContents _ -> panic "Module.. in import list?"
+ other -> check_ie name ies
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (True{-hidden-}, ies)))
+ = doIface1 pnfs si_fun iface
where
-- see comment above:
- si_fun (Unk str) | str `elemFM` entity_info = NotWanted
- | otherwise = Wanted
+ si_fun x | n `elementOf` entity_info = NotWanted
+ | otherwise = Wanted
+ where
+ n = case x of { Unk s -> s; Qunk _ s -> s }
- entity_info = fst (getIEStrings ie_list)
+ entity_info = getImportees ies
\end{code}
@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
quite happy to throw away short names that aren't mentioned?
\begin{code}
-selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter
+selectAll :: (FAST_STRING -> Bool) -> SelectiveImporter
-selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk
+selectAll is_mentioned_fn n
= let
- rn_str = renaming_fn str
+ rn_str = case n of { Unk s -> s ; Qunk _ s -> s }
in
if (isAvarid rn_str)
&& (not (is_mentioned_fn rn_str))
be described at its definition.
\begin{code}
-doIface1 :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> PreludeNameFuns
- -> SelectiveImporter
- -> ProtoNameInterface
- -> Rn12M AllIntDecls
-
-doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun
- (MkInterface i_name import_decls fix_decls ty_decls class_decls
+doIface1 :: PreludeNameMappers
+ -> SelectiveImporter
+ -> ProtoNameInterface
+ -> Rn12M AllIntDecls
+
+doIface1 (v_pnf, tc_pnf) sifun
+ (Interface i_name import_decls fix_decls ty_decls class_decls
inst_decls sig_decls anns)
- = doIfaceImports1 mod_rn_fn i_name import_decls `thenRn12` \ (v_bag, tc_bag) ->
+ = doIfaceImports1 (panic "i_name"{-i_name-}) import_decls `thenRn12` \ (v_bag, tc_bag) ->
do_body (v_bag, tc_bag)
where
do_body (v_bag, tc_bag)
= report_all_errors `thenRn12` \ _ ->
- doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' ->
+ doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' ->
doIfaceClassDecls1 sifun full_tc_nf class_decls `thenRn12` \ class_decls' ->
- let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls
- fix_decls' = doIfaceFixes1 sifun v_nf fix_decls
- inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
+ let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls
+ fix_decls' = doIfaceFixes1 sifun v_nf fix_decls
+ inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
in
returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
where
v_dups :: [[(FAST_STRING, ProtoName)]]
tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
- (imp_v_nf, v_dups) = mkNameFun {-OLD:v_pnf-} v_bag
- (imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag
+ (imp_v_nf, v_dups) = mkNameFun v_bag
+ (imp_tc_nf, tc_dups) = mkNameFun tc_bag
v_nf :: IntNameFun
v_nf (Unk s) = case v_pnf s of
Just n -> mkPreludeProtoName n
Nothing -> case imp_v_nf s of
Just n -> n
- Nothing -> Imp i_name s [i_name] (mod_rn_fn s)
+ Nothing -> Imp i_name s [i_name] s
+ -- used for (..)'d parts of prelude datatype/class decls
prel_con_or_op_nf :: FAST_STRING{-module name-}-> IntNameFun
- -- Used for (..)'d parts of prelude datatype/class decls;
- -- OLD:? For `data' types, we happen to know everything;
- -- OLD:? For class decls, we *don't* know what the class-ops are.
prel_con_or_op_nf m (Unk s)
= case v_pnf s of
Just n -> mkPreludeProtoName n
- Nothing -> Imp m s [m] (mod_rn_fn s)
+ Nothing -> Imp m s [m] s
-- Strictly speaking, should be *no renaming* here, folks
- local_con_or_op_nf :: IntNameFun
- -- used for non-prelude constructors/ops
- local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s)
+ -- used for non-prelude constructors/ops/fields
+ local_con_or_op_nf :: IntNameFun
+ local_con_or_op_nf (Unk s) = Imp i_name s [i_name] s
full_tc_nf :: IntTCNameFun
full_tc_nf (Unk s)
Nothing -> case imp_tc_nf s of
Just pair -> pair
- Nothing -> (Imp i_name s [i_name] (mod_rn_fn s),
- local_con_or_op_nf)
+ Nothing -> (Imp i_name s [i_name] s,
+ local_con_or_op_nf)
tc_nf = fst . full_tc_nf
- -- ADR: commented out next new lines because I don't believe
- -- ADR: the check is useful or required by the Standard. (It
- -- ADR: also messes up the interpreter.)
+ -- ADR: commented out next new lines because I don't believe
+ -- ADR: the check is useful or required by the Standard. (It
+ -- ADR: also messes up the interpreter.)
tc_errs = [] -- map (map (fst . snd)) tc_dups
-- Ugh! Just keep the dup'd protonames
\begin{code}
doIfaceImports1
- :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> FAST_STRING -- name of module whose interface we're doing
- -> [IfaceImportDecl]
+ :: FAST_STRING -- name of module whose interface we're doing
+ -> [IfaceImportDecl ProtoName]
-> Rn12M ImportNameBags
-doIfaceImports1 _ _ [] = returnRn12 (emptyBag, emptyBag)
+doIfaceImports1 _ [] = returnRn12 (emptyBag, emptyBag)
-doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest)
- = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) ->
- doIfaceImports1 mod_rn_fn int_mod_name rest `thenRn12` \ (vb2, tcb2) ->
--- pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) (
+doIfaceImports1 int_mod_name (imp_decl1 : rest)
+ = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) ->
+ doIfaceImports1 int_mod_name rest `thenRn12` \ (vb2, tcb2) ->
returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
--- )
where
- do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc)
+ do_decl (IfaceImportDecl orig_mod_name imports src_loc)
= -- Look at the renamings to get a suitable renaming function
- doRenamings mod_rn_fn int_mod_name orig_mod_name renamings
+ doRenamings{-not really-} int_mod_name orig_mod_name
`thenRn12` \ (orig_to_pn, local_to_pn) ->
-- Now deal with one import at a time, combining results.
returning a bag which maps local names to original names.
\begin{code}
-doIfaceImport1 :: ( FAST_STRING -- Original local name
+doIfaceImport1 :: ( ProtoName -- Original local name
-> (FAST_STRING, -- Local name in this interface
ProtoName) -- Its full protoname
- )
-
+ )
+
-> IntNameFun -- Local name to ProtoName; use for
-- constructors and class ops
-
+
-> ImportNameBags -- Accumulator
- -> IE -- An item in the import list
+ -> (IE ProtoName) -- An item in the import list
-> ImportNameBags
doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
= int_import1_help orig_to_pn local_to_pn acc orig_name
-- the next ones will go away with 1.3:
+{- OLD:
doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
= int_import1_help orig_to_pn local_to_pn acc orig_name
doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
= int_import1_help orig_to_pn local_to_pn acc orig_name
+-}
doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
- = panic "Rename1: strange import decl"
+ = panic "RnPass1: strange import decl"
-- Little help guy...
It can produce errors, if there is a domain clash on the renamings.
\begin{code}
---pprTrace
---instance Outputable _PackedString where
--- ppr sty s = ppStr (_UNPK_ s)
-
-doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> FAST_STRING -- Name of the module whose interface we're working on
+doRenamings :: FAST_STRING -- Name of the module whose interface we're working on
-> FAST_STRING -- Original-name module for these renamings
- -> [Renaming] -- Renamings
-> Rn12M
- ((FAST_STRING -- Original local name to...
+ ((ProtoName -- Original local name to...
-> (FAST_STRING, -- ... Local name in this interface
- ProtoName) -- ... Its full protoname
- ),
+ ProtoName) -- ... Its full protoname
+ ),
IntNameFun) -- Use for constructors, class ops
-doRenamings mod_rn_fn int_mod orig_mod []
+doRenamings int_mod orig_mod
= returnRn12 (
- \ s ->
- let
- result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s))
- in
--- pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
- result
--- )
- ,
-
\ (Unk s) ->
let
- result = Imp orig_mod s [int_mod] (mod_rn_fn s)
+ result = (s, Imp orig_mod s [int_mod] s)
in
--- pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
result
--- )
- )
-
-doRenamings mod_rn_fn int_mod orig_mod renamings
- = let
- local_rn_fn = mkRenamingFun renamings
- in
- --pprTrace "local_rns:" (ppr PprDebug renamings) (
- returnRn12 (
- \ s ->
- let
- local_name = local_rn_fn s
- result
- = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name))
- in
--- pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
- result
--- )
,
\ (Unk s) ->
let
- result
- = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s))
+ result = Imp orig_mod s [int_mod] s
in
--- pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
result
--- )
)
- --)
-\end{code}
-
-\begin{code}
-mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING
-
-mkRenamingFun [] = \ s -> s
-mkRenamingFun renamings
- = let
- rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn
- [ (old, new) | MkRenaming old new <- renamings ]
- ) -- OLD: False {-not-sorted-}
- in
- \s -> case rn_fn s of
- Nothing -> s
- Just s' -> s'
\end{code}
-
%************************************************************************
%* *
\subsection{Type declarations}
= mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
returnRn12 (catMaybes decls_maybe)
where
- do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc)
+ do_decl (TySynonym tycon tyvars monoty src_loc)
= let
full_thing = returnRn12 (Just ty_decl')
in
- -- GHC doesn't allow derivings in interfaces
- (if null derivs
- then returnRn12 ()
- else addErrRn12 (derivingInIfaceErr tycon derivs src_loc)
- ) `thenRn12` \ _ ->
+ case (sifun tycon) of
+ NotWanted -> returnRn12 Nothing
+ Wanted -> full_thing
+ WantedWith (IEThingAll _) -> full_thing
+ WantedWith weird_ie -> full_thing
+ where
+ (tycon_name,_) = full_tc_nf tycon
+ tc_nf = fst . full_tc_nf
+ monoty' = doIfaceMonoType1 tc_nf monoty
+ ty_decl' = TySynonym tycon_name tyvars monoty' src_loc
+
+ do_decl (TyData context tycon tyvars condecls derivs pragmas src_loc)
+ = do_data context tycon condecls derivs pragmas src_loc `thenRn12` \ done_data ->
+ case done_data of
+ Nothing -> returnRn12 Nothing
+ Just (context', tycon', condecls', derivs', pragmas') ->
+ returnRn12 (Just (TyData context' tycon' tyvars condecls' derivs' pragmas' src_loc))
+
+ do_decl (TyNew context tycon tyvars condecl derivs pragmas src_loc)
+ = do_data context tycon condecl derivs pragmas src_loc `thenRn12` \ done_data ->
+ case done_data of
+ Nothing -> returnRn12 Nothing
+ Just (context', tycon', condecl', derivs', pragmas') ->
+ returnRn12 (Just (TyNew context' tycon' tyvars condecl' derivs' pragmas' src_loc))
+
+ --------------------------------------------
+ do_data context tycon condecls derivs (DataPragmas hidden_cons specs) src_loc
+ = let
+ full_thing = Just (context', tycon_name, condecls', deriv', (pragmas' False))
+ abs_thing = Just (context', tycon_name, [], deriv', (pragmas' True))
+ in
case (sifun tycon) of
NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
- WantedWith (IEThingAbs _) -> returnRn12 (Just abs_ty_decl')
- WantedWith ie@(IEConWithCons _ _) -> full_thing
+ Wanted -> returnRn12 full_thing
+ WantedWith (IEThingAll _) -> returnRn12 full_thing
+ WantedWith (IEThingAbs _) -> returnRn12 abs_thing
WantedWith really_weird_ie -> -- probably a typo in the pgm
addErrRn12 (weirdImportExportConstraintErr
tycon really_weird_ie src_loc) `thenRn12` \ _ ->
- full_thing
+ returnRn12 full_thing
where
- (tycon_name, constr_nf) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
+ (tycon_name, constrfield_nf) = full_tc_nf tycon
+ tc_nf = fst . full_tc_nf
- condecls' = map (do_condecl constr_nf tc_nf) condecls
- hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons
+ condecls' = map (do_condecl constrfield_nf tc_nf) condecls
+ hidden_cons' = map (do_condecl constrfield_nf tc_nf) hidden_cons
pragmas' invent_hidden
= DataPragmas (if null hidden_cons && invent_hidden
- then condecls' -- if importing abstractly but condecls were
- -- exported we add them to the data pragma
+ then condecls' -- if importing abstractly but condecls were
+ -- exported we add them to the data pragma
else hidden_cons')
specs {- ToDo: do_specs -}
context' = doIfaceContext1 tc_nf context
- deriv' = map tc_nf derivs -- rename derived classes
+ deriv' = case derivs of
+ Nothing -> Nothing
+ Just ds -> panic "doIfaceTyDecls1:derivs" -- Just (map tc_nf ds)
+ -- rename derived classes
- ty_decl' = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc
- abs_ty_decl'= TyData context' tycon_name tyvars [] deriv' (pragmas' True) src_loc
+ --------------------------------------------
+ -- one name fun for the data constructor, another for the type:
- do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
- = let
- full_thing = returnRn12 (Just ty_decl')
- in
- case (sifun tycon) of
- NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
+ do_condecl cf_nf tc_nf (ConDecl name tys src_loc)
+ = ConDecl (cf_nf name) (map (do_bang tc_nf) tys) src_loc
- WantedWith weird_ie -> full_thing
- where
- (tycon_name,_) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
- monoty' = doIfaceMonoType1 tc_nf monoty
- ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc
+ do_condecl cf_nf tc_nf (ConOpDecl ty1 op ty2 src_loc)
+ = ConOpDecl (do_bang tc_nf ty1) (cf_nf op) (do_bang tc_nf ty2) src_loc
- -- one name fun for the data constructor, another for the type:
+ do_condecl cf_nf tc_nf (NewConDecl name ty src_loc)
+ = NewConDecl (cf_nf name) (doIfaceMonoType1 tc_nf ty) src_loc
+
+ do_condecl cf_nf tc_nf (RecConDecl con fields src_loc)
+ = RecConDecl (cf_nf con) (map do_field fields) src_loc
+ where
+ do_field (var, ty) = (cf_nf var, do_bang tc_nf ty)
- do_condecl c_nf tc_nf (ConDecl name tys src_loc)
- = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc
+ --------------------------------------------
+ do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty)
+ do_bang tc_nf (Unbanged ty) = Unbanged (doIfaceMonoType1 tc_nf ty)
\end{code}
%************************************************************************
= let
full_thing = returnRn12 (Just class_decl')
in
- case (sifun cname) of
+ case (sifun cname) of
NotWanted -> returnRn12 Nothing
Wanted -> full_thing
WantedWith (IEThingAll _) -> full_thing
---??? WantedWith (IEThingAbs _) -> returnRn12 (Just abs_class_decl')
- WantedWith (IEClsWithOps _ _) -> full_thing
-- ToDo: add checking of IEClassWithOps
WantedWith really_weird_ie -> -- probably a typo in the pgm
addErrRn12 (weirdImportExportConstraintErr
\begin{code}
doIfaceInstDecls1 :: SelectiveImporter
- -> IntNameFun
+ -> IntNameFun
-> [ProtoNameInstDecl]
-> [ProtoNameInstDecl]
doIfaceInstDecls1 si tc_nf inst_decls
= catMaybes (map do_decl inst_decls)
where
- do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc)
+ do_decl (InstDecl cname ty EmptyMonoBinds False modname uprags pragmas src_loc)
= case (si cname, tycon_reqd) of
(NotWanted, NotWanted) -> Nothing
_ -> Just inst_decl'
where
- context' = doIfaceContext1 tc_nf context
- ty' = doIfaceMonoType1 tc_nf ty
+ ty' = doIfacePolyType1 tc_nf ty
- inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc
+ inst_decl' = InstDecl (tc_nf cname) ty' EmptyMonoBinds False modname uprags pragmas src_loc
- tycon_reqd
+ tycon_reqd = _trace "RnPass1.tycon_reqd" NotWanted
+{- LATER:
= case getNonPrelOuterTyCon ty of
Nothing -> NotWanted -- Type doesn't have a user-defined tycon
-- at its outermost level
Just tycon -> si tycon -- It does, so look up in the si-fun
+-}
\end{code}
%************************************************************************
\begin{code}
doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
-doIfacePolyType1 tc_nf (UnoverloadedTy ty)
- = UnoverloadedTy (doIfaceMonoType1 tc_nf ty)
+doIfacePolyType1 tc_nf (HsPreForAllTy ctxt ty)
+ = HsPreForAllTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
-doIfacePolyType1 tc_nf (OverloadedTy ctxt ty)
- = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
+doIfacePolyType1 tc_nf (HsForAllTy tvs ctxt ty)
+ = HsForAllTy tvs (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
\end{code}
\begin{code}
\begin{code}
-doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType]
-doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys
-\end{code}
-
-
-\begin{code}
doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
-doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar
+doIfaceMonoType1 tc_nf tv@(MonoTyVar _) = tv
-doIfaceMonoType1 tc_nf (ListMonoTy ty)
- = ListMonoTy (doIfaceMonoType1 tc_nf ty)
+doIfaceMonoType1 tc_nf (MonoListTy ty)
+ = MonoListTy (doIfaceMonoType1 tc_nf ty)
-doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2)
- = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
+doIfaceMonoType1 tc_nf (MonoFunTy ty1 ty2)
+ = MonoFunTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
-doIfaceMonoType1 tc_nf (TupleMonoTy tys)
- = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys)
+doIfaceMonoType1 tc_nf (MonoTupleTy tys)
+ = MonoTupleTy (map (doIfaceMonoType1 tc_nf) tys)
-doIfaceMonoType1 tc_nf (MonoTyCon name tys)
- = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys)
+doIfaceMonoType1 tc_nf (MonoTyApp name tys)
+ = MonoTyApp (tc_nf name) (map (doIfaceMonoType1 tc_nf) tys)
+\end{code}
-#ifdef DPH
-doIfaceMonoType1 tc_nf (MonoTyProc tys ty)
- = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty)
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
-doIfaceMonoType1 tc_nf (MonoTyPod ty)
- = MonoTyPod (doIfaceMonoType1 tc_nf ty)
-#endif {- Data Parallel Haskell -}
+\begin{code}
+duplicateImportsInInterfaceErr iface dups
+ = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
+
+weirdImportExportConstraintErr thing constraint locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "Illegal import/export constraint on `",
+ ppr sty thing,
+ ppStr "': ", ppr PprForUser constraint])
\end{code}
projects / ghc-hetmet.git / blobdiff