From: sewardj Date: Tue, 17 Oct 2000 12:48:35 +0000 (+0000) Subject: [project @ 2000-10-17 12:48:34 by sewardj] X-Git-Tag: Approximately_9120_patches~3548 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b732f90c9e6b1c0177e04a5f84abac7f50cca4e4;p=ghc-hetmet.git [project @ 2000-10-17 12:48:34 by sewardj] More thrills and spills with the typechecker. --- diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 11dc9f6..9a6dfd1 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -8,7 +8,7 @@ module HscTypes ( ModDetails(..), GlobalSymbolTable, HomeSymbolTable, PackageSymbolTable, - TyThing(..), lookupTypeEnv, + TyThing(..), lookupTypeEnv, lookupFixityEnv, WhetherHasOrphans, ImportVersion, ExportItem, PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index a152ade..f99fe5f 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -784,19 +784,29 @@ deriving_occ_info -- these RDR names also have known keys, so we need to get back the RDR names to -- populate the occurrence list above. -intTyCon_RDR = nameRdrName intTyConName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -map_RDR = nameRdrName mapName -append_RDR = nameRdrName appendName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -enumFromTo_RDR = nameRdrName enumFromToName -returnM_RDR = nameRdrName returnMName -thenM_RDR = nameRdrName thenMName -failM_RDR = nameRdrName failMName +intTyCon_RDR = nameRdrName intTyConName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +map_RDR = nameRdrName mapName +append_RDR = nameRdrName appendName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +enumFromTo_RDR = nameRdrName enumFromToName +returnM_RDR = nameRdrName returnMName +thenM_RDR = nameRdrName thenMName +failM_RDR = nameRdrName failMName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +error_RDR = nameRdrName errorName +getTag_RDR = nameRdrName getTagName +fromEnum_RDR = nameRdrName fromEnumName +toEnum_RDR = nameRdrName toEnumName +enumFrom_RDR = nameRdrName enumFromName +mkInt_RDR = nameRdrName intDataConName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName \end{code} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 6c51aee..c8d61d2 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -167,11 +167,13 @@ checkForeignImport is_dynamic is_safe ty args res case args of [] -> check False (illegalForeignTyErr True{-Arg-} ty) (x:xs) -> + getDOptsTc `thenTc` \ dflags -> check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_` + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy res | otherwise = - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` + getDOptsTc `thenTc` \ dflags -> + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy res checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM () diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index bf828e4..81b6a89 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -47,9 +47,10 @@ import Name ( getOccString, getOccName, getSrcLoc, occNameString, Name, NamedThing(..), isDataSymOcc, isSymOcc ) +import HscTypes ( GlobalSymbolTable, lookupFixityEnv ) import PrelInfo -- Lots of RdrNames -import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) +import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize ) @@ -63,6 +64,7 @@ import Panic ( panic, assertPanic ) import Maybes ( maybeToBool ) import Constants import List ( partition, intersperse ) +import Outputable ( pprPanic, ppr ) #if __GLASGOW_HASKELL__ >= 404 import GlaExts ( fromInt ) @@ -398,18 +400,18 @@ gen_Ord_binds tycon defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] -lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( +lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr) -le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] ( +le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr) -ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( +ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr) -gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( +gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr) -max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( +max_ = mk_easy_FunMonoBind generatedSrcLoc max_RDR [a_Pat, b_Pat] [] ( compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) -min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] ( +min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] ( compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) -} \end{code} @@ -771,7 +773,7 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds gen_Read_binds gst tycon = reads_prec `AndMonoBinds` read_list @@ -1053,16 +1055,19 @@ getLRPrecs is_infix gst nm = [lp, rp] | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: GobalSymbolTable -> Name -> Integer -getFixity gst nm = case lookupFixityEnv gst nm of - Fixity x _ -> fromInt x +getFixity :: GlobalSymbolTable -> Name -> Integer +getFixity gst nm + = case lookupFixityEnv gst nm of + Just (Fixity x _) -> fromInt x + other -> pprPanic "TcGenDeriv.getFixity" (ppr nm) -isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) +isLRAssoc :: GlobalSymbolTable -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = - case lookupFixity fixs_assoc nm of - Fixity _ InfixN -> (False, False) - Fixity _ InfixR -> (False, True) - Fixity _ InfixL -> (True, False) + case lookupFixityEnv fixs_assoc nm of + Just (Fixity _ InfixN) -> (False, False) + Just (Fixity _ InfixR) -> (False, True) + Just (Fixity _ InfixL) -> (True, False) + other -> pprPanic "TcGenDeriv.isLRAssoc" (ppr nm) isInfixOccName :: String -> Bool isInfixOccName str = @@ -1212,10 +1217,10 @@ cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc, + mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc, + mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc] + generatedSrcLoc careful_compare_Case ty lt eq gt a b = if not (isUnboxedType ty) then @@ -1224,8 +1229,8 @@ careful_compare_Case ty lt eq gt a b else -- we have to do something special for primitive things... HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc) - mkGeneratedSrcLoc + (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc) + generatedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty relevant_lt_op = assoc_ty_id lt_op_tbl ty @@ -1278,8 +1283,8 @@ untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} - [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc] + generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op -> RdrName -> RdrName -- Things to compare @@ -1288,7 +1293,7 @@ cmp_tags_Expr :: RdrName -- Comparison op -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc + = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr