From 2f51f1402e6869c0f049ffbe7b019bf6ab80558f Mon Sep 17 00:00:00 2001 From: partain Date: Sat, 20 Apr 1996 10:39:05 +0000 Subject: [PATCH] [project @ 1996-04-20 10:37:06 by partain] SLPJ 1.3 changes through 960419 --- ghc/compiler/Jmakefile | 7 +- ghc/compiler/basicTypes/Id.lhs | 45 +-- ghc/compiler/basicTypes/Name.lhs | 231 +++++++----- ghc/compiler/basicTypes/SrcLoc.lhs | 3 + ghc/compiler/basicTypes/Unique.lhs | 10 +- ghc/compiler/coreSyn/CoreLint.lhs | 24 +- ghc/compiler/coreSyn/PprCore.lhs | 4 +- ghc/compiler/deSugar/DsCCall.lhs | 4 +- ghc/compiler/deSugar/DsUtils.lhs | 6 +- ghc/compiler/hsSyn/HsBinds.lhs | 18 +- ghc/compiler/hsSyn/HsDecls.lhs | 12 +- ghc/compiler/hsSyn/HsExpr.lhs | 10 +- ghc/compiler/hsSyn/HsImpExp.lhs | 6 +- ghc/compiler/hsSyn/HsPat.lhs | 10 +- ghc/compiler/hsSyn/HsTypes.lhs | 11 +- ghc/compiler/main/CmdLineOpts.lhs | 1 - ghc/compiler/main/MkIface.lhs | 18 +- ghc/compiler/prelude/PrelInfo.lhs | 332 +++++++++-------- ghc/compiler/prelude/TysWiredIn.lhs | 30 +- ghc/compiler/reader/RdrHsSyn.lhs | 2 + ghc/compiler/reader/ReadPrefix.lhs | 8 +- ghc/compiler/rename/ParseIface.y | 619 ++++++++++++++++++------------- ghc/compiler/rename/Rename.lhs | 204 +++++++--- ghc/compiler/rename/RnExpr.lhs | 4 +- ghc/compiler/rename/RnHsSyn.lhs | 45 ++- ghc/compiler/rename/RnIfaces.lhs | 559 +++++++++++++++++++++++++--- ghc/compiler/rename/RnMonad.lhs | 121 ++++-- ghc/compiler/rename/RnNames.lhs | 558 +++++++++++++++++++++++++--- ghc/compiler/rename/RnSource.lhs | 139 +++++-- ghc/compiler/rename/RnUtils.lhs | 32 +- ghc/compiler/simplCore/SetLevels.lhs | 2 +- ghc/compiler/simplCore/SimplEnv.lhs | 17 +- ghc/compiler/simplStg/SatStgRhs.lhs | 7 +- ghc/compiler/specialise/SpecUtils.lhs | 26 +- ghc/compiler/stgSyn/CoreToStg.lhs | 2 +- ghc/compiler/stgSyn/StgSyn.lhs | 4 +- ghc/compiler/typecheck/TcBinds.lhs | 74 +++- ghc/compiler/typecheck/TcClassDcl.lhs | 4 +- ghc/compiler/typecheck/TcDeriv.lhs | 2 +- ghc/compiler/typecheck/TcEnv.lhs | 20 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 18 +- ghc/compiler/typecheck/TcInstDcls.lhs | 14 +- ghc/compiler/typecheck/TcModule.lhs | 14 +- ghc/compiler/typecheck/TcMonoType.lhs | 12 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 2 +- ghc/compiler/typecheck/TcTyDecls.lhs | 15 +- ghc/compiler/typecheck/Unify.lhs | 10 +- ghc/compiler/types/Class.lhs | 3 +- ghc/compiler/types/PprType.lhs | 20 +- ghc/compiler/types/TyCon.lhs | 24 +- ghc/compiler/types/TyVar.lhs | 6 +- ghc/compiler/types/Type.lhs | 43 ++- ghc/compiler/utils/FiniteMap.lhs | 14 +- 53 files changed, 2387 insertions(+), 1039 deletions(-) diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 0562eb9..4019707 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -118,6 +118,7 @@ specialise/SpecEnv.lhs rename/ParseIface.hs #define RENAMERSRCS_LHS \ +rename/ParseUtils.lhs \ rename/RnHsSyn.lhs \ rename/RnMonad.lhs \ rename/Rename.lhs \ @@ -506,8 +507,9 @@ types/TyLoop.hi : types/TyLoop.lhi $(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi rename/ParseIface.hs : rename/ParseIface.y - $(RM) rename/ParseIface.hs - happy -g rename/ParseIface.y + $(RM) rename/ParseIface.hs rename/ParseIface.hinfo + happy -i rename/ParseIface.hinfo rename/ParseIface.y + @chmod 444 rename/ParseIface.hs compile(absCSyn/AbsCUtils,lhs,) compile(absCSyn/CStrings,lhs,) @@ -622,6 +624,7 @@ compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#inclu compile(reader/RdrHsSyn,lhs,) compile(rename/ParseIface,hs,) +compile(rename/ParseUtils,lhs,) compile(rename/RnHsSyn,lhs,) compile(rename/RnMonad,lhs,) compile(rename/Rename,lhs,) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 2046335..b48d5e2 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -103,16 +103,15 @@ import IdInfo import Maybes ( maybeToBool ) import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, isLocallyDefinedName, isPreludeDefinedName, - nameOrigName, mkTupleDataConName, - isAvarop, isAconop, getLocalName, + mkTupleDataConName, mkCompoundName, + isLexSym, getLocalName, isLocallyDefined, isPreludeDefined, - getOrigName, getOccName, + getOccName, moduleNamePair, origName, nameOf, isExported, ExportFlag(..), RdrName(..), Name ) import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) import PragmaInfo ( PragmaInfo(..) ) -import PrelMods ( pRELUDE_BUILTIN ) import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, GenType, GenTyVar ) @@ -654,10 +653,10 @@ pprIdInUnfolding in_scopes v pp_full_name = let - (m_str, n_str) = getOrigName v + (m_str, n_str) = moduleNamePair v pp_n = - if isAvarop n_str || isAconop n_str then + if isLexSym n_str then ppBesides [ppLparen, ppPStr n_str, ppRparen] else ppPStr n_str @@ -1009,10 +1008,10 @@ getIdNamePieces show_uniqs id get (Id u _ details _ _) = case details of DataConId n _ _ _ _ _ _ _ -> - case (nameOrigName n) of { (mod, name) -> + case (moduleNamePair n) of { (mod, name) -> if isPreludeDefinedName n then [name] else [mod, name] } - TupleConId n _ -> [snd (nameOrigName n)] + TupleConId n _ -> [nameOf (origName n)] RecordSelId lbl -> panic "getIdNamePieces:RecordSelId" @@ -1021,8 +1020,8 @@ getIdNamePieces show_uniqs id TopLevId n -> get_fullname_pieces n SuperDictSelId c sc -> - case (getOrigName c) of { (c_mod, c_name) -> - case (getOrigName sc) of { (sc_mod, sc_name) -> + case (moduleNamePair c) of { (c_mod, c_name) -> + case (moduleNamePair sc) of { (sc_mod, sc_name) -> let c_bits = if isPreludeDefined c then [c_name] @@ -1035,7 +1034,7 @@ getIdNamePieces show_uniqs id [SLIT("sdsel")] ++ c_bits ++ sc_bits }} MethodSelId clas op -> - case (getOrigName clas) of { (c_mod, c_name) -> + case (moduleNamePair clas) of { (c_mod, c_name) -> case (getClassOpString op) of { op_name -> if isPreludeDefined clas then [op_name] @@ -1043,14 +1042,14 @@ getIdNamePieces show_uniqs id } } DefaultMethodId clas op _ -> - case (getOrigName clas) of { (c_mod, c_name) -> + case (moduleNamePair clas) of { (c_mod, c_name) -> case (getClassOpString op) of { op_name -> if isPreludeDefined clas then [SLIT("defm"), op_name] else [SLIT("defm"), c_mod, c_name, op_name] }} DictFunId c ty _ _ -> - case (getOrigName c) of { (c_mod, c_name) -> + case (moduleNamePair c) of { (c_mod, c_name) -> let c_bits = if isPreludeDefined c then [c_name] @@ -1061,7 +1060,7 @@ getIdNamePieces show_uniqs id [SLIT("dfun")] ++ c_bits ++ ty_bits } ConstMethodId c ty o _ _ -> - case (getOrigName c) of { (c_mod, c_name) -> + case (moduleNamePair c) of { (c_mod, c_name) -> case (getTypeString ty) of { ty_bits -> case (getClassOpString o) of { o_name -> case (if isPreludeDefined c @@ -1091,7 +1090,7 @@ getIdNamePieces show_uniqs id get_fullname_pieces :: Name -> [FAST_STRING] get_fullname_pieces n - = BIND (nameOrigName n) _TO_ (mod, name) -> + = BIND (moduleNamePair n) _TO_ (mod, name) -> if isPreludeDefinedName n then [name] else [mod, name] @@ -1810,20 +1809,14 @@ instance NamedThing (GenId ty) where get (DataConId n _ _ _ _ _ _ _) = n get (TupleConId n _) = n get (RecordSelId l) = getName l - get (SuperDictSelId c sc) = panic "Id.getName.SuperDictSelId" - get (MethodSelId c op) = panic "Id.getName.MethodSelId" - get (DefaultMethodId c op _) = panic "Id.getName.DefaultMethodId" - get (DictFunId c ty _ _) = panic "Id.getName.DictFunId" - get (ConstMethodId c ty op _ _) = panic "Id.getName.ConstMethodId" - get (SpecId i tys _) = panic "Id.getName.SpecId" - get (WorkerId i) = panic "Id.getName.WorkerId" + get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id) {- LATER: - get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ??? - (mod, _) -> (mod, getClassOpString op) + get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? + mod -> (mod, getClassOpString op) get (SpecId unspec ty_maybes _) - = BIND getOrigName unspec _TO_ (mod, unspec_nm) -> + = BIND moduleNamePair unspec _TO_ (mod, unspec_nm) -> BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix -> (mod, unspec_nm _APPEND_ @@ -1834,7 +1827,7 @@ instance NamedThing (GenId ty) where BEND BEND get (WorkerId unwrkr) - = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) -> + = BIND moduleNamePair unwrkr _TO_ (mod, unwrkr_nm) -> (mod, unwrkr_nm _APPEND_ (if not (toplevelishId unwrkr) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 2c176ec..17f62d0 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -12,9 +12,8 @@ module Name ( RdrName(..), isUnqual, isQual, - isConopRdr, + isRdrLexCon, appendRdr, - rdrToOrig, showRdr, cmpRdr, @@ -23,27 +22,30 @@ module Name ( mkLocalName, isLocalName, mkTopLevName, mkImportedName, mkImplicitName, isImplicitName, - mkBuiltinName, + mkBuiltinName, mkCompoundName, mkFunTyConName, mkTupleDataConName, mkTupleTyConName, + mkTupNameStr, NamedThing(..), -- class ExportFlag(..), isExported, nameUnique, - nameOrigName, nameOccName, nameExportFlag, nameSrcLoc, + nameImportFlag, isLocallyDefinedName, isPreludeDefinedName, - getOrigName, getOccName, getExportFlag, + origName, moduleOf, nameOf, moduleNamePair, + getOccName, getExportFlag, getSrcLoc, isLocallyDefined, isPreludeDefined, - getLocalName, getOrigNameRdr, ltLexical, + getLocalName, ltLexical, - isOpLexeme, pprOp, pprNonOp, - isConop, isAconop, isAvarid, isAvarop + isSymLexeme, pprSym, pprNonSym, + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym ) where import Ubiq @@ -51,13 +53,13 @@ import Ubiq import CStrings ( identToC, cSEP ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE, pRELUDE_BUILTIN ) +import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude ) import Pretty import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, pprUnique, Unique ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic ) +import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic ) \end{code} %************************************************************************ @@ -69,8 +71,9 @@ import Util ( thenCmp, _CMP_STRING_, nOfThem, panic ) \begin{code} type Module = FAST_STRING -data RdrName = Unqual FAST_STRING - | Qual Module FAST_STRING +data RdrName + = Unqual FAST_STRING + | Qual Module FAST_STRING isUnqual (Unqual _) = True isUnqual (Qual _ _) = False @@ -78,14 +81,12 @@ isUnqual (Qual _ _) = False isQual (Unqual _) = False isQual (Qual _ _) = True -isConopRdr (Unqual n) = isConop n -isConopRdr (Qual m n) = isConop n +isRdrLexCon (Unqual n) = isLexCon n +isRdrLexCon (Qual m n) = isLexCon n appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = Qual m (n _APPEND_ str) - -rdrToOrig (Unqual n) = (pRELUDE, n) -rdrToOrig (Qual m n) = (m, n) +appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) + Qual m (n _APPEND_ str) cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 cmpRdr (Unqual n1) (Qual m2 n2) = LT_ @@ -152,7 +153,8 @@ data Name data Provenance = LocalDef SrcLoc -- locally defined; give its source location - | Imported SrcLoc -- imported; give the *original* source location + | Imported ExportFlag -- how it was imported + SrcLoc -- *original* source location -- [SrcLoc] -- any import source location(s) | Implicit @@ -163,7 +165,7 @@ data Provenance mkLocalName = Local mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs -mkImportedName u orig locn exp occs = Global u orig (Imported locn) exp occs +mkImportedName u orig imp locn exp occs = Global u orig (Imported imp locn) exp occs mkImplicitName :: Unique -> RdrName -> Name mkImplicitName u o = Global u o Implicit NotExported [] @@ -171,19 +173,27 @@ mkImplicitName u o = Global u o Implicit NotExported [] mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] +mkCompoundName :: Unique -> [FAST_STRING] -> Name +mkCompoundName u ns + = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported [] + where + dotify [] = [] + dotify [n] = [n] + dotify (n:ns) = n : (map (_CONS_ '.') ns) + mkFunTyConName = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") mkTupleDataConName arity - = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) + = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) mkTupleTyConName arity - = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity) - -mk_tup_name 0 = SLIT("()") -mk_tup_name 1 = panic "Name.mk_tup_name: 1 ???" -mk_tup_name 2 = SLIT("(,)") -- not strictly necessary -mk_tup_name 3 = SLIT("(,,)") -- ditto -mk_tup_name 4 = SLIT("(,,,)") -- ditto -mk_tup_name n + = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) + +mkTupNameStr 0 = SLIT("()") +mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" +mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary +mkTupNameStr 3 = SLIT("(,,)") -- ditto +mkTupNameStr 4 = SLIT("(,,,)") -- ditto +mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") -- ToDo: what about module ??? @@ -248,8 +258,12 @@ instance NamedThing Name where nameUnique (Local u _ _) = u nameUnique (Global u _ _ _ _) = u -nameOrigName (Local _ n _) = (panic "NamedThing.Local.nameOrigName", n) -nameOrigName (Global _ orig _ _ _) = rdrToOrig orig +nameOrigName (Local _ n _) = Unqual n +nameOrigName (Global _ orig _ _ _) = orig + +nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n) +nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) +nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) nameOccName (Local _ n _) = Unqual n nameOccName (Global _ orig _ _ [] ) = orig @@ -258,17 +272,23 @@ nameOccName (Global _ orig _ _ occs) = head occs nameExportFlag (Local _ _ _) = NotExported nameExportFlag (Global _ _ _ exp _) = exp -nameSrcLoc (Local _ _ loc) = loc -nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ (Imported loc) _ _) = loc -nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc +nameSrcLoc (Local _ _ loc) = loc +nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc +nameSrcLoc (Global _ _ (Imported _ loc) _ _) = loc +nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc +nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc + +nameImportFlag (Local _ _ _) = NotExported +nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll +nameImportFlag (Global _ _ (Imported exp _) _ _) = exp +nameImportFlag (Global _ _ Implicit _ _) = ExportAll +nameImportFlag (Global _ _ Builtin _ _) = ExportAll -isLocallyDefinedName (Local _ _ _) = True -isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ (Imported _) _ _) = False -isLocallyDefinedName (Global _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ Builtin _ _) = False +isLocallyDefinedName (Local _ _ _) = True +isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True +isLocallyDefinedName (Global _ _ (Imported _ _) _ _) = False +isLocallyDefinedName (Global _ _ Implicit _ _) = False +isLocallyDefinedName (Global _ _ Builtin _ _) = False isPreludeDefinedName (Local _ n _) = False isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig @@ -317,7 +337,7 @@ imported. \begin{code} data ExportFlag = ExportAll -- export with all constructors/methods - | ExportAbs -- export abstractly + | ExportAbs -- export abstractly (tycons/classes only) | NotExported isExported a @@ -344,28 +364,35 @@ class NamedThing a where \end{code} \begin{code} -getOrigName :: NamedThing a => a -> (Module, FAST_STRING) +origName :: NamedThing a => a -> RdrName +moduleOf :: RdrName -> Module +nameOf :: RdrName -> FAST_STRING +moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING) + getOccName :: NamedThing a => a -> RdrName +getLocalName :: NamedThing a => a -> FAST_STRING getExportFlag :: NamedThing a => a -> ExportFlag getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool isPreludeDefined :: NamedThing a => a -> Bool -getOrigName = nameOrigName . getName +-- ToDo: specialise for RdrNames? +origName = nameOrigName . getName +moduleNamePair = nameModuleNamePair . getName + +moduleOf (Unqual n) = pRELUDE +moduleOf (Qual m n) = m + +nameOf (Unqual n) = n +nameOf (Qual m n) = n + +getLocalName = nameOf . origName + getOccName = nameOccName . getName getExportFlag = nameExportFlag . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName isPreludeDefined = isPreludeDefinedName . getName - -getLocalName :: (NamedThing a) => a -> FAST_STRING -getLocalName = snd . getOrigName - -getOrigNameRdr :: (NamedThing a) => a -> RdrName -getOrigNameRdr n | isPreludeDefined n = Unqual str - | otherwise = Qual mod str - where - (mod,str) = getOrigName n \end{code} @ltLexical@ is used for sorting things into lexicographical order, so @@ -374,97 +401,103 @@ comparison.] \begin{code} a `ltLexical` b - = BIND isLocallyDefined a _TO_ a_local -> - BIND isLocallyDefined b _TO_ b_local -> - BIND getOrigName a _TO_ (a_mod, a_name) -> - BIND getOrigName b _TO_ (b_mod, b_name) -> - if a_local || b_local then + = case (moduleNamePair a) of { (a_mod, a_name) -> + case (moduleNamePair b) of { (b_mod, b_name) -> + if isLocallyDefined a || isLocallyDefined b then a_name < b_name -- can't compare module names else case _CMP_STRING_ a_mod b_mod of LT_ -> True EQ_ -> a_name < b_name GT__ -> False - BEND BEND BEND BEND + }} #ifdef USE_ATTACK_PRAGMAS {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} -{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} +{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} {-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-} #endif \end{code} These functions test strings to see if they fit the lexical categories -defined in the Haskell report. Normally applied as in e.g. @isConop -(getLocalName foo)@ +defined in the Haskell report. Normally applied as in e.g. @isCon +(getLocalName foo)@. \begin{code} -isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool +isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs -isConop cs +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- + +isLexConId cs | _NULL_ cs = False - | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s - | otherwise = isUpper c || c == ':' - || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!! - || isUpperISO c + | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s + | otherwise = isUpper c || isUpperISO c where c = _HEAD_ cs -isAconop cs - | _NULL_ cs = False - | otherwise = c == ':' +isLexVarId cs + | _NULL_ cs = False + | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s + | otherwise = isLower c || isLowerISO c where c = _HEAD_ cs -isAvarid cs - | _NULL_ cs = False - | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s - | isLower c = True - | isLowerISO c = True - | otherwise = False +isLexConSym cs + | _NULL_ cs = False + | otherwise = c == ':' + || c == '(' -- (), (,), (,,), ... + || cs == SLIT("->") + || cs == SLIT("[]") where c = _HEAD_ cs -isAvarop cs - | _NULL_ cs = False - | isLower c = False - | isUpper c = False - | c `elem` "!#$%&*+./<=>?@\\^|~-" = True - | isSymbolISO c = True - | otherwise = False +isLexVarSym cs + | _NULL_ cs = False + | otherwise = isSymbolASCII c + || isSymbolISO c + || c == '(' -- (), (,), (,,), ... + || cs == SLIT("[]") where c = _HEAD_ cs -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +------------- +isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) +isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} And one ``higher-level'' interface to those: \begin{code} -isOpLexeme :: NamedThing a => a -> Bool +isSymLexeme :: NamedThing a => a -> Bool -isOpLexeme v - = let str = snd (getOrigName v) in isAvarop str || isAconop str +isSymLexeme v + = let str = nameOf (origName v) in isLexSym str -- print `vars`, (op) correctly -pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty +pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty -pprOp sty var - = if isOpLexeme var +pprSym sty var + = if isSymLexeme var then ppr sty var else ppBesides [ppChar '`', ppr sty var, ppChar '`'] -pprNonOp sty var - = if isOpLexeme var +pprNonSym sty var + = if isSymLexeme var then ppBesides [ppLparen, ppr sty var, ppRparen] else ppr sty var #ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isOpLexeme :: Id -> Bool #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-} -{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-} +{-# SPECIALIZE isSymLexeme :: Id -> Bool #-} +{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-} +{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-} +{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-} #endif \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index f27a6f0..650de41 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -15,6 +15,8 @@ module SrcLoc ( mkSrcLoc, mkSrcLoc2, -- the usual mkUnknownSrcLoc, -- "I'm sorry, I haven't a clue" + mkIfaceSrcLoc, -- Unknown place in an interface + -- (this one can die eventually ToDo) mkBuiltinSrcLoc, -- something wired into the compiler mkGeneratedSrcLoc, -- code generated within the compiler unpackSrcLoc @@ -58,6 +60,7 @@ Things to make 'em: mkSrcLoc = SrcLoc mkSrcLoc2 x IBOX(y) = SrcLoc2 x y mkUnknownSrcLoc = SrcLoc SLIT("") SLIT("") +mkIfaceSrcLoc = SrcLoc SLIT("") SLIT("") mkBuiltinSrcLoc = SrcLoc SLIT("") SLIT("") mkGeneratedSrcLoc = SrcLoc SLIT("") SLIT("") diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index b77ed34..dd36c0e 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -45,6 +45,7 @@ module Unique ( augmentIdKey, binaryClassKey, boolTyConKey, + boundedClassKey, buildDataConKey, buildIdKey, byteArrayPrimTyConKey, @@ -54,7 +55,7 @@ module Unique ( charPrimTyConKey, charTyConKey, consDataConKey, - dataClassKey, + evalClassKey, doubleDataConKey, doublePrimTyConKey, doubleTyConKey, @@ -417,7 +418,8 @@ monadZeroClassKey = mkPreludeClassUnique 15 binaryClassKey = mkPreludeClassUnique 16 cCallableClassKey = mkPreludeClassUnique 17 cReturnableClassKey = mkPreludeClassUnique 18 -dataClassKey = mkPreludeClassUnique 19 +evalClassKey = mkPreludeClassUnique 19 +boundedClassKey = mkPreludeClassUnique 20 \end{code} %************************************************************************ @@ -589,7 +591,3 @@ enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43 eqClassOpKey = mkPreludeMiscIdUnique 44 geClassOpKey = mkPreludeMiscIdUnique 45 \end{code} - - - - diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 929d40d..4078820 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,7 +16,7 @@ import Ubiq import CoreSyn import Bag -import Kind ( Kind{-instance-} ) +import Kind ( isSubKindOf, Kind{-instance-} ) import Literal ( literalType, Literal{-instance-} ) import Id ( idType, isBottomingId, dataConArgTys, GenId{-instances-} @@ -32,12 +32,12 @@ import PrimOp ( primOpType, PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe, - isPrimType,getTypeKind,instantiateTy, + isPrimType,typeKind,instantiateTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, maybeAppDataTyCon, eqTy ) import TyCon ( isPrimTyCon, tyConFamilySize ) -import TyVar ( getTyVarKind, GenTyVar{-instances-} ) +import TyVar ( tyVarKind, GenTyVar{-instances-} ) import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets, unionUniqSets, elementOfUniqSet, UniqSet(..) ) @@ -274,10 +274,14 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty) checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) `seqL` case (getForAllTy_maybe ty) of - Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) -> - returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) - | pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (getTyVarKind tyvar), ppr PprDebug (getTypeKind arg_ty)]) False -> panic "impossible" - _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing + Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing + + Just (tyvar,body) -> + if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then + returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) + else + pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $ + addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing lintCoreArg _ e ty (UsageArg u) = -- ToDo: Check that usage has no unbound usage variables @@ -569,9 +573,9 @@ mkAppMsg fun arg expr sty ppHang (ppStr "Arg type:") 4 (ppr sty arg), ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] -mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg -mkTyAppMsg ty arg expr sty - = ppAboves [ppStr "Illegal type application:", +mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg +mkTyAppMsg msg ty arg expr sty + = ppAboves [ppCat [ppPStr msg, ppStr "type application:"], ppHang (ppStr "Exp type:") 4 (ppr sty ty), ppHang (ppStr "Arg type:") 4 (ppr sty arg), ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 412c62d..8e1c73d 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -32,7 +32,7 @@ import Id ( idType, getIdInfo, getIdStrictness, ) import IdInfo ( ppIdInfo, StrictnessInfo(..) ) import Literal ( Literal{-instances-} ) -import Name ( isOpLexeme ) +import Name ( isSymLexeme ) import Outputable -- quite a few things import PprEnv import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) @@ -309,7 +309,7 @@ ppr_alts pe (AlgAlts alts deflt) 4 (ppr_expr pe expr) where ppr_con con pp_con - = if isOpLexeme con then ppParens pp_con else pp_con + = if isSymLexeme con then ppParens pp_con else pp_con ppr_alts pe (PrimAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index e19eddf..e76b251 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -107,7 +107,7 @@ unboxArg arg -- Primitive types -- ADR Question: can this ever be used? None of the PrimTypes are - -- instances of the _CCallable class. + -- instances of the CCallable class. | isPrimType arg_ty = returnDs (arg, \body -> body) @@ -131,7 +131,7 @@ unboxArg arg length data_con_arg_tys == 2 && not (isPrimType data_con_arg_ty1) && isPrimType data_con_arg_ty2 - -- and, of course, it is an instance of _CCallable + -- and, of course, it is an instance of CCallable -- ( tycon == byteArrayTyCon || -- tycon == mutableByteArrayTyCon ) = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] -> diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index e6b80f2..81edf59 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -40,6 +40,7 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) +import PprType ( pprType{-ToDo:rm-} ) import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, @@ -50,7 +51,7 @@ import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, isUnboxedType, applyTyCon, getAppDataTyCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) -import Util ( panic, assertPanic ) +import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) splitDictType = panic "DsUtils.splitDictType" \end{code} @@ -129,6 +130,7 @@ mkCoPrimCaseMatchResult var alts mkCoAlgCaseMatchResult :: Id -- Scrutinee -> [(DataCon, [Id], MatchResult)] -- Alternatives -> DsM MatchResult + mkCoAlgCaseMatchResult var alts = -- Find all the constructors in the type which aren't -- explicitly mentioned in the alternatives: @@ -164,7 +166,7 @@ mkCoAlgCaseMatchResult var alts cxt1) where scrut_ty = idType var - (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty + (tycon, tycon_arg_tys, data_cons) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ getAppDataTyCon scrut_ty un_mentioned_constructors = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] ) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index d8908f1..a725c1d 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -22,7 +22,7 @@ import HsTypes ( PolyType ) --others: import Id ( DictVar(..), Id(..), GenId ) -import Name ( pprNonOp ) +import Name ( pprNonSym ) import Outputable ( interpp'SP, ifnotPprForUser, Outputable(..){-instance * (,)-} ) @@ -151,31 +151,31 @@ data Sig name \begin{code} instance (NamedThing name, Outputable name) => Outputable (Sig name) where ppr sty (Sig var ty pragmas _) - = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")]) + = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) 4 (ppHang (ppr sty ty) 4 (ifnotPprForUser sty (ppr sty pragmas))) ppr sty (ClassOpSig var ty pragmas _) - = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")]) + = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) 4 (ppHang (ppr sty ty) 4 (ifnotPprForUser sty (ppr sty pragmas))) ppr sty (DeforestSig var _) - = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var]) + = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var]) 4 (ppStr "#-}") ppr sty (SpecSig var ty using _) - = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")]) + = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")]) 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")]) where pp_using Nothing = ppNil pp_using (Just me) = ppCat [ppChar '=', ppr sty me] ppr sty (InlineSig var _) - = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")] + = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")] ppr sty (MagicUnfoldingSig var str _) - = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")] + = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")] \end{code} %************************************************************************ @@ -264,11 +264,11 @@ instance (NamedThing id, Outputable id, Outputable pat, = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) ppr sty (FunMonoBind fun inf matches locn) - = pprMatches sty (False, pprNonOp sty fun) matches + = pprMatches sty (False, pprNonSym sty fun) matches -- ToDo: print infix if appropriate ppr sty (VarMonoBind name expr) - = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr) + = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 750519a..68b1a87 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -20,7 +20,7 @@ import HsPragmas ( DataPragmas, ClassPragmas, import HsTypes -- others: -import Name ( pprOp, pprNonOp ) +import Name ( pprSym, pprNonSym ) import Outputable ( interppSP, interpp'SP, Outputable(..){-instance * []-} ) @@ -50,7 +50,7 @@ instance (NamedThing name, Outputable name) ppr sty (InfixN var prec) = print_it sty "" prec var print_it sty suff prec var - = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprOp sty var] + = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var] \end{code} %************************************************************************ @@ -175,13 +175,13 @@ data BangType name instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where ppr sty (ConDecl con tys _) - = ppCat [pprNonOp sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] + = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] ppr sty (ConOpDecl ty1 op ty2 _) - = ppCat [ppr_bang sty ty1, pprOp sty op, ppr_bang sty ty2] + = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2] ppr sty (NewConDecl con ty _) - = ppCat [pprNonOp sty con, pprParendMonoType sty ty] + = ppCat [pprNonSym sty con, pprParendMonoType sty ty] ppr sty (RecConDecl con fields _) - = ppCat [pprNonOp sty con, ppChar '{', + = ppCat [pprNonSym sty con, ppChar '{', ppInterleave pp'SP (map pp_field fields), ppChar '}'] where pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty] diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 3b4face..93aa0e3 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -19,7 +19,7 @@ import HsTypes ( PolyType ) -- others: import Id ( DictVar(..), GenId, Id(..) ) -import Name ( isOpLexeme, pprOp ) +import Name ( isSymLexeme, pprSym ) import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty @@ -195,7 +195,7 @@ instance (NamedThing id, Outputable id, Outputable pat, \begin{code} pprExpr sty (HsVar v) - = (if (isOpLexeme v) then ppParens else id) (ppr sty v) + = (if (isSymLexeme v) then ppParens else id) (ppr sty v) pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit @@ -222,7 +222,7 @@ pprExpr sty (OpApp e1 op e2) = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2]) pp_infixly v - = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]] + = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] pprExpr sty (NegApp e) = ppBeside (ppChar '-') (pprParendExpr sty e) @@ -241,7 +241,7 @@ pprExpr sty (SectionL expr op) 4 (ppCat [pp_expr, ppStr "_x )"]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (pprOp sty v) ppRparen ] + ppBeside (pprSym sty v) ppRparen ] pprExpr sty (SectionR op expr) = case op of @@ -253,7 +253,7 @@ pprExpr sty (SectionR op expr) pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) 4 (ppBeside pp_expr ppRparen) pp_infixly v - = ppSep [ ppBeside ppLparen (pprOp sty v), + = ppSep [ ppBeside ppLparen (pprSym sty v), ppBeside pp_expr ppRparen ] pprExpr sty (HsCase expr matches _) diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 031bf93..b1d462d 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -26,9 +26,9 @@ One per \tr{import} declaration in a module. \begin{code} data ImportDecl name = ImportDecl Module -- module name - Bool -- qualified? + Bool -- True => qualified (Maybe Module) -- as Module - (Maybe (Bool, [IE name])) -- (hiding?, names) + (Maybe (Bool, [IE name])) -- (True => hiding, names) SrcLoc \end{code} @@ -60,7 +60,7 @@ instance (Outputable name) => Outputable (ImportDecl name) where \begin{code} data IE name = IEVar name - | IEThingAbs name -- Constructor/Type/Class (can't tell) + | IEThingAbs name -- Class/Type (can't tell) | IEThingAll name -- Class/Type plus all methods/constructors | IEThingWith name [name] -- Class/Type plus some methods/constructors | IEModuleContents Module -- (Export Only) diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 99fda06..0161813 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -26,7 +26,7 @@ import HsLoop ( HsExpr ) -- others: import Id ( GenId, dataConSig ) import Maybes ( maybeToBool ) -import Name ( pprOp, pprNonOp ) +import Name ( pprSym, pprNonSym ) import Outputable ( interppSP, interpp'SP, ifPprShowAll ) import PprStyle ( PprStyle(..) ) import Pretty @@ -115,7 +115,7 @@ instance (Outputable name, NamedThing name) => Outputable (InPat name) where pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty pprInPat sty (WildPatIn) = ppStr "_" -pprInPat sty (VarPatIn var) = pprNonOp sty var +pprInPat sty (VarPatIn var) = pprNonSym sty var pprInPat sty (LitPatIn s) = ppr sty s pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) pprInPat sty (AsPatIn name pat) @@ -131,7 +131,7 @@ pprInPat sty (ConPatIn c pats) pprInPat sty (ConOpPatIn pat1 op pat2) = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] - -- ToDo: use pprOp to print op (but this involves fiddling various + -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) pprInPat sty (NegPatIn pat) @@ -168,7 +168,7 @@ instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, \begin{code} pprOutPat sty (WildPat ty) = ppChar '_' -pprOutPat sty (VarPat var) = pprNonOp sty var +pprOutPat sty (VarPat var) = pprNonSym sty var pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] pprOutPat sty (AsPat name pat) = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] @@ -183,7 +183,7 @@ pprOutPat sty (ConPat name ty pats) ifPprShowAll sty (pprConPatTy sty ty) ] pprOutPat sty (ConOpPat pat1 op pat2 ty) - = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen] + = ppBesides [ppLparen, ppr sty pat1, ppSP, pprSym sty op, ppSP, ppr sty pat2, ppRparen] pprOutPat sty (ListPat ty pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 13292e2..9c29e81 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -163,7 +163,7 @@ ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) #ifdef COMPILING_GHC extractCtxtTyNames :: Eq name => Context name -> [name] -extractMonoTyNames :: Eq name => MonoType name -> [name] +extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name] extractCtxtTyNames ctxt = foldr get [] ctxt @@ -174,10 +174,15 @@ extractCtxtTyNames ctxt is_elem = isIn "extractCtxtTyNames" -extractMonoTyNames ty +extractMonoTyNames is_tyvar_name ty = get ty [] where - get (MonoTyApp con tys) acc = foldr get acc tys + get (MonoTyApp con tys) acc = let + rest = foldr get acc tys + in + if is_tyvar_name con && not (con `is_elem` rest) + then con : rest + else rest get (MonoListTy ty) acc = get ty acc get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc) get (MonoDictTy _ ty) acc = get ty acc diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index e0a0382..e47f359 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -216,7 +216,6 @@ opt_SpecialiseOverloaded = lookup SLIT("-fspecialise-overloaded") opt_SpecialiseTrace = lookup SLIT("-ftrace-specialisation") opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed") opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape") -opt_UseGetMentionedVars = lookup SLIT("-fuse-get-mentioned-vars") opt_Verbose = lookup SLIT("-v") opt_AsmTarget = lookup_str "-fasm=" opt_SccGroup = lookup_str "-G=" diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 1e60923..8cd4e60 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -8,7 +8,7 @@ module MkIface ( mkInterface ) where -import PrelInfo ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN ) +import PrelInfo ( mkLiftTy, pRELUDE_BUILTIN ) import HsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds, RenamedMonoBinds(..), Name, RenamedPat(..), Sig ) @@ -138,7 +138,7 @@ mkInterface modname export_list_fns inline_env tycon_specs else let eq_fn = if isTopLevId i -- can't trust uniqs - then (\ x y -> getOrigName x == getOrigName y) + then (\ x y -> origName x == origName y) else eqId in case [ x | x <- better_ids, x `eq_fn` i ] of @@ -271,7 +271,7 @@ do_import_decls mod_name vals classes tycons print_a_decl (ielist@((m,_,_) : _)) | m == mod_name || (not compiling_the_prelude && - (m == pRELUDE_CORE || m == pRELUDE_BUILTIN)) + ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN)) = ppNil | otherwise @@ -281,7 +281,7 @@ do_import_decls mod_name vals classes tycons ] where isnt_tycon_ish :: FAST_STRING -> Bool - isnt_tycon_ish str = not (isConop str) + isnt_tycon_ish str = not (isLexCon str) grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING] @@ -289,7 +289,7 @@ do_import_decls mod_name vals classes tycons pp_str :: FAST_STRING -> Pretty pp_str pstr - = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr + = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr where str = _UNPK_ pstr \end{code} @@ -325,7 +325,7 @@ get_tycon_pair tycon (orig_mod, nm_to_print) } generic_pair thing - = case (getOrigName thing) of { (orig_mod, orig_nm) -> + = case (moduleNamePair thing) of { (orig_mod, orig_nm) -> case (getOccName thing) of { occur_name -> (orig_mod, orig_nm) }} \end{code} @@ -412,10 +412,10 @@ do_value better_id_fn inline_env val ppPStr SLIT("::"), pprGenType sty val_ty]) pp_id_info --- sadly duplicates Outputable.pprNonOp (ToDo) +-- sadly duplicates Name.pprNonSym (ToDo) ppr_non_op str - = if isAvarop str -- NOT NEEDED: || isAconop + = if isLexVarSym str -- NOT NEEDED: || isAconop then ppBesides [ppLparen, ppPStr str, ppRparen] else ppPStr str \end{code} @@ -528,7 +528,7 @@ is_mentionable tc where from_PreludeCore_or_Builtin thing = let - mod_name = fst (getOrigName thing) + mod_name = fst (moduleNamePair thing) in mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 553da13..710e254 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -110,7 +110,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( getOrigName ) +import Name ( origName, nameOf ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type @@ -131,39 +131,36 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) -type BuiltinNames = FiniteMap FAST_STRING RnName -- WiredIn Ids/TyCons -type BuiltinKeys = FiniteMap FAST_STRING Unique -- Names with known uniques +type BuiltinNames = (FiniteMap FAST_STRING RnName, -- WiredIn Ids + FiniteMap FAST_STRING RnName) -- WiredIn TyCons + -- Two maps because "[]" is in both... +type BuiltinKeys = FiniteMap FAST_STRING (Unique, Name -> RnName) + -- Names with known uniques type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids builtinNameInfo = if opt_HideBuiltinNames then ( - emptyFM, + (emptyFM, emptyFM), emptyFM, emptyUFM ) else if opt_HideMostBuiltinNames then ( - listToFM min_assoc_wired, + (listToFM min_assoc_val_wired, listToFM min_assoc_tc_wired), emptyFM, emptyUFM ) else ( - listToFM assoc_wired, + (listToFM assoc_val_wired, listToFM assoc_tc_wired), listToFM assoc_keys, listToUFM assoc_id_infos ) where - min_assoc_wired -- min needed when compiling bits of Prelude - = concat - [ - -- tycons - map pcTyConWiredInInfo prim_tycons, - map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo min_nonprim_tycon_list, - + min_assoc_val_wired -- min needed when compiling bits of Prelude + = concat [ -- data constrs concat (map pcDataConWiredInInfo g_con_tycons), concat (map pcDataConWiredInInfo min_nonprim_tycon_list), @@ -171,18 +168,18 @@ builtinNameInfo -- values map pcIdWiredInInfo wired_in_ids, primop_ids - ] - - assoc_wired - = concat - [ + ] + min_assoc_tc_wired + = concat [ -- tycons map pcTyConWiredInInfo prim_tycons, map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo data_tycons, - map pcTyConWiredInInfo synonym_tycons, + map pcTyConWiredInInfo min_nonprim_tycon_list + ] - -- data consts + assoc_val_wired + = concat [ + -- data constrs concat (map pcDataConWiredInInfo g_con_tycons), concat (map pcDataConWiredInInfo data_tycons), @@ -191,6 +188,14 @@ builtinNameInfo map pcIdWiredInInfo parallel_ids, primop_ids ] + assoc_tc_wired + = concat [ + -- tycons + map pcTyConWiredInInfo prim_tycons, + map pcTyConWiredInInfo g_tycons, + map pcTyConWiredInInfo data_tycons, + map pcTyConWiredInInfo synonym_tycons + ] assoc_keys = concat @@ -202,7 +207,7 @@ builtinNameInfo ] id_keys = map id_key id_keys_infos - id_key (str, uniq, info) = (str, uniq) + id_key (str, uniq, info) = (str, (uniq, RnImplicit)) assoc_id_infos = catMaybes (map assoc_info id_keys_infos) assoc_info (str, uniq, Just info) = Just (uniq, info) @@ -218,21 +223,21 @@ The WiredIn TyCons and DataCons ... \begin{code} prim_tycons - = [addrPrimTyCon, - arrayPrimTyCon, - byteArrayPrimTyCon, - charPrimTyCon, - doublePrimTyCon, - floatPrimTyCon, - intPrimTyCon, - mallocPtrPrimTyCon, - mutableArrayPrimTyCon, - mutableByteArrayPrimTyCon, - synchVarPrimTyCon, - realWorldTyCon, - stablePtrPrimTyCon, - statePrimTyCon, - wordPrimTyCon + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , mallocPtrPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , synchVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , statePrimTyCon + , wordPrimTyCon ] g_tycons @@ -242,101 +247,99 @@ g_con_tycons = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ] min_nonprim_tycon_list -- used w/ HideMostBuiltinNames - = [ boolTyCon, - orderingTyCon, - charTyCon, - intTyCon, - floatTyCon, - doubleTyCon, - integerTyCon, - ratioTyCon, - liftTyCon, - return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11) - returnIntAndGMPTyCon + = [ boolTyCon + , orderingTyCon + , charTyCon + , intTyCon + , floatTyCon + , doubleTyCon + , integerTyCon + , ratioTyCon + , liftTyCon + , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11) + , returnIntAndGMPTyCon ] data_tycons - = [ - addrTyCon, - boolTyCon, - charTyCon, - orderingTyCon, - doubleTyCon, - floatTyCon, - intTyCon, - integerTyCon, - liftTyCon, - mallocPtrTyCon, - ratioTyCon, - return2GMPsTyCon, - returnIntAndGMPTyCon, - stablePtrTyCon, - stateAndAddrPrimTyCon, - stateAndArrayPrimTyCon, - stateAndByteArrayPrimTyCon, - stateAndCharPrimTyCon, - stateAndDoublePrimTyCon, - stateAndFloatPrimTyCon, - stateAndIntPrimTyCon, - stateAndMallocPtrPrimTyCon, - stateAndMutableArrayPrimTyCon, - stateAndMutableByteArrayPrimTyCon, - stateAndSynchVarPrimTyCon, - stateAndPtrPrimTyCon, - stateAndStablePtrPrimTyCon, - stateAndWordPrimTyCon, - stateTyCon, - wordTyCon + = [ addrTyCon + , boolTyCon + , charTyCon + , orderingTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , integerTyCon + , liftTyCon + , mallocPtrTyCon + , ratioTyCon + , return2GMPsTyCon + , returnIntAndGMPTyCon + , stablePtrTyCon + , stateAndAddrPrimTyCon + , stateAndArrayPrimTyCon + , stateAndByteArrayPrimTyCon + , stateAndCharPrimTyCon + , stateAndDoublePrimTyCon + , stateAndFloatPrimTyCon + , stateAndIntPrimTyCon + , stateAndMallocPtrPrimTyCon + , stateAndMutableArrayPrimTyCon + , stateAndMutableByteArrayPrimTyCon + , stateAndSynchVarPrimTyCon + , stateAndPtrPrimTyCon + , stateAndStablePtrPrimTyCon + , stateAndWordPrimTyCon + , stateTyCon + , wordTyCon ] synonym_tycons - = [ - primIoTyCon, - rationalTyCon, - stTyCon, - stringTyCon + = [ primIoTyCon + , rationalTyCon + , stTyCon + , stringTyCon ] pcTyConWiredInInfo :: TyCon -> (FAST_STRING, RnName) -pcTyConWiredInInfo tc = (snd (getOrigName tc), WiredInTyCon tc) +pcTyConWiredInInfo tc = (nameOf (origName tc), WiredInTyCon tc) pcDataConWiredInInfo :: TyCon -> [(FAST_STRING, RnName)] pcDataConWiredInInfo tycon - = [ (snd (getOrigName con), WiredInId con) | con <- tyConDataCons tycon ] + = [ (nameOf (origName con), WiredInId con) | con <- tyConDataCons tycon ] \end{code} The WiredIn Ids ... ToDo: Some of these should be moved to id_keys_infos! \begin{code} wired_in_ids - = [eRROR_ID, - pAT_ERROR_ID, -- occurs in i/faces - pAR_ERROR_ID, -- ditto - tRACE_ID, - - runSTId, - seqId, - realWorldPrimId, - - -- foldr/build Ids have magic unfoldings - buildId, - augmentId, - foldlId, - foldrId, - unpackCStringAppendId, - unpackCStringFoldrId + = [ eRROR_ID + , pAT_ERROR_ID -- occurs in i/faces + , pAR_ERROR_ID -- ditto + , tRACE_ID + + , runSTId + , seqId + , realWorldPrimId + + -- foldr/build Ids have magic unfoldings + , buildId + , augmentId + , foldlId + , foldrId + , unpackCStringAppendId + , unpackCStringFoldrId ] parallel_ids = if not opt_ForConcurrent then [] else - [parId, - forkId + [ parId + , forkId #ifdef GRAN - ,parLocalId - ,parGlobalId + , parLocalId + , parGlobalId -- Add later: -- ,parAtId -- ,parAtForNowId @@ -346,7 +349,7 @@ parallel_ids ] pcIdWiredInInfo :: Id -> (FAST_STRING, RnName) -pcIdWiredInInfo id = (snd (getOrigName id), WiredInId id) +pcIdWiredInInfo id = (nameOf (origName id), WiredInId id) \end{code} WiredIn primitive numeric operations ... @@ -357,27 +360,26 @@ primop_ids fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n) funny_name_primops - = [ - (IntAddOp, SLIT("+#")), - (IntSubOp, SLIT("-#")), - (IntMulOp, SLIT("*#")), - (IntGtOp, SLIT(">#")), - (IntGeOp, SLIT(">=#")), - (IntEqOp, SLIT("==#")), - (IntNeOp, SLIT("/=#")), - (IntLtOp, SLIT("<#")), - (IntLeOp, SLIT("<=#")), - (DoubleAddOp, SLIT("+##")), - (DoubleSubOp, SLIT("-##")), - (DoubleMulOp, SLIT("*##")), - (DoubleDivOp, SLIT("/##")), - (DoublePowerOp, SLIT("**##")), - (DoubleGtOp, SLIT(">##")), - (DoubleGeOp, SLIT(">=##")), - (DoubleEqOp, SLIT("==##")), - (DoubleNeOp, SLIT("/=##")), - (DoubleLtOp, SLIT("<##")), - (DoubleLeOp, SLIT("<=##")) + = [ (IntAddOp, SLIT("+#")) + , (IntSubOp, SLIT("-#")) + , (IntMulOp, SLIT("*#")) + , (IntGtOp, SLIT(">#")) + , (IntGeOp, SLIT(">=#")) + , (IntEqOp, SLIT("==#")) + , (IntNeOp, SLIT("/=#")) + , (IntLtOp, SLIT("<#")) + , (IntLeOp, SLIT("<=#")) + , (DoubleAddOp, SLIT("+##")) + , (DoubleSubOp, SLIT("-##")) + , (DoubleMulOp, SLIT("*##")) + , (DoubleDivOp, SLIT("/##")) + , (DoublePowerOp, SLIT("**##")) + , (DoubleGtOp, SLIT(">##")) + , (DoubleGeOp, SLIT(">=##")) + , (DoubleEqOp, SLIT("==##")) + , (DoubleNeOp, SLIT("/=##")) + , (DoubleLtOp, SLIT("<##")) + , (DoubleLeOp, SLIT("<=##")) ] \end{code} @@ -387,46 +389,50 @@ For the Ids we may also have some builtin IdInfo. \begin{code} id_keys_infos :: [(FAST_STRING, Unique, Maybe IdInfo)] id_keys_infos - = [ + = [ (SLIT("main"), mainIdKey, Nothing) + , (SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) ] tysyn_keys - = [ - (SLIT("IO"), iOTyConKey) -- SLIT("PreludeMonadicIO") + = [ (SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) ] +-- this "class_keys" list *must* include: +-- classes that are grabbed by key (e.g., eqClassKey) +-- classes in "Class.standardClassKeys" (quite a few) + class_keys - = [ - (SLIT("Eq"), eqClassKey), - (SLIT("Ord"), ordClassKey), - (SLIT("Num"), numClassKey), - (SLIT("Real"), realClassKey), - (SLIT("Integral"), integralClassKey), - (SLIT("Fractional"), fractionalClassKey), - (SLIT("Floating"), floatingClassKey), - (SLIT("RealFrac"), realFracClassKey), - (SLIT("RealFloat"), realFloatClassKey), - (SLIT("Ix"), ixClassKey), - (SLIT("Enum"), enumClassKey), - (SLIT("Show"), showClassKey), - (SLIT("Read"), readClassKey), - (SLIT("Monad"), monadClassKey), - (SLIT("MonadZero"), monadZeroClassKey), - (SLIT("Binary"), binaryClassKey), - (SLIT("_CCallable"), cCallableClassKey), - (SLIT("_CReturnable"), cReturnableClassKey) - ] + = [ (s, (k, RnImplicitClass)) | (s,k) <- + [ (SLIT("Eq"), eqClassKey) -- mentioned, derivable + , (SLIT("Ord"), ordClassKey) -- derivable + , (SLIT("Num"), numClassKey) -- mentioned, numeric + , (SLIT("Real"), realClassKey) -- numeric + , (SLIT("Integral"), integralClassKey) -- numeric + , (SLIT("Fractional"), fractionalClassKey) -- numeric + , (SLIT("Floating"), floatingClassKey) -- numeric + , (SLIT("RealFrac"), realFracClassKey) -- numeric + , (SLIT("RealFloat"), realFloatClassKey) -- numeric +-- , (SLIT("Ix"), ixClassKey) + , (SLIT("Bounded"), boundedClassKey) -- derivable + , (SLIT("Enum"), enumClassKey) -- derivable + , (SLIT("Show"), showClassKey) -- derivable + , (SLIT("Read"), readClassKey) -- derivable + , (SLIT("Monad"), monadClassKey) + , (SLIT("MonadZero"), monadZeroClassKey) + , (SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish + , (SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish + ]] class_op_keys - = [ - (SLIT("fromInt"), fromIntClassOpKey), - (SLIT("fromInteger"), fromIntegerClassOpKey), - (SLIT("fromRational"), fromRationalClassOpKey), - (SLIT("enumFrom"), enumFromClassOpKey), - (SLIT("enumFromThen"), enumFromThenClassOpKey), - (SLIT("enumFromTo"), enumFromToClassOpKey), - (SLIT("enumFromThenTo"), enumFromThenToClassOpKey), - (SLIT("=="), eqClassOpKey), - (SLIT(">="), geClassOpKey) - ] + = [ (s, (k, RnImplicit)) | (s,k) <- + [ (SLIT("fromInt"), fromIntClassOpKey) + , (SLIT("fromInteger"), fromIntegerClassOpKey) + , (SLIT("fromRational"), fromRationalClassOpKey) + , (SLIT("enumFrom"), enumFromClassOpKey) + , (SLIT("enumFromThen"), enumFromThenClassOpKey) + , (SLIT("enumFromTo"), enumFromToClassOpKey) + , (SLIT("enumFromThenTo"), enumFromThenToClassOpKey) + , (SLIT("=="), eqClassOpKey) +-- , (SLIT(">="), geClassOpKey) + ]] \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 327b209..8d89294 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -87,6 +87,13 @@ module TysWiredIn ( ) where +--ToDo:rm +--import Pretty +--import Util +--import PprType +--import PprStyle +--import Kind + import Ubiq import TyLoop ( mkDataCon, StrictnessMark(..) ) @@ -105,7 +112,7 @@ import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy, mkFunTys, maybeAppDataTyCon, GenType(..), ThetaType(..), TauType(..) ) -import TyVar ( getTyVarKind, alphaTyVar, betaTyVar ) +import TyVar ( tyVarKind, alphaTyVar, betaTyVar ) import Unique import Util ( assoc, panic ) @@ -121,7 +128,7 @@ pcDataTyCon key mod str tyvars cons tyvars [{-no context-}] cons [{-no derivings-}] DataType where - tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars + tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id @@ -433,11 +440,14 @@ This is really just an ordinary synonym, except it is ABSTRACT. mkStateTransformerTy s a = mkSynTy stTyCon [s, a] stTyCon - = mkSynTyCon + = let + ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]) + in + mkSynTyCon (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST")) - (panic "TysWiredIn.stTyCon:Kind") + (mkBoxedTypeKind `mkArrowKind` (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)) 2 [alphaTyVar, betaTyVar] - (mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])) + ty \end{code} %************************************************************************ @@ -452,10 +462,14 @@ stTyCon mkPrimIoTy a = mkSynTy primIoTyCon [a] primIoTyCon - = mkSynTyCon + = let + ty = mkStateTransformerTy realWorldTy alphaTy + in +-- pprTrace "primIOTyCon:" (ppCat [pprType PprDebug ty, ppr PprDebug (typeKind ty)]) $ + mkSynTyCon (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO")) - (panic "TysWiredIn.primIoTyCon:Kind") - 1 [alphaTyVar] (mkStateTransformerTy realWorldTy alphaTy) + (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind) + 1 [alphaTyVar] ty \end{code} %************************************************************************ diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 758ea33..e884ce0 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -11,6 +11,7 @@ they are used somewhat later on in the compiler...) module RdrHsSyn ( RdrNameArithSeqInfo(..), + RdrNameBangType(..), RdrNameBind(..), RdrNameClassDecl(..), RdrNameClassOpSig(..), @@ -57,6 +58,7 @@ import Name ( ExportFlag(..) ) \begin{code} type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat +type RdrNameBangType = BangType RdrName type RdrNameBind = Bind Fake Fake RdrName RdrNamePat type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat type RdrNameClassOpSig = Sig RdrName diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 1ed9bd2..0fbd15b 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -23,8 +23,9 @@ import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( addErrLoc ) import FiniteMap ( elemFM, FiniteMap ) import MainMonad ( writeMn, exitMn, MainIO(..) ) -import Name ( RdrName(..), isConopRdr ) +import Name ( RdrName(..), isRdrLexCon ) import PprStyle ( PprStyle(..) ) +import PrelMods ( fromPrelude ) import Pretty import SrcLoc ( SrcLoc ) import Util ( nOfThem, pprError, panic ) @@ -64,6 +65,9 @@ wlkQid :: U_qid -> UgnM RdrName wlkQid (U_noqual name) = returnUgn (Unqual name) wlkQid (U_aqual mod name) + | fromPrelude mod + = returnUgn (Unqual name) + | otherwise = returnUgn (Qual mod name) wlkQid (U_gid n name) = returnUgn (Unqual name) @@ -376,7 +380,7 @@ wlkPat pat U_ident nn -> -- simple identifier wlkQid nn `thenUgn` \ n -> returnUgn ( - if isConopRdr n + if isRdrLexCon n then ConPatIn n [] else VarPatIn n ) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index f083712..a2e6eb6 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,290 +1,387 @@ { #include "HsVersions.h" -module ParseIface ( - parseIface, - - ParsedIface(..), RdrIfaceDecl(..), - - ExportsMap(..), LocalDefsMap(..), LocalPragmasMap(..), - LocalVersionsMap(..), PragmaStuff(..) - - ) where +module ParseIface ( parseIface ) where import Ubiq{-uitous-} -import HsSyn ( ClassDecl, InstDecl, TyDecl, PolyType, InPat, Fake ) -import RdrHsSyn ( RdrNameTyDecl(..), RdrNameClassDecl(..), - RdrNamePolyType(..), RdrNameInstDecl(..) - ) -import FiniteMap ( emptyFM, listToFM, fmToList, lookupFM, keysFM, FiniteMap ) -import Name ( ExportFlag(..) ) -import Util ( startsWith ) ------------------------------------------------------------------ +import ParseUtils -parseIface = parseIToks . lexIface +import HsSyn -- quite a bit of stuff +import RdrHsSyn -- oodles of synonyms +import HsPragmas ( noGenPragmas ) -type LocalVersionsMap = FiniteMap FAST_STRING Version -type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag) -type LocalDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff - -type PragmaStuff = String - -data ParsedIface - = ParsedIface - Module -- Module name - Version -- Module version number - (Maybe Version) -- Source version number - LocalVersionsMap -- Local version numbers - ExportsMap -- Exported names - [Module] -- Special instance modules - LocalDefsMap -- Local names defined - [RdrIfaceDecl] -- Local instance declarations - LocalPragmasMap -- Pragmas for local names - -{- -instance Text ParsedIface where - showsPrec _ (ParsedIface m v mv lcm exm ims ldm lids ldp) - = showString "interface " - . showString (_UNPK_ m) - . showChar ' ' - . showInt v - . showString "\n__versions__\n" - . showList (fmToList lcm) - . showString "\n__exports__\n" - . showList (fmToList exm) - . showString "\n__instance_modules__\n" - . showList (map _UNPK_ ims) - . showString "\n__declarations__\n" - . showList (map _UNPK_ (keysFM ldm)) - . showString "\n__instances__\n" - . showList lids - . showString "\n__pragmas__\n" - . showList (map _UNPK_ (keysFM ldp)) --} +import Bag ( emptyBag, unitBag, snocBag ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM ) +import Name ( ExportFlag(..), mkTupNameStr, + RdrName(..){-instance Outputable:ToDo:rm-} + ) +import Outputable -- ToDo:rm +import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging +import SrcLoc ( mkIfaceSrcLoc ) +import Util ( pprPanic{-ToDo:rm-} ) ----------------------------------------------------------------- -data RdrIfaceDecl - = TypeSig RdrName Bool SrcLoc RdrNameTyDecl - | NewTypeSig RdrName RdrName Bool SrcLoc RdrNameTyDecl - | DataSig RdrName [RdrName] Bool SrcLoc RdrNameTyDecl - | ClassSig RdrName [RdrName] Bool SrcLoc RdrNameClassDecl - | ValSig RdrName Bool SrcLoc RdrNamePolyType - | InstSig RdrName RdrName Bool SrcLoc RdrNameInstDecl - -- True => Source Iface decl ------------ -type Version = Int +parseIface = parseIToks . lexIface ----------------------------------------------------------------- } %name parseIToks %tokentype { IfaceToken } +%monad { IfM }{ thenIf }{ returnIf } %token - interface { ITinterface } - versions_part { ITversions } - exports_part { ITexports } - instance_modules_part { ITinstance_modules } - instances_part { ITinstances } - declarations_part { ITdeclarations } - pragmas_part { ITpragmas } - data { ITdata } - type { ITtype } - newtype { ITnewtype } - class { ITclass } - where { ITwhere } - instance { ITinstance } - bar { ITbar } - colons { ITcolons } - comma { ITcomma } - dblrarrow { ITdblrarrow } - dot { ITdot } - dotdot { ITdotdot } - equal { ITequal } - lbrace { ITlbrace } - lbrack { ITlbrack } - lparen { ITlparen } - rarrow { ITrarrow } - rbrace { ITrbrace } - rbrack { ITrbrack } - rparen { ITrparen } - semicolon { ITsemicolon } - num { ITnum $$ } - name { ITname $$ } + INTERFACE { ITinterface } + VERSIONS_PART { ITversions } + EXPORTS_PART { ITexports } + INSTANCE_MODULES_PART { ITinstance_modules } + INSTANCES_PART { ITinstances } + FIXITIES_PART { ITfixities } + DECLARATIONS_PART { ITdeclarations } + PRAGMAS_PART { ITpragmas } + BANG { ITbang } + BQUOTE { ITbquote } + CBRACK { ITcbrack } + CCURLY { ITccurly } + CLASS { ITclass } + COMMA { ITcomma } + CPAREN { ITcparen } + DARROW { ITdarrow } + DATA { ITdata } + DCOLON { ITdcolon } + DOTDOT { ITdotdot } + EQUAL { ITequal } + INFIX { ITinfix } + INFIXL { ITinfixl } + INFIXR { ITinfixr } + INSTANCE { ITinstance } + NEWTYPE { ITnewtype } + OBRACK { ITobrack } + OCURLY { ITocurly } + OPAREN { IToparen } + RARROW { ITrarrow } + SEMI { ITsemi } + TYPE { ITtype } + VBAR { ITvbar } + WHERE { ITwhere } + INTEGER { ITinteger $$ } + VARID { ITvarid $$ } + CONID { ITconid $$ } + VARSYM { ITvarsym $$ } + CONSYM { ITconsym $$ } + QVARID { ITqvarid $$ } + QCONID { ITqconid $$ } + QVARSYM { ITqvarsym $$ } + QCONSYM { ITqconsym $$ } %% -Iface :: { ParsedIface } -Iface : interface name num - VersionsPart ExportsPart InstanceModulesPart - DeclsPart InstancesPart PragmasPart - { ParsedIface $2 (fromInteger $3) Nothing{-src version-} +iface :: { ParsedIface } +iface : INTERFACE CONID INTEGER + versions_part exports_part inst_modules_part + fixities_part decls_part instances_part pragmas_part + { case $8 of { (tm, vm) -> + ParsedIface $2 (fromInteger $3) Nothing{-src version-} $4 -- local versions $5 -- exports map $6 -- instance modules - $7 -- decls map - $8 -- local instances - $9 -- pragmas map + $7 -- fixities map + tm -- decls maps + vm + $9 -- local instances + $10 -- pragmas map + } +-------------------------------------------------------------------------- } -VersionsPart :: { LocalVersionsMap } -VersionsPart : versions_part NameVersionPairs - { listToFM $2 } - -NameVersionPairs :: { [(FAST_STRING, Int)] } -NameVersionPairs : NameVersionPairs name lparen num rparen - { ($2, fromInteger $4) : $1 } - | { [] } - -ExportsPart :: { ExportsMap } -ExportsPart : exports_part ExportItems - { listToFM $2 } - -ExportItems :: { [(FAST_STRING, (RdrName, ExportFlag))] } -ExportItems : ExportItems name dot name MaybeDotDot - { ($4, (Qual $2 $4, $5)) : $1 } - | { [] } - -MaybeDotDot :: { ExportFlag } -MaybeDotDot : dotdot { ExportAll } - | { ExportAbs } - -InstanceModulesPart :: { [Module] } -InstanceModulesPart : instance_modules_part ModList - { $2 } - -ModList :: { [Module] } -ModList : ModList name { $2 : $1 } - | { [] } - -DeclsPart :: { LocalDefsMap } -DeclsPart : declarations_part - { emptyFM } - -InstancesPart :: { [RdrIfaceDecl] } -InstancesPart : instances_part - { [] } - -PragmasPart :: { LocalPragmasMap } -PragmasPart : pragmas_part +versions_part :: { LocalVersionsMap } +versions_part : VERSIONS_PART name_version_pairs + { bagToFM $2 } + +name_version_pairs :: { Bag (FAST_STRING, Int) } +name_version_pairs : iname OPAREN INTEGER CPAREN + { unitBag ($1, fromInteger $3) } + | name_version_pairs iname OPAREN INTEGER CPAREN + { $1 `snocBag` ($2, fromInteger $4) +-------------------------------------------------------------------------- + } + +exports_part :: { ExportsMap } +exports_part : EXPORTS_PART export_items { bagToFM $2 } + +export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) } +export_items : qiname maybe_dotdot + { unitBag (de_qual $1, ($1, $2)) } + | export_items qiname maybe_dotdot + { $1 `snocBag` (de_qual $2, ($2, $3)) } + +maybe_dotdot :: { ExportFlag } +maybe_dotdot : DOTDOT { ExportAll } + | { ExportAbs +-------------------------------------------------------------------------- + } + +inst_modules_part :: { Bag Module } +inst_modules_part : INSTANCE_MODULES_PART mod_list { $2 } + | { emptyBag } + +mod_list :: { Bag Module } +mod_list : CONID { unitBag $1 } + | mod_list CONID { $1 `snocBag` $2 +-------------------------------------------------------------------------- + } + +fixities_part :: { FixitiesMap } +fixities_part : FIXITIES_PART fixes { $2 } + | { emptyFM } + +fixes :: { FixitiesMap } +fixes : fix { case $1 of (k,v) -> unitFM k v } + | fixes SEMI fix { case $3 of (k,v) -> addToFM $1 k v } + +fix :: { (FAST_STRING, RdrNameFixityDecl) } +fix : INFIXL INTEGER qop { (de_qual $3, InfixL $3 (fromInteger $2)) } + | INFIXR INTEGER qop { (de_qual $3, InfixR $3 (fromInteger $2)) } + | INFIX INTEGER qop { (de_qual $3, InfixN $3 (fromInteger $2)) +-------------------------------------------------------------------------- + } + +decls_part :: { (LocalTyDefsMap, LocalValDefsMap) } +decls_part : DECLARATIONS_PART topdecls { $2 } + +topdecls :: { (LocalTyDefsMap, LocalValDefsMap) } +topdecls : topdecl { $1 } + | topdecls SEMI topdecl { case $1 of { (ts1, vs1) -> + case $3 of { (ts2, vs2) -> + (plusFM ts1 ts2, plusFM vs1 vs2)}} + } + +topdecl :: { (LocalTyDefsMap, LocalValDefsMap) } +topdecl : typed { ($1, emptyFM) } + | datad { $1 } + | newtd { $1 } + | classd { $1 } + | decl { case $1 of { (n, Sig qn ty _ loc) -> + (emptyFM, unitFM n (ValSig qn loc ty)) } + } + +typed :: { LocalTyDefsMap } +typed : TYPE simple EQUAL type { mk_type $2 $4 } + +datad :: { (LocalTyDefsMap, LocalValDefsMap) } +datad : DATA simple EQUAL constrs { mk_data [] $2 $4 } + | DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 } + +newtd :: { (LocalTyDefsMap, LocalValDefsMap) } +newtd : NEWTYPE simple EQUAL constr1 { mk_new [] $2 $4 } + | NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 } + +classd :: { (LocalTyDefsMap, LocalValDefsMap) } +classd : CLASS class cbody { mk_class [] $2 $3 } + | CLASS context DARROW class cbody { mk_class $2 $4 $5 } + +cbody :: { [(FAST_STRING, RdrNameSig)] } +cbody : WHERE OCURLY decls CCURLY { $3 } + | { [] } + +decls :: { [(FAST_STRING, RdrNameSig)] } +decls : decl { [$1] } + | decls SEMI decl { $1 ++ [$3] } + +decl :: { (FAST_STRING, RdrNameSig) } +decl : var DCOLON ctype { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) } + +context :: { RdrNameContext } +context : OPAREN context_list CPAREN { reverse $2 } + | class { [$1] } + +context_list :: { RdrNameContext{-reversed-} } +context_list : class { [$1] } + | context_list COMMA class { $3 : $1 } + +class :: { (RdrName, RdrName) } +class : gtycon VARID { ($1, Unqual $2) } + +ctype :: { RdrNamePolyType } +ctype : type DARROW type { HsPreForAllTy (type2context $1) $3 } + | type { HsPreForAllTy [] $1 } + +type :: { RdrNameMonoType } +type : btype { $1 } + | btype RARROW type { MonoFunTy $1 $3 } + +types :: { [RdrNameMonoType] } +types : type { [$1] } + | types COMMA type { $1 ++ [$3] } + +btype :: { RdrNameMonoType } +btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys } + | ntyconapp { case $1 of { (ty1, tys) -> + if null tys + then ty1 + else + case ty1 of { + MonoTyVar tv -> MonoTyApp tv tys; + MonoTyApp tc ts -> MonoTyApp tc (ts++tys); + MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys); + MonoListTy ty -> MonoTyApp (Unqual SLIT("[]")) (ty:tys); + MonoTupleTy ts -> MonoTyApp (Unqual (mkTupNameStr (length ts))) + (ts++tys); + _ -> pprPanic "test:" (ppr PprDebug $1) + }} + } + +ntyconapp :: { (RdrNameMonoType, [RdrNameMonoType]) } +ntyconapp : ntycon { ($1, []) } + | ntyconapp atype { case $1 of (t1,tys) -> (t1, tys ++ [$2]) } + +gtyconapp :: { (RdrName, [RdrNameMonoType]) } +gtyconapp : gtycon { ($1, []) } + | gtyconapp atype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } + +atype :: { RdrNameMonoType } +atype : gtycon { MonoTyApp $1 [] } + | ntycon { $1 } + +atypes :: { [RdrNameMonoType] } +atypes : atype { [$1] } + | atypes atype { $1 ++ [$2] } + +ntycon :: { RdrNameMonoType } +ntycon : VARID { MonoTyVar (Unqual $1) } + | OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) } + | OBRACK type CBRACK { MonoListTy $2 } + | OPAREN type CPAREN { $2 } + +gtycon :: { RdrName } +gtycon : QCONID { $1 } + | CONID { Unqual $1 } + | OPAREN RARROW CPAREN { Unqual SLIT("->") } + | OBRACK CBRACK { Unqual SLIT("[]") } + | OPAREN CPAREN { Unqual SLIT("()") } + | OPAREN commas CPAREN { Unqual (mkTupNameStr $2) } + +commas :: { Int } +commas : COMMA { 2{-1 comma => arity 2-} } + | commas COMMA { $1 + 1 } + +simple :: { (RdrName, [FAST_STRING]) } +simple : gtycon { ($1, []) } + | gtyconvars { case $1 of (tc,tvs) -> (tc, reverse tvs) } + +gtyconvars :: { (RdrName, [FAST_STRING] {-reversed-}) } +gtyconvars : gtycon VARID { ($1, [$2]) } + | gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) } + +constrs :: { [(RdrName, RdrNameConDecl)] } +constrs : constr { [$1] } + | constrs VBAR constr { $1 ++ [$3] } + +constr :: { (RdrName, RdrNameConDecl) } +constr : btyconapp + { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) } + | OPAREN QCONSYM CPAREN { ($2, ConDecl $2 [] mkIfaceSrcLoc) } + | OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) } + | OPAREN CONSYM CPAREN { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) } + | OPAREN CONSYM CPAREN batypes { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) } + | gtycon OCURLY fields CCURLY + { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) } + +btyconapp :: { (RdrName, [RdrNameBangType]) } +btyconapp : gtycon { ($1, []) } + | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } + +bbtype :: { RdrNameBangType } +bbtype : btype { Unbanged $1 } + | BANG atype { Banged $2 } + +batype :: { RdrNameBangType } +batype : atype { Unbanged $1 } + | BANG atype { Banged $2 } + +batypes :: { [RdrNameBangType] } +batypes : batype { [$1] } + | batypes batype { $1 ++ [$2] } + +fields :: { [([RdrName], RdrNameBangType)] } +fields : field { [$1] } + | fields COMMA field { $1 ++ [$3] } + +field :: { ([RdrName], RdrNameBangType) } +field : var DCOLON type { ([$1], Unbanged $3) } + | var DCOLON BANG atype { ([$1], Banged $4) } + +constr1 :: { (RdrName, RdrNameMonoType) } +constr1 : gtycon atype { ($1, $2) } + +var :: { RdrName } +var : QVARID { $1 } + | OPAREN QVARSYM CPAREN { $2 } + | VARID { Unqual $1 } + | OPAREN VARSYM CPAREN { Unqual $2 } + +op :: { FAST_STRING } +op : BQUOTE VARID BQUOTE { $2 } + | BQUOTE CONID BQUOTE { $2 } + | VARSYM { $1 } + | CONSYM { $1 } + +qop :: { RdrName } +qop : BQUOTE QVARID BQUOTE { $2 } + | BQUOTE QCONID BQUOTE { $2 } + | QVARSYM { $1 } + | QCONSYM { $1 } + | op { Unqual $1 } + +iname :: { FAST_STRING } +iname : VARID { $1 } + | CONID { $1 } + | OPAREN VARSYM CPAREN { $2 } + | OPAREN CONSYM CPAREN { $2 } + +qiname :: { RdrName } +qiname : QVARID { $1 } + | QCONID { $1 } + | OPAREN QVARSYM CPAREN { $2 } + | OPAREN QCONSYM CPAREN { $2 } + | iname { Unqual $1 } + +instances_part :: { Bag RdrIfaceInst } +instances_part : INSTANCES_PART instdecls { $2 } + | { emptyBag } + +instdecls :: { Bag RdrIfaceInst } +instdecls : instd { unitBag $1 } + | instdecls SEMI instd { $1 `snocBag` $3 } + +instd :: { RdrIfaceInst } +instd : INSTANCE context DARROW gtycon restrict_inst { mk_inst $2 $4 $5 } + | INSTANCE gtycon general_inst { mk_inst [] $2 $3 } + +restrict_inst :: { RdrNameMonoType } +restrict_inst : gtycon { MonoTyApp $1 [] } + | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono tvs) } + | OPAREN VARID COMMA tyvar_list CPAREN { MonoTupleTy (map en_mono ($2:$4)) } + | OBRACK VARID CBRACK { MonoListTy (en_mono $2) } + | OPAREN VARID RARROW VARID CPAREN { MonoFunTy (en_mono $2) (en_mono $4) } + +general_inst :: { RdrNameMonoType } +general_inst : gtycon { MonoTyApp $1 [] } + | OPAREN gtyconapp CPAREN { case $2 of (tc,tys) -> MonoTyApp tc tys } + | OPAREN type COMMA types CPAREN { MonoTupleTy ($2:$4) } + | OBRACK type CBRACK { MonoListTy $2 } + | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 } + +tyvar_list :: { [FAST_STRING] } +tyvar_list : VARID { [$1] } + | tyvar_list COMMA VARID { $1 ++ [$3] +-------------------------------------------------------------------------- + } + +pragmas_part :: { LocalPragmasMap } +pragmas_part : PRAGMAS_PART { emptyFM } + | { emptyFM } { ------------------------------------------------------------------ -happyError :: Int -> [IfaceToken] -> a -happyError i _ = error ("Parse error in line " ++ show i ++ "\n") - ------------------------------------------------------------------ -data IfaceToken - = ITinterface -- keywords - | ITversions - | ITexports - | ITinstance_modules - | ITinstances - | ITdeclarations - | ITpragmas - | ITdata - | ITtype - | ITnewtype - | ITclass - | ITwhere - | ITinstance - | ITbar -- magic symbols - | ITcolons - | ITcomma - | ITdblrarrow - | ITdot - | ITdotdot - | ITequal - | ITlbrace - | ITlbrack - | ITlparen - | ITrarrow - | ITrbrace - | ITrbrack - | ITrparen - | ITsemicolon - | ITnum Integer -- numbers and names - | ITname FAST_STRING - ------------------------------------------------------------------ -lexIface :: String -> [IfaceToken] - -lexIface str - = case str of - [] -> [] - - -- whitespace and comments - ' ' : cs -> lexIface cs - '\t' : cs -> lexIface cs - '\n' : cs -> lexIface cs - '-' : '-' : cs -> lex_comment cs - '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs - - '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs - '(' : cs -> ITlparen : lexIface cs - ')' : cs -> ITrparen : lexIface cs - '[' : cs -> ITlbrack : lexIface cs - ']' : cs -> ITrbrack : lexIface cs - '{' : cs -> ITlbrace : lexIface cs - '}' : cs -> ITrbrace : lexIface cs - '-' : '>' : cs -> ITrarrow : lexIface cs - '.' : cs -> ITdot : lexIface cs - '|' : cs -> ITbar : lexIface cs - ':' : ':' : cs -> ITcolons : lexIface cs - '=' : '>' : cs -> ITdblrarrow : lexIface cs - '=' : cs -> ITequal : lexIface cs - ',' : cs -> ITcomma : lexIface cs - ';' : cs -> ITsemicolon : lexIface cs - - '_' : cs -> lex_word str - c : cs | isDigit c -> lex_num str - | isAlpha c -> lex_word str - - other -> error ("lexing:"++other) - where - lex_comment str - = case (span ((/=) '\n') str) of { (junk, rest) -> - lexIface rest } - - lex_nested_comment lvl [] = error "EOF in nested comment in interface" - lex_nested_comment lvl str - = case str of - '{' : '-' : xs -> lex_nested_comment (lvl+1) xs - '-' : '}' : xs -> if lvl == 1 - then lexIface xs - else lex_nested_comment (lvl-1) xs - _ : xs -> lex_nested_comment lvl xs - - lex_num str - = case (span isDigit str) of { (num, rest) -> - ITnum (read num) : lexIface rest } - - lex_word str - = case (span is_word_sym str) of { (word, rest) -> - case (lookupFM keywordsFM word) of { - Nothing -> ITname (_PK_ word) : lexIface rest ; - Just xx -> xx : lexIface rest - }} - where - is_word_sym '_' = True - is_word_sym c = isAlphanum c - - keywordsFM :: FiniteMap String IfaceToken - keywordsFM = listToFM [ - ("interface", ITinterface) - - ,("__versions__", ITversions) - ,("__exports__", ITexports) - ,("__instance_modules__", ITinstance_modules) - ,("__instances__", ITinstances) - ,("__declarations__", ITdeclarations) - ,("__pragmas__", ITpragmas) - - ,("data", ITdata) - ,("class", ITclass) - ,("where", ITwhere) - ,("instance", ITinstance) - ] } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c040d6d..9d707af 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,15 +8,25 @@ module Rename ( renameModule ) where -import PreludeGlaST ( thenPrimIO, returnPrimIO, fixPrimIO, newVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) ) import Ubiq import HsSyn import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) -import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass ) - -import ParseIface ( ParsedIface ) +import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired ) + +--ToDo:rm: all for debugging only +import Maybes +import Name +import Outputable +import RnIfaces +import PprStyle +import Pretty +import FiniteMap +import Util (pprPanic, pprTrace) + +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) ) import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) @@ -24,12 +34,14 @@ import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) ) import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) import MainMonad -import Bag ( isEmptyBag, unionBags, bagToList, listToBag ) +import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList ) import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, eltsFM ) -import Name ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) ) +import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) +import Maybes ( catMaybes ) +import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) +import PrelMods ( pRELUDE ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) import Util ( panic, assertPanic ) @@ -41,18 +53,15 @@ renameModule :: BuiltinNames -> UniqSupply -> RdrNameHsModule - -> MainIO - ( - RenamedHsModule, -- output, after renaming - [Module], -- imported modules; for profiling + -> IO (RenamedHsModule, -- output, after renaming + [Module], -- imported modules; for profiling - VersionInfo, -- version info; for usage - [Module], -- instance modules; for iface + VersionInfo, -- version info; for usage + [Module], -- instance modules; for iface - Bag Error, - Bag Warning - ) -\end{code} + Bag Error, + Bag Warning) +\end{code} ToDo: May want to arrange to return old interface for this module! ToDo: Return OrigName RnEnv to rename derivings etc with. @@ -63,10 +72,16 @@ ToDo: Deal with instances (instance version, this module on instance list ???) renameModule b_names b_keys us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) - = findHiFiles opt_HiDirList opt_SysHiDirList `thenMn` \ hi_files -> - newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var -> + = pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> + ppAboves [ ppCat (map ppPStr (keysFM builtin_ids)) + , ppCat (map ppPStr (keysFM builtin_tcs)) + , ppCat (map ppPStr (keysFM b_keys)) + ]}) $ + + findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> + newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> - fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> + fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> let rec_occ_fn :: Name -> [RdrName] rec_occ_fn n = case lookupUFM rec_occ_fm n of @@ -75,11 +90,11 @@ 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, unqual_imps, imp_fixes, top_errs, top_warns) -> + getGlobalNames iface_cache global_name_info us1 input >>= + \ (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) + return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic) else -- No top-level name errors so rename source ... @@ -87,6 +102,8 @@ renameModule b_names b_keys us (rnSource imp_mods unqual_imps imp_fixes input) of { ((rn_module, export_fn, src_occs), src_errs, src_warns) -> + --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $ + let occ_fm :: UniqFM (RnName, [RdrName]) @@ -104,48 +121,135 @@ renameModule b_names b_keys us multiple_occs (rn, (o1:o2:_)) = True multiple_occs _ = False in - returnPrimIO (rn_module, imp_mods, - top_errs `unionBags` src_errs, - top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, - occ_fm, export_fn) + return (rn_module, imp_mods, + top_errs `unionBags` src_errs, + top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, + occ_fm, export_fn) - }) `thenPrimIO` \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> + }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> if not (isEmptyBag errs_so_far) then - returnMn (rn_panic, rn_panic, rn_panic, rn_panic, - errs_so_far, warns_so_far) + return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) else -- No errors renaming source so rename the interfaces ... let - imports_used = [ rn | (rn,_) <- eltsUFM occ_fm, not (isLocallyDefined rn) ] - (import_tcs, import_vals) = partition (\ rn -> isRnTyCon rn || isRnClass rn) imports_used + -- split up all names that occurred in the source; between + -- those that are defined therein and those merely mentioned. + -- We also divide by tycon/class and value names (as usual). + + occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ] + -- all occurrence names, from this module and imported + + (defined_here, defined_elsewhere) + = partition isLocallyDefined occ_rns + + (_, imports_used) = partition isRnWired defined_elsewhere + + (def_tcs, def_vals) = partition isRnTyConOrClass defined_here + (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns + -- the occ stuff includes *all* occurrences, + -- including those for which we have definitions + + (orig_def_env, orig_def_dups) + = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals) + (map pair_orig def_tcs) + (orig_occ_env, orig_occ_dups) + = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals) + (map pair_orig occ_tcs) + + pair_orig rn = (origName rn, rn) + + must_haves -- everything in the BuiltinKey table; as we *may* need these + -- later, we'd better bring their definitions in + = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ] + where + mk_key_name str name_fn u + = -- this is emphatically *not* the Right Way to do this... (WDP 96/04) + if (str == SLIT("main") || str == SLIT("mainPrimIO")) then + Nothing + else + Just (name_fn (mkBuiltinName u pRELUDE str)) + in + ASSERT (isEmptyBag orig_occ_dups) + ASSERT (isEmptyBag orig_def_dups) - (orig_env, orig_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig import_vals) - (map pair_orig import_tcs) - pair_orig rn = (getOrigNameRdr rn, rn) + rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>= + \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) -> - -- ToDo: Do we need top-level names from this module in orig_env ??? - in - ASSERT (isEmptyBag orig_dups) - rnIfaces iface_var orig_env us3 rn_module imports_used - `thenPrimIO` \ (rn_module_with_imports, - (implicit_val_fm, implicit_tc_fm), - iface_errs, iface_warns) -> let - all_imports_used = imports_used ++ eltsFM implicit_tc_fm ++ eltsFM implicit_val_fm + all_imports_used = bagToList (unionManyBags [listToBag imports_used, + listToBag (eltsFM implicit_tc_fm), + listToBag (eltsFM implicit_val_fm)]) in - finalIfaceInfo iface_var all_imports_used imp_mods - `thenPrimIO` \ (version_info, instance_mods) -> - - returnMn (rn_module_with_imports, imp_mods, - version_info, instance_mods, - errs_so_far `unionBags` iface_errs, - warns_so_far `unionBags` iface_warns) + finalIfaceInfo iface_cache all_imports_used imp_mods >>= + \ (version_info, instance_mods) -> + return (rn_module_with_imports, imp_mods, version_info, instance_mods, + errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns) where rn_panic = panic "renameModule: aborted with errors" (us1, us') = splitUniqSupply us (us2, us3) = splitUniqSupply us' \end{code} + +\begin{code} +pprPIface (ParsedIface m v mv lcm exm ims lfx ltdm lvdm lids ldp) + = ppAboves [ + ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v, + case mv of { Nothing -> ppNil; Just n -> ppInt n }], + + ppPStr SLIT("__versions__"), + ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ], + + ppPStr SLIT("__exports__"), + ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn, + case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}] + | (n,(rn,ex)) <- fmToList exm ], + + pp_ims (bagToList ims), + pp_fixities lfx, + pp_decls ltdm lvdm, + pp_insts (bagToList lids), + pp_pragmas ldp + ] + where + pp_ims [] = ppNil + pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__")) + (ppCat (map ppPStr ms)) + + pp_fixities fx + | isEmptyFM fx = ppNil + | otherwise = ppAboves (ppPStr SLIT("__fixities__") + : [ ppr PprDebug fix | (n, fix) <- fmToList fx]) + + pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__") + : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds]) + + pp_insts [] = ppNil + pp_insts is = ppAboves (ppPStr SLIT("__instances__") + : [ pprRdrInstDecl i | i <- is]) + + pp_pragmas ps | isEmptyFM ps = ppNil + | otherwise = panic "Rename.pp_pragmas" + +pprRdrIfaceDecl (TypeSig tc _ decl) + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl] + +pprRdrIfaceDecl (NewTypeSig tc dc _ decl) + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, ppStr "; ", ppr PprDebug decl] + +pprRdrIfaceDecl (DataSig tc dcs _ decl) + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, ppStr "; ", ppr PprDebug decl] + +pprRdrIfaceDecl (ClassSig c ops _ decl) + = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, ppStr "; ", ppr PprDebug decl] + +pprRdrIfaceDecl (ValSig f _ ty) + = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty] + +pprRdrInstDecl (InstSig c t _ decl) + = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ", + ppr PprDebug decl] +\end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 9c7a1f5..19110b8 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,7 +26,7 @@ import RnHsSyn import RnMonad import ErrUtils ( addErrLoc ) -import Name ( isLocallyDefinedName, pprOp, Name, RdrName ) +import Name ( isLocallyDefinedName, pprSym, Name, RdrName ) import Pretty import UniqFM ( lookupUFM ) import UniqSet ( emptyUniqSet, unitUniqSet, @@ -547,7 +547,7 @@ precParseErr op1 op2 src_loc ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, ppStr " in the same infix expression"]) -pp_op sty (op, fix, prec) = ppBesides [pprOp sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen] +pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen] pp_fix INFIXL = ppStr "infixl" pp_fix INFIXR = ppStr "infixr" pp_fix INFIXN = ppStr "infix" diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 432991c..8e4d0d1 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -22,7 +22,7 @@ import PprType ( GenType, GenTyVar, TyCon ) import Pretty import TyCon ( TyCon ) import TyVar ( GenTyVar ) -import Unique ( Unique ) +import Unique ( mkAlphaTyVarUnique, Unique ) import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} ) \end{code} @@ -30,7 +30,7 @@ import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} ) data RnName = WiredInId Id | WiredInTyCon TyCon - | RnName Name -- funtions/binders/tyvars + | RnName Name -- functions/binders/tyvars | RnSyn Name -- type synonym | RnData Name [Name] -- data type (with constrs) | RnConstr Name Name -- constructor (with data type) @@ -65,6 +65,15 @@ isRnClass (RnClass _ _) = True isRnClass (RnImplicitClass _) = True isRnClass _ = False +-- a common need: isRnTyCon || isRnClass: +isRnTyConOrClass (WiredInTyCon _) = True +isRnTyConOrClass (RnSyn _) = True +isRnTyConOrClass (RnData _ _) = True +isRnTyConOrClass (RnImplicitTyCon _) = True +isRnTyConOrClass (RnClass _ _) = True +isRnTyConOrClass (RnImplicitClass _) = True +isRnTyConOrClass _ = False + isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls isRnClassOp cls (RnImplicit _) = True -- ho hummm ... isRnClassOp cls _ = False @@ -93,21 +102,23 @@ instance Uniquable RnName where uniqueOf = nameUnique . getName instance NamedThing RnName where - getName (WiredInId id) = getName id - getName (WiredInTyCon tc) = getName tc - getName (RnName n) = n - getName (RnSyn n) = n - getName (RnData n _) = n - getName (RnConstr n _) = n - getName (RnClass n _) = n - getName (RnClassOp n _) = n - getName (RnImplicit n) = n - getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) - (case occ of - Unqual n -> mkLocalName bottom n bottom2 - Qual m n -> mkLocalName bottom n bottom2) - where bottom = panic "getRnName: unique" - bottom2 = panic "getRnName: srcloc" + getName (WiredInId id) = getName id + getName (WiredInTyCon tc) = getName tc + getName (RnName n) = n + getName (RnSyn n) = n + getName (RnData n _) = n + getName (RnConstr n _) = n + getName (RnClass n _) = n + getName (RnClassOp n _) = n + getName (RnImplicit n) = n + getName (RnImplicitTyCon n) = n + getName (RnImplicitClass n) = n + getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) + (case occ of + Unqual n -> mkLocalName bottom n bottom2 + Qual m n -> mkLocalName bottom n bottom2) + where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print + bottom2 = panic "getRnName: srcloc" instance Outputable RnName where #ifdef DEBUG diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 9a9dab8..063bfbc 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -9,6 +9,7 @@ module RnIfaces ( findHiFiles, cachedIface, + cachedDecl, readIface, rnIfaces, finalIfaceInfo, @@ -19,25 +20,37 @@ module RnIfaces ( import Ubiq import LibDirectory -import PreludeGlaST ( returnPrimIO, thenPrimIO, seqPrimIO, - readVar, writeVar, MutableVar(..) - ) +import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) ) import HsSyn +import HsPragmas ( noGenPragmas ) import RdrHsSyn import RnHsSyn import RnMonad -import RnUtils ( RnEnv(..) ) -import ParseIface ( parseIface, ParsedIface ) +import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) +import RnUtils ( RnEnv(..), lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) +import ParseIface ( parseIface ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) ) -import Bag ( emptyBag ) +import Bag ( emptyBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, lookupFM, addToFM ) +import FiniteMap ( emptyFM, lookupFM, addToFM, plusFM, eltsFM, + fmToList, delListFromFM, keysFM{-ToDo:rm-} + ) +import Maybes ( maybeToBool ) +import Name ( moduleNamePair, origName, isRdrLexCon, + RdrName(..){-instance NamedThing-} + ) +import PprStyle -- ToDo:rm +import Outputable -- ToDo:rm +import PrelInfo ( builtinNameInfo ) import Pretty import Maybes ( MaybeErr(..) ) -import Util ( startsWith, panic ) +import UniqFM ( emptyUFM ) +import UniqSupply ( splitUniqSupply ) +import Util ( startsWith, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} \begin{code} @@ -72,24 +85,27 @@ findHiFiles dirs sysdirs = --trace ("Having a go on..."++dir) $ getDirectoryContents dir >>= \ entries -> do_entries env entries - ------- - do_entries env [] = return env - do_entries env (e:es) - = do_entry env e >>= \ new_env -> - do_entries new_env es - ------- - do_entry env e - = case (acceptable_hi (reverse e)) of - Nothing -> --trace ("Deemed uncool:"++e) $ - return env - Just mod -> let - pmod = _PK_ mod - in - case (lookupFM env pmod) of - Nothing -> --trace ("Adding "++mod++" -> "++e) $ - return (addToFM env pmod e) - Just xx -> trace ("Already mapped: "++mod++" -> "++xx) $ - return env + where + do_entries env [] = return env + do_entries env (e:es) + = do_entry env e >>= \ new_env -> + do_entries new_env es + ------- + do_entry env e + = case (acceptable_hi (reverse e)) of + Nothing -> --trace ("Deemed uncool:"++e) $ + return env + Just mod -> + let + pmod = _PK_ mod + in + case (lookupFM env pmod) of + Nothing -> --trace ("Adding "++mod++" -> "++e) $ + return (addToFM env pmod (dir ++ '/':e)) + -- ToDo: use DIR_SEP, not / + + Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $ + return env ------- acceptable_hi rev_e -- looking at pathname *backwards* = case (startsWith (reverse opt_HiSuffix) rev_e) of @@ -97,6 +113,10 @@ findHiFiles dirs sysdirs Just xs -> plausible_modname xs{-reversed-} ------- + de_dot ('.' : '/' : xs) = xs + de_dot xs = xs + + ------- plausible_modname rev_e = let cand = reverse (takeWhile is_modname_char rev_e) @@ -123,8 +143,8 @@ cachedIface :: IfaceCache -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface iface_var mod - = readVar iface_var `thenPrimIO` \ (iface_fm, file_fm) -> +cachedIface iface_cache mod + = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) -> case (lookupFM iface_fm mod) of Just iface -> return (Succeeded iface) @@ -134,13 +154,88 @@ cachedIface iface_var mod Just file -> readIface file mod >>= \ read_iface -> case read_iface of - Failed err -> return (Failed err) + Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $ + return (Failed err) Succeeded iface -> let iface_fm' = addToFM iface_fm mod iface in - writeVar iface_var (iface_fm', file_fm) `seqPrimIO` + writeVar iface_cache (iface_fm', file_fm) `seqPrimIO` return (Succeeded iface) + +---------- +cachedDecl :: IfaceCache + -> Bool -- True <=> tycon or class name + -> RdrName + -> IO (MaybeErr RdrIfaceDecl Error) + +-- ToDo: this is where the check for Prelude.map being +-- located in PreludeList.map should be done ... + +cachedDecl iface_cache class_or_tycon orig + = cachedIface iface_cache mod >>= \ maybe_iface -> + case maybe_iface of + Failed err -> return (Failed err) + Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) -> + case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of + Just decl -> return (Succeeded decl) + Nothing -> return (Failed (noDeclInIfaceErr mod str)) + where + (mod, str) = moduleNamePair orig + +---------- +cachedDeclByType :: IfaceCache + -> RnName{-NB: diff type than cachedDecl -} + -> IO (MaybeErr RdrIfaceDecl Error) + +cachedDeclByType iface_cache rn + -- the idea is: check that, e.g., if we're given an + -- RnClass, then we really get back a ClassDecl from + -- the cache (not an RnData, or something silly) + = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl -> + let + return_maybe_decl = return maybe_decl + return_failed msg = return (Failed msg) + in + case maybe_decl of + Failed _ -> return_maybe_decl + Succeeded if_decl -> + case rn of + WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) + WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn) + RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn) + + RnSyn _ -> return_maybe_decl + RnData _ _ -> return_maybe_decl + RnImplicitTyCon _ -> if is_tycon_decl if_decl + then return_maybe_decl + else return_failed (badIfaceLookupErr "type constructor" rn if_decl) + + RnClass _ _ -> return_maybe_decl + RnImplicitClass _ -> if is_class_decl if_decl + then return_maybe_decl + else return_failed (badIfaceLookupErr "class" rn if_decl) + + RnName _ -> return_maybe_decl + RnConstr _ _ -> return_maybe_decl + RnClassOp _ _ -> return_maybe_decl + RnImplicit _ -> if is_val_decl if_decl + then return_maybe_decl + else return_failed (badIfaceLookupErr "value/method" rn if_decl) + where + is_tycon_decl (TypeSig _ _ _) = True + is_tycon_decl (NewTypeSig _ _ _ _) = True + is_tycon_decl (DataSig _ _ _ _) = True + is_tycon_decl _ = False + + is_class_decl (ClassSig _ _ _ _) = True + is_class_decl _ = False + + is_val_decl (ValSig _ _ _) = True + is_val_decl (ClassSig _ _ _ _) = True -- if the thing we were after *happens* to + -- be a class op; we will have fished a ClassSig + -- out of the interface for it. + is_val_decl _ = False \end{code} \begin{code} @@ -150,39 +245,389 @@ readIface :: FilePath -> Module readIface file mod = readFile file `thenPrimIO` \ read_result -> case read_result of - Left err -> return (Failed (cannaeReadErr file)) - Right contents -> return (Succeeded (parseIface contents)) + Left err -> return (Failed (cannaeReadErr file err)) + Right contents -> return (parseIface contents) \end{code} \begin{code} -rnIfaces :: IfaceCache -- iface cache - -> RnEnv -- original name env +rnIfaces :: IfaceCache -- iface cache (mutvar) -> UniqSupply - -> RenamedHsModule -- module to extend with iface decls - -> [RnName] -- imported names required - -> PrimIO (RenamedHsModule, -- extended module - ImplicitEnv, -- implicit names required - Bag Error, - Bag Warning) - -rnIfaces iface_var occ_env us rn_module todo - = returnPrimIO (rn_module, (emptyFM, emptyFM), emptyBag, emptyBag) + -> RnEnv -- defined (in the source) name env + -> RnEnv -- mentioned (in the source) name env + -> RenamedHsModule -- module to extend with iface decls + -> [RnName] -- imported names required (really the + -- same info as in mentioned name env) + -- Also, all the things we may look up + -- later by key (Unique). + -> IO (RenamedHsModule, -- extended module + ImplicitEnv, -- implicit names used (for usage info) + Bag Error, + Bag Warning) + +rnIfaces iface_cache us + def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack) + occ_env@((qual, unqual, tc_qual, tc_unqual), stack) + rn_module@(HsModule modname iface_version exports imports fixities + typedecls typesigs classdecls instdecls instsigs + defdecls binds sigs src_loc) + todo + = {-pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ + + pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $ + pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ + pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $ + pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ + + pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $ + pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $ + pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $ + pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $ + -} + let + (us1,us2) = splitUniqSupply us + in + + -- do transitive closure to bring in all needed names/defns: + + loop todo -- initial batch of names to process + (def_env, occ_env, us1) -- init stuff down + empty_return -- init acc results + >>= \ (((if_typedecls, if_classdecls, if_sigs), + if_implicits, + (if_errs, if_warns)), + new_occ_env) -> + + -- go back and handle instance things: + + rnIfaceInstStuff iface_cache modname us2 new_occ_env if_implicits + >>= \ (if_instdecls, (ifi_errs, ifi_warns)) -> + + return ( + HsModule modname iface_version exports imports fixities + (typedecls ++ if_typedecls) + typesigs + (classdecls ++ if_classdecls) + (instdecls ++ if_instdecls) + instsigs defdecls binds + (sigs ++ if_sigs) + src_loc, + if_implicits, + if_errs `unionBags` ifi_errs, + if_warns `unionBags` ifi_warns + ) + where + loop :: [RnName] -- Names we're looking for; we keep adding/deleting + -- from this list; we're done when empty (nothing + -- more needs to be looked for) + -> Go_Down -- see defn below + -> To_Return -- accumulated result + -> IO (To_Return, RnEnv{-final occurrence env; to pass on for doing instances-}) + + loop to_find@[] down to_return = return (to_return, occenv down) + + loop to_find@(n:ns) down to_return + = case (lookup_defd down (origName n)) of + Just _ -> -- previous processing must've found the stuff for this name; + -- continue with the rest: + -- pprTrace "loop:done:" (ppr PprDebug n) $ + loop ns down to_return + + Nothing -> -- OK, see what the cache has for us... + + cachedDeclByType iface_cache n >>= \ maybe_ans -> + case maybe_ans of + Failed err -> -- add the error, but keep going: + -- pprTrace "loop:cache error:" (ppr PprDebug n) $ + loop ns down (add_err err to_return) + + Succeeded iface_decl -> -- something needing renaming! + let + (us1, us2) = splitUniqSupply (uniqsupply down) + in + case (initRn False{-iface-} modname (occenv down) us1 ( + setExtraRn emptyUFM{-ignore fixities-} $ + rnIfaceDecl iface_decl)) of { + ((if_decl, if_defd, if_implicits), if_errs, if_warns) -> + let + new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits) + in +-- pprTrace "loop:renamed:" (ppAboves [ppr PprDebug n +-- , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns] +-- , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ] +-- , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ] +-- ]) $ + loop (new_unknowns ++ ns) + (add_occs if_defd if_implicits $ + new_uniqsupply us2 down) + (add_decl if_decl $ + add_implicits if_implicits $ + add_errs if_errs $ + add_warns if_warns to_return) + } + +----------- +type Go_Down = (RnEnv, -- stuff we already have defns for; + -- to check quickly if we've already + -- found something for the name under consideration, + -- due to previous processing. + -- It starts off just w/ the defns for + -- the things in this module. + RnEnv, -- occurrence env; this gets added to as + -- we process new iface decls. It includes + -- entries for *all* occurrences, including those + -- for which we have definitions. + UniqSupply -- the obvious + ) + +lookup_defd (def_env, _, _) n + = (if isRdrLexCon n then lookupTcRnEnv else lookupRnEnv) def_env n + +occenv (_, occ_env, _) = occ_env +uniqsupply (_, _, us) = us + +new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us) + +add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) + = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) -> + ASSERT(isEmptyBag def_dups) + let + val_occs = val_defds ++ fmToList val_imps + tc_occs = tc_defds ++ fmToList tc_imps + in + case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) -> + +-- ASSERT(isEmptyBag occ_dups) +-- False because we may get a dup on the name we just shoved in + + (new_def_env, new_occ_env, us) }} + +---------------- +type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedSig]), + ImplicitEnv, -- new names used implicitly + (Bag Error, Bag Warning) + ) + +empty_return :: To_Return +empty_return = (([],[],[]), emptyImplicitEnv, (emptyBag,emptyBag)) + +add_decl decl ((tydecls, classdecls, sigs), implicit, msgs) + = case decl of + AddedTy t -> ((t:tydecls, classdecls, sigs), implicit, msgs) + AddedClass c -> ((tydecls, c:classdecls, sigs), implicit, msgs) + AddedSig s -> ((tydecls, classdecls, s:sigs), implicit, msgs) + +add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) + = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) + where + pairify rn = (origName rn, rn) + +add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) +add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) +add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws)) +\end{code} + +\begin{code} +data AddedDecl -- purely local + = AddedTy RenamedTyDecl + | AddedClass RenamedClassDecl + | AddedSig RenamedSig + +rnIfaceDecl :: RdrIfaceDecl + -> RnM_Fixes _RealWorld + (AddedDecl, -- the resulting decl to add to the pot + ([(RdrName,RnName)], [(RdrName,RnName)]), + -- new val/tycon-class names that have + -- *been defined* while processing this decl + ImplicitEnv -- new implicit val/tycon-class names that we + -- stumbled into + ) + +rnIfaceDecl (TypeSig tc _ decl) + = rnTyDecl decl `thenRn` \ rn_decl -> + lookupTyCon tc `thenRn` \ rn_tc -> + getImplicitUpRn `thenRn` \ mentioned -> + let + defds = ([], [(tc, rn_tc)]) + implicits = mentioned `sub` defds + in + returnRn (AddedTy rn_decl, defds, implicits) + +rnIfaceDecl (NewTypeSig tc dc _ decl) + = rnTyDecl decl `thenRn` \ rn_decl -> + lookupTyCon tc `thenRn` \ rn_tc -> + lookupValue dc `thenRn` \ rn_dc -> + getImplicitUpRn `thenRn` \ mentioned -> + let + defds = ([(dc, rn_dc)], [(tc, rn_tc)]) + implicits = mentioned `sub` defds + in + returnRn (AddedTy rn_decl, defds, implicits) + +rnIfaceDecl (DataSig tc dcs _ decl) + = rnTyDecl decl `thenRn` \ rn_decl -> + lookupTyCon tc `thenRn` \ rn_tc -> + mapRn lookupValue dcs `thenRn` \ rn_dcs -> + getImplicitUpRn `thenRn` \ mentioned -> + let + defds = (dcs `zip` rn_dcs, [(tc, rn_tc)]) + implicits = mentioned `sub` defds + in + returnRn (AddedTy rn_decl, defds, implicits) + +rnIfaceDecl (ClassSig clas ops _ decl) + = rnClassDecl decl `thenRn` \ rn_decl -> + lookupClass clas `thenRn` \ rn_clas -> + mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops -> + getImplicitUpRn `thenRn` \ mentioned -> + let + defds = (ops `zip` rn_ops, [(clas, rn_clas)]) + implicits = mentioned `sub` defds + in + returnRn (AddedClass rn_decl, defds, implicits) + +rnIfaceDecl (ValSig f src_loc ty) + -- should rename_sig in RnBinds be used here? ToDo + = lookupValue f `thenRn` \ rn_f -> + -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $ + rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty -> + getImplicitUpRn `thenRn` \ mentioned -> + let + defds = ([(f, rn_f)], []) + implicits = mentioned `sub` defds + in + returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits) + +---- +sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv + +sub (val_ment, tc_ment) (val_defds, tc_defds) + = (delListFromFM val_ment (map fst val_defds), + delListFromFM tc_ment (map fst tc_defds)) \end{code} +% ------------------------------ + +@rnIfaceInstStuff@: Deal with instance declarations from interface files. + +\begin{code} +rnIfaceInstStuff + :: IfaceCache -- all about ifaces we've read + -> Module + -> UniqSupply + -> RnEnv + -> ImplicitEnv -- info about all names we've used + -> IO ([RenamedInstDecl], + (Bag Error, Bag Warning)) + +rnIfaceInstStuff iface_cache modname us occ_env implicit_env + = -- nearly all the instance decls we might even want + -- to consider are in the ParsedIfaces that are in our + -- cache; any *other* instances to consider are in any + -- "instance modules" fields that we've encounted. + -- Get both: + + readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + let + ifaces_so_far = eltsFM iface_fm + all_iface_imods = unionManyBags (map get_ims ifaces_so_far) + insts_so_far = unionManyBags (map get_insts ifaces_so_far) + in + -- OK, get all the instance decls out of the "instance module" + -- modules: + + read_iface_imods iface_fm (bagToList all_iface_imods) emptyBag emptyBag{-accumulators-} + >>= \ (more_insts, ims_errs) -> + let + all_insts = insts_so_far `unionBags` more_insts + + -- an instance decl can only be of interest if *both* + -- its class and tycon have made their way into our + -- purview: + interesting_insts = filter (good_inst implicit_env) (bagToList all_insts) + in +-- pprTrace "in implicit:\n" (ppCat (map (ppr PprDebug) (keysFM (snd implicit_env)))) $ +-- pprTrace "insts_so_far:\n" (ppr_insts (bagToList insts_so_far)) $ +-- pprTrace "more_insts:\n" (ppr_insts (bagToList more_insts)) $ +-- pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $ + -- Do the renaming for real: + -- + case (initRn False{-iface-} modname occ_env us ( + setExtraRn emptyUFM{-ignore fixities-} $ + mapRn rnIfaceInst interesting_insts)) of { + (if_inst_decls, if_errs, if_warns) -> + + return (if_inst_decls, (ims_errs `unionBags` if_errs, if_warns)) + } + where + get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts + get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims + + good_inst (_, tc_imp_env) i@(InstSig clas tycon _ _) + = -- it's a "good instance" (one to hang onto) if we have + -- some chance of referring to *both* the class and tycon + -- later on. + mentionable clas && mentionable tycon + where + mentionable nm + = case (lookupFM tc_imp_env nm) of + Just _ -> True + Nothing -> -- maybe it's builtin + case nm of + Qual _ _ -> False + Unqual n -> + case (lookupFM b_tc_names n) of + Just _ -> True + Nothing -> maybeToBool (lookupFM b_keys n) + + (b_tc_names, b_keys) -- pretty UGLY ... + = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys) + + ppr_insts insts + = ppAboves (map ppr_inst insts) + where + ppr_inst (InstSig c t _ inst_decl) + = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl] + + read_iface_imods :: ModuleToIfaceContents + -> [Module] + -> Bag RdrIfaceInst -> Bag Error + -> IO (Bag RdrIfaceInst, Bag Error) + + read_iface_imods iface_fm [] iacc eacc = return (iacc, eacc) + read_iface_imods iface_fm (m:ms) iacc eacc + = case (lookupFM iface_fm m) of + Just _ -> -- module's already in our cache; keep going + read_iface_imods iface_fm ms iacc eacc + + Nothing -> -- bring it in + cachedIface iface_cache m >>= \ read_res -> + case read_res of + Failed msg -> -- oh well, keep going anyway (saving the error) + read_iface_imods iface_fm ms iacc (eacc `snocBag` msg) + + Succeeded iface -> + read_iface_imods iface_fm ms (iacc `unionBags` get_insts iface) eacc +\end{code} + +\begin{code} +rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl + +rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl +\end{code} \begin{code} finalIfaceInfo :: - IfaceCache -- iface cache - -> [RnName] -- all imported names required - -> [Module] -- directly imported modules - -> PrimIO (VersionInfo, -- info about version numbers - [Module]) -- special instance modules + IfaceCache -- iface cache + -> [RnName] -- all imported names required + -> [Module] -- directly imported modules + -> IO (VersionInfo, -- info about version numbers + [Module]) -- special instance modules type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])] -finalIfaceInfo iface_var imps_reqd imp_mods - = returnPrimIO ([], []) +finalIfaceInfo iface_cache imps_reqd imp_mods + = return ([], []) \end{code} @@ -190,6 +635,16 @@ finalIfaceInfo iface_var imps_reqd imp_mods noIfaceErr mod sty = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] -cannaeReadErr file sty - = ppCat [ppPStr SLIT("Failed in reading file:"), ppStr file] +noDeclInIfaceErr mod str sty + = ppBesides [ppPStr SLIT("Could not find interface declaration of: "), + ppPStr mod, ppStr ".", ppPStr str] + +cannaeReadErr file err sty + = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)] + +ifaceLookupWiredErr msg n sty + = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n] + +badIfaceLookupErr msg name decl sty + = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index c7955ae..46fdb4f 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -16,7 +16,7 @@ module RnMonad ( setExtraRn, getExtraRn, getModuleRn, pushSrcLocRn, getSrcLocRn, getSourceRn, getOccurrenceUpRn, - getImplicitUpRn, ImplicitEnv(..), + getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv, rnGetUnique, rnGetUniques, newLocalNames, @@ -25,7 +25,9 @@ module RnMonad ( extendSS2, extendSS, TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, - lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs + lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, + + fixIO ) where import Ubiq{-uitous-} @@ -35,7 +37,8 @@ import SST import HsSyn ( FixityDecl ) import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, mkRnImplicitTyCon, mkRnImplicitClass, - isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp, + isRnLocal, isRnWired, isRnTyCon, isRnClass, + isRnTyConOrClass, isRnClassOp, RenamedFixityDecl(..) ) import RnUtils ( RnEnv(..), extendLocalRnEnv, lookupRnEnv, lookupTcRnEnv, @@ -51,6 +54,7 @@ import Name ( Module(..), RdrName(..), isQual, Name, mkLocalName, mkImplicitName, getOccName ) +import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) import Pretty ( Pretty(..), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) @@ -83,12 +87,14 @@ data RnMode s = RnSource (MutableVar s (Bag (RnName, RdrName))) -- Renaming source; returning occurences - | RnIface (MutableVar s ImplicitEnv) + | RnIface BuiltinNames BuiltinKeys + (MutableVar s ImplicitEnv) -- Renaming interface; creating and returning implicit names - -- One map for Values and one for TyCons/Classes. + -- ImplicitEnv: one map for Values and one for TyCons/Classes. type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName) - +emptyImplicitEnv :: ImplicitEnv +emptyImplicitEnv = (emptyFM, emptyFM) -- With a builtin polymorphic type for _runSST the type for -- initTc should use RnM s r instead of RnM _RealWorld r @@ -103,14 +109,15 @@ initRn :: Bool -- True => Source; False => Iface initRn source mod env us do_rn = _runSST ( newMutVarSST emptyBag `thenSST` \ occ_var -> - newMutVarSST (emptyFM,emptyFM) `thenSST` \ imp_var -> + newMutVarSST emptyImplicitEnv `thenSST` \ imp_var -> newMutVarSST us `thenSST` \ us_var -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> let mode = if source then RnSource occ_var else - RnIface imp_var + case builtinNameInfo of { (wiredin_fm, key_fm, _) -> + RnIface wiredin_fm key_fm imp_var } rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var in @@ -208,17 +215,17 @@ getSrcLocRn (RnDown _ _ locn _ _ _ _) = returnSST locn getSourceRn :: RnMonad x s Bool -getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True -getSourceRn (RnDown _ _ _ (RnIface _) _ _ _) = returnSST False +getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True +getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName)) getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _) = readMutVarSST occ_var -getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _) +getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = panic "getOccurrenceUpRn:RnIface" -getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName) -getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _) +getImplicitUpRn :: RnMonad x s ImplicitEnv +getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _) = readMutVarSST imp_var getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _) = panic "getImplicitUpRn:RnIface" @@ -318,13 +325,13 @@ lookupValue rdr = lookup_val rdr (\ rn -> True) (unknownNameErr "value") lookupClassOp cls rdr - = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls) + = lookup_val rdr (\ rn -> True){-WAS:(isRnClassOp cls)-} (badClassOpErr cls) lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) = case lookupRnEnv env rdr of Just name | check name -> succ name - | otherwise -> fail + | otherwise -> fail Nothing -> fail where @@ -335,24 +342,38 @@ lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down -lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _) +lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) = case lookupRnEnv env rdr of Just name | check name -> returnSST name | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down - Nothing -> lookup_or_create_implicit_val imp_var us_var rdr + Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr + +lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr + = case rdr of + Qual _ _ -> -- builtin things *don't* have Qual names + lookup_or_create_implicit_val b_key imp_var us_var rdr -lookup_or_create_implicit_val imp_var us_var rdr - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)-> + Unqual n -> case (lookupFM b_names n) of + Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr + Just xx -> returnSST xx + +lookup_or_create_implicit_val b_key imp_var us_var rdr + = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> case lookupFM implicit_val_fm rdr of Just implicit -> returnSST implicit Nothing -> - get_unique us_var `thenSST` \ uniq -> - let - implicit = mkRnImplicit (mkImplicitName uniq rdr) - new_val_fm = addToFM implicit_val_fm rdr implicit - in - writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` - returnSST implicit + (case rdr of + Qual _ _ -> get_unique us_var + Unqual n -> case (lookupFM b_key n) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> + let + implicit = mkRnImplicit (mkImplicitName uniq rdr) + new_val_fm = addToFM implicit_val_fm rdr implicit + in + writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` + returnSST implicit lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName) @@ -372,7 +393,7 @@ lookupClass rdr = lookup_tc rdr isRnClass mkRnImplicitClass "class" lookupTyConOrClass rdr - = lookup_tc rdr (\ rn -> isRnTyCon rn || isRnClass rn) + = lookup_tc rdr isRnTyConOrClass (panic "lookupTC:mk_implicit") "class or type constructor" lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _) @@ -385,27 +406,41 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _) +lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) = case lookupTcRnEnv env rdr of Just name | check name -> returnSST name | otherwise -> fail - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr + Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr where fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)-> +lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr + = case rdr of + Qual _ _ -> -- builtin things *don't* have Qual names + lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + + Unqual n -> case (lookupFM b_names n) of + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + Just xx -> returnSST xx + +lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> case lookupFM implicit_tc_fm rdr of Just implicit | check implicit -> returnSST implicit | otherwise -> fail Nothing -> - get_unique us_var `thenSST` \ uniq -> - let - implicit = mk_implicit (mkImplicitName uniq rdr) - new_tc_fm = addToFM implicit_tc_fm rdr implicit - in - writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` - returnSST implicit + (case rdr of + Qual _ _ -> get_unique us_var + Unqual n -> case (lookupFM b_key n) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> + let + implicit = mk_implicit (mkImplicitName uniq rdr) + new_tc_fm = addToFM implicit_tc_fm rdr implicit + in + writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` + returnSST implicit \end{code} @@ -493,3 +528,13 @@ lookupTyVarName env occ failButContinueRn (mkRnUnbound occ) (unknownNameErr "type variable" occ loc) \end{code} + + +\begin{code} +fixIO :: (a -> IO a) -> IO a +fixIO k s = let + result = k loop s + (Right loop, _) = result + in + result +\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index f391cbc..912e675 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -11,7 +11,7 @@ module RnNames ( GlobalNameInfo(..) ) where -import PreludeGlaST ( returnPrimIO, thenPrimIO, MutableVar(..) ) +import PreludeGlaST ( MutableVar(..) ) import Ubiq @@ -19,32 +19,41 @@ import HsSyn import RdrHsSyn import RnHsSyn -import ParseIface ( ParsedIface ) import RnMonad -import RnIfaces ( IfaceCache(..), cachedIface ) -import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr ) +import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) +import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, + lubExportFlag, qualNameErr, dupNamesErr ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) -import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList ) + +import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags, + mapBag, listToBag, bagToList ) +import CmdLineOpts ( opt_NoImplicitPrelude ) import ErrUtils ( Error(..), Warning(..), addShortErrLocLine ) -import FiniteMap ( fmToList ) +import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) +import Id ( GenId ) +import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) import Name ( RdrName(..), Name, isQual, mkTopLevName, - mkImportedName, nameExportFlag, - getLocalName, getSrcLoc, pprNonOp + mkImportedName, nameExportFlag, nameImportFlag, + getLocalName, getSrcLoc, pprNonSym, moduleNamePair, + isLexCon, isRdrLexCon, ExportFlag(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude ) +import PrelMods ( fromPrelude, pRELUDE ) import Pretty -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, mkIfaceSrcLoc ) +import TyCon ( tyConDataCons ) +import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) -import Util ( equivClasses, panic ) +import Util ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic ) \end{code} \begin{code} type GlobalNameInfo = (BuiltinNames, BuiltinKeys, - Name -> ExportFlag, - Name -> [RdrName]) + Name -> ExportFlag, -- export flag + Name -> [RdrName]) -- occurence names type RnM_Info s r = RnMonad GlobalNameInfo s r @@ -53,21 +62,21 @@ getGlobalNames :: -> GlobalNameInfo -> UniqSupply -> RdrNameHsModule - -> PrimIO (RnEnv, - [Module], -- directly imported modules - Bag (Module,(RnName,ExportFlag)), -- unqualified imports from module - Bag RenamedFixityDecl, -- imported fixity decls - Bag Error, - Bag Warning) - -getGlobalNames iface_var info us + -> IO (RnEnv, + [Module], -- directly imported modules + Bag (Module,RnName), -- unqualified imports from module + Bag RenamedFixityDecl, -- imported fixity decls + Bag Error, + Bag Warning) + +getGlobalNames iface_cache info us (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _) = case initRn True mod emptyRnEnv us1 (setExtraRn info $ getSourceNames ty_decls cls_decls binds) of { ((src_vals, src_tcs), src_errs, src_warns) -> - getImportedNames iface_var info us2 imports `thenPrimIO` + doImportDecls iface_cache info us2 imports >>= \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) -> let @@ -83,10 +92,10 @@ getGlobalNames iface_var info us cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2 dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest]) - all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs + 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, unqual_imps, imp_fixes, all_errs, all_warns) + return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) } where (us1, us2) = splitUniqSupply us @@ -234,28 +243,28 @@ newGlobalName :: SrcLoc -> Maybe ExportFlag -> RdrName -> RnM_Info s Name newGlobalName locn maybe_exp rdr - = getExtraRn `thenRn` \ (_,_,exp_fn,occ_fn) -> + = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) -> getModuleRn `thenRn` \ mod -> - getSourceRn `thenRn` \ source -> rnGetUnique `thenRn` \ u -> let - src_unqual = getLocalName rdr + (uniq, unqual) + = case rdr of + Qual m n -> (u, n) + Unqual n -> case (lookupFM b_keys n) of + Nothing -> (u, n) + Just (key,_) -> (key, n) - src_orig = if fromPrelude mod - then (Unqual src_unqual) - else (Qual mod src_unqual) + orig = if fromPrelude mod + then (Unqual unqual) + else (Qual mod unqual) exp = case maybe_exp of Just exp -> exp Nothing -> exp_fn n - n = if source then - mkTopLevName u src_orig locn exp (occ_fn n) - else - mkImportedName u rdr locn exp (occ_fn n) + n = mkTopLevName uniq orig locn exp (occ_fn n) in - addErrIfRn (source && isQual rdr) - (qualNameErr "name in definition" (rdr, locn)) `thenRn_` + addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` returnRn n \end{code} @@ -266,35 +275,474 @@ newGlobalName locn maybe_exp rdr ********************************************************* \begin{code} -getImportedNames :: +type ImportNameInfo = (GlobalNameInfo, + FiniteMap (Module,FAST_STRING) RnName, -- values imported so far + FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far + Name -> ExportFlag) -- import flag + +type RnM_IInfo s r = RnMonad ImportNameInfo s r + +doImportDecls :: 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 (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, emptyBag) + -> [RdrNameImportDecl] -- import declarations + -> IO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + [Module], -- directly imported modules + Bag (Module,RnName), -- unqualified import from module + Bag RenamedFixityDecl, -- fixity info for imported names + Bag Error, + Bag Warning) + +doImportDecls iface_cache g_info us src_imps + = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_flags) -> + let + rec_imp_fm = addListToUFM_C lubExportFlag emptyUFM (bagToList rec_imp_flags) + + rec_imp_fn :: Name -> ExportFlag + rec_imp_fn n = case lookupUFM rec_imp_fm n of + Nothing -> panic "RnNames:rec_imp_fn" + Just flag -> flag + + i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) + in + doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps) + ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) -> + let + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- src_imps ] + imp_warns = listToBag (map dupImportWarn imp_dups) + prel_warns = listToBag (map qualPreludeImportWarn qual_prels) + + (_, imp_dups) = removeDups cmp_mod src_imps + cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 + qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps, + fromPrelude mod && qual] + in + return (vals, tcs, imp_mods, unquals, fixes, errs, + prel_warns `unionBags` imp_warns `unionBags` warns) + where + explicit_prelude_import + = null [() | (ImportDecl mod qual _ _ _) <- src_imps, + fromPrelude mod && not qual] + + qprel_imp = if opt_NoImplicitPrelude + then [{-the flag really means it: *NO* implicit "import Prelude" -}] + else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc] + + prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude + then + [ {-prelude imported explicitly => no import Prelude-} ] + else + [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc] + +doImports iface_cache i_info us [] + = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) +doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) + = doImport iface_cache i_info us1 imp + >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) -> + let + new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1, + not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ] + -- moduleNamePair computed twice + ext_vals = addListToFM done_vals new_vals + + new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1, + not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ] + ext_tcs = addListToFM done_tcs new_tcs + in + doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps + >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) -> + return (vals1 `unionBags` vals2, + tcs1 `unionBags` tcs2, + unquals1 `unionBags` unquals2, + fixes1 `unionBags` fixes2, + errs1 `unionBags` errs2, + warns1 `unionBags` warns2, + imps1 `unionBags` imps2) + where + (us1, us2) = splitUniqSupply us + + +doImport :: IfaceCache + -> ImportNameInfo + -> UniqSupply + -> RdrNameImportDecl + -> IO (Bag (RdrName,RnName), -- values + Bag (RdrName,RnName), -- tycons/classes + Bag (Module,RnName), -- unqual imports + Bag RenamedFixityDecl, + Bag Error, + Bag Warning, + Bag (RnName,ExportFlag)) -- import flags + +doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) + = cachedIface iface_cache mod >>= \ maybe_iface -> + case maybe_iface of + Failed err -> + return (emptyBag, emptyBag, emptyBag, emptyBag, + unitBag err, emptyBag, emptyBag) + Succeeded iface -> + let + (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec + (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec' + in + doOrigIEs iface_cache info mod src_loc us ies + >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> + accumulate (map (checkOrigIE iface_cache) chk_ies) + >>= \ chk_errs_warns -> + accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals)) + >>= \ fix_maybes_errs -> + let + (chk_errs, chk_warns) = unzip chk_errs_warns + (fix_maybes, fix_errs) = unzip fix_maybes_errs + + final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals + final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs + + unquals = if qual then emptyBag + else mapBag pair_as (ie_vals `unionBags` ie_tcs) + + final_fixes = listToBag (catMaybes fix_maybes) + + final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs)) + `unionBags` errs `unionBags` unionManyBags fix_errs + final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns) + `unionBags` warns + in + return (final_vals, final_tcs, unquals, final_fixes, + final_errs, final_warns, imp_flags) + where + as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this} + mk_occ str = if qual then Qual as_mod str else Unqual str + + fst_occ (str, rn) = (mk_occ str, rn) + pair_occ rn = (mk_occ (getLocalName rn), rn) + pair_as rn = (as_mod, rn) + + +getBuiltins info mod maybe_spec + | not (fromPrelude mod) + = (emptyBag, emptyBag, maybe_spec) + +getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec + = case maybe_spec of + Nothing -> (all_vals, all_tcs, Nothing) + + Just (True, ies) -> -- hiding does not work for builtin names + (all_vals, all_tcs, maybe_spec) + + Just (False, ies) -> let + (vals,tcs,ies_left) = do_builtin ies + in + (vals, tcs, Just (False, ies_left)) + where + all_vals = do_all_builtin (fmToList b_val_names) + all_tcs = do_all_builtin (fmToList b_tc_names) + + do_all_builtin [] = emptyBag + do_all_builtin ((str,rn):rest) + = (str, rn) `consBag` do_all_builtin rest + + do_builtin [] = (emptyBag,emptyBag,[]) + do_builtin (ie:ies) + = let str = unqual_str (ie_name ie) + in + case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM... + Just rn -> case (ie,rn) of + (IEThingAbs _, WiredInTyCon tc) + -> (vals, (str, rn) `consBag` tcs, ies_left) + (IEThingAll _, WiredInTyCon tc) + -> (listToBag (map (\ id -> (getLocalName id, WiredInId id)) + (tyConDataCons tc)) + `unionBags` vals, + (str,rn) `consBag` tcs, ies_left) + _ -> panic "importing builtin names (1)" + + Nothing -> + case (lookupFM b_val_names str) of + Nothing -> (vals, tcs, ie:ies_left) + Just rn -> case (ie,rn) of + (IEVar _, WiredInId _) + -> ((str, rn) `consBag` vals, tcs, ies_left) + _ -> panic "importing builtin names (2)" + where + (vals, tcs, ies_left) = do_builtin ies + + +getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all + = (map mkAllIE (eltsFM exps), [], emptyBag) + +getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding + = (map mkAllIE (eltsFM exps_left), found_ies, errs) + where + (found_ies, errs) = lookupIEs exps ies + exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies) + +getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) + = (map fst found_ies, found_ies, errs) + where + (found_ies, errs) = lookupIEs exps ies + + +mkAllIE (orig,ExportAbs) + = ASSERT(isLexCon (getLocalName orig)) + IEThingAbs orig +mkAllIE (orig, ExportAll) + | isLexCon (getLocalName orig) + = IEThingAll orig + | otherwise + = IEVar orig + + +lookupIEs exps [] + = ([], emptyBag) +lookupIEs exps (ie:ies) + = case lookupFM exps (unqual_str (ie_name ie)) of + Nothing -> + (orig_ies, unknownImpSpecErr ie `consBag` errs) + Just (orig,flag) -> + (orig_ie orig flag ie ++ orig_ies, + adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs) + where + (orig_ies, errs) = lookupIEs exps ies + + orig_ie orig flag (IEVar n) = [(IEVar orig, flag)] + orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)] + orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)] + orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)] + + seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies + + +doOrigIEs iface_cache info mod src_loc us [] + = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag) + +doOrigIEs iface_cache info mod src_loc us (ie:ies) + = doOrigIE iface_cache info mod src_loc us1 ie + >>= \ (vals1, tcs1, errs1, warns1, imps1) -> + doOrigIEs iface_cache info mod src_loc us2 ies + >>= \ (vals2, tcs2, errs2, warns2, imps2) -> + return (vals1 `unionBags` vals2, + tcs1 `unionBags` tcs2, + errs1 `unionBags` errs2, + warns1 `unionBags` warns2, + imps1 `unionBags` imps2) + where + (us1, us2) = splitUniqSupply us + +doOrigIE iface_cache info mod src_loc us ie + = with_decl iface_cache (ie_name ie) + (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag)) + (\ decl -> case initRn True mod emptyRnEnv us + (setExtraRn info $ + pushSrcLocRn src_loc $ + getIfaceDeclNames ie decl) + of + ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) + +checkOrigIE iface_cache (IEThingAll n, ExportAbs) + = with_decl iface_cache n + (\ err -> (unitBag (\ mod locn -> err), emptyBag)) + (\ decl -> case decl of + TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n)) + other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag)) + +checkOrigIE iface_cache (IEThingWith n ns, ExportAbs) + = return (unitBag (withWhenAbsImpSpecErr n), emptyBag) + +checkOrigIE iface_cache (IEThingWith n ns, ExportAll) + = with_decl iface_cache n + (\ err -> (unitBag (\ mod locn -> err), emptyBag)) + (\ decl -> case decl of + NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) + DataSig _ cons _ _ -> (check_with "constructrs" cons ns, emptyBag) + ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) where - -- For now jsut add the builtin names ... - (b_names,_,_,_) = info - builtin_vals = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, not (isRnTyCon rn)] - builtin_tcs = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, isRnTyCon rn] + check_with str has rdrs + | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs) + = emptyBag + | otherwise + = unitBag (withImpSpecErr str n has rdrs) + +checkOrigIE iface_cache other + = return (emptyBag, emptyBag) + + +with_decl iface_cache n do_err do_decl + = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl -> + case maybe_decl of + Failed err -> return (do_err err) + Succeeded decl -> return (do_decl decl) + + +getFixityDecl iface_cache rn + = let + (mod, str) = moduleNamePair rn + in + cachedIface iface_cache mod >>= \ maybe_iface -> + case maybe_iface of + Failed err -> + return (Nothing, unitBag err) + Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) -> + case lookupFM fixes str of + Nothing -> return (Nothing, emptyBag) + Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag) + Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag) + Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag) + +ie_name (IEVar n) = n +ie_name (IEThingAbs n) = n +ie_name (IEThingAll n) = n +ie_name (IEThingWith n _) = n + +unqual_str (Unqual str) = str +unqual_str q@(Qual _ _) = panic "unqual_str" + +adderr_if True err errs = err `consBag` errs +adderr_if False err errs = errs \end{code} +********************************************************* +* * +\subsection{Actually creating the imported names} +* * +********************************************************* + +\begin{code} +getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl + -> RnM_IInfo s (Bag RnName, -- values + Bag RnName, -- tycons/classes + Bag (RnName,ExportFlag)) -- import flags + +getIfaceDeclNames ie (ValSig val src_loc _) + = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> + returnRn (unitBag (RnName val_name), + emptyBag, + unitBag (RnName val_name, ExportAll)) + +getIfaceDeclNames ie (TypeSig tycon src_loc _) + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + returnRn (emptyBag, + unitBag (RnSyn tycon_name), + unitBag (RnSyn tycon_name, ExportAll)) + +getIfaceDeclNames ie (NewTypeSig tycon con src_loc _) + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + [con] `thenRn` \ con_names -> + returnRn (if imp_all (imp_flag ie) then + listToBag (map (\ n -> RnConstr n tycon_name) con_names) + else + emptyBag, + unitBag (RnData tycon_name con_names), + unitBag (RnData tycon_name con_names, imp_flag ie)) + +getIfaceDeclNames ie (DataSig tycon cons src_loc _) + = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> + mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + cons `thenRn` \ con_names -> + returnRn (if imp_all (imp_flag ie) then + listToBag (map (\ n -> RnConstr n tycon_name) con_names) + else + emptyBag, + unitBag (RnData tycon_name con_names), + unitBag (RnData tycon_name con_names, imp_flag ie)) + +getIfaceDeclNames ie (ClassSig cls ops src_loc _) + = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name -> + mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name)) + (Just (nameImportFlag cls_name))) + ops `thenRn` \ op_names -> + returnRn (if imp_all (imp_flag ie) then + listToBag (map (\ n -> RnClassOp n cls_name) op_names) + else + emptyBag, + unitBag (RnClass cls_name op_names), + unitBag (RnClass cls_name op_names, imp_flag ie)) + + +imp_all ExportAll = True +imp_all _ = False + +imp_flag (IEThingAbs _) = ExportAbs +imp_flag (IEThingAll _) = ExportAll +imp_flag (IEThingWith _ _) = ExportAll +\end{code} + +********************************************************* +* * +\subsection{Creating a new imported name} +* * +********************************************************* + +\begin{code} +newImportedName :: Bool -- True => tycon or class + -> SrcLoc + -> Maybe ExportFlag -- maybe export flag + -> Maybe ExportFlag -- maybe import flag + -> RdrName -- orig name + -> RnM_IInfo s Name + +newImportedName tycon_or_class locn maybe_exp maybe_imp rdr + = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) -> + case if tycon_or_class + then lookupFM done_tcs (moduleNamePair rdr) + else lookupFM done_vals (moduleNamePair rdr) + of + Just rn -> returnRn (getName rn) + Nothing -> + rnGetUnique `thenRn` \ u -> + let + uniq = case rdr of + Qual m n -> u + Unqual n -> case lookupFM b_keys n of + Nothing -> u + Just (key,_) -> key + + exp = case maybe_exp of + Just exp -> exp + Nothing -> exp_fn n + + imp = case maybe_imp of + Just imp -> imp + Nothing -> imp_fn n + + n = mkImportedName uniq rdr imp locn exp (occ_fn n) + in + returnRn n +\end{code} \begin{code} globalDupNamesErr rdr rns sty - = ppHang (ppBesides [pprNonOp sty rdr, ppStr " multiply defined:"]) + = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"]) 4 (ppAboves (map pp_def rns)) where pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty - -- ToDo: print import src locs for imported names +dupImportWarn dup_imps sty + = ppStr "dupImportWarn" + +qualPreludeImportWarn imp sty + = ppStr "qualPreludeImportWarn" + +unknownImpSpecErr ie imp_mod locn sty + = ppStr "unknownImpSpecErr" + +duplicateImpSpecErr ie imp_mod locn sty + = ppStr "duplicateImpSpecErr" + +allWhenSynImpSpecWarn n imp_mod locn sty + = ppStr "allWhenSynImpSpecWarn" + +allWhenAbsImpSpecErr n imp_mod locn sty + = ppStr "allWhenAbsImpSpecErr" + +withWhenAbsImpSpecErr n imp_mod locn sty + = ppStr "withWhenAbsImpSpecErr" + +withImpSpecErr str n has ns imp_mod locn sty + = ppStr "withImpSpecErr" \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 73cf832..8cf8221 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -6,7 +6,7 @@ \begin{code} #include "HsVersions.h" -module RnSource ( rnSource, rnPolyType ) where +module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where import Ubiq import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking @@ -17,18 +17,23 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnBinds ( rnTopBinds, rnMethodBinds ) +import RnUtils ( lubExportFlag ) -import Bag ( emptyBag, unitBag, consBag, unionManyBags, listToBag, bagToList ) +import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) +import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) -import Name ( Name, isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName ) +import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), + nameImportFlag, RdrName, pprNonSym ) +import Outputable -- ToDo:rm +import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) import Unique ( Unique ) -import UniqFM ( addListToUFM, listToUFM ) +import UniqFM ( emptyUFM, addListToUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM ) import UniqSet ( UniqSet(..) ) -import Util ( isIn, isn'tIn, sortLt, panic, assertPanic ) +import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, panic, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} @@ -48,8 +53,8 @@ Checks the (..) etc constraints in the export list. \begin{code} rnSource :: [Module] - -> Bag (Module,(RnName,ExportFlag)) -- unqualified imports from module - -> Bag RenamedFixityDecl -- fixity info for imported names + -> Bag (Module,RnName) -- unqualified imports from module + -> Bag RenamedFixityDecl -- fixity info for imported names -> RdrNameHsModule -> RnM s (RenamedHsModule, Name -> ExportFlag, -- export info @@ -95,8 +100,8 @@ rnSource imp_mods unqual_imps imp_fixes occ_info ) where - trashed_exports = trace "rnSource:trashed_exports" Nothing - trashed_imports = trace "rnSource:trashed_imports" [] + trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing + trashed_imports = {-trace "rnSource:trashed_imports"-} [] \end{code} @@ -108,7 +113,7 @@ rnSource imp_mods unqual_imps imp_fixes \begin{code} rnExports :: [Module] - -> Bag (Module,(RnName,ExportFlag)) + -> Bag (Module,RnName) -> Maybe [RdrNameIE] -> RnM s (Name -> ExportFlag) @@ -118,26 +123,54 @@ rnExports mods unqual_imps Nothing rnExports mods unqual_imps (Just exps) = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> let + exp_names = bagToList (unionManyBags exp_bags) exp_mods = catMaybes mod_maybes - exp_names = unionManyBags exp_bags - -- check for duplicate names - -- check for duplicate modules + -- Warn for duplicate names and modules + (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names + (uniq_exp_mods, dup_mods) = removeDups cmpPString exp_mods + cmp_fst (x,_) (y,_) = x `cmp` y - -- check for duplicate local names - -- add in module contents checking for duplicate local names + -- Build finite map of exported names to export flag + exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names) + exp_map1 = foldl add_mod_names exp_map0 uniq_exp_mods - -- build export flag lookup function - exp_fn n = if isLocallyDefined n then ExportAll else NotExported + mod_fm = addListToFM_C unionBags emptyFM + [(mod, unitBag (getName rn, nameImportFlag (getName rn))) + | (mod,rn) <- bagToList unqual_imps] + + add_mod_names exp_map mod + = case lookupFM mod_fm mod of + Nothing -> exp_map + Just mod_names -> addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)) + + pair_fst p@(f,_) = (f,p) + lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2) + + -- Check for exporting of duplicate local names + exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1] + (_, dup_locals) = removeDups cmp_local exp_locals + cmp_local (x,_) (y,_) = x `cmpPString` y + + + -- Build export flag function + exp_fn n = case lookupUFM exp_map1 n of + Nothing -> NotExported + Just (_,flag) -> flag in + getSrcLocRn `thenRn` \ src_loc -> + mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_` + mapRn (addWarnRn . dupModuleExportWarn src_loc) dup_mods `thenRn_` + mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_` 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 (RnName n) = returnRn (unitBag (n,ExportAll)) checkIEVar (RnUnbound _) = returnRn emptyBag checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> failButContinueRn emptyBag (classOpExportErr rn src_loc) @@ -157,6 +190,7 @@ rnIE mods (IEThingAbs name) rnIE mods (IEThingAll name) = lookupTyConOrClass name `thenRn` \ rn -> checkIEAll rn `thenRn` \ exps -> + checkImportAll rn `thenRn_` returnRn (Nothing, exps) where checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons))) @@ -172,6 +206,7 @@ rnIE mods (IEThingWith name names) = lookupTyConOrClass name `thenRn` \ rn -> mapRn lookupValue names `thenRn` \ rns -> checkIEWith rn rns `thenRn` \ exps -> + checkImportAll rn `thenRn_` returnRn (Nothing, exps) where checkIEWith rn@(RnData n cons) rns @@ -196,9 +231,18 @@ rnIE mods (IEThingWith name names) 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) + | isIn "rnIE:IEModule" mod mods + = returnRn (Just mod, emptyBag) + | otherwise + = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc) + + +checkImportAll rn + = case nameImportFlag (getName rn) of + ExportAll -> returnRn () + exp -> getSrcLocRn `thenRn` \ src_loc -> + addErrRn (importAllErr rn src_loc) \end{code} %********************************************************* @@ -312,9 +356,9 @@ rnConDecls tv_env con_decls \end{code} %********************************************************* -%* * +%* * \subsection{SPECIALIZE data pragmas} -%* * +%* * %********************************************************* \begin{code} @@ -324,12 +368,14 @@ rnSpecDataSig :: RdrNameSpecDataSig rnSpecDataSig (SpecDataSig tycon ty src_loc) = pushSrcLocRn src_loc $ let - tyvars = extractMonoTyNames ty + tyvars = extractMonoTyNames is_tyvar_name ty in mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> lookupTyCon tycon `thenRn` \ tycon' -> rnMonoType tv_env ty `thenRn` \ ty' -> returnRn (SpecDataSig tycon' ty' src_loc) + +is_tyvar_name n = isLexVarId (getLocalName n) \end{code} %********************************************************* @@ -444,7 +490,7 @@ rnSpecInstSig :: RdrNameSpecInstSig rnSpecInstSig (SpecInstSig clas ty src_loc) = pushSrcLocRn src_loc $ let - tyvars = extractMonoTyNames ty + tyvars = extractMonoTyNames is_tyvar_name ty in mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> lookupClass clas `thenRn` \ new_clas -> @@ -518,17 +564,13 @@ rnPolyType :: TyVarNamesEnv rnPolyType tv_env (HsForAllTy tvs ctxt ty) = rn_poly_help tv_env tvs ctxt ty -rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty) +rnPolyType tv_env (HsPreForAllTy ctxt ty) = rn_poly_help tv_env forall_tyvars ctxt ty where - mentioned_tyvars = extract_poly_ty_names poly_ty - forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env - ------------- -extract_poly_ty_names (HsPreForAllTy ctxt ty) - = extractCtxtTyNames ctxt - `unionLists` - extractMonoTyNames ty + mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty + forall_tyvars = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $ + --pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $ + mentioned_tyvars `minusList` domTyVarNamesEnv tv_env ------------ rn_poly_help :: TyVarNamesEnv @@ -538,12 +580,17 @@ rn_poly_help :: TyVarNamesEnv -> RnM_Fixes s RenamedPolyType rn_poly_help tv_env tyvars ctxt ty - = getSrcLocRn `thenRn` \ src_loc -> + = --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env), + -- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars), + -- ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt), + -- ppStr ";ty=", ppr PprShowAll ty] + -- ) $ + getSrcLocRn `thenRn` \ src_loc -> mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> let tv_env2 = catTyVarNamesEnvs tv_env1 tv_env in - rnContext tv_env2 ctxt `thenRn` \ new_ctxt -> + rnContext tv_env2 ctxt `thenRn` \ new_ctxt -> rnMonoType tv_env2 ty `thenRn` \ new_ty -> returnRn (HsForAllTy new_tyvars new_ctxt new_ty) \end{code} @@ -571,11 +618,11 @@ rnMonoType tv_env (MonoTupleTy tys) rnMonoType tv_env (MonoTyApp name tys) = let - lookup_fn = if isAvarid (getLocalName name) + lookup_fn = if isLexVarId (getLocalName name) then lookupTyVarName tv_env else lookupTyCon in - lookup_fn name `thenRn` \ name' -> + lookup_fn name `thenRn` \ name' -> mapRn (rnMonoType tv_env) tys `thenRn` \ tys' -> returnRn (MonoTyApp name' tys') \end{code} @@ -594,6 +641,18 @@ rnContext tv_env ctxt \begin{code} +dupNameExportWarn locn names@((n,_):_) sty + = ppHang (ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times:"]) + 4 (ppr sty locn) + +dupModuleExportWarn locn mods@(mod:_) sty + = ppHang (ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list:"]) + 4 (ppr sty locn) + +dupLocalsExportErr locn locals@((str,_):_) sty + = ppHang (ppBesides [ppStr "Exported names have same local name `", ppPStr str, ppStr "': ", ppr sty locn]) + 4 (ppInterleave ppSP (map (pprNonSym sty . snd) locals)) + classOpExportErr op locn sty = ppHang (ppStr "Class operation can only be exported with class:") 4 (ppCat [ppr sty op, ppr sty locn]) @@ -607,6 +666,10 @@ withExportErr str rn has rns locn sty 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)]) (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)])) +importAllErr rn locn sty + = ppHang (ppCat [pprNonSym sty rn, ppStr "exported concretely but only imported abstractly"]) + 4 (ppr sty locn) + badModExportErr mod locn sty = ppHang (ppStr "Unknown module in export list:") 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn]) diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index f2d3f05..2658fcc 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -12,6 +12,8 @@ module RnUtils ( emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv, lookupRnEnv, lookupTcRnEnv, + lubExportFlag, + unknownNameErr, badClassOpErr, qualNameErr, @@ -30,7 +32,7 @@ import ErrUtils ( addShortErrLocLine, addErrLoc ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addListToFM, addToFM ) import Maybes ( maybeToBool ) -import Name ( RdrName(..), isQual, pprNonOp, getLocalName ) +import Name ( RdrName(..), isQual, pprNonSym, getLocalName, ExportFlag(..) ) import PprStyle ( PprStyle(..) ) import Pretty import RnHsSyn ( RnName ) @@ -72,9 +74,9 @@ vaule Unqual Names. @lookupTcRnEnv@ looks up tycons/classes in the alternative global name space. -@extendGlobalRnEnv@ adds global names to the RnEnv. It takes seperate +@extendGlobalRnEnv@ adds global names to the RnEnv. It takes separate value and tycon/class name lists. It returns any duplicate names -seperatle. +seperately. @extendRnEnv@ adds new local names to the ScopeStack in an RnEnv. It optionally reports any shadowed names. @@ -83,7 +85,6 @@ It optionally reports any shadowed names. emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM) - 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) @@ -150,6 +151,19 @@ lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr ********************************************************* * * +\subsection{Export Flag Functions} +* * +********************************************************* + +\begin{code} +lubExportFlag ExportAll ExportAll = ExportAll +lubExportFlag ExportAll ExportAbs = ExportAll +lubExportFlag ExportAbs ExportAll = ExportAll +lubExportFlag ExportAbs ExportAbs = ExportAbs +\end{code} + +********************************************************* +* * \subsection{Errors used in RnMonad} * * ********************************************************* @@ -157,16 +171,16 @@ lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr \begin{code} unknownNameErr descriptor name locn = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonOp sty name] ) + ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] ) badClassOpErr clas op locn = addErrLoc locn "" ( \ sty -> - ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `", + ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `", ppr sty clas, ppStr "'"] ) qualNameErr descriptor (name,locn) = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonOp sty name ] ) + ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] ) dupNamesErr descriptor ((name1,locn1) : dup_things) sty = ppAboves (item1 : map dup_item dup_things) @@ -174,11 +188,11 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty item1 = ppBesides [ ppr PprForUser locn1, ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ", - pprNonOp sty name1 ] + pprNonSym sty name1 ] dup_item (name, locn) = ppBesides [ ppr PprForUser locn, - ppStr ": here was another declaration of `", pprNonOp sty name, ppStr "'" ] + ppStr ": here was another declaration of `", pprNonSym sty name, ppStr "'" ] shadowedNameWarn locn shadow = addShortErrLocLine locn ( \ sty -> diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 0605971..5e9fffc 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -49,7 +49,7 @@ import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs, import Usage ( UVar(..) ) import Util ( mapAccumL, zipWithEqual, panic, assertPanic ) -isLeakFreeType = panic "SetLevels.isLeakFreeType (ToDo)" +isLeakFreeType x y = False -- safe option; ToDo \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index f07a328..ed4d11d 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -41,8 +41,6 @@ module SimplEnv ( InExpr(..), InAlts(..), InDefault(..), InArg(..), OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) - - -- and to make the interface self-sufficient... ) where import Ubiq{-uitous-} @@ -50,21 +48,24 @@ import Ubiq{-uitous-} import SmplLoop -- breaks the MagicUFs / SimplEnv loop import BinderInfo ( BinderInfo{-instances-} ) +import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) import CoreSyn import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, calcUnfoldingGuidance, UnfoldingGuidance(..), mkFormSummary, FormSummary ) +import CoreUtils ( manifestlyWHNF ) import FiniteMap -- lots of things import Id ( idType, getIdUnfolding, getIdStrictness, applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, IdEnv(..), IdSet(..), GenId ) -import IdInfo ( StrictnessInfo ) +import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) import Name ( isLocallyDefined ) +import OccurAnal ( occurAnalyseExpr ) import Outputable ( Outputable(..){-instances-} ) import PprCore -- various instances import PprStyle ( PprStyle(..) ) @@ -76,23 +77,17 @@ import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, TyVarEnv(..), GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Outputable-} ) +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) import UniqSet -- lots of things import Usage ( UVar(..), GenUsage{-instances-} ) import Util ( zipEqual, panic, assertPanic ) type TypeEnv = TyVarEnv Type -addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)" -bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)" cmpType = panic "cmpType (SimplEnv)" exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)" -lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)" -manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)" -occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)" oneSafeOcc = panic "oneSafeOcc (SimplEnv)" oneTextualOcc = panic "oneTextualOcc (SimplEnv)" simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" -uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)" -ufmToList = panic "ufmToList (SimplEnv)" \end{code} %************************************************************************ @@ -730,7 +725,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem modify (u, occ_info) env - = case (lookupDirectlyUFM env u) of + = case (lookupUFM_Directly env u) of Nothing -> env -- ToDo: can this happen? Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index 2c9dcfc..5290a54 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -71,11 +71,10 @@ import Id ( idType, getIdArity, addIdArity, mkSysLocal, ) import IdInfo ( arityMaybe ) import SrcLoc ( mkUnknownSrcLoc ) +import Type ( splitSigmaTy, splitFunTy ) import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) import Util ( panic, assertPanic ) -splitTypeWithDictsAsArgs = panic "SatStgRhs.splitTypeWithDictsAsArgs (ToDo)" - type Count = Int type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed @@ -167,7 +166,9 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body) new_arity = num_args + needed_args -- get type info for this function: - (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (idType b) + (_,rho_arg_tys,tau_ty) = splitSigmaTy (idType b) + (tau_arg_tys, _) = splitFunTy tau_ty + all_arg_tys = ASSERT(null rho_arg_tys) {-rho_arg_tys ++-} tau_arg_tys -- now, we already have "args"; we drop that many types args_we_dont_have_tys = drop num_args all_arg_tys diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 4f83c8e..4ce7a2b 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -33,11 +33,12 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, GenId {-instance NamedThing -} ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( isAvarop, pprNonOp, getOrigName ) +import Name ( isLexVarSym, pprNonSym, moduleNamePair ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar ) +import PrelMods ( fromPrelude, pRELUDE ) import Pretty -- plenty of it import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, @@ -234,21 +235,18 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs | isDictFunId id || maybeToBool (isConstMethodId_maybe id) = let get_mod = getInstIdModule id - use_mod = if from_prelude get_mod - then SLIT("Prelude") + use_mod = if fromPrelude get_mod + then pRELUDE else get_mod in (use_mod, _NIL_) | otherwise - = getOrigName id + = moduleNamePair id get_ty_data (ty, tys) = (mod_name, [(ty_name, ty, tys)]) where - (mod_name,ty_name) = getOrigName ty - - from_prelude mod - = SLIT("Prelude") == (_SUBSTR_ mod 0 6) + (mod_name,ty_name) = moduleNamePair ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] mods = map head (equivClasses _CMP_STRING_ module_names) @@ -259,7 +257,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs EQ_ -> ([_NIL_], tail mods) other -> ([], mods) - (prels, others) = partition from_prelude known + (prels, others) = partition fromPrelude known use_modules = unks ++ prels ++ others pp_module_specs :: FAST_STRING -> Pretty @@ -291,7 +289,7 @@ pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty pp_tyspec sty pp_mod (_, tycon, tys) = ppCat [pp_mod, ppStr "{-# SPECIALIZE", ppStr "data", - pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), + pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), ppStr "#-}", ppStr "{- Essential -}" ] where @@ -315,7 +313,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | is_const_method_id = let Just (cls, clsty, clsop) = const_method_maybe - (_, cls_str) = getOrigName cls + (_, cls_str) = moduleNamePair cls clsop_str = getClassOpString clsop in ppCat [pp_mod, @@ -329,7 +327,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | is_default_method_id = let Just (cls, clsop, _) = default_method_maybe - (_, cls_str) = getOrigName cls + (_, cls_str) = moduleNamePair cls clsop_str = getClassOpString clsop in ppCat [pp_mod, @@ -343,7 +341,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | otherwise = ppCat [pp_mod, ppStr "{-# SPECIALIZE", - pprNonOp PprForUser id, ppStr "::", + pprNonSym PprForUser id, ppStr "::", pprGenType sty spec_ty, ppStr "#-}", pp_essential ] where @@ -356,7 +354,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) default_method_maybe = isDefaultMethodId_maybe id is_default_method_id = maybeToBool default_method_maybe - pp_clsop str | isAvarop str + pp_clsop str | isLexVarSym str = ppBesides [ppLparen, ppPStr str, ppRparen] | otherwise = ppPStr str diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index c3bd393..e9dacd3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -41,7 +41,7 @@ import Type ( getAppDataTyCon ) import UniqSupply -- all of it, really import Util ( panic ) -isLeakFreeType = panic "CoreToStg.isLeakFreeType (ToDo)" +isLeakFreeType x y = False -- safe option; ToDo \end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index ba87f68..8e08d32 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -44,7 +44,7 @@ import Ubiq{-uitous-} import CostCentre ( showCostCentre ) import Id ( idPrimRep, GenId{-instance NamedThing-} ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) -import Name ( isExported, isOpLexeme ) +import Name ( isExported, isSymLexeme ) import Outputable ( ifPprDebug, interppSP, interpp'SP, Outputable(..){-instance * Bool-} ) @@ -652,7 +652,7 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) 4 (ppBeside (ppr sty expr) ppSemi) where ppr_con sty con - = if isOpLexeme con + = if isSymLexeme con then ppBesides [ppLparen, ppr sty con, ppRparen] else ppr sty con diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 2fb8408..88667f0 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -11,7 +11,7 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where import Ubiq import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), - HsExpr, Match, PolyType, InPat, OutPat, + HsExpr, Match, PolyType, InPat, OutPat(..), GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, collectBinders ) import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), @@ -36,14 +36,14 @@ import Kind ( mkBoxedTypeKind, mkTypeKind ) import Id ( GenId, idType, mkUserId ) import IdInfo ( noIdInfo ) import Maybes ( assocMaybe, catMaybes, Maybe(..) ) -import Name ( pprNonOp ) +import Name ( pprNonSym ) import PragmaInfo ( PragmaInfo(..) ) import Pretty import RnHsSyn ( RnName ) -- instances import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, mkSigmaTy, splitSigmaTy, splitRhoTy, mkForAllTy, splitForAllTy ) -import Util ( panic ) +import Util ( isIn, panic ) \end{code} %************************************************************************ @@ -251,8 +251,9 @@ data SigInfo -- Make poly_ids for all the binders that don't have type signatures let + tys_to_gen = mkTyVarTys tyvars_to_gen dicts_to_gen = map instToId (bagToList lie_to_gen) - dict_tys = map tcIdType dicts_to_gen + dict_tys = map tcIdType dicts_to_gen mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo where @@ -260,31 +261,32 @@ data SigInfo mkFunTys dict_tys $ tcIdType local_id - tys_to_gen = mkTyVarTys tyvars_to_gen more_sig_infos = [ SigInfo binder (mk_poly binder local_id) local_id tys_to_gen dicts_to_gen lie_to_gen | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids ] - local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts) - | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos - ] - all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder in -- Now generalise the bindings let - find_sig lid = head [ (pid, tvs, ds, lie) + -- local_binds is a bunch of bindings of the form + -- f_mono = f_poly tyvars dicts + -- one for each binder, f, that lacks a type signature. + -- This bunch of bindings is put at the top of the RHS of every + -- binding in the group, so as to bind all the f_monos. + + local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen) + | local_id <- nosig_local_ids + ] + + find_sig lid = head [ (pid, tvs, ds, lie) | SigInfo _ pid lid' tvs ds lie, lid==lid' ] - -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen: - -- We still need to do this simplification, because some dictionaries - -- may gratuitously constrain some tyvars over which we *are* going - -- to generalise. - -- For example d::Eq (Foo a b), where Foo is instanced as above. + gen_bind (bind, lie) = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie `thenTc` \ (lie_free, dict_binds) -> @@ -361,7 +363,7 @@ getImplicitStuffToGen is_restricted sig_ids binds_w_lies returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE) where - sig_ids = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs] + sig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2, lie1 `plusLIE` lie2)) @@ -641,8 +643,42 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) \end{code} -Error contexts and messages -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection[TcBinds-monomorphism]{The monomorphism restriction} +%* * +%************************************************************************ + +Not exported: + +\begin{code} +isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these + -> TcBind s + -> Bool + +isUnRestrictedGroup sigs EmptyBind = True +isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds +isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds + +is_elem v vs = isIn "isUnResMono" v vs + +isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs +isUnResMono sigs (PatMonoBind other _ _) = False +isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs +isUnResMono sigs (FunMonoBind _ _ _ _) = True +isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && + isUnResMono sigs mb2 +isUnResMono sigs EmptyMonoBinds = True +\end{code} + + +%************************************************************************ +%* * +\subsection[TcBinds-errors]{Error contexts and messages} +%* * +%************************************************************************ + + \begin{code} patMonoBindsCtxt bind sty = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind) @@ -675,7 +711,7 @@ specGroundnessCtxt valSpecSigCtxt v ty sty = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:")) - 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")), + 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")), ppr sty ty]) \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a48bc1e..330075d 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -41,7 +41,7 @@ import CoreUtils ( escErrorMsg ) import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, idType ) import IdInfo ( noIdInfo ) -import Name ( isLocallyDefined, getOrigName, getLocalName ) +import Name ( isLocallyDefined, moduleNamePair, getLocalName ) import PrelVals ( pAT_ERROR_ID ) import PprStyle import Pretty @@ -504,7 +504,7 @@ makeClassDeclDefaultMethodRhs clas method_ids tag HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where - (clas_mod, clas_name) = getOrigName clas + (clas_mod, clas_name) = moduleNamePair clas method_id = method_ids !! (tag-1) class_op = (getClassOps clas) !! (tag-1) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index b1bbb95..d69a577 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -564,7 +564,7 @@ gen_inst_info modname fixities deriver_name_funs where clas_key = getClassKey clas clas_Name - = let (mod, nm) = getOrigName clas in + = let (mod, nm) = moduleNamePair clas in ClassName clas_key (mkPreludeCoreName mod nm) [] \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 290db74..5d427a3 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -29,7 +29,7 @@ import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars ) -import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet ) +import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity ) import Class ( Class(..), GenClass, getClassSig ) @@ -41,9 +41,9 @@ import PprStyle import Pretty import RnHsSyn ( RnName(..) ) import Type ( splitForAllTy ) -import Unique ( Unique ) +import Unique ( pprUnique10, pprUnique{-ToDo:rm-} ) import UniqFM -import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic ) +import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic, pprTrace{-ToDo:rm-} ) \end{code} Data type declarations @@ -151,7 +151,7 @@ Looking up in the environments. \begin{code} tcLookupTyVar name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name) + returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name) tcLookupTyCon (WiredInTyCon tc) -- wired in tycons @@ -159,26 +159,28 @@ tcLookupTyCon (WiredInTyCon tc) -- wired in tycons tcLookupTyCon name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tce (panic "tcLookupTyCon") name) + returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name) tcLookupTyConByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce - (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq)) + (pprPanic "tcLookupTyCon:" (pprUnique10 uniq)) uniq in returnNF_Tc tycon tcLookupClass name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM ce (panic "tcLookupClass") name) +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $ +-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $ + returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name) tcLookupClassByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let (kind, clas) = lookupWithDefaultUFM_Directly ce - (pprPanic "tcLookupClas:" (ppr PprDebug uniq)) + (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq)) uniq in returnNF_Tc clas @@ -261,7 +263,7 @@ tcLookupGlobalValueByKey uniq returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq) where #ifdef DEBUG - def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq) + def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq) #else def = panic "tcLookupGlobalValueByKey" #endif diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 0baa230..e631dc1 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -517,7 +517,7 @@ gen_Ix_binds tycon then enum_ixes else single_con_ixes where - tycon_str = _UNPK_ (snd (getOrigName tycon)) + tycon_str = _UNPK_ (snd (moduleNamePair tycon)) -------------------------------------------------------------- enum_ixes = enum_range `AndMonoBinds` @@ -655,7 +655,7 @@ gen_Read_binds fixities tycon read_con data_con -- note: "b" is the string being "read" = let data_con_PN = Prel (WiredInId data_con) - data_con_str= snd (getOrigName data_con) + data_con_str= snd (moduleNamePair data_con) as_needed = take (dataConArity data_con) as_PNs bs_needed = take (dataConArity data_con) bs_PNs con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed) @@ -707,7 +707,7 @@ gen_Show_binds fixities tycon nullary_con = dataConArity data_con == 0 show_con - = let (mod, nm) = getOrigName data_con + = let (mod, nm) = moduleNamePair data_con space_maybe = if nullary_con then _NIL_ else SLIT(" ") in HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe))) @@ -1074,19 +1074,19 @@ d_Pat = VarPatIn d_PN con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName con2tag_PN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") in Imp mod con2tag [mod] con2tag tag2con_PN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") in Imp mod tag2con [mod] tag2con maxtag_PN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") in Imp mod maxtag [mod] maxtag @@ -1095,19 +1095,19 @@ maxtag_PN tycon con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName tag2con_FN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") in mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc maxtag_FN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") in mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc con2tag_FN tycon - = let (mod, nm) = getOrigName tycon + = let (mod, nm) = moduleNamePair tycon con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") in mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0d54c22..ac3c4d0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -63,10 +63,12 @@ import CoreUtils ( escErrorMsg ) import Id ( GenId, idType, isDefaultMethodId_maybe ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust ) -import Name ( getLocalName, getOrigName ) +import Name ( getLocalName, origName, nameOf ) import PrelInfo ( pAT_ERROR_ID ) +import PrelMods ( pRELUDE ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, - pprParendGenType ) + pprParendGenType + ) import PprStyle import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) @@ -558,13 +560,13 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag error_msg = "%E" -- => No explicit method for \" ++ escErrorMsg error_str - mod_str = case inst_mod of { Nothing -> SLIT("Prelude"); Just m -> m } + mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" - (_, clas_name) = getOrigName clas + clas_name = nameOf (origName clas) \end{code} @@ -778,7 +780,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc clas = lookupCE ce class_name -- Renamer ensures this can't fail -- Make some new type variables, named as in the specialised instance type - ty_names = extractMonoTyNames (==) ty + ty_names = extractMonoTyNames ???is_tyvarish_name??? ty (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names in babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) @@ -909,7 +911,7 @@ scrutiniseInstanceType from_here clas inst_tau = failTc (derivingWhenInstanceExistsErr clas inst_tycon) | -- CCALL CHECK - -- A user declaration of a _CCallable/_CReturnable instance + -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas && not opt_CompilingPrelude -- which allows anything diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1645d0e..1f2b513 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -44,7 +44,7 @@ import PrelInfo ( unitTy, mkPrimIoTy ) import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) import TyCon ( TyCon ) -import Type ( applyTyCon ) +import Type ( mkSynTy ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) @@ -103,13 +103,13 @@ tcModule renamer_name_funs fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) -> -- Type-check the type and class decls - trace "tcTyAndClassDecls:" $ + --trace "tcTyAndClassDecls:" $ tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag `thenTc` \ (env, record_binds) -> -- Typecheck the instance decls, includes deriving tcSetEnv env ( - trace "tcInstDecls:" $ + --trace "tcInstDecls:" $ tcInstDecls1 inst_decls_bag specinst_sigs mod_name renamer_name_funs fixities ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> @@ -142,7 +142,7 @@ tcModule renamer_name_funs -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process - trace "tcBinds:" $ + --trace "tcBinds:" $ tcBindsAndThen (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing)) (val_decls `ThenBinds` deriv_binds) @@ -233,7 +233,7 @@ checkTopLevelIds mod final_env case (maybe_main, maybe_prim) of (Just main, Nothing) -> tcAddErrCtxt mainCtxt $ - unifyTauTy (applyTyCon io_tc [unitTy]) + unifyTauTy (mkSynTy io_tc [unitTy]) (idType main) (Nothing, Just prim) -> tcAddErrCtxt primCtxt $ @@ -254,7 +254,5 @@ mainBothIdErr sty = ppStr "module Main contains definitions for both main and mainPrimIO" mainNoneIdErr sty - = panic "ToDo: sort out mainIdKey" - -- ppStr "module Main does not contain a definition for main (or mainPrimIO)" - + = ppStr "module Main does not contain a definition for main (or mainPrimIO)" \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index bd27cbd..50f80cf 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -39,7 +39,7 @@ import Pretty import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon, RnName{-instance NamedThing-} ) -import Util ( zipWithEqual, panic ) +import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} ) \end{code} @@ -85,12 +85,14 @@ tcMonoTypeKind (MonoTyApp name tys) = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> tcMonoTyApp kind (mkTyVarTy tyvar) tys -tcMonoTypeKind (MonoTyApp name tys) - | isRnTyCon name -- Must be a type constructor + | otherwise {-isRnTyCon name-} -- Must be a type constructor = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) -> case maybe_arity of Just arity -> tcSynApp name kind arity tycon tys -- synonum Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data + +-- | otherwise +-- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name) -- for unfoldings only: tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty) @@ -155,10 +157,10 @@ tcClassAssertion (class_name, tyvar_name) returnTc (clas, mkTyVarTy tyvar) \end{code} -HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@ +HACK warning: Someone discovered that @CCallable@ and @CReturnable@ could be used in contexts such as: \begin{verbatim} -foo :: _CCallable a => a -> PrimIO Int +foo :: CCallable a => a -> PrimIO Int \end{verbatim} Doing this utterly wrecks the whole point of introducing these diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 06b8d04..0ff60b6 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -87,7 +87,7 @@ Dealing with a group \begin{code} tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s) tcGroup inst_mapper decls - = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ + = --pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ -- TIE THE KNOT fixTc ( \ ~(tycons,classes,_) -> diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 89a90b0..73916b6 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -30,7 +30,6 @@ import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - tcLookupClassByKey, newLocalId, newLocalIds ) import TcMonad @@ -51,12 +50,12 @@ import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, import Pretty import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, tyConDataCons ) -import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, +import Type ( typeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, splitFunTy, mkTyVarTy, getTyVar_maybe ) -import TyVar ( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) -import Unique ( Unique {- instance Eq -}, dataClassKey ) +import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) +import Unique ( Unique {- instance Eq -}, evalClassKey ) import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) import Util ( equivClasses, zipEqual, panic, assertPanic ) \end{code} @@ -91,8 +90,8 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) -- but the simplest thing to do seems to be to get the Kind by (lazily) -- looking at the tyvars and rhs_ty. result_kind, final_tycon_kind :: Kind -- NB not TcKind! - result_kind = getTypeKind rhs_ty - final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars + result_kind = typeKind rhs_ty + final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars -- Construct the tycon tycon = mkSynTyCon (getName tycon_name) @@ -138,7 +137,7 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra let -- Construct the tycon final_tycon_kind :: Kind -- NB not TcKind! - final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars + final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars tycon = mkDataTyCon (getName tycon_name) final_tycon_kind @@ -235,7 +234,7 @@ mkConstructor con_id -- to the Data class [getTyVar "mkConstructor" ty | (clas,ty) <- theta, - uniqueOf clas == dataClassKey] + uniqueOf clas == evalClassKey] check_data arg = case getTyVar_maybe (tcIdType arg) of Nothing -> returnTc () -- Not a tyvar, so OK diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index c8edce0..4eb7b3f 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -15,9 +15,9 @@ import Ubiq -- friends: import TcMonad -import Type ( GenType(..), getTypeKind, mkFunTy, getFunTy_maybe ) +import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe ) import TyCon ( TyCon, mkFunTyCon ) -import TyVar ( GenTyVar(..), TyVar(..), getTyVarKind ) +import TyVar ( GenTyVar(..), TyVar(..), tyVarKind ) import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..), newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType ) @@ -245,7 +245,7 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2 = case maybe_ty1 of DontBind -> failTc (unifyDontBindErr tv1 ps_ty2) - UnBound | getTypeKind non_var_ty2 `isSubKindOf` kind1 + UnBound | typeKind non_var_ty2 `isSubKindOf` kind1 -> occur_check non_var_ty2 `thenTc_` tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () @@ -330,9 +330,9 @@ expectedFunErr ty sty unifyKindErr tyvar ty sty = ppHang (ppStr "Compiler bug: kind mis-match between") - 4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (getTyVarKind tyvar), ppRparen, + 4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (tyVarKind tyvar), ppRparen, ppStr "and", - ppr sty ty, ppLparen, ppr sty (getTypeKind ty), ppRparen]) + ppr sty ty, ppLparen, ppr sty (typeKind ty), ppRparen]) unifyDontBindErr tyvar ty sty = ppHang (ppStr "Couldn't match the *signature/existential* type variable") diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 7174e8e..73001e7 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -207,6 +207,7 @@ derivableClassKeys = [ eqClassKey, showClassKey, ordClassKey, + boundedClassKey, enumClassKey, ixClassKey, readClassKey ] @@ -216,7 +217,7 @@ cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] standardClassKeys = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys -- - -- We have to have "_CCallable" and "_CReturnable" in the standard + -- We have to have "CCallable" and "CReturnable" in the standard -- classes, so that if you go... -- -- _ccall_ foo ... 93{-numeric literal-} ... diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 9597b93..fa790ac 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -38,7 +38,7 @@ import Kind ( Kind(..) ) import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( isAvarop, isPreludeDefined, getOrigName, +import Name ( isLexVarSym, isPreludeDefined, origName, moduleOf, Name{-instance Outputable-} ) import Outputable ( ifPprShowAll, interpp'SP ) @@ -173,7 +173,9 @@ ppr_ty sty env ctxt_prec (DictTy clas ty usage) -- Some help functions ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys - = ASSERT(length arg_tys == 2) + | length arg_tys == 2 + = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $ + ASSERT(length arg_tys == 2) ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys @@ -317,13 +319,7 @@ pprTyCon sty (TupleTyCon _ name _) = ppr sty name pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) - = case sty of - PprDebug -> pp_tycon_and_uniq - PprShowAll -> pp_tycon_and_uniq - _ -> pp_tycon - where - pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq] - pp_tycon = ppr sty name + = ppr sty name pprTyCon sty (SpecTyCon tc ty_maybes) = ppBeside (pprTyCon sty tc) @@ -364,7 +360,7 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) _ -> pp_user where pp_C = ppPStr op_name - pp_user = if isAvarop op_name + pp_user = if isLexVarSym op_name then ppBesides [ppLparen, pp_C, ppRparen] else pp_C \end{code} @@ -395,7 +391,7 @@ getTypeString ty Just (tycon,_) -> if isPreludeDefined tycon then true_bottom - else (False, fst (getOrigName tycon)) + else (False, moduleOf (origName tycon)) true_bottom = (True, panic "getTypeString") @@ -507,7 +503,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings dat = let (_, _, con_arg_tys, _) = dataConSig con in - ppCat [pprNonOp PprForUser con, -- the data con's name... + ppCat [pprNonSym PprForUser con, -- the data con's name... ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)] ppr_next_con con = ppCat [ppChar '|', ppr_con con] diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index e0a6ed2..09dfc13 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -48,7 +48,6 @@ import TyLoop ( Type(..), GenType, import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar ) import Usage ( GenUsage, Usage(..) ) import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) -import PrelMods ( pRELUDE_BUILTIN ) import Maybes import Name ( Name, RdrName(..), appendRdr, nameUnique, @@ -161,14 +160,7 @@ tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind tyConKind (PrimTyCon _ _ kind) = kind - -tyConKind (SpecTyCon tc tys) - = spec (tyConKind tc) tys - where - spec kind [] = kind - spec kind (Just _ : tys) = spec (resultKind kind) tys - spec kind (Nothing : tys) = - argKind kind `mkArrowKind` spec (resultKind kind) tys +tyConKind (SynTyCon _ _ k _ _ _) = k tyConKind (TupleTyCon _ _ n) = mkArrow n @@ -177,6 +169,14 @@ tyConKind (TupleTyCon _ _ n) mkArrow 1 = kind1 mkArrow 2 = kind2 mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1) + +tyConKind (SpecTyCon tc tys) + = spec (tyConKind tc) tys + where + spec kind [] = kind + spec kind (Just _ : tys) = spec (resultKind kind) tys + spec kind (Nothing : tys) = + argKind kind `mkArrowKind` spec (resultKind kind) tys \end{code} \begin{code} @@ -297,11 +297,13 @@ instance Ord3 TyCon where where tag1 = tag_TyCon other_1 tag2 = tag_TyCon other_2 + tag_TyCon FunTyCon = ILIT(1) tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2) tag_TyCon (TupleTyCon _ _ _) = ILIT(3) tag_TyCon (PrimTyCon _ _ _) = ILIT(4) tag_TyCon (SpecTyCon _ _) = ILIT(5) + tag_TyCon (SynTyCon _ _ _ _ _ _) = ILIT(6) instance Eq TyCon where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -333,9 +335,9 @@ instance NamedThing TyCon where getName tc = panic "TyCon.getName" {- LATER: - getName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in + getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in (m, n _APPEND_ specMaybeTysSuffix tys) - getName other_tc = getOrigName (expectJust "tycon1" (getName other_tc)) + getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc)) getName other = Nothing -} \end{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 1b700f6..cddcdcb 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -4,7 +4,7 @@ module TyVar ( GenTyVar(..), TyVar(..), mkTyVar, - getTyVarKind, -- TyVar -> Kind + tyVarKind, -- TyVar -> Kind cloneTyVar, alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, @@ -66,8 +66,8 @@ mkTyVar name uniq kind = TyVar uniq (Just name) usageOmega -getTyVarKind :: GenTyVar flexi -> Kind -getTyVarKind (TyVar _ kind _ _) = kind +tyVarKind :: GenTyVar flexi -> Kind +tyVarKind (TyVar _ kind _ _) = kind cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi cloneTyVar (TyVar _ k n x) u = TyVar u k n x diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 0fd31ef..e1d303d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -31,10 +31,8 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, getTypeKind - - -) where + tyVarsOfType, tyVarsOfTypes, typeKind + ) where import Ubiq import IdLoop -- for paranoia checking @@ -49,9 +47,9 @@ import PrelLoop -- for paranoia checking -- friends: import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} ) import Kind ( mkBoxedTypeKind, resultKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, tyConArity, +import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) -import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), +import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), emptyTyVarSet, unionTyVarSets, minusTyVarSet, unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, addOneToTyVarEnv, TyVarEnv(..) ) @@ -80,7 +78,7 @@ data GenType tyvar uvar -- Parameterised over type and usage variables (GenType tyvar uvar) | TyConTy -- Constants of a specified kind - TyCon + TyCon -- Must *not* be a SynTyCon (GenUsage uvar) -- Usage gives uvar of the full application, -- iff the full application is of kind Type -- c.f. the Usage field in TyVars @@ -146,7 +144,7 @@ expandTy (DictTy clas ty u) -- A tuple of 'em -- Note: length of all_arg_tys can be 0 if the class is - -- _CCallable, _CReturnable (and anything else + -- CCallable, CReturnable (and anything else -- *really weird* that the user writes). where (tyvar, super_classes, ops) = getClassSig clas @@ -227,10 +225,14 @@ splitFunTy t = go t [] \begin{code} -- NB applyTyCon puts in usageOmega, for now at least -mkTyConTy tycon = TyConTy tycon usageOmega +mkTyConTy tycon + = ASSERT(not (isSynTyCon tycon)) + TyConTy tycon usageOmega applyTyCon :: TyCon -> [GenType t u] -> GenType t u -applyTyCon tycon tys = foldl AppTy (TyConTy tycon usageOmega) tys +applyTyCon tycon tys + = ASSERT (not (isSynTyCon tycon)) + foldl AppTy (TyConTy tycon usageOmega) tys getTyCon_maybe :: GenType t u -> Maybe TyCon getTyCon_maybe (TyConTy tycon _) = Just tycon @@ -240,7 +242,8 @@ getTyCon_maybe other_ty = Nothing \begin{code} mkSynTy syn_tycon tys - = SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) + = ASSERT(isSynTyCon syn_tycon) + SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon \end{code} @@ -405,15 +408,15 @@ mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) Finding the kind of a type ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -getTypeKind :: GenType (GenTyVar any) u -> Kind -getTypeKind (TyVarTy tyvar) = getTyVarKind tyvar -getTypeKind (TyConTy tycon usage) = tyConKind tycon -getTypeKind (SynTy _ _ ty) = getTypeKind ty -getTypeKind (FunTy fun arg _) = mkBoxedTypeKind -getTypeKind (DictTy clas arg _) = mkBoxedTypeKind -getTypeKind (AppTy fun arg) = resultKind (getTypeKind fun) -getTypeKind (ForAllTy _ _) = mkBoxedTypeKind -getTypeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind +typeKind :: GenType (GenTyVar any) u -> Kind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (TyConTy tycon usage) = tyConKind tycon +typeKind (SynTy _ _ ty) = typeKind ty +typeKind (FunTy fun arg _) = mkBoxedTypeKind +typeKind (DictTy clas arg _) = mkBoxedTypeKind +typeKind (AppTy fun arg) = resultKind (typeKind fun) +typeKind (ForAllTy _ _) = mkBoxedTypeKind +typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 87da3e0..f7f9594 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -56,6 +56,7 @@ module FiniteMap ( fmToList, keysFM, eltsFM{-used in GHCI-} #ifdef COMPILING_GHC + , bagToFM , FiniteSet(..), emptySet, mkSet, isEmptySet , elementOf, setToList, union, minusSet{-exported for GHCI-} #endif @@ -73,6 +74,7 @@ import Ubiq{-uitous-} # ifdef DEBUG import Pretty # endif +import Bag ( foldBag ) #if ! OMIT_NATIVE_CODEGEN #define IF_NCG(a) a #else @@ -98,9 +100,13 @@ import Pretty \begin{code} -- BUILDING emptyFM :: FiniteMap key elt -unitFM :: key -> elt -> FiniteMap key elt +unitFM :: key -> elt -> FiniteMap key elt listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt -- In the case of duplicates, the last is taken +#ifdef COMPILING_GHC +bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt + -- In the case of duplicates, who knows which is taken +#endif -- ADDING AND DELETING -- Throws away any previous binding @@ -203,7 +209,11 @@ emptyFM unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM -listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs +listToFM = addListToFM emptyFM + +#ifdef COMPILING_GHC +bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM +#endif \end{code} %************************************************************************ -- 1.7.10.4