uhc-light-1.1.8.2: src/UHC/Light/Compiler/Base/Common.hs
{-# LANGUAGE CPP #-}
module UHC.Light.Compiler.Base.Common
( 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
, whenM, unlessM
, str2stMp, str2stMpWithOmit, 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
, ppSemi
, ppPair
, showPP
, ppFM
, putCompileMsg
, writePP, writeToFile
, CLbl (..), clbl
, Unbox (..)
, replicateBy
, strPadLeft, strBlankPad
, Verbosity (..)
, splitByRadix
, strHex
, Backend (..)
, Presence (..)
, fmap2Tuple
, genNmMap
, MaybeOk (..), isJustOk, isNotOk, maybeOk, fromJustOk, fromNotOk
, KnownPrim (..)
, allKnownPrimMp
, module UHC.Light.Compiler.Base.RLList
, PredOccId (..)
, mkPrId, poiHNm
, mkPrIdCHR
, emptyPredOccId
, ppListV
, snd3, thd
, CHRScoped (..)
, InstVariant (..)
, VarUIDHsName (..), vunmNm
, vunmMbVar
, combineToDistinguishedElts
, LinkingStyle (..)
, fixityAppPrio
, InstDerivingFrom (..)
, SrcConst (..)
, ppAppTop'
, PkgName, emptyPkgName
, graphVisit )
where
import UHC.Util.Utils
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.Light.Compiler.Base.RLList
import UHC.Util.Binary
import UHC.Util.Serialize
{-# LINE 94 "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 145 "src/ehc/Base/Common.chs" #-}
newtype PredOccId
= PredOccId
{ poiId :: UID
}
deriving (Show,Eq,Ord)
{-# LINE 153 "src/ehc/Base/Common.chs" #-}
mkPrId :: UID -> PredOccId
mkPrId u = PredOccId u
poiHNm :: PredOccId -> HsName
poiHNm = uidHNm . poiId
{-# LINE 161 "src/ehc/Base/Common.chs" #-}
mkPrIdCHR :: UID -> PredOccId
mkPrIdCHR = mkPrId
{-# LINE 166 "src/ehc/Base/Common.chs" #-}
emptyPredOccId :: PredOccId
emptyPredOccId = mkPrId uidStart
{-# LINE 175 "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 196 "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 202 "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 212 "src/ehc/Base/Common.chs" #-}
ppSemi :: PP x => x -> PP_Doc
ppSemi = (>|< ";")
{-# LINE 217 "src/ehc/Base/Common.chs" #-}
ppSpaced :: PP a => [a] -> PP_Doc
ppSpaced = ppListSep "" "" " "
{-# LINE 224 "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 238 "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 254 "src/ehc/Base/Common.chs" #-}
ppPair :: (PP a, PP b) => (a,b) -> PP_Doc
ppPair (x,y) = ppParens (pp x >|< "," >|< pp y)
{-# LINE 259 "src/ehc/Base/Common.chs" #-}
showPP :: PP a => a -> String
showPP x = disp (pp x) 100 ""
{-# LINE 264 "src/ehc/Base/Common.chs" #-}
ppFM :: (PP k,PP v) => Map.Map k v -> PP_Doc
ppFM = ppAssocL . Map.toList
{-# LINE 269 "src/ehc/Base/Common.chs" #-}
ppListV :: PP a => [a] -> PP_Doc
ppListV = vlist . map pp
{-# LINE 278 "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 288 "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 313 "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 335 "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 361 "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)
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 379 "src/ehc/Base/Common.chs" #-}
instance PP CLbl where
pp = clbl empty pp pp
{-# LINE 388 "src/ehc/Base/Common.chs" #-}
data Unbox
= Unbox_FirstField
| Unbox_Tag !Int
| Unbox_None
{-# LINE 399 "src/ehc/Base/Common.chs" #-}
unions :: Eq a => [[a]] -> [a]
unions = foldr union []
{-# LINE 404 "src/ehc/Base/Common.chs" #-}
listCombineUniq :: Eq a => [[a]] -> [a]
listCombineUniq = nub . concat
{-# LINE 424 "src/ehc/Base/Common.chs" #-}
replicateBy :: [a] -> b -> [b]
replicateBy l e = replicate (length l) e
{-# LINE 433 "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 441 "src/ehc/Base/Common.chs" #-}
snd3 :: (a,b,c) -> b
snd3 (a,b,c) = b
thd :: (a,b,c) -> c
thd (a,b,c) = c
{-# LINE 453 "src/ehc/Base/Common.chs" #-}
data Verbosity
= VerboseQuiet | VerboseMinimal | VerboseNormal | VerboseALot | VerboseDebug
deriving (Eq,Ord,Enum)
{-# LINE 463 "src/ehc/Base/Common.chs" #-}
data CHRScoped
= CHRScopedInstOnly | CHRScopedMutualSuper | CHRScopedAll
deriving (Eq,Ord)
{-# LINE 473 "src/ehc/Base/Common.chs" #-}
data CompilePoint
= CompilePoint_Imports
| CompilePoint_Parse
| CompilePoint_AnalHS
| CompilePoint_AnalEH
| CompilePoint_Core
| CompilePoint_All
deriving (Eq,Ord,Show)
{-# LINE 490 "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 501 "src/ehc/Base/Common.chs" #-}
fixityMaxPrio :: Int
fixityMaxPrio = 9
{-# LINE 506 "src/ehc/Base/Common.chs" #-}
fixityAppPrio :: Int
fixityAppPrio = fixityMaxPrio + 1
{-# LINE 515 "src/ehc/Base/Common.chs" #-}
data InstVariant
= InstNormal | InstDefault
| InstDeriving InstDerivingFrom
deriving (Eq,Ord,Show)
{-# LINE 524 "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)
{-# LINE 536 "src/ehc/Base/Common.chs" #-}
type NmLev = Int
nmLevAbsent, nmLevBuiltin, nmLevOutside, nmLevModule :: NmLev
nmLevAbsent = -3
nmLevBuiltin = -2
nmLevOutside = -1
nmLevModule = 0
{-# LINE 557 "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 575 "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 585 "src/ehc/Base/Common.chs" #-}
tokMkQNames :: [Token] -> [HsName]
tokMkQNames = map tokMkQName
instance HSNM Token where
mkHNm = tokMkQName
{-# LINE 597 "src/ehc/Base/Common.chs" #-}
hsnLclSupplyWith :: HsName -> [HsName]
hsnLclSupplyWith n = map (\i -> hsnSuffix n $ "_" ++ show i) [1..]
hsnLclSupply :: [HsName]
hsnLclSupply = hsnLclSupplyWith (hsnFromString "")
{-# LINE 609 "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 626 "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 637 "src/ehc/Base/Common.chs" #-}
data Backend
= BackendGrinByteCode
| BackendSilly
deriving (Eq, Ord)
{-# LINE 648 "src/ehc/Base/Common.chs" #-}
data VarUIDHsName
= VarUIDHs_Name { vunmId :: !UID, vunmNm' :: !HsName }
| VarUIDHs_UID { vunmId :: !UID }
| VarUIDHs_Var !UID
deriving (Eq, Ord)
vunmNm :: VarUIDHsName -> HsName
vunmNm (VarUIDHs_Name _ n) = n
vunmNm (VarUIDHs_UID i ) = mkHNm i
vunmNm _ = panic "Common.assnmNm"
{-# LINE 661 "src/ehc/Base/Common.chs" #-}
vunmMbVar :: VarUIDHsName -> Maybe UID
vunmMbVar (VarUIDHs_Var v) = Just v
vunmMbVar _ = Nothing
{-# LINE 667 "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 681 "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 690 "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 705 "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 716 "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 728 "src/ehc/Base/Common.chs" #-}
data Presence = Present | Absent deriving (Eq,Ord,Show)
{-# LINE 736 "src/ehc/Base/Common.chs" #-}
-- | Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x2..y1],..,[xn..ym]].
-- Each element [xi..yi] is distinct based on the the key k in xi==(k,_)
combineToDistinguishedElts :: Eq k => [AssocL k v] -> [AssocL k v]
combineToDistinguishedElts [] = []
combineToDistinguishedElts [[]] = []
combineToDistinguishedElts [x] = map (:[]) x
combineToDistinguishedElts (l:ls)
= combine l $ combineToDistinguishedElts ls
where combine l ls
= concatMap (\e@(k,_)
-> mapMaybe (\ll -> maybe (Just (e:ll)) (const Nothing) $ lookup k ll)
ls
) l
{-# LINE 759 "src/ehc/Base/Common.chs" #-}
data AlwaysEq a = AlwaysEq 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
{-# LINE 779 "src/ehc/Base/Common.chs" #-}
type PkgName = String
emptyPkgName = ""
{-# LINE 789 "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,Enum,Bounded)
{-# LINE 829 "src/ehc/Base/Common.chs" #-}
metaLevTy, metaLevKi, metaLevSo :: MetaLev
metaLevTy = metaLevVal + 1
metaLevKi = metaLevTy + 1
metaLevSo = metaLevKi + 1
{-# LINE 840 "src/ehc/Base/Common.chs" #-}
-- | Use as variable id
type VarId = UID
type VarIdS = Set.Set UID
{-# LINE 850 "src/ehc/Base/Common.chs" #-}
uidHNm :: UID -> HsName
uidHNm = mkHNm -- hsnFromString . show
{-# LINE 855 "src/ehc/Base/Common.chs" #-}
uidQualHNm :: HsName -> UID -> HsName
uidQualHNm modnm uid =
hsnPrefixQual modnm $
uidHNm uid
{-# LINE 873 "src/ehc/Base/Common.chs" #-}
data SrcConst
= SrcConst_Int Integer
| SrcConst_Char Char
| SrcConst_Ratio Integer Integer
deriving (Eq,Show,Ord)
{-# LINE 885 "src/ehc/Base/Common.chs" #-}
fmap2Tuple :: Functor f => snd -> f x -> f (x,snd)
fmap2Tuple snd = fmap (\x -> (x,snd))
{-# LINE 894 "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 #-}
{-# LINE 914 "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 934 "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 961 "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 986 "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 1032 "src/ehc/Base/Common.chs" #-}
instance PP KnownPrim where
pp = pp . show
{-# LINE 1037 "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 1052 "src/ehc/Base/Common.chs" #-}
str2stMpWithOmit :: (Show opt, Enum opt, Bounded opt, Eq opt) => [opt] -> Map.Map String opt
str2stMpWithOmit omits = Map.fromList [ (show o, o) | o <- [minBound .. maxBound] \\ omits ]
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 1067 "src/ehc/Base/Common.chs" #-}
deriving instance Data KnownPrim
deriving instance Typeable KnownPrim
{-# LINE 1072 "src/ehc/Base/Common.chs" #-}
deriving instance Typeable VarUIDHsName
deriving instance Data VarUIDHsName
deriving instance Typeable TagDataInfo
deriving instance Data TagDataInfo
deriving instance Typeable Fixity
deriving instance Data Fixity
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable AlwaysEq
#else
deriving instance Typeable1 AlwaysEq
#endif
deriving instance Data x => Data (AlwaysEq x)
deriving instance Typeable PredOccId
deriving instance Data PredOccId
deriving instance Typeable CLbl
deriving instance Data CLbl
{-# LINE 1101 "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
instance Serialize VarUIDHsName where
sput (VarUIDHs_Name a b) = sputWord8 0 >> sput a >> sput b
sput (VarUIDHs_UID a ) = sputWord8 1 >> sput a
sput (VarUIDHs_Var a ) = sputWord8 2 >> sput a
sget = do t <- sgetWord8
case t of
0 -> liftM2 VarUIDHs_Name sget sget
1 -> liftM VarUIDHs_UID sget
2 -> liftM VarUIDHs_Var sget
instance Serialize CLbl where
sput (CLbl_Nm a ) = sputWord8 0 >> sput a
sput (CLbl_Tag a ) = sputWord8 1 >> sput a
sput (CLbl_None ) = sputWord8 2
sget = do t <- sgetWord8
case t of
0 -> liftM CLbl_Nm sget
1 -> liftM CLbl_Tag sget
2 -> return CLbl_None
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