module Distribution.Simple.Compiler (
module Distribution.Compiler,
Compiler(..),
showCompilerId, showCompilerIdWithAbi,
compilerFlavor, compilerVersion,
compilerCompatFlavor,
compilerCompatVersion,
compilerInfo,
PackageDB(..),
PackageDBStack,
registrationPackageDB,
absolutePackageDBPaths,
absolutePackageDBPath,
OptimisationLevel(..),
flagToOptimisationLevel,
DebugInfoLevel(..),
flagToDebugInfoLevel,
CompilerFlag,
languageToFlags,
unsupportedLanguages,
extensionsToFlags,
unsupportedExtensions,
parmakeSupported,
reexportedModulesSupported,
renamingPackageFlagsSupported,
unifiedIPIDRequired,
packageKeySupported,
unitIdSupported,
coverageSupported,
profilingSupported,
backpackSupported,
arResponseFilesSupported,
libraryDynDirSupported,
libraryVisibilitySupported,
ProfDetailLevel(..),
knownProfDetailLevels,
flagToProfDetailLevel,
showProfDetailLevel,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Pretty
import Distribution.Compiler
import Distribution.Version
import Language.Haskell.Extension
import Distribution.Simple.Utils
import qualified Data.Map as Map (lookup)
import System.Directory (canonicalizePath)
data Compiler = Compiler {
compilerId :: CompilerId,
compilerAbiTag :: AbiTag,
compilerCompat :: [CompilerId],
compilerLanguages :: [(Language, CompilerFlag)],
compilerExtensions :: [(Extension, Maybe CompilerFlag)],
compilerProperties :: Map String String
}
deriving (Eq, Generic, Typeable, Show, Read)
instance Binary Compiler
instance Structured Compiler
showCompilerId :: Compiler -> String
showCompilerId = prettyShow . compilerId
showCompilerIdWithAbi :: Compiler -> String
showCompilerIdWithAbi comp =
prettyShow (compilerId comp) ++
case compilerAbiTag comp of
NoAbiTag -> []
AbiTag xs -> '-':xs
compilerFlavor :: Compiler -> CompilerFlavor
compilerFlavor = (\(CompilerId f _) -> f) . compilerId
compilerVersion :: Compiler -> Version
compilerVersion = (\(CompilerId _ v) -> v) . compilerId
compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool
compilerCompatFlavor flavor comp =
flavor == compilerFlavor comp
|| flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ]
compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion flavor comp
| compilerFlavor comp == flavor = Just (compilerVersion comp)
| otherwise =
listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]
compilerInfo :: Compiler -> CompilerInfo
compilerInfo c = CompilerInfo (compilerId c)
(compilerAbiTag c)
(Just . compilerCompat $ c)
(Just . map fst . compilerLanguages $ c)
(Just . map fst . compilerExtensions $ c)
data PackageDB = GlobalPackageDB
| UserPackageDB
| SpecificPackageDB FilePath
deriving (Eq, Generic, Ord, Show, Read, Typeable)
instance Binary PackageDB
instance Structured PackageDB
type PackageDBStack = [PackageDB]
registrationPackageDB :: PackageDBStack -> PackageDB
registrationPackageDB dbs = case safeLast dbs of
Nothing -> error "internal error: empty package db set"
Just p -> p
absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths = traverse absolutePackageDBPath
absolutePackageDBPath :: PackageDB -> IO PackageDB
absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
absolutePackageDBPath UserPackageDB = return UserPackageDB
absolutePackageDBPath (SpecificPackageDB db) =
SpecificPackageDB `liftM` canonicalizePath db
data OptimisationLevel = NoOptimisation
| NormalOptimisation
| MaximumOptimisation
deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary OptimisationLevel
instance Structured OptimisationLevel
flagToOptimisationLevel :: Maybe String -> OptimisationLevel
flagToOptimisationLevel Nothing = NormalOptimisation
flagToOptimisationLevel (Just s) = case reads s of
[(i, "")]
| i >= fromEnum (minBound :: OptimisationLevel)
&& i <= fromEnum (maxBound :: OptimisationLevel)
-> toEnum i
| otherwise -> error $ "Bad optimisation level: " ++ show i
++ ". Valid values are 0..2"
_ -> error $ "Can't parse optimisation level " ++ s
data DebugInfoLevel = NoDebugInfo
| MinimalDebugInfo
| NormalDebugInfo
| MaximalDebugInfo
deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary DebugInfoLevel
instance Structured DebugInfoLevel
flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
flagToDebugInfoLevel Nothing = NormalDebugInfo
flagToDebugInfoLevel (Just s) = case reads s of
[(i, "")]
| i >= fromEnum (minBound :: DebugInfoLevel)
&& i <= fromEnum (maxBound :: DebugInfoLevel)
-> toEnum i
| otherwise -> error $ "Bad debug info level: " ++ show i
++ ". Valid values are 0..3"
_ -> error $ "Can't parse debug info level " ++ s
unsupportedLanguages :: Compiler -> [Language] -> [Language]
unsupportedLanguages comp langs =
[ lang | lang <- langs
, isNothing (languageToFlag comp lang) ]
languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag]
languageToFlags comp = filter (not . null)
. catMaybes . map (languageToFlag comp)
. maybe [Haskell98] (\x->[x])
languageToFlag :: Compiler -> Language -> Maybe CompilerFlag
languageToFlag comp ext = lookup ext (compilerLanguages comp)
unsupportedExtensions :: Compiler -> [Extension] -> [Extension]
unsupportedExtensions comp exts =
[ ext | ext <- exts
, isNothing (extensionToFlag' comp ext) ]
type CompilerFlag = String
extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag]
extensionsToFlags comp = nub . filter (not . null)
. catMaybes . map (extensionToFlag comp)
extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag
extensionToFlag comp ext = join (extensionToFlag' comp ext)
extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag)
extensionToFlag' comp ext = lookup ext (compilerExtensions comp)
parmakeSupported :: Compiler -> Bool
parmakeSupported = ghcSupported "Support parallel --make"
reexportedModulesSupported :: Compiler -> Bool
reexportedModulesSupported = ghcSupported "Support reexported-modules"
renamingPackageFlagsSupported :: Compiler -> Bool
renamingPackageFlagsSupported = ghcSupported
"Support thinning and renaming package flags"
unifiedIPIDRequired :: Compiler -> Bool
unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs"
packageKeySupported :: Compiler -> Bool
packageKeySupported = ghcSupported "Uses package keys"
unitIdSupported :: Compiler -> Bool
unitIdSupported = ghcSupported "Uses unit IDs"
backpackSupported :: Compiler -> Bool
backpackSupported = ghcSupported "Support Backpack"
libraryDynDirSupported :: Compiler -> Bool
libraryDynDirSupported comp = case compilerFlavor comp of
GHC ->
((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) ||
v >= mkVersion [8,1,20161021])
_ -> False
where
v = compilerVersion comp
arResponseFilesSupported :: Compiler -> Bool
arResponseFilesSupported = ghcSupported "ar supports at file"
coverageSupported :: Compiler -> Bool
coverageSupported comp =
case compilerFlavor comp of
GHC -> True
GHCJS -> True
_ -> False
profilingSupported :: Compiler -> Bool
profilingSupported comp =
case compilerFlavor comp of
GHC -> True
GHCJS -> True
_ -> False
libraryVisibilitySupported :: Compiler -> Bool
libraryVisibilitySupported comp = case compilerFlavor comp of
GHC -> v >= mkVersion [8,8]
_ -> False
where
v = compilerVersion comp
ghcSupported :: String -> Compiler -> Bool
ghcSupported key comp =
case compilerFlavor comp of
GHC -> checkProp
GHCJS -> checkProp
_ -> False
where checkProp =
case Map.lookup key (compilerProperties comp) of
Just "YES" -> True
_ -> False
data ProfDetailLevel = ProfDetailNone
| ProfDetailDefault
| ProfDetailExportedFunctions
| ProfDetailToplevelFunctions
| ProfDetailAllFunctions
| ProfDetailOther String
deriving (Eq, Generic, Read, Show, Typeable)
instance Binary ProfDetailLevel
instance Structured ProfDetailLevel
flagToProfDetailLevel :: String -> ProfDetailLevel
flagToProfDetailLevel "" = ProfDetailDefault
flagToProfDetailLevel s =
case lookup (lowercase s)
[ (name, value)
| (primary, aliases, value) <- knownProfDetailLevels
, name <- primary : aliases ]
of Just value -> value
Nothing -> ProfDetailOther s
knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]
knownProfDetailLevels =
[ ("default", [], ProfDetailDefault)
, ("none", [], ProfDetailNone)
, ("exported-functions", ["exported"], ProfDetailExportedFunctions)
, ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)
, ("all-functions", ["all"], ProfDetailAllFunctions)
]
showProfDetailLevel :: ProfDetailLevel -> String
showProfDetailLevel dl = case dl of
ProfDetailNone -> "none"
ProfDetailDefault -> "default"
ProfDetailExportedFunctions -> "exported-functions"
ProfDetailToplevelFunctions -> "toplevel-functions"
ProfDetailAllFunctions -> "all-functions"
ProfDetailOther other -> other