{-# LANGUAGE CPP #-}

module UHC.Light.Compiler.Base.Common
( module UHC.Util.Hashable
, module Data.Typeable
, module GHC.Generics
, module UHC.Light.Compiler.Base.HsName
, module UHC.Light.Compiler.Base.Range
, module UHC.Light.Compiler.Base.UID
, module UHC.Util.AssocL
, ppAppTop
, ppCon, ppCmt
, ppSpaced
, ParNeed (..), ParNeedL, parNeedApp
, ppParNeed
, CompilePoint (..)
, Fixity (..)
, fixityMaxPrio
, NmLev, nmLevAbsent, nmLevBuiltin, nmLevOutside, nmLevModule
, tokMkInt, tokMkStr
, tokMkQNames
, hsnLclSupply, hsnLclSupplyWith
, AlwaysEq (..)
, VarId, VarIdS
, if'
, whenM, unlessM, ifM, ifM'
, maybeM, maybeM', maybe2M, maybeGuardM, guardMaybeM, whenJustM, whenJustGuardM, unlessJustM
, str2stMp, str2stMpWithOmit, str2stMpWithShow, showStr2stMp
, unions
, withLkupLiftCyc1, withLkupChkVisitLift, withLkupLift
, lookupLiftCycMb1, lookupLiftCycMb2
, MetaLev, metaLevVal
, listCombineUniq
, metaLevTy, metaLevKi, metaLevSo
, ppFld, mkPPAppFun, mkPPAppFun'
, mkExtAppPP, mkExtAppPP'
, tokMkQName
, uidHNm
, uidQualHNm
, module UHC.Light.Compiler.Base.Fld
, module UHC.Light.Compiler.CodeGen.Tag
, module UHC.Light.Compiler.Base.Strictness
, ppHsnNonAlpha, ppHsnEscaped, hsnEscapeeChars, ppHsnEscapeWith, hsnOkChars, hsnNotOkStrs
, VarPPMp
, ppSemi
, ppPair
, ppFM
, putCompileMsg
, writePP, writeToFile
, CLbl (..), clbl
, Unbox (..)
, replicateBy
, strPadLeft, strBlankPad
, Verbosity (..)
, splitByRadix
, strHex
, Backend (..)
, Presence (..)
, LinkingStyle (..)
, fmap2Tuple
, genNmMap
, MaybeOk (..), isJustOk, isNotOk, maybeOk, fromJustOk, fromNotOk
, KnownPrim (..)
, allKnownPrimMp
, PredOccId (..)
, mkPrId, poiHNm
, mkPrIdCHR
, emptyPredOccId
, ppListV
, CHRScoped (..)
, InstVariant (..)
, VarUIDHsName (..), vunmNm
, vunmMbVar
, fixityAppPrio
, InstDerivingFrom (..)
, SrcConst (..)
, ppAppTop'
, PkgName, emptyPkgName
, graphVisit )
where
import UHC.Util.Utils
import UHC.Util.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import UHC.Light.Compiler.Base.HsName
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Range
import UHC.Light.Compiler.Base.UID
import UHC.Util.AssocL
import UHC.Util.Pretty
import Data.List
import Control.Applicative ((<|>))
import UHC.Util.ScanUtils
import qualified Data.Set as Set
import Control.Monad
import UHC.Util.VarLookup (MetaLev,metaLevVal)
import UHC.Light.Compiler.Scanner.Token
import UHC.Light.Compiler.Scanner.Machine(scanpredIsIdChar,scanpredIsKeywExtra)
import UHC.Util.FPath
import System.IO
import System.Environment
import System.Exit
import Data.Char
import Data.Maybe
import Numeric
import UHC.Light.Compiler.Base.Fld
import UHC.Light.Compiler.CodeGen.Tag
import qualified Data.Map as Map
import UHC.Light.Compiler.Base.Strictness
import qualified Control.Monad.State as ST
import UHC.Util.Binary
import UHC.Util.Serialize
import Data.Version








{-# LINE 92 "src/ehc/Base/Common.chs" #-}
#if __GLASGOW_HASKELL__ < 800
deriving instance Generic Version
#endif

{-# LINE 105 "src/ehc/Base/Common.chs" #-}
ppHsnEscapeWith :: Char -> (Char -> Bool) -> (String -> Bool) -> (HsName -> Bool) -> HsName -> (PP_Doc,Bool)
ppHsnEscapeWith escChar okChars notOkStr leaveAsIs n = flip ST.runState False $ do
    let shown = hsnShow' showUIDParseable show (\s -> "{" ++ s ++ "}") "." "``" n
    if leaveAsIs n
      then return $ pp n
      else do cs <- fmap concat $ forM shown esc
              isEscaped <- ST.get
              return $ pp $ if isEscaped || notOkStr shown then escChar:cs else cs
  where esc c | okChars c = return [c]
              | otherwise = ST.put True >> return [escChar,c]

ppHsnEscaped :: Either Char (Set.Set Char) -> Char -> Set.Set Char -> HsName -> PP_Doc
ppHsnEscaped first escChar escapeeChars
  = \n -> let (nh:nt) = show n
          in  pp $ hd ++ chkhd nh ++ (concatMap esc nt)
  where (hd,chkhd) = either (\c -> ([c],(:""))) (\chs -> ("",\h -> if Set.member h chs then [escChar,h] else esc h)) first
        escapeeChars' = Set.unions [escapeeChars, Set.fromList [escChar]]
        hexChars      = Set.fromList $ ['\NUL'..' '] ++ "\t\r\n"
        esc c | Set.member c escapeeChars' = [escChar,c]
              | Set.member c hexChars      = [escChar,'x'] ++ pad_out (showHex (ord c) "")
              | otherwise                  = [c]
        pad_out ls = (replicate (2 - length ls) '0') ++ ls

hsnEscapeeChars :: Char -> ScanOpts -> Set.Set Char
hsnEscapeeChars escChar scanOpts
  = Set.fromList [escChar] `Set.union` scoSpecChars scanOpts `Set.union` scoOpChars scanOpts

hsnOkChars :: Char -> ScanOpts -> Char -> Bool
hsnOkChars escChar scanOpts c
  = c /= escChar && (scanpredIsIdChar c || scanpredIsKeywExtra scanOpts c)

hsnNotOkStrs :: ScanOpts -> String -> Bool
hsnNotOkStrs scanOpts s = s `Set.member` scoKeywordsTxt scanOpts

ppHsnNonAlpha :: ScanOpts -> HsName -> PP_Doc
ppHsnNonAlpha scanOpts
  = p
  where escapeeChars = hsnEscapeeChars '$' scanOpts
        p n = let name = show n
              in  {- if name `elem`  scoKeywordsTxt scanOpts
                   then pp ('$' : '_' : name)
                   else -}
                        let s = foldr (\c r -> if c `Set.member` escapeeChars then '$':c:r else c:r) [] name
                         in  pp ('$':s)

{-# LINE 156 "src/ehc/Base/Common.chs" #-}
newtype PredOccId
  = PredOccId
      { poiId       :: UID
      }
  deriving (Show,Eq,Ord)

{-# LINE 164 "src/ehc/Base/Common.chs" #-}
mkPrId :: UID -> PredOccId
mkPrId u = PredOccId u

poiHNm :: PredOccId -> HsName
poiHNm = uidHNm . poiId

{-# LINE 172 "src/ehc/Base/Common.chs" #-}
mkPrIdCHR :: UID -> PredOccId
mkPrIdCHR = mkPrId

{-# LINE 177 "src/ehc/Base/Common.chs" #-}
emptyPredOccId :: PredOccId
emptyPredOccId = mkPrId uidStart

{-# LINE 186 "src/ehc/Base/Common.chs" #-}
type VarPPMp = Map.Map UID PP_Doc

{-# LINE 194 "src/ehc/Base/Common.chs" #-}
ppAppTop :: PP arg => (HsName,arg) -> [arg] -> PP_Doc -> PP_Doc
ppAppTop (conNm,con) argL dflt
  =  if       (  hsnIsArrow conNm
              || hsnIsPrArrow conNm
              ) && length argL == 2
                                then  ppListSep "" "" (" " >|< con >|< " ") argL
     else if  hsnIsProd  conNm  then  ppParensCommas argL
     else if  hsnIsList  conNm  then  ppBracketsCommas argL
     else if  hsnIsRec   conNm  then  ppListSep (hsnORec >|< con) hsnCRec "," argL
     else if  hsnIsSum   conNm  then  ppListSep (hsnOSum >|< con) hsnCSum "," argL
     else if  hsnIsRow   conNm  then  ppListSep (hsnORow >|< con) hsnCRow "," argL
                                else  dflt

{-# LINE 215 "src/ehc/Base/Common.chs" #-}
ppAppTop' :: PP arg => (HsName,arg) -> [arg] -> [Bool] -> PP_Doc -> PP_Doc
ppAppTop' cc@(conNm,_) [_,a] [True,_] _ | hsnIsArrow conNm || hsnIsPrArrow conNm    = pp a
ppAppTop' cc argL _ dflt                                                            = ppAppTop cc argL dflt

{-# LINE 221 "src/ehc/Base/Common.chs" #-}
ppCon :: HsName -> PP_Doc
ppCon nm =  if    hsnIsProd nm
            then  ppParens (text (replicate (hsnProdArity nm - 1) ','))
            else  pp nm

ppCmt :: PP_Doc -> PP_Doc
ppCmt p = "{-" >#< p >#< "-}"

{-# LINE 231 "src/ehc/Base/Common.chs" #-}
ppSemi :: PP x => x -> PP_Doc
ppSemi = (>|< ";")

{-# LINE 236 "src/ehc/Base/Common.chs" #-}

ppSpaced :: PP a => [a] -> PP_Doc
ppSpaced = ppListSep "" "" " "


{-# LINE 243 "src/ehc/Base/Common.chs" #-}
ppFld :: String -> Maybe HsName -> HsName -> PP_Doc -> PP_Doc -> PP_Doc
ppFld sep positionalNm nm nmPP f
  = case positionalNm of
      Just pn | pn == nm -> f
      _                  -> nmPP >#< sep >#< f

mkPPAppFun' :: String -> HsName -> PP_Doc -> PP_Doc
mkPPAppFun' sep c p = if c == hsnRowEmpty then empty else p >|< sep

mkPPAppFun :: HsName -> PP_Doc -> PP_Doc
mkPPAppFun = mkPPAppFun' "|"

{-# LINE 257 "src/ehc/Base/Common.chs" #-}
mkExtAppPP' :: String -> (HsName,PP_Doc,[PP_Doc]) -> (HsName,PP_Doc,[PP_Doc],PP_Doc) -> (PP_Doc,[PP_Doc])
mkExtAppPP' sep (funNm,funNmPP,funPPL) (argNm,argNmPP,argPPL,argPP)
  =  if hsnIsRec funNm || hsnIsSum funNm
     then (mkPPAppFun' sep argNm argNmPP,argPPL)
     else (funNmPP,funPPL ++ [argPP])

mkExtAppPP :: (HsName,PP_Doc,[PP_Doc]) -> (HsName,PP_Doc,[PP_Doc],PP_Doc) -> (PP_Doc,[PP_Doc])
mkExtAppPP = mkExtAppPP' "|"

{-# LINE 273 "src/ehc/Base/Common.chs" #-}
ppPair :: (PP a, PP b) => (a,b) -> PP_Doc
ppPair (x,y) = ppParens (pp x >|< "," >|< pp y)

{-# LINE 283 "src/ehc/Base/Common.chs" #-}
ppFM :: (PP k,PP v) => Map.Map k v -> PP_Doc
ppFM = ppAssocL . Map.toList

{-# LINE 288 "src/ehc/Base/Common.chs" #-}
ppListV :: PP a => [a] -> PP_Doc
ppListV = vlist . map pp

{-# LINE 297 "src/ehc/Base/Common.chs" #-}
putCompileMsg :: Verbosity -> Verbosity -> String -> Maybe String -> HsName -> FPath -> IO ()
putCompileMsg v optsVerbosity msg mbMsg2 modNm fNm
  = if optsVerbosity >= v
    then do { hPutStrLn stdout (strBlankPad 40 msg ++ " " ++ strBlankPad 22 (show modNm) ++ " (" ++ fpathToStr fNm ++ maybe "" (\m -> ", " ++ m) mbMsg2 ++ ")")
            ; hFlush stdout
            }
    else return ()

{-# LINE 307 "src/ehc/Base/Common.chs" #-}
writePP ::  (a -> PP_Doc) -> a -> FPath -> IO ()
writePP f text fp = writeToFile (show.f $ text) fp

writeToFile' :: Bool -> String -> FPath -> IO ()
writeToFile' binary str fp
  = do { (fn, fh) <- openFPath fp WriteMode binary
       ; (if binary then hPutStr else hPutStrLn) fh str
       ; hClose fh
       }

writeToFile :: String -> FPath -> IO ()
writeToFile = writeToFile' False


{-# LINE 332 "src/ehc/Base/Common.chs" #-}
data ParNeed =  ParNotNeeded | ParNeededLow | ParNeeded | ParNeededHigh | ParOverrideNeeded
                deriving (Eq,Ord)

type ParNeedL = [ParNeed]

parNeedApp :: HsName -> (ParNeed,ParNeedL)
parNeedApp conNm
  =  let  pr  | hsnIsArrow  conNm   =  (ParNeededLow,[ParNotNeeded,ParNeeded])
              | hsnIsProd   conNm   =  (ParOverrideNeeded,repeat ParNotNeeded)
              | hsnIsList   conNm   =  (ParOverrideNeeded,[ParNotNeeded])
              | hsnIsRec    conNm   =  (ParOverrideNeeded,[ParNotNeeded])
              | hsnIsSum    conNm   =  (ParOverrideNeeded,[ParNotNeeded])
              | hsnIsRow    conNm   =  (ParOverrideNeeded,repeat ParNotNeeded)
              | otherwise           =  (ParNeeded,repeat ParNeededHigh)
     in   pr

{-# LINE 354 "src/ehc/Base/Common.chs" #-}
ppParNeed :: PP p => ParNeed -> ParNeed -> p -> PP_Doc
ppParNeed locNeed globNeed p
  = par (pp p)
  where par = if globNeed > locNeed then ppParens else id

{-# LINE 365 "src/ehc/Base/Common.chs" #-}
-- | Expressions in a CBound position optionally may be labelled
data CLbl
  = CLbl_None
  | CLbl_Nm
      { clblNm		:: !HsName
      }
  | CLbl_Tag
      { clblTag		:: !CTag
      }
  deriving (Show,Eq,Ord,Generic)

clbl :: a -> (HsName -> a) -> (CTag -> a) -> CLbl -> a
clbl f _ _  CLbl_None   = f
clbl _ f _ (CLbl_Nm  n) = f n
clbl _ _ f (CLbl_Tag t) = f t

{-# LINE 383 "src/ehc/Base/Common.chs" #-}
instance PP CLbl where
  pp = clbl empty pp pp

{-# LINE 392 "src/ehc/Base/Common.chs" #-}
data Unbox
  = Unbox_FirstField
  | Unbox_Tag         !Int
  | Unbox_None

{-# LINE 403 "src/ehc/Base/Common.chs" #-}
unions :: Eq a => [[a]] -> [a]
unions = foldr union []

{-# LINE 408 "src/ehc/Base/Common.chs" #-}
listCombineUniq :: Eq a => [[a]] -> [a]
listCombineUniq = nub . concat

{-# LINE 413 "src/ehc/Base/Common.chs" #-}
replicateBy :: [a] -> b -> [b]
replicateBy l e = replicate (length l) e

{-# LINE 422 "src/ehc/Base/Common.chs" #-}
strPadLeft :: Char -> Int -> String -> String
strPadLeft c n s = replicate (n - length s) c ++ s

strBlankPad :: Int -> String -> String
strBlankPad n s = s ++ replicate (n - length s) ' '

{-# LINE 442 "src/ehc/Base/Common.chs" #-}
data Verbosity
  = VerboseQuiet		-- nothing at all
  | VerboseMinimal
  | VerboseNormal		-- basic info
  | VerboseALot
  | VerboseDebug
  deriving (Eq,Ord,Enum)

{-# LINE 456 "src/ehc/Base/Common.chs" #-}
data CHRScoped
  = CHRScopedInstOnly | CHRScopedMutualSuper | CHRScopedAll
  deriving (Eq,Ord)

{-# LINE 466 "src/ehc/Base/Common.chs" #-}
data CompilePoint
  = CompilePoint_Imports
  | CompilePoint_Parse
  | CompilePoint_AnalHS
  | CompilePoint_AnalEH
  | CompilePoint_Core
  | CompilePoint_All
  deriving (Eq,Ord,Show)

{-# LINE 483 "src/ehc/Base/Common.chs" #-}
data Fixity
  = Fixity_Infix | Fixity_Infixr | Fixity_Infixl
  deriving (Eq,Ord,Show,Enum)

instance PP Fixity where
  pp Fixity_Infix  = pp "infix"
  pp Fixity_Infixl = pp "infixl"
  pp Fixity_Infixr = pp "infixr"

{-# LINE 494 "src/ehc/Base/Common.chs" #-}
fixityMaxPrio :: Int
fixityMaxPrio = 9

{-# LINE 499 "src/ehc/Base/Common.chs" #-}
fixityAppPrio :: Int
fixityAppPrio = fixityMaxPrio + 1

{-# LINE 508 "src/ehc/Base/Common.chs" #-}
data InstVariant
  = InstNormal | InstDefault
  | InstDeriving InstDerivingFrom
  deriving (Eq,Ord,Show)

instance PP InstVariant where
  pp = pp . show

{-# LINE 520 "src/ehc/Base/Common.chs" #-}
-- | Either a deriving combined from a datatype directly or a standalone
data InstDerivingFrom
  = InstDerivingFrom_Datatype
  | InstDerivingFrom_Standalone
  deriving (Eq,Ord,Show)

instance PP InstDerivingFrom where
  pp = pp . show

{-# LINE 535 "src/ehc/Base/Common.chs" #-}
type NmLev = Int

nmLevAbsent, nmLevBuiltin, nmLevOutside, nmLevModule :: NmLev
nmLevAbsent  = -3
nmLevBuiltin = -2
nmLevOutside = -1
nmLevModule  =  0


{-# LINE 556 "src/ehc/Base/Common.chs" #-}
-- Assumption: tokTpIsInt (genTokTp t) == True
tokMkInt :: Token -> Int
tokMkInt t
  = case genTokTp t of
      Just TkInteger10 -> read v
      _                -> 0
  where v = tokenVal t

tokMkStr :: Token -> String
tokMkStr = tokenVal

{-# LINE 574 "src/ehc/Base/Common.chs" #-}
tokMkQName :: Token -> HsName
tokMkQName t
  = case genTokTp t of
      Just tp | tokTpIsInt tp -> mkHNmPos $ tokMkInt t
      _                       -> mkHNm $ map hsnFromString $ tokenVals t

{-# LINE 584 "src/ehc/Base/Common.chs" #-}
tokMkQNames :: [Token] -> [HsName]
tokMkQNames = map tokMkQName

instance HSNM Token where
  mkHNm = tokMkQName

{-# LINE 596 "src/ehc/Base/Common.chs" #-}
hsnLclSupplyWith :: HsName -> [HsName]
hsnLclSupplyWith n = map (\i -> hsnSuffix n $ "_" ++ show i) [1..]

hsnLclSupply :: [HsName]
hsnLclSupply = hsnLclSupplyWith (hsnFromString "")

{-# LINE 608 "src/ehc/Base/Common.chs" #-}
splitByRadix :: (Integral b) => Int -> Int -> b -> (Int,[Int])
splitByRadix len radix num
  = ( fromIntegral $ signum num
    , replicate difflen 0 ++ drop (-difflen) repr
    )
  where radix' = fromIntegral radix
        repr = reverse $
               unfoldr
                 (\b -> if b == 0
                        then Nothing
                        else let (q,r) = b `divMod` radix'
                             in  Just (fromIntegral r, q))
                 (abs num)
        difflen = len - length repr

{-# LINE 625 "src/ehc/Base/Common.chs" #-}
strHex :: (Show a, Integral a) => Int -> a -> String
strHex prec x
  = replicate (prec - length h) '0' ++ h
  where h = showHex x []

{-# LINE 636 "src/ehc/Base/Common.chs" #-}
data Backend
  = BackendGrinByteCode
  | BackendSilly
  deriving (Eq, Ord)

{-# LINE 647 "src/ehc/Base/Common.chs" #-}
data VarUIDHsName
  = VarUIDHs_Name       { vunmId :: !UID, vunmNm' :: !HsName }
  | VarUIDHs_UID        { vunmId :: !UID }
  | VarUIDHs_Var        !UID
  deriving (Eq, Ord, Generic)

vunmNm :: VarUIDHsName -> HsName
vunmNm (VarUIDHs_Name _ n) = n
vunmNm (VarUIDHs_UID  i  ) = mkHNm i
vunmNm _                   = panic "Common.assnmNm"

{-# LINE 660 "src/ehc/Base/Common.chs" #-}
vunmMbVar :: VarUIDHsName -> Maybe UID
vunmMbVar (VarUIDHs_Var v) = Just v
vunmMbVar _                = Nothing

{-# LINE 666 "src/ehc/Base/Common.chs" #-}
instance Show VarUIDHsName where
  show (VarUIDHs_Name _ n) = show n
  show (VarUIDHs_UID  i  ) = show i
  show (VarUIDHs_Var  i  ) = show i

instance PP VarUIDHsName where
  pp a = pp $ show a

{-# LINE 680 "src/ehc/Base/Common.chs" #-}
withLkupLiftCyc2 :: (t -> Maybe UID) -> (t -> UIDS) -> (UID -> Maybe t) -> x -> (UIDS -> t -> x) -> (t -> x) -> UIDS -> UID -> x
withLkupLiftCyc2 get noVisit lookup dflt yes no vsVisited v
  = case lookup v of
      Just t | not (v `Set.member` vsVisited)
        -> yes (Set.insert v $ Set.union (noVisit t) vsVisited) t
      _ -> dflt

{-# LINE 689 "src/ehc/Base/Common.chs" #-}
withLkupLiftCyc1 :: (t -> Maybe UID) -> (t -> UIDS) -> (UID -> Maybe t) -> (UIDS -> t -> x) -> (t -> x) -> UIDS -> t -> x
withLkupLiftCyc1 get noVisit lookup yes no vsVisited t
  = maybe dflt (withLkupLiftCyc2 get noVisit lookup dflt yes no vsVisited) $ get t
  where dflt = no t

withLkupChkVisitLift :: (t -> Maybe UID) -> (t -> UIDS) -> (UID -> Maybe t) -> (t -> x) -> (t -> x) -> t -> x
withLkupChkVisitLift get noVisit lookup yes no t
  = withLkupLiftCyc1 get noVisit lookup (\_ t -> yes t) no Set.empty t

withLkupLift :: (t -> Maybe UID) -> (UID -> Maybe t) -> (t -> x) -> (t -> x) -> t -> x
withLkupLift get
  = withLkupChkVisitLift get (const Set.empty)

{-# LINE 704 "src/ehc/Base/Common.chs" #-}
lookupLiftCyc1 :: (x -> Maybe UID) -> (UID -> Maybe x) -> x' -> (x->x') -> x -> x'
lookupLiftCyc1 get lookup dflt found x
  = lk Set.empty dflt found x
  where lk s dflt found x = withLkupLiftCyc1 get (const Set.empty) lookup (\s t -> lk s (found t) found t) (const dflt) s x

lookupLiftCyc2 :: (x -> Maybe UID) -> (UID -> Maybe x) -> x' -> (x->x') -> UID -> x'
lookupLiftCyc2 get lookup dflt found x
  = maybe dflt (\x -> lookupLiftCyc1 get lookup (found x) found x) $ lookup x

{-# LINE 715 "src/ehc/Base/Common.chs" #-}
lookupLiftCycMb1 :: (x -> Maybe UID) -> (UID -> Maybe x) -> x -> Maybe x
lookupLiftCycMb1 get lookup x = lookupLiftCyc1 get lookup Nothing Just x

lookupLiftCycMb2 :: (x -> Maybe UID) -> (UID -> Maybe x) -> UID -> Maybe x
lookupLiftCycMb2 get lookup x = lookupLiftCyc2 get lookup Nothing Just x

{-# LINE 727 "src/ehc/Base/Common.chs" #-}
data Presence = Present | Absent deriving (Eq,Ord,Show)

{-# LINE 759 "src/ehc/Base/Common.chs" #-}
data AlwaysEq a = AlwaysEq { unAlwaysEq :: a }

instance Eq (AlwaysEq a) where
  _ == _ = True

instance Ord (AlwaysEq a) where
  _ `compare` _ = EQ

instance Show a => Show (AlwaysEq a) where
  show (AlwaysEq x) = show x

instance PP a => PP (AlwaysEq a) where
  pp (AlwaysEq x) = pp x

instance Hashable (AlwaysEq a) where
  hashWithSalt salt _ = hashWithSalt salt (12345 :: Int) -- arbitarry, but constant


{-# LINE 783 "src/ehc/Base/Common.chs" #-}
type PkgName = String

emptyPkgName = ""

{-# LINE 793 "src/ehc/Base/Common.chs" #-}
-- | How to do linking/packaging
data LinkingStyle
  = LinkingStyle_None			-- ^ no linking (e.g. indicated by --compile-only flag)
  | LinkingStyle_Exec			-- ^ executable linking
  | LinkingStyle_Pkg			-- ^ package linking
  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance Hashable LinkingStyle



{-# LINE 836 "src/ehc/Base/Common.chs" #-}
metaLevTy, metaLevKi, metaLevSo :: MetaLev
metaLevTy  = metaLevVal + 1
metaLevKi  = metaLevTy  + 1
metaLevSo  = metaLevKi  + 1

{-# LINE 847 "src/ehc/Base/Common.chs" #-}
-- | Use as variable id
type VarId    = UID
type VarIdS   = Set.Set UID

{-# LINE 857 "src/ehc/Base/Common.chs" #-}
uidHNm :: UID -> HsName
uidHNm = mkHNm -- hsnFromString . show

{-# LINE 862 "src/ehc/Base/Common.chs" #-}
uidQualHNm :: HsName -> UID -> HsName
uidQualHNm modnm uid =
                        hsnPrefixQual modnm $
                        uidHNm uid


{-# LINE 880 "src/ehc/Base/Common.chs" #-}
data SrcConst
  = SrcConst_Int    Integer
  | SrcConst_Char   Char
  | SrcConst_Ratio  Integer Integer
  deriving (Eq,Show,Ord)

{-# LINE 892 "src/ehc/Base/Common.chs" #-}
fmap2Tuple :: Functor f => snd -> f x -> f (x,snd)
fmap2Tuple snd = fmap (\x -> (x,snd))

{-# LINE 901 "src/ehc/Base/Common.chs" #-}
-- | Shorthand for if
if' :: Bool -> a -> a -> a
if' c t e = if c then t else e
{-# INLINE if' #-}

{-# LINE 912 "src/ehc/Base/Common.chs" #-}
-- | Variation of `when` where Boolean condition is computed in a monad
whenM :: Monad m => m Bool -> m () -> m ()
whenM c m = do
  c' <- c
  when c' m
{-# INLINE whenM #-}

-- | Variation of `unless` where Boolean condition is computed in a monad
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c m = do
  c' <- c
  unless c' m
{-# INLINE unlessM #-}

-- | Variation of `if` where Boolean condition is computed in a monad
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c mt me = do
  c' <- c
  if c' then mt else me
{-# INLINE ifM #-}

-- | Variation of `if` where Boolean condition is computed in a monad, with then and else part flipped
ifM' :: Monad m => m Bool -> m a -> m a -> m a
ifM' c = flip (ifM c)
{-# INLINE ifM' #-}


{-# LINE 941 "src/ehc/Base/Common.chs" #-}
-- | Variation of `maybe` where the maybe is computed in a monad. See also `maybeM'`
maybeM :: Monad m => m (Maybe a) -> m b -> (a -> m b) -> m b
maybeM mmaybe mnothing mjust = mmaybe >>= maybe mnothing mjust
{-# INLINE maybeM #-}

-- | Variation of `maybe` where the maybe is computed in a monad. See also `maybeM'`
maybe2M :: Monad m => m (Maybe a1) -> (a1 -> m (Maybe a2)) -> m b -> (a1 -> a2 -> m b) -> m b
maybe2M mmaybe1 mmaybe2 mnothing mjust = do
  mb1@(~(Just m1)) <- mmaybe1
  if (isJust mb1)
    then maybeM (mmaybe2 m1) mnothing (mjust m1)
    else mnothing

-- | Variation of `maybe` where the maybe is computed in a monad and a guard is involved. See also `maybeM'`
maybeGuardM :: Monad m => m (Maybe a) -> (a -> m Bool) -> m b -> (a -> m b) -> m b
maybeGuardM mmaybe mgrd mnothing mjust = mmaybe >>= maybe mnothing (\x -> ifM (mgrd x) (mjust x) mnothing)
{-# INLINE maybeGuardM #-}

-- | Variation of `maybe` where the maybe is computed in a guarded monad. See also `maybeGuardM'`
guardMaybeM :: Monad m => (m Bool) -> m (Maybe a) -> m b -> (a -> m b) -> m b
guardMaybeM mgrd mmaybe mnothing mjust = ifM' mgrd mnothing $ maybeM mmaybe mnothing mjust
{-# INLINE guardMaybeM #-}

-- | As 'maybeM' but with last 2 args flipped, allowing a continuation based style for case by case analysis based on Maybe
maybeM' :: Monad m => m (Maybe a) -> (a -> m b) -> m b -> m b
maybeM' mmaybe = flip (maybeM mmaybe)
{-# INLINE maybeM' #-}

-- | Variation of `maybe`, when, and ifJust where the maybe is computed in a monad
whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()
whenJustM mmaybe = maybeM mmaybe (return ())

-- | Variation of `maybe`, when, and ifJust where the maybe is computed in a monad and a guard is involved
whenJustGuardM :: Monad m => m (Maybe a) -> (a -> m Bool) -> (a -> m ()) -> m ()
whenJustGuardM mmaybe mgrd mjust = maybeM mmaybe (return ()) $ \a -> whenM (mgrd a) $ mjust a

-- | Variation of `maybe`, unless, and ifNothing where the maybe is computed in a monad
unlessJustM :: Monad m => m (Maybe a) -> m () -> m ()
unlessJustM mmaybe = maybeM' mmaybe (\_ -> return ())

{-# LINE 987 "src/ehc/Base/Common.chs" #-}
genNmMap :: Ord x => (String->s) -> [x] -> Map.Map x s -> (Map.Map x s, [s])
genNmMap mk xs m
  = (m',reverse ns)
  where (m',_,ns)
          = foldl (\(m,sz,ns) x
                    -> case Map.lookup x m of
                         Just n -> (m, sz, n:ns)
                         _      -> (Map.insert x n m, sz+1, n:ns)
                                where n = mk $ ch sz
                  )
                  (m,Map.size m,[]) xs
        ch x | x < 26    = [chr $ ord 'a' + x]
             | otherwise = let (q,r) = x `quotRem` 26 in ch q ++ ch r

{-# LINE 1007 "src/ehc/Base/Common.chs" #-}
data MaybeOk a
  = JustOk  a
  | NotOk   String
  deriving (Eq,Ord,Show)

isJustOk (JustOk _) = True
isJustOk _          = False

fromJustOk (JustOk x) = x
fromJustOk _          = panic "fromJustOk"

isNotOk (NotOk _) = True
isNotOk _         = False

fromNotOk (NotOk x) = x
fromNotOk _         = panic "fromNotOk"

maybeOk :: (String -> x) -> (a -> x) -> MaybeOk a -> x
maybeOk _ j (JustOk x) = j x
maybeOk n _ (NotOk  x) = n x

{-# LINE 1034 "src/ehc/Base/Common.chs" #-}
-- | Abstract graph visit, over arbitrary structures
graphVisit
  :: (Ord node)
     => (thr -> graph -> node -> (thr,Set.Set node))        -- fun: visit node, get new thr and nodes to visit next
     -> (Set.Set node -> Set.Set node -> Set.Set node)      -- fun: combine new to visit + already known to visit (respectively)
     -> thr                                                 -- the accumulator, threaded as state
     -> Set.Set node                                        -- root/start
     -> graph                                               -- graph over which we visit
     -> thr                                                 -- accumulator is what we are interested in
graphVisit visit unionUnvisited thr start graph
  = snd $ v ((Set.empty,start),thr)
  where v st@((visited,unvisited),thr)
          | Set.null unvisited = st
          | otherwise          = let (n,unvisited2)      = Set.deleteFindMin unvisited
                                     (thr',newUnvisited) = visit thr graph n
                                     visited'            = Set.insert n visited
                                     unvisited3          = unionUnvisited (newUnvisited `Set.difference` visited') unvisited2
                                 in  v ((visited',unvisited3),thr')

{-# LINE 1059 "src/ehc/Base/Common.chs" #-}
data KnownPrim
  =
    -- platform Int
    KnownPrim_AddI
  | KnownPrim_SubI
  | KnownPrim_MulI

    -- platform Float
  | KnownPrim_AddF
  | KnownPrim_SubF
  | KnownPrim_MulF

    -- platform Double
  | KnownPrim_AddD
  | KnownPrim_SubD
  | KnownPrim_MulD

    -- 8 bit
  | KnownPrim_Add8          -- add: 1 byte / 8 bit, etc etc
  | KnownPrim_Sub8
  | KnownPrim_Mul8

    -- 16 bit
  | KnownPrim_Add16
  | KnownPrim_Sub16
  | KnownPrim_Mul16

    -- 32 bit
  | KnownPrim_Add32
  | KnownPrim_Sub32
  | KnownPrim_Mul32

    -- 64 bit
  | KnownPrim_Add64
  | KnownPrim_Sub64
  | KnownPrim_Mul64
  deriving (Show,Eq,Enum,Bounded)

{-# LINE 1105 "src/ehc/Base/Common.chs" #-}
instance PP KnownPrim where
  pp = pp . show

{-# LINE 1110 "src/ehc/Base/Common.chs" #-}
allKnownPrimMp :: Map.Map String KnownPrim
allKnownPrimMp
  = Map.fromList [ (drop prefixLen $ show t, t) | t <- [ minBound .. maxBound ] ]
  where prefixLen = length "KnownPrim_"

{-# LINE 1125 "src/ehc/Base/Common.chs" #-}
str2stMpWithOmitShow :: (Enum opt, Bounded opt, Eq opt) => (opt -> String) -> [opt] -> Map.Map String opt
str2stMpWithOmitShow shw omits = Map.fromList [ (shw o, o) | o <- [minBound .. maxBound] \\ omits ]

str2stMpWithOmit :: (Show opt, Enum opt, Bounded opt, Eq opt) => [opt] -> Map.Map String opt
str2stMpWithOmit = str2stMpWithOmitShow show

str2stMpWithShow :: (Enum opt, Bounded opt, Eq opt) => (opt -> String) -> Map.Map String opt
str2stMpWithShow shw = str2stMpWithOmitShow shw []

str2stMp :: (Show opt, Enum opt, Bounded opt, Eq opt) => Map.Map String opt
str2stMp = str2stMpWithOmit []

showStr2stMp :: Map.Map String opt -> String
showStr2stMp = concat . intersperse " " . Map.keys

{-# LINE 1146 "src/ehc/Base/Common.chs" #-}
deriving instance Typeable KnownPrim

{-# LINE 1150 "src/ehc/Base/Common.chs" #-}
deriving instance Typeable VarUIDHsName

deriving instance Typeable TagDataInfo

deriving instance Typeable Fixity

#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable  AlwaysEq
#else
deriving instance Typeable1 AlwaysEq
#endif

deriving instance Typeable PredOccId

deriving instance Typeable CLbl


{-# LINE 1173 "src/ehc/Base/Common.chs" #-}
instance Binary KnownPrim where
  put = putEnum8
  get = getEnum8

instance Serialize KnownPrim where
  sput = sputPlain
  sget = sgetPlain

instance Serialize TagDataInfo where
  sput (TagDataInfo a b) = sput a >> sput b
  sget = liftM2 TagDataInfo sget sget

{-# LINE 1187 "src/ehc/Base/Common.chs" #-}
instance Serialize VarUIDHsName
instance Serialize CLbl

{-# LINE 1214 "src/ehc/Base/Common.chs" #-}
instance Binary Fixity where
  put = putEnum8
  get = getEnum8

instance Serialize Fixity where
  sput = sputPlain
  sget = sgetPlain

instance Binary x => Binary (AlwaysEq x) where
  put (AlwaysEq x) = put x
  get = liftM AlwaysEq get

instance Serialize x => Serialize (AlwaysEq x) where
  sput (AlwaysEq x) = sput x
  sget = liftM AlwaysEq sget

instance Binary PredOccId where
  put (PredOccId a) = put a
  get = liftM PredOccId get

instance Serialize PredOccId where
  sput = sputPlain
  sget = sgetPlain