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