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 Data.Typeable (Typeable)
import Data.Generics (Data)
import GHC.Generics
import UHC.Light.Compiler.Base.UID
import UU.Scanner.Position
import UHC.Util.Hashable
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
data HsNameUniqifier
= HsNameUniqifier_Blank
| HsNameUniqifier_New
| HsNameUniqifier_Error
| HsNameUniqifier_GloballyUnique
| HsNameUniqifier_Evaluated
| HsNameUniqifier_Field
| HsNameUniqifier_Class
| HsNameUniqifier_ClassDict
| HsNameUniqifier_SelfDict
| HsNameUniqifier_ResultDict
| HsNameUniqifier_SuperClass
| HsNameUniqifier_DictField
| HsNameUniqifier_Inline
| HsNameUniqifier_GloballyUniqueDict
| HsNameUniqifier_FieldOffset
| HsNameUniqifier_CaseContinuation
| HsNameUniqifier_GrinUpdated
| HsNameUniqifier_FFIArg
| HsNameUniqifier_LacksLabel
| HsNameUniqifier_BindAspect
| HsNameUniqifier_Strict
| HsNameUniqifier_GenericClass
| HsNameUniqifier_FFE
| HsNameUniqifier_FFECoerced
| HsNameUniqifier_CoreAPI
deriving (Eq,Ord,Enum,Generic)
instance Hashable HsNameUniqifier
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"
data HsNameUnique
= HsNameUnique_None
| HsNameUnique_String !String
| HsNameUnique_Int !Int
| HsNameUnique_UID !UID
deriving (Eq,Ord,Generic)
instance Hashable HsNameUnique
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
type HsNameUniqifierMp = Map.Map HsNameUniqifier [HsNameUnique]
emptyHsNameUniqifierMp :: HsNameUniqifierMp
emptyHsNameUniqifierMp = Map.empty
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
uniqifierMpAdd :: HsNameUniqifier -> HsNameUnique -> HsNameUniqifierMp -> HsNameUniqifierMp
uniqifierMpAdd ufier u m = Map.unionWith (++) (Map.singleton ufier [u]) m
uniqifierMpUnion :: HsNameUniqifierMp -> HsNameUniqifierMp -> HsNameUniqifierMp
uniqifierMpUnion = Map.unionWith (++)
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)
hsnUniqify :: HsNameUniqifier -> HsName -> HsName
hsnUniqify ufier = hsnUniqify' ufier HsNameUnique_None
hsnUniqifyInt :: HsNameUniqifier -> Int -> HsName -> HsName
hsnUniqifyInt ufier u = hsnUniqify' ufier (HsNameUnique_Int u)
hsnUniqifyUID :: HsNameUniqifier -> UID -> HsName -> HsName
hsnUniqifyUID ufier u = hsnUniqify' ufier (HsNameUnique_UID u)
hsnUniqifyStr :: HsNameUniqifier -> String -> HsName -> HsName
hsnUniqifyStr ufier u = hsnUniqify' ufier (HsNameUnique_String u)
hsnUniqifyEval :: HsName -> HsName
hsnUniqifyEval = hsnUniqify HsNameUniqifier_Evaluated
hsnStripUniqify :: HsName -> Maybe HsName
hsnStripUniqify n@(HsName_Modf {hsnUniqifiers=us})
| Map.null us = Nothing
| otherwise = Just $ n {hsnUniqifiers = Map.empty}
hsnStripUniqify _ = Nothing
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 _ = []
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
hsnFixateHash :: HsName -> HsName
hsnFixateHash n@(HsName_Modf _ _ _ _) = n {hsnHash = hsnHashWithSalt 17 n}
hsnFixateHash n = n
data HsName
= HsName_Base
{ hsnBaseStr :: !String
}
| HsName_UID
{ hsnUID :: !UID
}
| HsName_Modf
{
hsnHash :: !Int
, hsnQualifiers :: ![String]
, hsnBase :: !HsName
, hsnUniqifiers :: !HsNameUniqifierMp
}
| HsName_Pos !Int
| HsName_Nr !Int !OrigName
deriving (Eq,Ord,Generic)
hsnEmpty :: HsName
hsnEmpty = mkHNm ""
hsnMbPos :: HsName -> Maybe Int
hsnMbPos (HsName_Pos p) = Just p
hsnMbPos _ = Nothing
hsnIsPos :: HsName -> Bool
hsnIsPos = isJust . hsnMbPos
hsnMbNr :: HsName -> Maybe (Int,OrigName)
hsnMbNr (HsName_Nr i o) = Just (i,o)
hsnMbNr _ = Nothing
hsnIsNr :: HsName -> Bool
hsnIsNr = isJust . hsnMbNr
hsnMkModf :: [String] -> HsName -> HsNameUniqifierMp -> HsName
hsnMkModf q b u = hsnFixateHash $ either (\(_,n) -> n {hsnQualifiers = q, hsnUniqifiers = hsnUniqifiers n `uniqifierMpUnion` u}) (\b -> HsName_Modf 0 q b u) $ hsnCanonicSplit b
hsnMkNr :: Int -> OrigName -> HsName
hsnMkNr = HsName_Nr
mkHNmBase :: String -> HsName
mkHNmBase s = hsnMkModf [] (HsName_Base s) Map.empty
hsnEnsureIsBase :: HsName -> HsName
hsnEnsureIsBase n@(HsName_UID _) = mkHNm $ show n
hsnEnsureIsBase (HsName_Pos i) = mkHNm $ show i
hsnEnsureIsBase n = n
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
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
hsnMbBaseString :: HsName -> Maybe String
hsnMbBaseString = fmap fst . hsnBaseUnpack
hsnIsBaseString :: HsName -> Bool
hsnIsBaseString = isJust . hsnMbBaseString
hsnBaseString :: HsName -> String
hsnBaseString = maybe "??" id . hsnMbBaseString
mkHNmPos :: Int -> HsName
mkHNmPos s = hsnMkModf [] (HsName_Pos s) Map.empty
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
hsnFromString :: String -> HsName
hsnFromString = mkHNmBase
data OrigName
= OrigNone
| OrigLocal HsName
| OrigGlobal HsName
| OrigFunc HsName
deriving (Eq,Ord,Generic)
instance Hashable OrigName
instance PP HsName where
pp h = pp (show h)
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
hsnShow :: String -> String -> HsName -> String
hsnShow q u n = hsnShow' hsnShowUID id id q u n
hsnShowUID i = 'u' : show i
instance Show HsName where
show = hsnShow "." "_@"
hsnCanonicSplit :: HsName -> Either ([String],HsName) HsName
hsnCanonicSplit n@(HsName_Modf _ qs _ _) = Left $ (qs, hsnFixateHash (n {hsnQualifiers = []}))
hsnCanonicSplit n = Right n
hsnToList :: HsName -> [HsName]
hsnToList n = either (\(qs,b) -> map mkHNmBase qs ++ [b]) (:[]) (hsnCanonicSplit n)
hsnInitLast :: HsName -> ([HsName],HsName)
hsnInitLast n = either (\(qs,b) -> (map mkHNmBase qs, b)) (\x -> ([],x)) (hsnCanonicSplit n)
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
stringAlphanumeric :: String -> String
stringAlphanumeric s
= concat (map (charAlphanumeric) s)
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"
charAlphanumeric ']' = "bus"
charAlphanumeric '(' = "open"
charAlphanumeric ',' = "comma"
charAlphanumeric ')' = "close"
charAlphanumeric c = [c]
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 (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)
hsnToFPath :: HsName -> FPath
hsnToFPath n
= mkFPathFromDirsFile qs b
where (qs,b) = hsnInitLast n
instance FPATH HsName where
mkFPath = hsnToFPath
hsnConcat :: HsName -> HsName -> HsName
hsnConcat h1 h2 = hsnFromString (show h1 ++ show h2)
rowLabCmp :: HsName -> HsName -> Ordering
rowLabCmp = cmpHsNameOnNm
hsnSplitQualify :: HsName -> (Maybe HsName,HsName)
hsnSplitQualify n
= case hsnInitLast n of
([],n') -> (Nothing,n')
(ns,n') -> (Just (mkHNm ns),n')
hsnQualified :: HsName -> HsName
hsnQualified = snd . hsnSplitQualify
hsnPrefixQual :: HsName -> HsName -> HsName
hsnPrefixQual m n = mkHNm (hsnToList m ++ hsnToList n)
hsnMapQualified :: (String -> String) -> HsName -> HsName
hsnMapQualified f qn
= maybe qn (\(s,mk) -> mk $ f s) $ hsnBaseUnpack qn
hsnQualifier :: HsName -> Maybe HsName
hsnQualifier = fst . hsnSplitQualify
hsnSetQual :: HsName -> HsName -> HsName
hsnSetQual m = hsnPrefixQual m . hsnQualified
hsnIsQual :: HsName -> Bool
hsnIsQual = isJust . hsnQualifier
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
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 ""
hsnStripUniqifiers :: HsName -> HsName
hsnStripUniqifiers (HsName_Modf _ qs n us) = hsnMkModf qs n emptyHsNameUniqifierMp
hsnStripUniqifiers n = n
hsnQualUniqify :: HsName -> HsName -> HsName
hsnQualUniqify modNm n
= if hsnIsQual n
then n
else hsnSetQual modNm n
class HSNM a where
mkHNm :: a -> HsName
instance HSNM HsName where
mkHNm = id
instance HSNM Int where
mkHNm = mkHNm . show
instance HSNM UID where
mkHNm = HsName_UID
instance HSNM String where
mkHNm s
= mkHNm $ map hsnFromString $ splitForQualified s
instance HSNM ([HsName],HsName) where
mkHNm (l,n) = mkHNm (l ++ [n])
instance HSNM [HsName] where
mkHNm [n] = n
mkHNm [] = hsnFromString ""
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
instance Position HsName where
line _ = (1)
column _ = (1)
file _ = ""
deriving instance Typeable HsName
deriving instance Data HsName
deriving instance Typeable IdOccKind
deriving instance Data IdOccKind
deriving instance Typeable IdOcc
deriving instance Data IdOcc
deriving instance Typeable HsNameUniqifier
deriving instance Data HsNameUniqifier
deriving instance Typeable HsNameUnique
deriving instance Data HsNameUnique
deriving instance Typeable OrigName
deriving instance Data OrigName
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
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)
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"
instance PP IdOccKind where
pp = text . show
data IdOcc
= IdOcc { ioccNm :: !HsName, ioccKind :: !IdOccKind }
deriving (Show,Eq,Ord)
type HsNameS = Set.Set HsName
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
type FvS = HsNameS
type FvSMp = Map.Map HsName FvS
type HsNameMp = Map.Map HsName HsName
hsnRepl :: HsNameMp -> HsName -> HsName
hsnRepl m n = Map.findWithDefault n n m
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)"
rpatNmIsOrig :: RPatNm -> Bool
rpatNmIsOrig (RPatNmOrig _) = True
rpatNmIsOrig _ = False
hsnUnknown :: HsName
hsnUnknown = hsnFromString "??"
data Track
= TrackNone
| TrackSelf
| TrackCtx Int
| TrackSelect Int Track
| TrackVarApply HsName [Track]
deriving (Eq, Ord, Show)
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