X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FOccName.lhs;h=6739ba3d2e99bbbdaa08d809b8b267812147b271;hb=d033f3b42761135a4a7ae55669e3ac03f938d6c5;hp=0d1cb37949b5fa47fa104783bc7cdabf3cb96c14;hpb=30098da67fd3ce50ef5a110f57c1780002f83615;p=ghc-hetmet.git diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 0d1cb37..6739ba3 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -1,10 +1,8 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[OccName]{@OccName@} - \begin{code} module OccName ( -- * The NameSpace type; abstact @@ -33,7 +31,11 @@ module OccName ( mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, + mkPArrayTyConOcc, mkPArrayDataConOcc, + mkPReprTyConOcc, + mkPADFunOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, @@ -45,15 +47,16 @@ module OccName ( -- The OccEnv type OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + filterOccEnv, delListFromOccEnv, delFromOccEnv, -- The OccSet type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, - + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -63,25 +66,22 @@ module OccName ( startsVarSym, startsVarId, startsConSym, startsConId ) where -#include "HsVersions.h" - -import Util ( thenCmp ) -import Unique ( Unique, mkUnique, Uniquable(..) ) -import BasicTypes ( Boxity(..), Arity ) -import StaticFlags ( opt_PprStyle_Debug ) +import Util +import Unique +import BasicTypes +import StaticFlags import UniqFM import UniqSet import FastString +import FastTypes import Outputable import Binary -import GLAEXTS - -import Data.Char ( isUpper, isLower, ord ) +import GHC.Exts +import Data.Char -- Unicode TODO: put isSymbol in libcompat -#if __GLASGOW_HASKELL__ > 604 -import Data.Char ( isSymbol ) +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604 #else isSymbol = const False #endif @@ -95,8 +95,8 @@ isSymbol = const False %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables, including "source" data constructors - | DataName -- "Real" data constructors +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them -- in the same name space for now. @@ -120,6 +120,9 @@ data NameSpace = VarName -- Variables, including "source" data constructors -- The real datacon has type Int -> Int -> T -- GHC chooses a representation based on the strictness etc. +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace -- Though type constructors and classes are in the same name space now, -- the NameSpace type is abstract, so we can easily separate them later @@ -141,22 +144,23 @@ isTcClsName _ = False isVarName :: NameSpace -> Bool -- Variables or type variables, but not constructors isVarName TvName = True isVarName VarName = True -isVarName other = False +isVarName _ = False pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = ptext SLIT("data constructor") -pprNameSpace VarName = ptext SLIT("variable") -pprNameSpace TvName = ptext SLIT("type variable") -pprNameSpace TcClsName = ptext SLIT("type constructor or class") +pprNameSpace DataName = ptext (sLit "data constructor") +pprNameSpace VarName = ptext (sLit "variable") +pprNameSpace TvName = ptext (sLit "type variable") +pprNameSpace TcClsName = ptext (sLit "type constructor or class") pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns +pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = ptext SLIT("tv") -pprNameSpaceBrief TcClsName = ptext SLIT("tc") +pprNameSpaceBrief TvName = ptext (sLit "tv") +pprNameSpaceBrief TcClsName = ptext (sLit "tc") \end{code} @@ -179,8 +183,9 @@ instance Eq OccName where (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 instance Ord OccName where - compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` - (sp1 `compare` sp2) + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) \end{code} @@ -246,7 +251,7 @@ easy to build an OccEnv. \begin{code} instance Uniquable OccName where getUnique (OccName ns fs) - = mkUnique char (I# (uniqueOfFS fs)) + = mkUnique char (iBox (uniqueOfFS fs)) where -- See notes above about this getUnique function char = case ns of VarName -> 'i' @@ -254,7 +259,7 @@ instance Uniquable OccName where TvName -> 'v' TcClsName -> 't' -type OccEnv a = UniqFM a +newtype OccEnv a = A (UniqFM a) emptyOccEnv :: OccEnv a unitOccEnv :: OccName -> a -> OccEnv a @@ -262,6 +267,7 @@ extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a lookupOccEnv :: OccEnv a -> OccName -> Maybe a mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a elemOccEnv :: OccName -> OccEnv a -> Bool foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b occEnvElts :: OccEnv a -> [a] @@ -269,22 +275,32 @@ extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b - -emptyOccEnv = emptyUFM -unitOccEnv = unitUFM -extendOccEnv = addToUFM -extendOccEnvList = addListToUFM -lookupOccEnv = lookupUFM -mkOccEnv = listToUFM -elemOccEnv = elemUFM -foldOccEnv = foldUFM -occEnvElts = eltsUFM -plusOccEnv = plusUFM -plusOccEnv_C = plusUFM_C -extendOccEnv_C = addToUFM_C -mapOccEnv = mapUFM - -type OccSet = UniqFM OccName +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y + +instance Outputable a => Outputable (OccEnv a) where + ppr (A x) = ppr x + +type OccSet = UniqSet OccName emptyOccSet :: OccSet unitOccSet :: OccName -> OccSet @@ -331,20 +347,20 @@ occNameString (OccName _ s) = unpackFS s setOccNameSpace :: NameSpace -> OccName -> OccName setOccNameSpace sp (OccName _ occ) = OccName sp occ -isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool +isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc, isValOcc, isDataOcc :: OccName -> Bool isVarOcc (OccName VarName _) = True -isVarOcc other = False +isVarOcc _ = False isTvOcc (OccName TvName _) = True -isTvOcc other = False +isTvOcc _ = False isTcOcc (OccName TcClsName _) = True -isTcOcc other = False +isTcOcc _ = False isValOcc (OccName VarName _) = True isValOcc (OccName DataName _) = True -isValOcc other = False +isValOcc _ = False -- Data constructor operator (starts with ':', or '[]') -- Pretty inefficient! @@ -352,20 +368,20 @@ isDataSymOcc (OccName DataName s) = isLexConSym s isDataSymOcc (OccName VarName s) | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) -- Jan06: I don't think this should happen -isDataSymOcc other = False +isDataSymOcc _ = False isDataOcc (OccName DataName _) = True isDataOcc (OccName VarName s) | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) -- Jan06: I don't think this should happen -isDataOcc other = False +isDataOcc _ = False -- Any operator (data constructor or variable) -- Pretty inefficient! isSymOcc (OccName DataName s) = isLexConSym s isSymOcc (OccName TcClsName s) = isLexConSym s isSymOcc (OccName VarName s) = isLexSym s -isSymOcc other = False +isSymOcc (OccName TvName s) = isLexSym s parenSymOcc :: OccName -> SDoc -> SDoc -- Wrap parens around an operator @@ -401,6 +417,7 @@ Here's our convention for splitting up the interface file name space: $w... workers :T... compiler-generated tycons for dictionaries :D... ...ditto data cons + :Co... ...ditto coercions $sf.. specialised version of f in encoded form these appear as Zdfxxx etc @@ -427,7 +444,10 @@ mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, + mkPArrayTyConOcc, mkPArrayDataConOcc, mkPReprTyConOcc, mkPADFunOcc :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have @@ -443,7 +463,8 @@ mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" mkNewTyCoOcc = mk_simple_deriv tcName ":Co" -mkInstTyCoOcc = mk_simple_deriv tcName ":Co" -- derived from rep ty +mkInstTyCoOcc = mk_simple_deriv tcName ":CoF" -- derived from rep ty +mkEqPredCoOcc = mk_simple_deriv tcName "$co" -- Generic derivable classes mkGenOcc1 = mk_simple_deriv varName "$gfrom" @@ -455,6 +476,17 @@ mkGenOcc2 = mk_simple_deriv varName "$gto" mkDataTOcc = mk_simple_deriv varName "$t" mkDataCOcc = mk_simple_deriv varName "$c" +-- Vectorisation +mkVectOcc = mk_simple_deriv varName "$v_" +mkVectTyConOcc = mk_simple_deriv tcName ":V_" +mkVectDataConOcc = mk_simple_deriv dataName ":VD_" +mkVectIsoOcc = mk_simple_deriv varName "$VI_" +mkPArrayTyConOcc = mk_simple_deriv tcName ":VP_" +mkPArrayDataConOcc = mk_simple_deriv dataName ":VPD_" +mkPReprTyConOcc = mk_simple_deriv tcName ":VR_" +mkPADFunOcc = mk_simple_deriv varName "$PA_" + +mk_simple_deriv :: NameSpace -> String -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) -- Data constructor workers are made by setting the name space @@ -531,8 +563,8 @@ guys never show up in error messages. What a hack. \begin{code} mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName fs) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ \end{code} @@ -557,6 +589,7 @@ tack on the '1', if necessary. type TidyOccEnv = OccEnv Int -- The in-scope OccNames -- Range gives a plausible starting point for new guesses +emptyTidyOccEnv :: TidyOccEnv emptyTidyOccEnv = emptyOccEnv initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! @@ -627,18 +660,18 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == FSLIT("[]") = True - | otherwise = startsConId (headFS cs) + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers | nullFS cs = False -- e.g. "x", "_x" | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == FSLIT("->") = True - | otherwise = startsConSym (headFS cs) + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) isLexVarSym cs -- Infix identifiers | nullFS cs = False -- e.g. "+" @@ -651,6 +684,7 @@ startsConSym c = c == ':' -- Infix data constructors startsVarId c = isLower c || c == '_' -- Ordinary Ids startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors +isSymbolASCII :: Char -> Bool isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" \end{code}