{-# LANGUAGE CPP #-} module UHC.Light.Compiler.Base.Common ( module UHC.Util.Hashable , module UHC.Light.Compiler.Base.HsName , module UHC.Light.Compiler.Base.Range , module UHC.Light.Compiler.Base.UID , module UHC.Util.AssocL , module Data.Typeable, module Data.Generics , 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.Util.Hashable 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 Data.Typeable (Typeable) import Data.Generics (Data) 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 import GHC.Generics (Generic) import Data.Version {-# LINE 104 "src/ehc/Base/Common.chs" #-} deriving instance Generic Version instance Hashable Version {-# LINE 114 "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 165 "src/ehc/Base/Common.chs" #-} newtype PredOccId = PredOccId { poiId :: UID } deriving (Show,Eq,Ord) {-# LINE 173 "src/ehc/Base/Common.chs" #-} mkPrId :: UID -> PredOccId mkPrId u = PredOccId u poiHNm :: PredOccId -> HsName poiHNm = uidHNm . poiId {-# LINE 181 "src/ehc/Base/Common.chs" #-} mkPrIdCHR :: UID -> PredOccId mkPrIdCHR = mkPrId {-# LINE 186 "src/ehc/Base/Common.chs" #-} emptyPredOccId :: PredOccId emptyPredOccId = mkPrId uidStart {-# LINE 195 "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 216 "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 222 "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 232 "src/ehc/Base/Common.chs" #-} ppSemi :: PP x => x -> PP_Doc ppSemi = (>|< ";") {-# LINE 237 "src/ehc/Base/Common.chs" #-} ppSpaced :: PP a => [a] -> PP_Doc ppSpaced = ppListSep "" "" " " {-# LINE 244 "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 258 "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 274 "src/ehc/Base/Common.chs" #-} ppPair :: (PP a, PP b) => (a,b) -> PP_Doc ppPair (x,y) = ppParens (pp x >|< "," >|< pp y) {-# LINE 279 "src/ehc/Base/Common.chs" #-} showPP :: PP a => a -> String showPP x = disp (pp x) 100 "" {-# LINE 284 "src/ehc/Base/Common.chs" #-} ppFM :: (PP k,PP v) => Map.Map k v -> PP_Doc ppFM = ppAssocL . Map.toList {-# LINE 289 "src/ehc/Base/Common.chs" #-} ppListV :: PP a => [a] -> PP_Doc ppListV = vlist . map pp {-# LINE 298 "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 308 "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 333 "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 355 "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 381 "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 399 "src/ehc/Base/Common.chs" #-} instance PP CLbl where pp = clbl empty pp pp {-# LINE 408 "src/ehc/Base/Common.chs" #-} data Unbox = Unbox_FirstField | Unbox_Tag !Int | Unbox_None {-# LINE 419 "src/ehc/Base/Common.chs" #-} unions :: Eq a => [[a]] -> [a] unions = foldr union [] {-# LINE 424 "src/ehc/Base/Common.chs" #-} listCombineUniq :: Eq a => [[a]] -> [a] listCombineUniq = nub . concat {-# LINE 444 "src/ehc/Base/Common.chs" #-} replicateBy :: [a] -> b -> [b] replicateBy l e = replicate (length l) e {-# LINE 453 "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 461 "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 473 "src/ehc/Base/Common.chs" #-} data Verbosity = VerboseQuiet | VerboseMinimal | VerboseNormal | VerboseALot | VerboseDebug deriving (Eq,Ord,Enum) {-# LINE 483 "src/ehc/Base/Common.chs" #-} data CHRScoped = CHRScopedInstOnly | CHRScopedMutualSuper | CHRScopedAll deriving (Eq,Ord) {-# LINE 493 "src/ehc/Base/Common.chs" #-} data CompilePoint = CompilePoint_Imports | CompilePoint_Parse | CompilePoint_AnalHS | CompilePoint_AnalEH | CompilePoint_Core | CompilePoint_All deriving (Eq,Ord,Show) {-# LINE 510 "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 521 "src/ehc/Base/Common.chs" #-} fixityMaxPrio :: Int fixityMaxPrio = 9 {-# LINE 526 "src/ehc/Base/Common.chs" #-} fixityAppPrio :: Int fixityAppPrio = fixityMaxPrio + 1 {-# LINE 535 "src/ehc/Base/Common.chs" #-} data InstVariant = InstNormal | InstDefault | InstDeriving InstDerivingFrom deriving (Eq,Ord,Show) {-# LINE 544 "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 556 "src/ehc/Base/Common.chs" #-} type NmLev = Int nmLevAbsent, nmLevBuiltin, nmLevOutside, nmLevModule :: NmLev nmLevAbsent = -3 nmLevBuiltin = -2 nmLevOutside = -1 nmLevModule = 0 {-# LINE 577 "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 595 "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 605 "src/ehc/Base/Common.chs" #-} tokMkQNames :: [Token] -> [HsName] tokMkQNames = map tokMkQName instance HSNM Token where mkHNm = tokMkQName {-# LINE 617 "src/ehc/Base/Common.chs" #-} hsnLclSupplyWith :: HsName -> [HsName] hsnLclSupplyWith n = map (\i -> hsnSuffix n $ "_" ++ show i) [1..] hsnLclSupply :: [HsName] hsnLclSupply = hsnLclSupplyWith (hsnFromString "") {-# LINE 629 "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 646 "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 657 "src/ehc/Base/Common.chs" #-} data Backend = BackendGrinByteCode | BackendSilly deriving (Eq, Ord) {-# LINE 668 "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 681 "src/ehc/Base/Common.chs" #-} vunmMbVar :: VarUIDHsName -> Maybe UID vunmMbVar (VarUIDHs_Var v) = Just v vunmMbVar _ = Nothing {-# LINE 687 "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 701 "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 710 "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 725 "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 736 "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 748 "src/ehc/Base/Common.chs" #-} data Presence = Present | Absent deriving (Eq,Ord,Show) {-# LINE 756 "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 779 "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 799 "src/ehc/Base/Common.chs" #-} type PkgName = String emptyPkgName = "" {-# LINE 809 "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 849 "src/ehc/Base/Common.chs" #-} metaLevTy, metaLevKi, metaLevSo :: MetaLev metaLevTy = metaLevVal + 1 metaLevKi = metaLevTy + 1 metaLevSo = metaLevKi + 1 {-# LINE 860 "src/ehc/Base/Common.chs" #-} -- | Use as variable id type VarId = UID type VarIdS = Set.Set UID {-# LINE 870 "src/ehc/Base/Common.chs" #-} uidHNm :: UID -> HsName uidHNm = mkHNm -- hsnFromString . show {-# LINE 875 "src/ehc/Base/Common.chs" #-} uidQualHNm :: HsName -> UID -> HsName uidQualHNm modnm uid = hsnPrefixQual modnm $ uidHNm uid {-# LINE 893 "src/ehc/Base/Common.chs" #-} data SrcConst = SrcConst_Int Integer | SrcConst_Char Char | SrcConst_Ratio Integer Integer deriving (Eq,Show,Ord) {-# LINE 905 "src/ehc/Base/Common.chs" #-} fmap2Tuple :: Functor f => snd -> f x -> f (x,snd) fmap2Tuple snd = fmap (\x -> (x,snd)) {-# LINE 914 "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 934 "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 954 "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 981 "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 1006 "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 1052 "src/ehc/Base/Common.chs" #-} instance PP KnownPrim where pp = pp . show {-# LINE 1057 "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 1072 "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 1087 "src/ehc/Base/Common.chs" #-} deriving instance Data KnownPrim deriving instance Typeable KnownPrim {-# LINE 1092 "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 1121 "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