gdrhs gdpat valrhs
lampats cexps
-%type <umaybe> maybeexports impas maybeimpspec deriving
-
-%type <ueither> impspec
+%type <umaybe> maybeexports impspec deriving
%type <uliteral> lit_constant
VARID CONID VARSYM CONSYM
var con varop conop op
vark varid varsym varsym_nominus
- tycon modid impmod ccallid
+ tycon modid ccallid
%type <uqid> QVARID QCONID QVARSYM QCONSYM
qvarid qconid qvarsym qconsym
%type <uentid> export import
-%type <ulong> commas impqual
+%type <ulong> commas
/**********************************************************************
* *
;
-impdecl : importkey impqual impmod impas maybeimpspec
- {
- $$ = lsing(mkimport($3,$2,$4,$5,startlineno));
- }
- ;
-
-impmod : modid { $$ = $1; }
- ;
-
-impqual : /* noqual */ { $$ = 0; }
- | QUALIFIED { $$ = 1; }
- ;
-
-impas : /* noas */ { $$ = mknothing(); }
- | AS modid { $$ = mkjust($2); }
- ;
-
-maybeimpspec : /* empty */ { $$ = mknothing(); }
- | impspec { $$ = mkjust($1); }
+impdecl : importkey modid impspec
+ { $$ = lsing(mkimport($2,0,mknothing(),$3,startlineno)); }
+ | importkey QUALIFIED modid impspec
+ { $$ = lsing(mkimport($3,1,mknothing(),$4,startlineno)); }
+ | importkey QUALIFIED modid AS modid impspec
+ { $$ = lsing(mkimport($3,1,mkjust($5),$6,startlineno)); }
;
-impspec : OPAREN CPAREN { $$ = mkleft(Lnil); }
- | OPAREN import_list CPAREN { $$ = mkleft($2); }
- | OPAREN import_list COMMA CPAREN { $$ = mkleft($2); }
- | HIDING OPAREN import_list CPAREN { $$ = mkright($3); }
- | HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3); }
+impspec : /* empty */ { $$ = mknothing(); }
+ | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
+ | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
+ | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
+ | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
+ | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
;
import_list:
import RnMonad
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
-import RnIfaces ( rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface )
+import RnIfaces ( findHiFiles, rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface )
import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
import MainMonad
import UniqSupply ( splitUniqSupply )
import Util ( panic, assertPanic )
-findHiFiles :: PrimIO (FiniteMap Module FAST_STRING)
-findHiFiles = returnPrimIO emptyFM
+opt_HiDirList = panic "opt_HiDirList"
\end{code}
\begin{code}
\begin{code}
renameModule b_names b_keys us
input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
- = findHiFiles `thenPrimIO` \ hi_files ->
+ = findHiFiles opt_HiDirList `thenPrimIO` \ hi_files ->
newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var ->
fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
in
getGlobalNames iface_var global_name_info us1 input
- `thenPrimIO` \ (occ_env, imp_mods, imp_fixes, top_errs, top_warns) ->
+ `thenPrimIO` \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
if not (isEmptyBag top_errs) then
returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
-- No top-level name errors so rename source ...
case initRn True mod occ_env us2
- (rnSource imp_mods imp_fixes input) of {
+ (rnSource imp_mods unqual_imps imp_fixes input) of {
((rn_module, export_fn, src_occs), src_errs, src_warns) ->
let
) where
import Ubiq
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+import RnLoop -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import HsPragmas ( isNoGenPragmas, noGenPragmas )
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecInfixBind )
+import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
(rnMethodBinds class_name mb2)
rnMethodBinds class_name (FunMonoBind occname inf matches locn)
- = pushSrcLocRn locn $
- lookupClassOp class_name occname `thenRn` \ op_name ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
--- checkPrecInfixBind inf op_name new_matches `thenRn_`
+ = pushSrcLocRn locn $
+ lookupClassOp class_name occname `thenRn` \ op_name ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
+ mapRn (checkPrecMatch inf op_name) new_matches `thenRn_`
returnRn (FunMonoBind op_name inf new_matches locn)
rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
)
flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
- = pushSrcLocRn locn $
- lookupValue name `thenRn` \ name' ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
--- checkPrecInfixBind inf name' new_matches `thenRn_`
+ = pushSrcLocRn locn $
+ lookupValue name `thenRn` \ name' ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+ mapRn (checkPrecMatch inf name') new_matches `thenRn_`
let
fvs = unionManyUniqSets fv_lists
module RnExpr (
rnMatch, rnGRHSsAndBinds, rnPat,
- checkPrecInfixBind
+ checkPrecMatch
) where
import Ubiq
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+import RnLoop -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import RdrHsSyn
\end{code}
\begin{code}
-checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s ()
+checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
-checkPrecInfixBind False fn pats
+checkPrecMatch False fn match
= returnRn ()
-checkPrecInfixBind True op [p1,p2]
+checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
= checkPrec op p1 False `thenRn_`
checkPrec op p2 True
+checkPrecMatch True op _
+ = panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _) right
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
getSrcLocRn `thenRn` \ src_loc ->
let
inf_ok = op1_prec > op_prec ||
- op1_prec == op_prec &&
- (op1_fix == INFIXR && op_fix == INFIXR && right ||
- op1_fix == INFIXL && op_fix == INFIXL && not right)
+ (op1_prec == op_prec &&
+ (op1_fix == INFIXR && op_fix == INFIXR && right ||
+ op1_fix == INFIXL && op_fix == INFIXL && not right))
info = (op,op_fix,op_prec)
info1 = (op1,op1_fix,op1_prec)
(infol, infor) = if right then (info, info1) else (info1, info)
-
- inf_err = precParseErr infol infor src_loc
in
- addErrIfRn (not inf_ok) inf_err
+ addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
checkPrec op (NegPatIn _) right
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
#include "HsVersions.h"
module RnIfaces (
+ findHiFiles,
cacheInterface,
readInterface,
rnInterfaces,
\begin{code}
type IfaceCache = MutableVar _RealWorld (FiniteMap Module ParsedIface,
- FiniteMap Module FAST_STRING)
+ FiniteMap Module String)
data ParsedIface = ParsedIface
+\end{code}
+
+*********************************************************
+* *
+\subsection{Looking for interface files}
+* *
+*********************************************************
+
+\begin{code}
+findHiFiles :: [String] -> PrimIO (FiniteMap Module String)
+findHiFiles dirs = returnPrimIO emptyFM
+\end{code}
+*********************************************************
+* *
+\subsection{Reading interface files}
+* *
+*********************************************************
+\begin{code}
cacheInterface :: IfaceCache -> Module
-> PrimIO (MaybeErr ParsedIface Error)
returnPrimIO (Succeeded iface)
-readInterface :: FAST_STRING -> Module
+readInterface :: String -> Module
-> PrimIO (MaybeErr ParsedIface Error)
readInterface file mod = panic "readInterface"
rnGetUnique, rnGetUniques,
newLocalNames,
- lookupValue, lookupValueMaybe,
- lookupTyCon, lookupClass, lookupClassOp,
+ lookupValue, lookupValueMaybe, lookupClassOp,
+ lookupTyCon, lookupClass, lookupTyConOrClass,
extendSS2, extendSS,
TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
lookupClass rdr
= lookup_tc rdr isRnClass mkRnImplicitClass "class"
+lookupTyConOrClass rdr
+ = lookup_tc rdr (\ rn -> isRnTyCon rn || isRnClass rn)
+ (panic "lookupTC:mk_implicit") "class or type constructor"
lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
= case lookupTcRnEnv env rdr of
-> UniqSupply
-> RdrNameHsModule
-> PrimIO (RnEnv,
- [Module],
- Bag RenamedFixityDecl,
+ [Module], -- directly imported modules
+ Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module
+ Bag RenamedFixityDecl, -- imported fixity decls
Bag Error,
Bag Warning)
of { ((src_vals, src_tcs), src_errs, src_warns) ->
getImportedNames iface_var info us2 imports `thenPrimIO`
- \ (imp_vals, imp_tcs, imp_mods, imp_fixes, imp_errs, imp_warns) ->
+ \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
let
unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
- returnPrimIO (all_env, bagToList imp_mods, imp_fixes, all_errs, all_warns)
+ returnPrimIO (all_env, bagToList imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
}
where
(us1, us2) = splitUniqSupply us
\begin{code}
getImportedNames ::
IfaceCache
- -> GlobalNameInfo -- builtin and knot name info
+ -> GlobalNameInfo -- builtin and knot name info
-> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> PrimIO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- Bag Module, -- directly imported modules
- Bag RenamedFixityDecl, -- fixity info for imported names
+ -> [RdrNameImportDecl] -- import declarations
+ -> PrimIO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ Bag Module, -- directly imported modules
+ Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
Bag Error,
Bag Warning)
getImportedNames iface_var info us imports
- = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag)
+ = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
where
-- For now jsut add the builtin names ...
(b_names,_,_,_) = info
module RnSource ( rnSource, rnPolyType ) where
import Ubiq
-import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
import HsSyn
import HsPragmas
import RnMonad
import RnBinds ( rnTopBinds, rnMethodBinds )
-import Bag ( bagToList )
+import Bag ( emptyBag, unitBag, consBag, unionManyBags, listToBag, bagToList )
import Class ( derivableClassKeys )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
-import Name ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
+import Name ( Name, isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
import UniqFM ( addListToUFM, listToUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isn'tIn, panic, assertPanic )
+import Util ( isIn, isn'tIn, sortLt, panic, assertPanic )
-rnExports mods Nothing = returnRn (\n -> ExportAll)
-rnExports mods (Just exps) = returnRn (\n -> ExportAll)
\end{code}
rnSource `renames' the source module and export list.
\begin{code}
-rnSource :: [Module] -- imported modules
+rnSource :: [Module]
+ -> Bag (Module,(RnName,ExportFlag)) -- unqualified imports from module
-> Bag RenamedFixityDecl -- fixity info for imported names
-> RdrNameHsModule
-> RnM s (RenamedHsModule,
Name -> ExportFlag, -- export info
Bag (RnName, RdrName)) -- occurrence info
-rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
- ty_decls specdata_sigs class_decls
- inst_decls specinst_sigs defaults
- binds _ src_loc)
+rnSource imp_mods unqual_imps imp_fixes
+ (HsModule mod version exports _ fixes
+ ty_decls specdata_sigs class_decls
+ inst_decls specinst_sigs defaults
+ binds _ src_loc)
= pushSrcLocRn src_loc $
- rnExports (mod:imp_mods) exports `thenRn` \ exported_fn ->
- rnFixes fixes `thenRn` \ src_fixes ->
+ rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
+ rnFixes fixes `thenRn` \ src_fixes ->
let
pair_name inf@(InfixL n _) = (n, inf)
pair_name inf@(InfixR n _) = (n, inf)
trashed_imports = trace "rnSource:trashed_imports" []
\end{code}
+
+%*********************************************************
+%* *
+\subsection{Export list}
+%* *
+%*********************************************************
+
+\begin{code}
+rnExports :: [Module]
+ -> Bag (Module,(RnName,ExportFlag))
+ -> Maybe [RdrNameIE]
+ -> RnM s (Name -> ExportFlag)
+
+rnExports mods unqual_imps Nothing
+ = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+
+rnExports mods unqual_imps (Just exps)
+ = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
+ let
+ exp_mods = catMaybes mod_maybes
+ exp_names = unionManyBags exp_bags
+
+ -- check for duplicate names
+ -- check for duplicate modules
+
+ -- check for duplicate local names
+ -- add in module contents checking for duplicate local names
+
+ -- build export flag lookup function
+ exp_fn n = if isLocallyDefined n then ExportAll else NotExported
+ in
+ returnRn exp_fn
+
+rnIE mods (IEVar name)
+ = lookupValue name `thenRn` \ rn ->
+ checkIEVar rn `thenRn` \ exps ->
+ returnRn (Nothing, exps)
+ where
+ checkIEVar (RnName n) = returnRn (unitBag (n,ExportAbs))
+ checkIEVar (RnUnbound _) = returnRn emptyBag
+ checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (classOpExportErr rn src_loc)
+ checkIEVar rn = panic "checkIEVar"
+
+rnIE mods (IEThingAbs name)
+ = lookupTyConOrClass name `thenRn` \ rn ->
+ checkIEAbs rn `thenRn` \ exps ->
+ returnRn (Nothing, exps)
+ where
+ checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs (RnData n _) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs (RnUnbound _) = returnRn emptyBag
+ checkIEAbs rn = panic "checkIEAbs"
+
+rnIE mods (IEThingAll name)
+ = lookupTyConOrClass name `thenRn` \ rn ->
+ checkIEAll rn `thenRn` \ exps ->
+ returnRn (Nothing, exps)
+ where
+ checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
+ checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
+ checkIEAll (RnUnbound _) = returnRn emptyBag
+ checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
+ warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEAll rn = panic "checkIEAll"
+
+ exp_all n = (n, ExportAll)
+
+rnIE mods (IEThingWith name names)
+ = lookupTyConOrClass name `thenRn` \ rn ->
+ mapRn lookupValue names `thenRn` \ rns ->
+ checkIEWith rn rns `thenRn` \ exps ->
+ returnRn (Nothing, exps)
+ where
+ checkIEWith rn@(RnData n cons) rns
+ | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
+ | otherwise = rnWithErr "constructrs" rn cons rns
+ checkIEWith rn@(RnClass n ops) rns
+ | same_names ops rns = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
+ | otherwise = rnWithErr "class ops" rn ops rns
+ checkIEWith (RnUnbound _) rns = returnRn emptyBag
+ checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEWith rn rns = panic "checkIEWith"
+
+ exp_all n = (n, ExportAll)
+
+ same_names has rns
+ = all (not.isRnUnbound) rns &&
+ sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
+
+ rnWithErr str rn has rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
+
+rnIE mods (IEModuleContents mod)
+ | isIn "IEModule" mod mods = returnRn (Just mod, emptyBag)
+ | otherwise = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
+\end{code}
+
%*********************************************************
%* *
\subsection{Type declarations}
\begin{code}
+classOpExportErr op locn sty
+ = ppHang (ppStr "Class operation can only be exported with class:")
+ 4 (ppCat [ppr sty op, ppr sty locn])
+
+synAllExportErr syn locn sty
+ = ppHang (ppStr "Type synonym should be exported abstractly:")
+ 4 (ppCat [ppr sty syn, ppr sty locn])
+
+withExportErr str rn has rns locn sty
+ = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn])
+ 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)])
+ (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)]))
+
+badModExportErr mod locn sty
+ = ppHang (ppStr "Unknown module in export list:")
+ 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn])
+
derivingNonStdClassErr clas locn sty
- = ppHang (ppStr "Non-standard class in deriving")
+ = ppHang (ppStr "Non-standard class in deriving:")
4 (ppCat [ppr sty clas, ppr sty locn])
dupDefaultDeclErr defs sty
- = ppHang (ppStr "Duplicate default declarations")
+ = ppHang (ppStr "Duplicate default declarations:")
4 (ppAboves (map pp_def_loc defs))
where
pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
undefinedFixityDeclErr decl sty
- = ppHang (ppStr "Fixity declaration for unknown operator")
+ = ppHang (ppStr "Fixity declaration for unknown operator:")
4 (ppr sty decl)
\end{code}
extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
= ASSERT(isEmptyFM stack)
- (((qual', unqual', tc_qual, tc_unqual), stack), tc_dups `unionBags` dups)
+ (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups)
where
(qual', unqual', dups) = extend_global qual unqual val_list
(tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
projects / ghc-hetmet.git / commitdiff