rename/ParseIface.hs
#define RENAMERSRCS_LHS \
+rename/ParseUtils.lhs \
rename/RnHsSyn.lhs \
rename/RnMonad.lhs \
rename/Rename.lhs \
$(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,)
compile(reader/RdrHsSyn,lhs,)
compile(rename/ParseIface,hs,)
+compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,)
compile(rename/Rename,lhs,)
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
)
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
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"
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]
[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]
} }
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]
[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
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]
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_
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)
RdrName(..),
isUnqual,
isQual,
- isConopRdr,
+ isRdrLexCon,
appendRdr,
- rdrToOrig,
showRdr,
cmpRdr,
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
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}
%************************************************************************
\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
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_
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
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 []
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 ???
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
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
\begin{code}
data ExportFlag
= ExportAll -- export with all constructors/methods
- | ExportAbs -- export abstractly
+ | ExportAbs -- export abstractly (tycons/classes only)
| NotExported
isExported a
\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
\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}
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
mkSrcLoc = SrcLoc
mkSrcLoc2 x IBOX(y) = SrcLoc2 x y
mkUnknownSrcLoc = SrcLoc SLIT("<unknown>") SLIT("<unknown>")
+mkIfaceSrcLoc = SrcLoc SLIT("<an interface file>") SLIT("<unknown>")
mkBuiltinSrcLoc = SrcLoc SLIT("<built-into-the-compiler>") SLIT("<none>")
mkGeneratedSrcLoc = SrcLoc SLIT("<compiler-generated-code>") SLIT("<none>")
augmentIdKey,
binaryClassKey,
boolTyConKey,
+ boundedClassKey,
buildDataConKey,
buildIdKey,
byteArrayPrimTyConKey,
charPrimTyConKey,
charTyConKey,
consDataConKey,
- dataClassKey,
+ evalClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
binaryClassKey = mkPreludeClassUnique 16
cCallableClassKey = mkPreludeClassUnique 17
cReturnableClassKey = mkPreludeClassUnique 18
-dataClassKey = mkPreludeClassUnique 19
+evalClassKey = mkPreludeClassUnique 19
+boundedClassKey = mkPreludeClassUnique 20
\end{code}
%************************************************************************
eqClassOpKey = mkPreludeMiscIdUnique 44
geClassOpKey = mkPreludeMiscIdUnique 45
\end{code}
-
-
-
-
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-}
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(..)
)
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
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)]
)
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-} )
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 ]
-- 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)
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] ->
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,
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}
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:
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] )
--others:
import Id ( DictVar(..), Id(..), GenId )
-import Name ( pprNonOp )
+import Name ( pprNonSym )
import Outputable ( interpp'SP, ifnotPprForUser,
Outputable(..){-instance * (,)-}
)
\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}
%************************************************************************
= 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}
%************************************************************************
import HsTypes
-- others:
-import Name ( pprOp, pprNonOp )
+import Name ( pprSym, pprNonSym )
import Outputable ( interppSP, interpp'SP,
Outputable(..){-instance * []-}
)
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}
%************************************************************************
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]
-- 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
\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
= 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)
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
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 _)
\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}
\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)
-- 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
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)
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)
\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]
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]
#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
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
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="
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
)
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
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
]
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]
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}
(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}
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}
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
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
\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),
-- 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),
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
]
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)
\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
= 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
]
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 ...
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}
\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}
) where
+--ToDo:rm
+--import Pretty
+--import Util
+--import PprType
+--import PprStyle
+--import Kind
+
import Ubiq
import TyLoop ( mkDataCon, StrictnessMark(..) )
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 )
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
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}
%************************************************************************
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}
%************************************************************************
module RdrHsSyn (
RdrNameArithSeqInfo(..),
+ RdrNameBangType(..),
RdrNameBind(..),
RdrNameClassDecl(..),
RdrNameClassOpSig(..),
\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
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 )
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)
U_ident nn -> -- simple identifier
wlkQid nn `thenUgn` \ n ->
returnUgn (
- if isConopRdr n
+ if isRdrLexCon n
then ConPatIn n []
else VarPatIn n
)
{
#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)
- ]
}
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 )
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 )
-> 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.
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
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 ...
(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])
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}
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,
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"
import Pretty
import TyCon ( TyCon )
import TyVar ( GenTyVar )
-import Unique ( Unique )
+import Unique ( mkAlphaTyVarUnique, Unique )
import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
\end{code}
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)
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
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
module RnIfaces (
findHiFiles,
cachedIface,
+ cachedDecl,
readIface,
rnIfaces,
finalIfaceInfo,
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}
= --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
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)
-> 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)
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}
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}
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}
setExtraRn, getExtraRn,
getModuleRn, pushSrcLocRn, getSrcLocRn,
getSourceRn, getOccurrenceUpRn,
- getImplicitUpRn, ImplicitEnv(..),
+ getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
rnGetUnique, rnGetUniques,
newLocalNames,
extendSS2, extendSS,
TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
+ lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
+
+ fixIO
) where
import Ubiq{-uitous-}
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,
Name, mkLocalName, mkImplicitName,
getOccName
)
+import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
import Pretty ( Pretty(..), PrettyRep )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
= 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
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
= 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"
= 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
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)
= 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 _ _)
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}
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}
GlobalNameInfo(..)
) where
-import PreludeGlaST ( returnPrimIO, thenPrimIO, MutableVar(..) )
+import PreludeGlaST ( MutableVar(..) )
import Ubiq
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
-> 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
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
-> 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}
*********************************************************
\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}
\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
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}
\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
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}
\begin{code}
rnExports :: [Module]
- -> Bag (Module,(RnName,ExportFlag))
+ -> Bag (Module,RnName)
-> Maybe [RdrNameIE]
-> RnM s (Name -> ExportFlag)
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)
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)))
= 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
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}
%*********************************************************
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{SPECIALIZE data pragmas}
-%* *
+%* *
%*********************************************************
\begin{code}
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}
%*********************************************************
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 ->
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
-> 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}
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}
\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])
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])
emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
lookupRnEnv, lookupTcRnEnv,
+ lubExportFlag,
+
unknownNameErr,
badClassOpErr,
qualNameErr,
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 )
@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.
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)
*********************************************************
* *
+\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}
* *
*********************************************************
\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)
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 ->
import Usage ( UVar(..) )
import Util ( mapAccumL, zipWithEqual, panic, assertPanic )
-isLeakFreeType = panic "SetLevels.isLeakFreeType (ToDo)"
+isLeakFreeType x y = False -- safe option; ToDo
\end{code}
%************************************************************************
InExpr(..), InAlts(..), InDefault(..), InArg(..),
OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
-
- -- and to make the interface self-sufficient...
) where
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(..) )
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}
%************************************************************************
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)
)
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
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
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,
| 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)
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
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
| 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,
| 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,
| otherwise
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
- pprNonOp PprForUser id, ppStr "::",
+ pprNonSym PprForUser id, ppStr "::",
pprGenType sty spec_ty,
ppStr "#-}", pp_essential ]
where
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
import UniqSupply -- all of it, really
import Util ( panic )
-isLeakFreeType = panic "CoreToStg.isLeakFreeType (ToDo)"
+isLeakFreeType x y = False -- safe option; ToDo
\end{code}
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-}
)
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
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(..),
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}
%************************************************************************
-- 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
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) ->
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))
\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)
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}
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
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)
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}
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 )
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
\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
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
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
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`
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)
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)))
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
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
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(..) )
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}
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)
= 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
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 )
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) ->
-- 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)
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 $
= 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}
import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon,
RnName{-instance NamedThing-}
)
-import Util ( zipWithEqual, panic )
+import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
\end{code}
= 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)
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
\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,_) ->
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
- tcLookupClassByKey,
newLocalId, newLocalIds
)
import TcMonad
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}
-- 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)
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
-- 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
-- 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
)
= 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 ()
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")
= [ eqClassKey,
showClassKey,
ordClassKey,
+ boundedClassKey,
enumClassKey,
ixClassKey,
readClassKey ]
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-} ...
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 )
-- 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
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)
_ -> 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}
Just (tycon,_) ->
if isPreludeDefined tycon
then true_bottom
- else (False, fst (getOrigName tycon))
+ else (False, moduleOf (origName tycon))
true_bottom = (True, panic "getTypeString")
= 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]
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,
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
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}
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 }
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}
module TyVar (
GenTyVar(..), TyVar(..),
mkTyVar,
- getTyVarKind, -- TyVar -> Kind
+ tyVarKind, -- TyVar -> Kind
cloneTyVar,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
(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
isTauTy,
- tyVarsOfType, tyVarsOfTypes, getTypeKind
-
-
-) where
+ tyVarsOfType, tyVarsOfTypes, typeKind
+ ) where
import Ubiq
import IdLoop -- 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(..) )
(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
-- 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
\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
\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}
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}
fmToList, keysFM, eltsFM{-used in GHCI-}
#ifdef COMPILING_GHC
+ , bagToFM
, FiniteSet(..), emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet{-exported for GHCI-}
#endif
# ifdef DEBUG
import Pretty
# endif
+import Bag ( foldBag )
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
#else
\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
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}
%************************************************************************
projects / ghc-hetmet.git / commitdiff