Skip to content

GitLab

Commit 2f51f140 authored by partain's avatar partain
Browse files

[project @ 1996-04-20 10:37:06 by partain] 

SLPJ 1.3 changes through 960419
parent c49d51f8
Hide whitespace changes
Inline Side-by-side
ghc/compiler/Jmakefile
View file @ 2f51f140
......@@ -118,6 +118,7 @@ specialise/SpecEnv.lhs
rename/ParseIface.hs
#define RENAMERSRCS_LHS \
rename/ParseUtils.lhs \
rename/RnHsSyn.lhs \
rename/RnMonad.lhs \
rename/Rename.lhs \
......@@ -506,8 +507,9 @@ types/TyLoop.hi : types/TyLoop.lhi
$(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs
happy -g rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy -i rename/ParseIface.hinfo rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
compile(absCSyn/AbsCUtils,lhs,)
compile(absCSyn/CStrings,lhs,)
......@@ -622,6 +624,7 @@ compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#inclu
compile(reader/RdrHsSyn,lhs,)
compile(rename/ParseIface,hs,)
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,)
compile(rename/Rename,lhs,)
......
ghc/compiler/basicTypes/Id.lhs
View file @ 2f51f140
......@@ -103,16 +103,15 @@ import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
nameOrigName, mkTupleDataConName,
isAvarop, isAconop, getLocalName,
mkTupleDataConName, mkCompoundName,
isLexSym, getLocalName,
isLocallyDefined, isPreludeDefined,
getOrigName, getOccName,
getOccName, moduleNamePair, origName, nameOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
GenType, GenTyVar
)
......@@ -654,10 +653,10 @@ pprIdInUnfolding in_scopes v
pp_full_name
= let
(m_str, n_str) = getOrigName v
(m_str, n_str) = moduleNamePair v
pp_n =
if isAvarop n_str || isAconop n_str then
if isLexSym n_str then
ppBesides [ppLparen, ppPStr n_str, ppRparen]
else
ppPStr n_str
......@@ -1009,10 +1008,10 @@ getIdNamePieces show_uniqs id
get (Id u _ details _ _)
= case details of
DataConId n _ _ _ _ _ _ _ ->
case (nameOrigName n) of { (mod, name) ->
case (moduleNamePair n) of { (mod, name) ->
if isPreludeDefinedName n then [name] else [mod, name] }
TupleConId n _ -> [snd (nameOrigName n)]
TupleConId n _ -> [nameOf (origName n)]
RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
......@@ -1021,8 +1020,8 @@ getIdNamePieces show_uniqs id
TopLevId n -> get_fullname_pieces n
SuperDictSelId c sc ->
case (getOrigName c) of { (c_mod, c_name) ->
case (getOrigName sc) of { (sc_mod, sc_name) ->
case (moduleNamePair c) of { (c_mod, c_name) ->
case (moduleNamePair sc) of { (sc_mod, sc_name) ->
let
c_bits = if isPreludeDefined c
then [c_name]
......@@ -1035,7 +1034,7 @@ getIdNamePieces show_uniqs id
[SLIT("sdsel")] ++ c_bits ++ sc_bits }}
MethodSelId clas op ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
if isPreludeDefined clas
then [op_name]
......@@ -1043,14 +1042,14 @@ getIdNamePieces show_uniqs id
} }
DefaultMethodId clas op _ ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
if isPreludeDefined clas
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
DictFunId c ty _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
case (moduleNamePair c) of { (c_mod, c_name) ->
let
c_bits = if isPreludeDefined c
then [c_name]
......@@ -1061,7 +1060,7 @@ getIdNamePieces show_uniqs id
[SLIT("dfun")] ++ c_bits ++ ty_bits }
ConstMethodId c ty o _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
case (moduleNamePair c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
case (getClassOpString o) of { o_name ->
case (if isPreludeDefined c
......@@ -1091,7 +1090,7 @@ getIdNamePieces show_uniqs id
get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
= BIND (nameOrigName n) _TO_ (mod, name) ->
= BIND (moduleNamePair n) _TO_ (mod, name) ->
if isPreludeDefinedName n
then [name]
else [mod, name]
......@@ -1810,20 +1809,14 @@ instance NamedThing (GenId ty) where
get (DataConId n _ _ _ _ _ _ _) = n
get (TupleConId n _) = n
get (RecordSelId l) = getName l
get (SuperDictSelId c sc) = panic "Id.getName.SuperDictSelId"
get (MethodSelId c op) = panic "Id.getName.MethodSelId"
get (DefaultMethodId c op _) = panic "Id.getName.DefaultMethodId"
get (DictFunId c ty _ _) = panic "Id.getName.DictFunId"
get (ConstMethodId c ty op _ _) = panic "Id.getName.ConstMethodId"
get (SpecId i tys _) = panic "Id.getName.SpecId"
get (WorkerId i) = panic "Id.getName.WorkerId"
get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
{- LATER:
get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
(mod, _) -> (mod, getClassOpString op)
get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
mod -> (mod, getClassOpString op)
get (SpecId unspec ty_maybes _)
= BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
= BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
(mod,
unspec_nm _APPEND_
......@@ -1834,7 +1827,7 @@ instance NamedThing (GenId ty) where
BEND BEND
get (WorkerId unwrkr)
= BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
= BIND moduleNamePair unwrkr _TO_ (mod, unwrkr_nm) ->
(mod,
unwrkr_nm _APPEND_
(if not (toplevelishId unwrkr)
......
ghc/compiler/basicTypes/Name.lhs
View file @ 2f51f140
......@@ -12,9 +12,8 @@ module Name (
RdrName(..),
isUnqual,
isQual,
isConopRdr,
isRdrLexCon,
appendRdr,
rdrToOrig,
showRdr,
cmpRdr,
......@@ -23,27 +22,30 @@ module Name (
mkLocalName, isLocalName,
mkTopLevName, mkImportedName,
mkImplicitName, isImplicitName,
mkBuiltinName,
mkBuiltinName, mkCompoundName,
mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
mkTupNameStr,
NamedThing(..), -- class
ExportFlag(..), isExported,
nameUnique,
nameOrigName,
nameOccName,
nameExportFlag,
nameSrcLoc,
nameImportFlag,
isLocallyDefinedName,
isPreludeDefinedName,
getOrigName, getOccName, getExportFlag,
origName, moduleOf, nameOf, moduleNamePair,
getOccName, getExportFlag,
getSrcLoc, isLocallyDefined, isPreludeDefined,
getLocalName, getOrigNameRdr, ltLexical,
getLocalName, ltLexical,
isOpLexeme, pprOp, pprNonOp,
isConop, isAconop, isAvarid, isAvarop
isSymLexeme, pprSym, pprNonSym,
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
import Ubiq
......@@ -51,13 +53,13 @@ import Ubiq
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..), codeStyle )
import PrelMods ( pRELUDE, pRELUDE_BUILTIN )
import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
import Pretty
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic )
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
\end{code}
%************************************************************************
......@@ -69,8 +71,9 @@ import Util ( thenCmp, _CMP_STRING_, nOfThem, panic )
\begin{code}
type Module = FAST_STRING
data RdrName = Unqual FAST_STRING
| Qual Module FAST_STRING
data RdrName
= Unqual FAST_STRING
| Qual Module FAST_STRING
isUnqual (Unqual _) = True
isUnqual (Qual _ _) = False
......@@ -78,14 +81,12 @@ isUnqual (Qual _ _) = False
isQual (Unqual _) = False
isQual (Qual _ _) = True
isConopRdr (Unqual n) = isConop n
isConopRdr (Qual m n) = isConop n
isRdrLexCon (Unqual n) = isLexCon n
isRdrLexCon (Qual m n) = isLexCon n
appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
rdrToOrig (Unqual n) = (pRELUDE, n)
rdrToOrig (Qual m n) = (m, n)
appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
Qual m (n _APPEND_ str)
cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
cmpRdr (Unqual n1) (Qual m2 n2) = LT_
......@@ -152,7 +153,8 @@ data Name
data Provenance
= LocalDef SrcLoc -- locally defined; give its source location
| Imported SrcLoc -- imported; give the *original* source location
| Imported ExportFlag -- how it was imported
SrcLoc -- *original* source location
-- [SrcLoc] -- any import source location(s)
| Implicit
......@@ -163,7 +165,7 @@ data Provenance
mkLocalName = Local
mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
mkImportedName u orig locn exp occs = Global u orig (Imported locn) exp occs
mkImportedName u orig imp locn exp occs = Global u orig (Imported imp locn) exp occs
mkImplicitName :: Unique -> RdrName -> Name
mkImplicitName u o = Global u o Implicit NotExported []
......@@ -171,19 +173,27 @@ mkImplicitName u o = Global u o Implicit NotExported []
mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
mkCompoundName :: Unique -> [FAST_STRING] -> Name
mkCompoundName u ns
= Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
where
dotify [] = []
dotify [n] = [n]
dotify (n:ns) = n : (map (_CONS_ '.') ns)
mkFunTyConName
= mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
mkTupleDataConName arity
= mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity)
= mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
mkTupleTyConName arity
= mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mk_tup_name arity)
mk_tup_name 0 = SLIT("()")
mk_tup_name 1 = panic "Name.mk_tup_name: 1 ???"
mk_tup_name 2 = SLIT("(,)") -- not strictly necessary
mk_tup_name 3 = SLIT("(,,)") -- ditto
mk_tup_name 4 = SLIT("(,,,)") -- ditto
mk_tup_name n
= mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
mkTupNameStr 0 = SLIT("()")
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
mkTupNameStr 3 = SLIT("(,,)") -- ditto
mkTupNameStr 4 = SLIT("(,,,)") -- ditto
mkTupNameStr n
= _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
-- ToDo: what about module ???
......@@ -248,8 +258,12 @@ instance NamedThing Name where
nameUnique (Local u _ _) = u
nameUnique (Global u _ _ _ _) = u
nameOrigName (Local _ n _) = (panic "NamedThing.Local.nameOrigName", n)
nameOrigName (Global _ orig _ _ _) = rdrToOrig orig
nameOrigName (Local _ n _) = Unqual n
nameOrigName (Global _ orig _ _ _) = orig
nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n)
nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
nameOccName (Local _ n _) = Unqual n
nameOccName (Global _ orig _ _ [] ) = orig
......@@ -258,17 +272,23 @@ nameOccName (Global _ orig _ _ occs) = head occs
nameExportFlag (Local _ _ _) = NotExported
nameExportFlag (Global _ _ _ exp _) = exp
nameSrcLoc (Local _ _ loc) = loc
nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
nameSrcLoc (Global _ _ (Imported loc) _ _) = loc
nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
nameSrcLoc (Local _ _ loc) = loc
nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
nameSrcLoc (Global _ _ (Imported _ loc) _ _) = loc
nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
nameImportFlag (Local _ _ _) = NotExported
nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
nameImportFlag (Global _ _ (Imported exp _) _ _) = exp
nameImportFlag (Global _ _ Implicit _ _) = ExportAll
nameImportFlag (Global _ _ Builtin _ _) = ExportAll
isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
isLocallyDefinedName (Global _ _ (Imported _) _ _) = False
isLocallyDefinedName (Global _ _ Implicit _ _) = False
isLocallyDefinedName (Global _ _ Builtin _ _) = False
isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
isLocallyDefinedName (Global _ _ (Imported _ _) _ _) = False
isLocallyDefinedName (Global _ _ Implicit _ _) = False
isLocallyDefinedName (Global _ _ Builtin _ _) = False
isPreludeDefinedName (Local _ n _) = False
isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
......@@ -317,7 +337,7 @@ imported.
\begin{code}
data ExportFlag
= ExportAll -- export with all constructors/methods
| ExportAbs -- export abstractly
| ExportAbs -- export abstractly (tycons/classes only)
| NotExported
isExported a
......@@ -344,28 +364,35 @@ class NamedThing a where
\end{code}
\begin{code}
getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
origName :: NamedThing a => a -> RdrName
moduleOf :: RdrName -> Module
nameOf :: RdrName -> FAST_STRING
moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
getOccName :: NamedThing a => a -> RdrName
getLocalName :: NamedThing a => a -> FAST_STRING
getExportFlag :: NamedThing a => a -> ExportFlag
getSrcLoc :: NamedThing a => a -> SrcLoc
isLocallyDefined :: NamedThing a => a -> Bool
isPreludeDefined :: NamedThing a => a -> Bool
getOrigName = nameOrigName . getName
-- ToDo: specialise for RdrNames?
origName = nameOrigName . getName
moduleNamePair = nameModuleNamePair . getName
moduleOf (Unqual n) = pRELUDE
moduleOf (Qual m n) = m
nameOf (Unqual n) = n
nameOf (Qual m n) = n
getLocalName = nameOf . origName
getOccName = nameOccName . getName
getExportFlag = nameExportFlag . getName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
isPreludeDefined = isPreludeDefinedName . getName
getLocalName :: (NamedThing a) => a -> FAST_STRING
getLocalName = snd . getOrigName
getOrigNameRdr :: (NamedThing a) => a -> RdrName
getOrigNameRdr n | isPreludeDefined n = Unqual str
| otherwise = Qual mod str
where
(mod,str) = getOrigName n
\end{code}
@ltLexical@ is used for sorting things into lexicographical order, so
......@@ -374,97 +401,103 @@ comparison.]
\begin{code}
a `ltLexical` b
= BIND isLocallyDefined a _TO_ a_local ->
BIND isLocallyDefined b _TO_ b_local ->
BIND getOrigName a _TO_ (a_mod, a_name) ->
BIND getOrigName b _TO_ (b_mod, b_name) ->
if a_local || b_local then
= case (moduleNamePair a) of { (a_mod, a_name) ->
case (moduleNamePair b) of { (b_mod, b_name) ->
if isLocallyDefined a || isLocallyDefined b then
a_name < b_name -- can't compare module names
else
case _CMP_STRING_ a_mod b_mod of
LT_ -> True
EQ_ -> a_name < b_name
GT__ -> False
BEND BEND BEND BEND
}}
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
#endif
\end{code}
These functions test strings to see if they fit the lexical categories
defined in the Haskell report. Normally applied as in e.g. @isConop
(getLocalName foo)@
defined in the Haskell report. Normally applied as in e.g. @isCon
(getLocalName foo)@.
\begin{code}
isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
isLexCon cs = isLexConId cs || isLexConSym cs
isLexVar cs = isLexVarId cs || isLexVarSym cs
isConop cs
isLexId cs = isLexConId cs || isLexVarId cs
isLexSym cs = isLexConSym cs || isLexVarSym cs
-------------
isLexConId cs
| _NULL_ cs = False
| c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
| otherwise = isUpper c || c == ':'
|| c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
|| isUpperISO c
| c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
| otherwise = isUpper c || isUpperISO c
where
c = _HEAD_ cs
isAconop cs
| _NULL_ cs = False
| otherwise = c == ':'
isLexVarId cs
| _NULL_ cs = False
| c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
| otherwise = isLower c || isLowerISO c
where
c = _HEAD_ cs
isAvarid cs
| _NULL_ cs = False
| c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
| isLower c = True
| isLowerISO c = True
| otherwise = False
isLexConSym cs
| _NULL_ cs = False
| otherwise = c == ':'
|| c == '(' -- (), (,), (,,), ...
|| cs == SLIT("->")
|| cs == SLIT("[]")
where
c = _HEAD_ cs
isAvarop cs
| _NULL_ cs = False
| isLower c = False
| isUpper c = False
| c `elem` "!#$%&*+./<=>?@\\^|~-" = True
| isSymbolISO c = True
| otherwise = False
isLexVarSym cs
| _NULL_ cs = False
| otherwise = isSymbolASCII c
|| isSymbolISO c
|| c == '(' -- (), (,), (,,), ...
|| cs == SLIT("[]")
where
c = _HEAD_ cs
isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-------------
isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
And one ``higher-level'' interface to those:
\begin{code}
isOpLexeme :: NamedThing a => a -> Bool
isSymLexeme :: NamedThing a => a -> Bool
isOpLexeme v
= let str = snd (getOrigName v) in isAvarop str || isAconop str
isSymLexeme v
= let str = nameOf (origName v) in isLexSym str
-- print `vars`, (op) correctly
pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprOp sty var
= if isOpLexeme var
pprSym sty var
= if isSymLexeme var
then ppr sty var
else ppBesides [ppChar '`', ppr sty var, ppChar '`']
pprNonOp sty var
= if isOpLexeme var
pprNonSym sty var
= if isSymLexeme var
then ppBesides [ppLparen, ppr sty var, ppRparen]
else ppr sty var
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
{-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}
#endif
\end{code}
ghc/compiler/basicTypes/SrcLoc.lhs
View file @ 2f51f140
......@@ -15,6 +15,8 @@ module SrcLoc (
mkSrcLoc, mkSrcLoc2, -- the usual
mkUnknownSrcLoc, -- "I'm sorry, I haven't a clue"
mkIfaceSrcLoc, -- Unknown place in an interface
-- (this one can die eventually ToDo)
mkBuiltinSrcLoc, -- something wired into the compiler
mkGeneratedSrcLoc, -- code generated within the compiler
unpackSrcLoc
......@@ -58,6 +60,7 @@ Things to make 'em:
mkSrcLoc = SrcLoc
mkSrcLoc2 x IBOX(y) = SrcLoc2 x y
mkUnknownSrcLoc = SrcLoc SLIT("<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>")
......
ghc/compiler/basicTypes/Unique.lhs
View file @ 2f51f140
......@@ -45,6 +45,7 @@ module Unique (
augmentIdKey,
binaryClassKey,
boolTyConKey,
boundedClassKey,
buildDataConKey,
buildIdKey,
byteArrayPrimTyConKey,
......@@ -54,7 +55,7 @@ module Unique (
charPrimTyConKey,
charTyConKey,
consDataConKey,
dataClassKey,
evalClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
......@@ -417,7 +418,8 @@ monadZeroClassKey = mkPreludeClassUnique 15
binaryClassKey = mkPreludeClassUnique 16
cCallableClassKey = mkPreludeClassUnique 17
cReturnableClassKey = mkPreludeClassUnique 18
dataClassKey = mkPreludeClassUnique 19
evalClassKey = mkPreludeClassUnique 19
boundedClassKey = mkPreludeClassUnique 20
\end{code}
%************************************************************************
......@@ -589,7 +591,3 @@ enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
eqClassOpKey = mkPreludeMiscIdUnique 44
geClassOpKey = mkPreludeMiscIdUnique 45
\end{code}
ghc/compiler/coreSyn/CoreLint.lhs
View file @ 2f51f140
......@@ -16,7 +16,7 @@ import Ubiq
import CoreSyn
import Bag
import Kind ( Kind{-instance-} )
import Kind ( isSubKindOf, Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
dataConArgTys, GenId{-instances-}
......@@ -32,12 +32,12 @@ import PrimOp ( primOpType, PrimOp(..) )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
isPrimType,getTypeKind,instantiateTy,
isPrimType,typeKind,instantiateTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
maybeAppDataTyCon, eqTy
)
import TyCon ( isPrimTyCon, tyConFamilySize )
import TyVar ( getTyVarKind, GenTyVar{-instances-} )
import TyVar ( tyVarKind, GenTyVar{-instances-} )
import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
unionUniqSets, elementOfUniqSet, UniqSet(..)
)
......@@ -274,10 +274,14 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
`seqL`
case (getForAllTy_maybe ty) of
Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
| pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (getTyVarKind tyvar), ppr PprDebug (getTypeKind arg_ty)]) False -> panic "impossible"
_ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
Just (tyvar,body) ->
if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $