module UHC.Light.Compiler.Base.HsName ( HSNM (..) , HsName , hsnEmpty , mkHNmBase , hsnEnsureIsBase , hsnBaseUnpack', hsnBaseUnpack , hsnMbBaseString, hsnIsBaseString, hsnBaseString , hsnFromString , hsnInitLast , hsnPrefix, hsnSuffix, mkHNmPrefix , IdOccKind (..) , IdOcc (..) , hsnUnknown , HsNameS , HsNameUniqifier (..) , HsNameUnique (..) , HsNameUniqifierMp , hsnUniqify, hsnUniqifyUID, hsnUniqifyStr, hsnUniqifyInt, hsnUniqifyEval , hsnMbPos, hsnIsPos , hsnMkModf , mkHNmPos , cmpHsNameOnNm , hsnShow, hsnShow' , rowLabCmp , OrigName (..) , hsnStripUniqify , hsnSimplifications , hsnMbNr, hsnIsNr , hsnMkNr , hsnShowAlphanumeric, hsnShowAlphanumericShort , hsnSplitQualify, hsnQualified, hsnPrefixQual, hsnMapQualified , hsnQualifier, hsnSetQual, hsnIsQual , hsnFixUniqifiers , hsnStripUniqifiers , hsnSafeJavaLike , FvS, FvSMp , HsNameMp, hsnRepl , RPatNm (..) , rpatNmIsOrig , Track (..) , hsnConcat , hsnMapQual, hsnSetLevQual , hsnQualUniqify ) where import UHC.Util.Utils import UHC.Util.Pretty import Data.List import UHC.Light.Compiler.Base.UID import UU.Scanner.Position import qualified Data.Set as Set import Data.Maybe import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import Data.Char import Numeric import UHC.Util.FPath import Data.Char import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize import Data.Hashable {-# LINE 57 "src/ehc/Base/HsName.chs" #-} -- | A HsNameUniqifier represents the 'type' of unification data HsNameUniqifier = HsNameUniqifier_Blank -- just a new identifier, with an empty show | HsNameUniqifier_New -- just a new identifier | HsNameUniqifier_Error -- error | HsNameUniqifier_GloballyUnique -- globally unique | HsNameUniqifier_Evaluated -- evaluated | HsNameUniqifier_Field -- extracted field | HsNameUniqifier_Class -- class | HsNameUniqifier_ClassDict -- dictionary | HsNameUniqifier_SelfDict -- dictionary under construction itself, passed as arg in tying the knot recursion | HsNameUniqifier_ResultDict -- dictionary under construction result | HsNameUniqifier_SuperClass -- super class field | HsNameUniqifier_DictField -- dictionary field | HsNameUniqifier_Inline -- new identifier because of inlining | HsNameUniqifier_GloballyUniqueDict -- globally unique dictionary | HsNameUniqifier_FieldOffset -- offset for a field | HsNameUniqifier_CaseContinuation -- continuation of a case expression | HsNameUniqifier_GrinUpdated -- Grin: updated value | HsNameUniqifier_FFIArg -- arg evaluated for FFI | HsNameUniqifier_LacksLabel -- label used in lacking predicates | HsNameUniqifier_BindAspect -- binding aspect | HsNameUniqifier_Strict -- strict variant of binding | HsNameUniqifier_GenericClass -- a name introduced by generics | HsNameUniqifier_FFE -- name of value to be ff exported | HsNameUniqifier_FFECoerced -- name of possibly coerced value to be ff exported | HsNameUniqifier_CoreAPI -- Used by the Core API, to allow external programs to generate new identifiers. deriving (Eq,Ord,Enum) -- | The show of a HsNameUniqifier is found back in the pretty printed code, current convention is 3 uppercase letters, as a balance between size and clarity of meaning instance Show HsNameUniqifier where show HsNameUniqifier_Blank = "" show HsNameUniqifier_New = "NEW" show HsNameUniqifier_Error = "ERR" show HsNameUniqifier_GloballyUnique = "UNQ" show HsNameUniqifier_Evaluated = "EVL" show HsNameUniqifier_Field = "FLD" show HsNameUniqifier_Class = "CLS" show HsNameUniqifier_ClassDict = "DCT" show HsNameUniqifier_SelfDict = "SDC" show HsNameUniqifier_ResultDict = "RDC" show HsNameUniqifier_SuperClass = "SUP" show HsNameUniqifier_DictField = "DFL" show HsNameUniqifier_Inline = "INL" show HsNameUniqifier_GloballyUniqueDict = "UND" show HsNameUniqifier_FieldOffset = "OFF" show HsNameUniqifier_CaseContinuation = "CCN" show HsNameUniqifier_GrinUpdated = "UPD" show HsNameUniqifier_FFIArg = "FFI" show HsNameUniqifier_LacksLabel = "LBL" show HsNameUniqifier_BindAspect = "ASP" show HsNameUniqifier_Strict = "STR" show HsNameUniqifier_GenericClass = "GEN" show HsNameUniqifier_FFE = "FFE" show HsNameUniqifier_FFECoerced = "FFC" show HsNameUniqifier_CoreAPI = "CRA" {-# LINE 146 "src/ehc/Base/HsName.chs" #-} -- | A HsNameUnique represents the optional additional info to make the uniqification even more unique data HsNameUnique = HsNameUnique_None | HsNameUnique_String !String | HsNameUnique_Int !Int | HsNameUnique_UID !UID deriving (Eq,Ord) showHsNameUnique :: (UID -> String) -> (String -> String) -> HsNameUnique -> String showHsNameUnique _ _ (HsNameUnique_None ) = "" showHsNameUnique _ shws (HsNameUnique_String s) = shws s showHsNameUnique _ _ (HsNameUnique_Int i) = show i showHsNameUnique shwu _ (HsNameUnique_UID u) = shwu u instance Show HsNameUnique where show = showHsNameUnique hsnShowUID id {-# LINE 165 "src/ehc/Base/HsName.chs" #-} type HsNameUniqifierMp = Map.Map HsNameUniqifier [HsNameUnique] emptyHsNameUniqifierMp :: HsNameUniqifierMp emptyHsNameUniqifierMp = Map.empty -- | Show uniqifier map, parseable back again when properly parameterized. showHsNameUniqifierMp'' :: (UID -> String) -> (String -> String) -> (String -> String) -> Bool -> String -> HsNameUniqifierMp -> [String] showHsNameUniqifierMp'' shwu shws brk showLen usep us = [ usep ++ slen u ++ show uqf ++ (brk $ concat [ usep ++ showHsNameUnique shwu shws uu | uu <- u, uu /= HsNameUnique_None ]) | (uqf,u) <- Map.toList us ] where slen u | showLen && l /= 1 = usep ++ show l | otherwise = "" where l = length u showHsNameUniqifierMp' :: Bool -> String -> HsNameUniqifierMp -> [String] showHsNameUniqifierMp' = showHsNameUniqifierMp'' hsnShowUID id id showHsNameUniqifierMp :: String -> HsNameUniqifierMp -> [String] showHsNameUniqifierMp = showHsNameUniqifierMp' True {-# LINE 200 "src/ehc/Base/HsName.chs" #-} uniqifierMpAdd :: HsNameUniqifier -> HsNameUnique -> HsNameUniqifierMp -> HsNameUniqifierMp uniqifierMpAdd ufier u m = Map.unionWith (++) (Map.singleton ufier [u]) m uniqifierMpUnion :: HsNameUniqifierMp -> HsNameUniqifierMp -> HsNameUniqifierMp uniqifierMpUnion = Map.unionWith (++) {-# LINE 212 "src/ehc/Base/HsName.chs" #-} hsnUniqify' :: HsNameUniqifier -> HsNameUnique -> HsName -> HsName hsnUniqify' ufier u = mk where mk n@(HsName_Modf {hsnUniqifiers=us}) = hsnFixateHash (n {hsnUniqifiers = uniqifierMpAdd ufier u us}) mk n = mk (hsnMkModf [] n Map.empty) -- | Uniqify with just a name suffix hsnUniqify :: HsNameUniqifier -> HsName -> HsName hsnUniqify ufier = hsnUniqify' ufier HsNameUnique_None -- | Uniqify with a name suffix + extra Int uniq info hsnUniqifyInt :: HsNameUniqifier -> Int -> HsName -> HsName hsnUniqifyInt ufier u = hsnUniqify' ufier (HsNameUnique_Int u) -- | Uniqify with a name suffix + extra UID uniq info hsnUniqifyUID :: HsNameUniqifier -> UID -> HsName -> HsName hsnUniqifyUID ufier u = hsnUniqify' ufier (HsNameUnique_UID u) -- | Uniqify with a name suffix + extra String uniq info hsnUniqifyStr :: HsNameUniqifier -> String -> HsName -> HsName hsnUniqifyStr ufier u = hsnUniqify' ufier (HsNameUnique_String u) -- | Uniqify for use as evaluated name hsnUniqifyEval :: HsName -> HsName hsnUniqifyEval = hsnUniqify HsNameUniqifier_Evaluated {-# LINE 240 "src/ehc/Base/HsName.chs" #-} -- | Remove uniqification, if present hsnStripUniqify :: HsName -> Maybe HsName hsnStripUniqify n@(HsName_Modf {hsnUniqifiers=us}) | Map.null us = Nothing | otherwise = Just $ n {hsnUniqifiers = Map.empty} hsnStripUniqify _ = Nothing {-# LINE 249 "src/ehc/Base/HsName.chs" #-} -- | Simplify name into list of simplifications of increasing complexity, all strictly simpler than the one given. [] therefore means no simplifications exist hsnSimplifications :: HsName -> [HsName] hsnSimplifications n@(HsName_Modf {}) = case hsnStripUniqify n of Just n' -> hsnSimplifications n' ++ [n'] _ -> hsnSimplifications $ hsnBase n hsnSimplifications (HsName_UID {hsnUID = u}) = map mkHNm $ uidSimplifications u -- hsnSimplifications n@(HsName_Base {} ) = [] -- [n] hsnSimplifications _ = [] {-# LINE 264 "src/ehc/Base/HsName.chs" #-} hsnHashWithSalt :: Int -> HsName -> Int hsnHashWithSalt salt (HsName_Base s ) = hashWithSalt salt s hsnHashWithSalt salt (HsName_UID i ) = hashWithSalt salt i hsnHashWithSalt salt (HsName_Pos p ) = hashWithSalt salt p hsnHashWithSalt salt (HsName_Modf _ q b u) = hashWithSalt salt q `hashWithSalt` hashWithSalt salt b `hashWithSalt` hashWithSalt salt (Map.toList u) hsnHashWithSalt salt (HsName_Nr i n ) = i `hashWithSalt` hashWithSalt salt n instance Hashable HsName where hashWithSalt salt n@(HsName_Modf h _ _ _) | h /= 0 = h hashWithSalt salt n = hsnHashWithSalt salt n instance Hashable OrigName where hashWithSalt salt (OrigNone ) = salt hashWithSalt salt (OrigLocal n) = 23 `hashWithSalt` hashWithSalt salt n hashWithSalt salt (OrigGlobal n) = 19 `hashWithSalt` hashWithSalt salt n hashWithSalt salt (OrigFunc n) = 17 `hashWithSalt` hashWithSalt salt n instance Hashable HsNameUnique where hashWithSalt salt (HsNameUnique_None ) = salt hashWithSalt salt (HsNameUnique_String s) = hashWithSalt salt s hashWithSalt salt (HsNameUnique_Int i) = hashWithSalt salt i hashWithSalt salt (HsNameUnique_UID u) = hashWithSalt salt u instance Hashable HsNameUniqifier where hashWithSalt salt u = hashWithSalt salt (fromEnum u) {-# LINE 292 "src/ehc/Base/HsName.chs" #-} -- | Fixate hash hsnFixateHash :: HsName -> HsName hsnFixateHash n@(HsName_Modf _ _ _ _) = n {hsnHash = hsnHashWithSalt 17 n} hsnFixateHash n = n {-# INLINE hsnFixateHash #-} {-# LINE 306 "src/ehc/Base/HsName.chs" #-} -- | Haskell name representation, exports of constructors only intented for internal use data HsName = HsName_Base { hsnBaseStr :: !String } | HsName_UID { hsnUID :: !UID } | HsName_Modf { -- a secret hash, prefixing other fields as to enforce comparison on the hash first; only used at variant 99 and onwards to avoid clutter hsnHash :: !Int , hsnQualifiers :: ![String] , hsnBase :: !HsName , hsnUniqifiers :: !HsNameUniqifierMp } | HsName_Pos !Int | HsName_Nr !Int !OrigName deriving (Eq,Ord) {-# LINE 332 "src/ehc/Base/HsName.chs" #-} hsnEmpty :: HsName hsnEmpty = mkHNm "" {-# LINE 346 "src/ehc/Base/HsName.chs" #-} -- | Is HsName a HsName_Pos? hsnMbPos :: HsName -> Maybe Int hsnMbPos (HsName_Pos p) = Just p hsnMbPos _ = Nothing hsnIsPos :: HsName -> Bool hsnIsPos = isJust . hsnMbPos {-# INLINE hsnIsPos #-} {-# LINE 357 "src/ehc/Base/HsName.chs" #-} -- | Is HsName a HsName_Pos? hsnMbNr :: HsName -> Maybe (Int,OrigName) hsnMbNr (HsName_Nr i o) = Just (i,o) hsnMbNr _ = Nothing hsnIsNr :: HsName -> Bool hsnIsNr = isJust . hsnMbNr {-# INLINE hsnIsNr #-} {-# LINE 368 "src/ehc/Base/HsName.chs" #-} -- | Smart constructor for HsName_Modf hsnMkModf :: [String] -> HsName -> HsNameUniqifierMp -> HsName -- hsnMkModf q b u = hsnFixateHash $ HsName_Modf 0 q b u hsnMkModf q b u = hsnFixateHash $ either (\(_,n) -> n {hsnQualifiers = q, hsnUniqifiers = hsnUniqifiers n `uniqifierMpUnion` u}) (\b -> HsName_Modf 0 q b u) $ hsnCanonicSplit b {-# INLINE hsnMkModf #-} {-# LINE 380 "src/ehc/Base/HsName.chs" #-} -- | Smart constructor for HsName_Nr hsnMkNr :: Int -> OrigName -> HsName hsnMkNr = HsName_Nr {-# INLINE hsnMkNr #-} {-# LINE 395 "src/ehc/Base/HsName.chs" #-} -- | Just lift a string to the base HsName variant mkHNmBase :: String -> HsName mkHNmBase s = hsnMkModf [] (HsName_Base s) Map.empty {-# LINE 405 "src/ehc/Base/HsName.chs" #-} -- | Eliminate alternative internal representations hsnEnsureIsBase :: HsName -> HsName hsnEnsureIsBase n@(HsName_UID _) = mkHNm $ show n hsnEnsureIsBase (HsName_Pos i) = mkHNm $ show i hsnEnsureIsBase n = n {-# LINE 415 "src/ehc/Base/HsName.chs" #-} -- | unpack a HsName into qualifiers + base string + repack function hsnBaseUnpack' :: HsName -> Maybe ([String],String,[String] -> String -> HsName) hsnBaseUnpack' (HsName_Base s ) = Just ([],s,\_ s -> HsName_Base s) hsnBaseUnpack' (HsName_Modf _ q b u) = fmap (\(bs,mk) -> (q, bs, \q s -> hsnMkModf q (mk s) u)) (hsnBaseUnpack b) hsnBaseUnpack' _ = Nothing -- | unpack a HsName into base string + repack function hsnBaseUnpack :: HsName -> Maybe (String,String -> HsName) hsnBaseUnpack (HsName_Base s ) = Just (s,HsName_Base) hsnBaseUnpack (HsName_Modf _ q b u) = fmap (\(bs,mk) -> (bs, \s -> hsnMkModf q (mk s) u)) (hsnBaseUnpack b) hsnBaseUnpack _ = Nothing {-# LINE 433 "src/ehc/Base/HsName.chs" #-} -- | If name is a HsName_Base after some unpacking, return the base string, without qualifiers, without uniqifiers hsnMbBaseString :: HsName -> Maybe String hsnMbBaseString = fmap fst . hsnBaseUnpack {-# INLINE hsnMbBaseString #-} -- | Is name is a HsName_Base after some unpacking? hsnIsBaseString :: HsName -> Bool hsnIsBaseString = isJust . hsnMbBaseString {-# INLINE hsnIsBaseString #-} hsnBaseString :: HsName -> String hsnBaseString = maybe "??" id . hsnMbBaseString {-# LINE 449 "src/ehc/Base/HsName.chs" #-} -- | Just lift a int to the int HsName variant mkHNmPos :: Int -> HsName mkHNmPos s = hsnMkModf [] (HsName_Pos s) Map.empty {-# LINE 459 "src/ehc/Base/HsName.chs" #-} -- | Compare, ignoring hash cmpHsNameOnNm :: HsName -> HsName -> Ordering cmpHsNameOnNm (HsName_Modf _ q1 b1 u1) (HsName_Modf _ q2 b2 u2) = compare (HsName_Modf 0 q1 b1 u1) (HsName_Modf 0 q2 b2 u2) cmpHsNameOnNm n1 n2 = compare n1 n2 {-# LINE 474 "src/ehc/Base/HsName.chs" #-} hsnFromString :: String -> HsName hsnFromString = mkHNmBase {-# INLINE hsnFromString #-} {-# LINE 485 "src/ehc/Base/HsName.chs" #-} data OrigName = OrigNone | OrigLocal HsName | OrigGlobal HsName | OrigFunc HsName deriving (Eq,Ord) {-# LINE 494 "src/ehc/Base/HsName.chs" #-} instance PP HsName where pp h = pp (show h) {-# LINE 500 "src/ehc/Base/HsName.chs" #-} -- | Parameterizable show of HsName when used from within the Show instance for HsName, or for a parseable representation used by (e.g.) Core pretty printing hsnShow' :: (UID -> String) -> (String -> String) -> (String -> String) -> String -> String -> HsName -> String hsnShow' shwu shws brk qsep usep n = shw n where shw n = case n of HsName_Base s -> s HsName_UID i -> shwu i HsName_Modf _ qs b us -> concat $ (intersperse qsep $ qs ++ [shw b]) ++ showHsNameUniqifierMp'' shwu shws brk False usep us HsName_Pos p -> show p HsName_Nr n OrigNone -> "x_" ++ show n HsName_Nr n (OrigLocal hsn) -> "x_" ++ show n ++ "_" ++ shw hsn HsName_Nr n (OrigGlobal hsn) -> "global_x_" ++ show n ++ "_" ++ shw hsn HsName_Nr n (OrigFunc hsn) -> "fun_x_" ++ show n ++ "_" ++ shw hsn -- | Parseable show of HsName when used from within the Show instance for HsName hsnShow :: String -> String -> HsName -> String hsnShow q u n = hsnShow' hsnShowUID id id q u n {-# INLINE hsnShow #-} hsnShowUID i = 'u' : show i {-# LINE 525 "src/ehc/Base/HsName.chs" #-} instance Show HsName where show = hsnShow "." "_@" {-# LINE 535 "src/ehc/Base/HsName.chs" #-} -- | A HsName is either a complex/aggregrate name or a base case hsnCanonicSplit :: HsName -> Either ([String],HsName) HsName hsnCanonicSplit n@(HsName_Modf _ qs _ _) = Left $ (qs, hsnFixateHash (n {hsnQualifiers = []})) hsnCanonicSplit n = Right n {-# LINE 544 "src/ehc/Base/HsName.chs" #-} hsnToList :: HsName -> [HsName] hsnToList n = either (\(qs,b) -> map mkHNmBase qs ++ [b]) (:[]) (hsnCanonicSplit n) {-# LINE 549 "src/ehc/Base/HsName.chs" #-} hsnInitLast :: HsName -> ([HsName],HsName) hsnInitLast n = either (\(qs,b) -> (map mkHNmBase qs, b)) (\x -> ([],x)) (hsnCanonicSplit n) {-# LINE 554 "src/ehc/Base/HsName.chs" #-} hsnPrefix :: String -> HsName -> HsName hsnPrefix p hsn = maybe (mkHNmBase $ p ++ show hsn) (\(s,mk) -> mk $ p ++ s) $ hsnBaseUnpack hsn hsnSuffix :: HsName -> String -> HsName hsnSuffix hsn p = maybe (mkHNmBase $ show hsn ++ p) (\(s,mk) -> mk $ s ++ p) $ hsnBaseUnpack hsn mkHNmPrefix :: HSNM x => String -> x -> HsName mkHNmPrefix p = hsnPrefix p . mkHNm {-# LINE 567 "src/ehc/Base/HsName.chs" #-} stringAlphanumeric :: String -> String stringAlphanumeric s = concat (map (charAlphanumeric) s) {-# LINE 580 "src/ehc/Base/HsName.chs" #-} charAlphanumeric :: Char -> String charAlphanumeric '\'' = "prime" charAlphanumeric ':' = "colon" charAlphanumeric '!' = "exclam" charAlphanumeric '@' = "at" charAlphanumeric '#' = "number" charAlphanumeric '$' = "dollar" charAlphanumeric '%' = "percent" charAlphanumeric '^' = "circon" charAlphanumeric '&' = "amp" charAlphanumeric '*' = "star" charAlphanumeric '+' = "plus" charAlphanumeric '-' = "minus" charAlphanumeric '.' = "dot" charAlphanumeric '/' = "slash" charAlphanumeric '\\' = "backsl" charAlphanumeric '|' = "bar" charAlphanumeric '<' = "lt" charAlphanumeric '=' = "eq" charAlphanumeric '>' = "gt" charAlphanumeric '?' = "quest" charAlphanumeric '~' = "tilde" charAlphanumeric '[' = "sub" -- although this is not a legal Haskell operator symbol, it can be part of the Nil constructor charAlphanumeric ']' = "bus" charAlphanumeric '(' = "open" -- although this is not a legal Haskell operator symbol, it can be part of the tuple constructor charAlphanumeric ',' = "comma" charAlphanumeric ')' = "close" charAlphanumeric c = [c] {-# LINE 613 "src/ehc/Base/HsName.chs" #-} dontStartWithDigit :: String -> String dontStartWithDigit xs@(a:_) | isDigit a || a=='_' = "y"++xs | otherwise = xs hsnShowAlphanumericShort :: HsName -> String hsnShowAlphanumericShort (HsName_Nr n (OrigFunc orig)) = hsnShowAlphanumeric orig hsnShowAlphanumericShort x = hsnShowAlphanumeric x hsnShowAlphanumeric :: HsName -> String hsnShowAlphanumeric (HsName_Base s ) = dontStartWithDigit(stringAlphanumeric s) hsnShowAlphanumeric (HsName_UID i ) = "u" ++ show i hsnShowAlphanumeric (HsName_Pos p) = "y" ++ show p hsnShowAlphanumeric (HsName_Nr n OrigNone) = "x" ++ show n hsnShowAlphanumeric (HsName_Nr n (OrigLocal orig)) = "x" ++ show n -- hsnShowAlphanumeric orig hsnShowAlphanumeric (HsName_Nr n (OrigGlobal orig)) = "global_" ++ hsnShowAlphanumeric orig hsnShowAlphanumeric (HsName_Nr n (OrigFunc orig)) = "fun_" ++ hsnShowAlphanumeric orig hsnShowAlphanumeric (HsName_Modf _ q b u) = concat $ intersperse "_" $ q ++ [hsnShowAlphanumeric b] ++ map stringAlphanumeric (showHsNameUniqifierMp "_" u) -- hsnShowAlphanumeric n = concat $ intersperse "_" $ map hsnShowAlphanumeric $ hsnToList n {-# LINE 637 "src/ehc/Base/HsName.chs" #-} hsnToFPath :: HsName -> FPath hsnToFPath n = mkFPathFromDirsFile qs b where (qs,b) = hsnInitLast n instance FPATH HsName where mkFPath = hsnToFPath {-# LINE 648 "src/ehc/Base/HsName.chs" #-} hsnConcat :: HsName -> HsName -> HsName hsnConcat h1 h2 = hsnFromString (show h1 ++ show h2) {-# LINE 657 "src/ehc/Base/HsName.chs" #-} -- compare for row labels, lexicographic ordering (currently) rowLabCmp :: HsName -> HsName -> Ordering rowLabCmp = cmpHsNameOnNm {-# LINE 667 "src/ehc/Base/HsName.chs" #-} -- qualifier (i.e. module name) and qualified part of name hsnSplitQualify :: HsName -> (Maybe HsName,HsName) hsnSplitQualify n = case hsnInitLast n of ([],n') -> (Nothing,n') (ns,n') -> (Just (mkHNm ns),n') -- qualified part of a name hsnQualified :: HsName -> HsName hsnQualified = snd . hsnSplitQualify -- prefix/qualify with module name, on top of possible previous qualifier hsnPrefixQual :: HsName -> HsName -> HsName hsnPrefixQual m n = mkHNm (hsnToList m ++ hsnToList n) -- map qualified part hsnMapQualified :: (String -> String) -> HsName -> HsName hsnMapQualified f qn = maybe qn (\(s,mk) -> mk $ f s) $ hsnBaseUnpack qn {- = case hsnSplitQualify qn of (Nothing,n) -> f n (Just q ,n) -> hsnPrefixQual q (f n) -} {-# LINE 694 "src/ehc/Base/HsName.chs" #-} -- qualifier (i.e. module name) of name hsnQualifier :: HsName -> Maybe HsName hsnQualifier = fst . hsnSplitQualify -- replace/set qualifier hsnSetQual :: HsName -> HsName -> HsName hsnSetQual m = hsnPrefixQual m . hsnQualified -- is qualified? hsnIsQual :: HsName -> Bool hsnIsQual = isJust . hsnQualifier {-# LINE 720 "src/ehc/Base/HsName.chs" #-} hsnMapQual :: (HsName -> HsName) -> HsName -> HsName hsnMapQual f qn = case hsnSplitQualify qn of (Nothing,n) -> qn (Just q ,n) -> hsnSetQual (f q) n hsnSetLevQual :: Int -> HsName -> HsName -> HsName hsnSetLevQual 0 m n = hsnSetQual m n hsnSetLevQual _ _ n = n {-# LINE 736 "src/ehc/Base/HsName.chs" #-} hsnFixUniqifiers' :: Bool -> String -> HsName -> HsName hsnFixUniqifiers' showlen sep (HsName_Modf _ qs n us) = hsnMkModf qs (hsnSuffix n (concat $ showHsNameUniqifierMp' showlen sep us)) Map.empty hsnFixUniqifiers' _ _ n = n hsnFixUniqifiers :: HsName -> HsName hsnFixUniqifiers = hsnFixUniqifiers' True "_@" hsnJavalikeFixUniqifiers :: HsName -> HsName hsnJavalikeFixUniqifiers = hsnFixUniqifiers' False "" {-# LINE 752 "src/ehc/Base/HsName.chs" #-} hsnStripUniqifiers :: HsName -> HsName hsnStripUniqifiers (HsName_Modf _ qs n us) = hsnMkModf qs n emptyHsNameUniqifierMp hsnStripUniqifiers n = n {-# LINE 762 "src/ehc/Base/HsName.chs" #-} hsnQualUniqify :: HsName -> HsName -> HsName hsnQualUniqify modNm n = if hsnIsQual n then n else hsnSetQual modNm n {-# LINE 774 "src/ehc/Base/HsName.chs" #-} class HSNM a where mkHNm :: a -> HsName instance HSNM HsName where mkHNm = id instance HSNM Int where mkHNm = mkHNm . show {-# LINE 786 "src/ehc/Base/HsName.chs" #-} instance HSNM UID where mkHNm = HsName_UID -- mkHNm x = hsnFromString ('_' : show x) {-# LINE 797 "src/ehc/Base/HsName.chs" #-} instance HSNM String where mkHNm s = mkHNm $ map hsnFromString $ splitForQualified s {-# LINE 803 "src/ehc/Base/HsName.chs" #-} instance HSNM ([HsName],HsName) where mkHNm (l,n) = mkHNm (l ++ [n]) instance HSNM [HsName] where mkHNm [n] = n mkHNm [] = hsnFromString "" -- ????, or empty alternative of HsName mkHNm ns = case initlast ns of Just (i,l) -> case l of n@(HsName_Modf _ _ _ _) -> hsnFixateHash (n {hsnQualifiers = qs}) n -> hsnMkModf qs n Map.empty where qs = catMaybes $ map hsnMbBaseString i {-# LINE 826 "src/ehc/Base/HsName.chs" #-} instance Position HsName where line _ = (-1) column _ = (-1) file _ = "" {-# LINE 837 "src/ehc/Base/HsName.chs" #-} deriving instance Typeable HsNameUniqifier deriving instance Data HsNameUniqifier deriving instance Typeable HsNameUnique deriving instance Data HsNameUnique deriving instance Typeable HsName deriving instance Data HsName deriving instance Typeable OrigName deriving instance Data OrigName deriving instance Typeable IdOccKind deriving instance Data IdOccKind deriving instance Typeable IdOcc deriving instance Data IdOcc {-# LINE 861 "src/ehc/Base/HsName.chs" #-} instance Binary HsNameUniqifier where put = putEnum8 get = getEnum8 instance Binary HsNameUnique where put (HsNameUnique_String a ) = putWord8 0 >> put a put (HsNameUnique_Int a ) = putWord8 1 >> put a put (HsNameUnique_UID a ) = putWord8 2 >> put a put (HsNameUnique_None ) = putWord8 3 get = do t <- getWord8 case t of 0 -> liftM HsNameUnique_String get 1 -> liftM HsNameUnique_Int get 2 -> liftM HsNameUnique_UID get 3 -> return HsNameUnique_None instance Binary HsName where put (HsName_Base a ) = putWord8 0 >> put a put (HsName_UID a ) = putWord8 1 >> put a put (HsName_Pos a ) = putWord8 2 >> put a put (HsName_Nr a b ) = putWord8 3 >> put a >> put b put (HsName_Modf a b c d) = putWord8 4 >> put a >> put b >> put c >> put d get = do t <- getWord8 case t of 0 -> liftM HsName_Base get 1 -> liftM HsName_UID get 2 -> liftM HsName_Pos get 3 -> liftM2 HsName_Nr get get 4 -> liftM4 HsName_Modf get get get get instance Serialize HsName where sput = sputShared sget = sgetShared sputNested = sputPlain sgetNested = sgetPlain instance Binary OrigName where put (OrigNone ) = putWord8 0 put (OrigLocal a) = putWord8 1 >> put a put (OrigGlobal a) = putWord8 2 >> put a put (OrigFunc a) = putWord8 3 >> put a get = do t <- getWord8 case t of 0 -> return OrigNone 1 -> liftM OrigLocal get 2 -> liftM OrigGlobal get 3 -> liftM OrigFunc get instance Binary IdOccKind where put = putEnum8 get = getEnum8 instance Serialize IdOccKind where sput = sputPlain sget = sgetPlain instance Binary IdOcc where put (IdOcc a b) = put a >> put b get = liftM2 IdOcc get get instance Serialize IdOcc where sput = sputShared sget = sgetShared sputNested = sputPlain sgetNested = sgetPlain {-# LINE 933 "src/ehc/Base/HsName.chs" #-} data IdOccKind = IdOcc_Val | IdOcc_Pat | IdOcc_Type | IdOcc_Kind | IdOcc_Fld | IdOcc_Class | IdOcc_Inst | IdOcc_Dflt | IdOcc_Any | IdOcc_Data | IdOcc_Fusion deriving (Eq,Ord,Enum) {-# LINE 959 "src/ehc/Base/HsName.chs" #-} -- intended for parsing instance Show IdOccKind where show IdOcc_Val = "Value" show IdOcc_Pat = "Pat" show IdOcc_Type = "Type" show IdOcc_Kind = "Kind" show IdOcc_Fld = "Field" show IdOcc_Class = "Class" show IdOcc_Inst = "Instance" show IdOcc_Dflt = "Default" show IdOcc_Any = "Any" show IdOcc_Data = "Data" show IdOcc_Fusion = "Fusion" {-# LINE 985 "src/ehc/Base/HsName.chs" #-} -- intended for parsing instance PP IdOccKind where pp = text . show {-# LINE 991 "src/ehc/Base/HsName.chs" #-} data IdOcc = IdOcc { ioccNm :: !HsName, ioccKind :: !IdOccKind } deriving (Show,Eq,Ord) {-# LINE 1002 "src/ehc/Base/HsName.chs" #-} type HsNameS = Set.Set HsName {-# LINE 1010 "src/ehc/Base/HsName.chs" #-} -- ensure a name valid for backends which are more restrictive in their allowed identifier character set hsnSafeJavaLike :: HsName -> HsName hsnSafeJavaLike = hsnMapQualified (concatMap safe . first) . hsnJavalikeFixUniqifiers . hsnEnsureIsBase where safe '_' = "__" safe c | isDigit c || isLetter c || c == '_' = [c] | otherwise = "_" ++ showHex (ord c) "" first s@(c:_) | isDigit c = '_' : s first s = s {-# LINE 1037 "src/ehc/Base/HsName.chs" #-} type FvS = HsNameS type FvSMp = Map.Map HsName FvS {-# LINE 1046 "src/ehc/Base/HsName.chs" #-} type HsNameMp = Map.Map HsName HsName hsnRepl :: HsNameMp -> HsName -> HsName hsnRepl m n = Map.findWithDefault n n m {-# LINE 1057 "src/ehc/Base/HsName.chs" #-} data RPatNm = RPatNmOrig {rpatNmNm :: !HsName} | RPatNmUniq {rpatNmNm :: !HsName} deriving Eq instance Ord RPatNm where x `compare` y = rpatNmNm x `cmpHsNameOnNm` rpatNmNm y instance Show RPatNm where show pnm = show (rpatNmNm pnm) instance PP RPatNm where pp (RPatNmOrig n) = n >|< "(O)" pp (RPatNmUniq n) = n >|< "(U)" {-# LINE 1074 "src/ehc/Base/HsName.chs" #-} rpatNmIsOrig :: RPatNm -> Bool rpatNmIsOrig (RPatNmOrig _) = True rpatNmIsOrig _ = False {-# LINE 1084 "src/ehc/Base/HsName.chs" #-} hsnUnknown :: HsName hsnUnknown = hsnFromString "??" {-# LINE 1093 "src/ehc/Base/HsName.chs" #-} data Track = TrackNone | TrackSelf | TrackCtx Int | TrackSelect Int Track | TrackVarApply HsName [Track] deriving (Eq, Ord, Show) {-# LINE 1105 "src/ehc/Base/HsName.chs" #-} instance Serialize Track where sput (TrackNone ) = sputWord8 0 sput (TrackSelf ) = sputWord8 1 sput (TrackCtx a ) = sputWord8 2 >> sput a sput (TrackSelect a b ) = sputWord8 3 >> sput a >> sput b sput (TrackVarApply a b ) = sputWord8 4 >> sput a >> sput b sget = do t <- sgetWord8 case t of 0 -> return TrackNone 1 -> return TrackSelf 2 -> liftM TrackCtx sget 3 -> liftM2 TrackSelect sget sget 4 -> liftM2 TrackVarApply sget sget deriving instance Data Track deriving instance Typeable Track