Commit f0e42a46 authored by partain's avatar partain

[project @ 1996-04-10 16:55:54 by partain]

Sansom 1.3 changes through 960410
parent b4255f2c
......@@ -237,9 +237,7 @@ BOOLEAN inpat;
gdrhs gdpat valrhs
lampats cexps
%type <umaybe> maybeexports impas maybeimpspec deriving
%type <ueither> impspec
%type <umaybe> maybeexports impspec deriving
%type <uliteral> lit_constant
......@@ -254,7 +252,7 @@ BOOLEAN inpat;
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
......@@ -284,7 +282,7 @@ BOOLEAN inpat;
%type <uentid> export import
%type <ulong> commas impqual
%type <ulong> commas
/**********************************************************************
* *
......@@ -380,32 +378,20 @@ impdecls: impdecl { $$ = $1; }
;
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:
......
......@@ -19,7 +19,7 @@ import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass )
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
......@@ -32,8 +32,7 @@ import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
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}
......@@ -63,7 +62,7 @@ ToDo: Deal with instances (instance version, this module on instance list ???)
\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) ->
......@@ -76,7 +75,7 @@ renameModule b_names b_keys us
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)
......@@ -84,7 +83,7 @@ renameModule b_names b_keys us
-- 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
......
......@@ -20,14 +20,14 @@ module RnBinds (
) 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 )
......@@ -172,10 +172,10 @@ rnMethodBinds class_name (AndMonoBinds mb1 mb2)
(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)
......@@ -348,10 +348,10 @@ flattenMonoBinds uniq sigs (PatMonoBind pat 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
......
......@@ -14,11 +14,11 @@ free variables.
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
......@@ -498,13 +498,15 @@ lookupFixity op
\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) ->
......@@ -512,17 +514,15 @@ checkPrec op (ConOpPatIn _ op1 _) right
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) ->
......
......@@ -7,6 +7,7 @@
#include "HsVersions.h"
module RnIfaces (
findHiFiles,
cacheInterface,
readInterface,
rnInterfaces,
......@@ -40,11 +41,29 @@ import Util ( panic )
\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)
......@@ -67,7 +86,7 @@ cacheInterface iface_var mod
returnPrimIO (Succeeded iface)
readInterface :: FAST_STRING -> Module
readInterface :: String -> Module
-> PrimIO (MaybeErr ParsedIface Error)
readInterface file mod = panic "readInterface"
......
......@@ -20,8 +20,8 @@ module RnMonad (
rnGetUnique, rnGetUniques,
newLocalNames,
lookupValue, lookupValueMaybe,
lookupTyCon, lookupClass, lookupClassOp,
lookupValue, lookupValueMaybe, lookupClassOp,
lookupTyCon, lookupClass, lookupTyConOrClass,
extendSS2, extendSS,
TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
......@@ -371,6 +371,9 @@ lookupTyCon rdr
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
......
......@@ -53,8 +53,9 @@ getGlobalNames ::
-> 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)
......@@ -66,7 +67,7 @@ getGlobalNames iface_var info us
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
......@@ -84,7 +85,7 @@ getGlobalNames iface_var info us
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
......@@ -266,18 +267,19 @@ newGlobalName locn maybe_exp rdr
\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
......
......@@ -9,7 +9,7 @@
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
......@@ -18,20 +18,18 @@ import RnHsSyn
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.
......@@ -49,22 +47,24 @@ Checks the (..) etc constraints in the 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)
......@@ -99,6 +99,108 @@ rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
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}
......@@ -492,17 +594,34 @@ rnContext tv_env ctxt
\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}
......@@ -86,7 +86,7 @@ emptyRnEnv
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment