{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This should be a much more sophisticated abstraction than it is. Currently -- it's just a bit of data about the compiler, like its flavour and name and -- version. The reason it's just data is because currently it has to be in -- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The -- only interesting bit of info it contains is a mapping between language -- extensions and compiler command line flags. This module also defines a -- 'PackageDB' type which is used to refer to package databases. Most compilers -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. module Distribution.Simple.Compiler ( -- * Haskell implementations module Distribution.Compiler, Compiler(..), showCompilerId, showCompilerIdWithAbi, compilerFlavor, compilerVersion, compilerCompatFlavor, compilerCompatVersion, compilerInfo, -- * Support for package databases PackageDB(..), PackageDBStack, registrationPackageDB, absolutePackageDBPaths, absolutePackageDBPath, -- * Support for optimisation levels OptimisationLevel(..), flagToOptimisationLevel, -- * Support for debug info levels DebugInfoLevel(..), flagToDebugInfoLevel, -- * Support for language extensions Flag, languageToFlags, unsupportedLanguages, extensionsToFlags, unsupportedExtensions, parmakeSupported, reexportedModulesSupported, renamingPackageFlagsSupported, unifiedIPIDRequired, packageKeySupported, unitIdSupported, coverageSupported, profilingSupported, backpackSupported, arResponseFilesSupported, libraryDynDirSupported, -- * Support for profiling detail levels ProfDetailLevel(..), knownProfDetailLevels, flagToProfDetailLevel, showProfDetailLevel, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.Generic(safeLast) import Distribution.Pretty import Distribution.Compiler import Distribution.Version import Language.Haskell.Extension import Distribution.Simple.Utils import Control.Monad (join) import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) data Compiler = Compiler { compilerId :: CompilerId, -- ^ Compiler flavour and version. compilerAbiTag :: AbiTag, -- ^ Tag for distinguishing incompatible ABI's on the same -- architecture/os. compilerCompat :: [CompilerId], -- ^ Other implementations that this compiler claims to be -- compatible with. compilerLanguages :: [(Language, Flag)], -- ^ Supported language standards. compilerExtensions :: [(Extension, Maybe Flag)], -- ^ Supported extensions. compilerProperties :: Map String String -- ^ A key-value map for properties not covered by the above fields. } deriving (Eq, Generic, Typeable, Show, Read) instance Binary 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 -- | Is this compiler compatible with the compiler flavour we're interested in? -- -- For example this checks if the compiler is actually GHC or is another -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. -- -- > if compilerCompatFlavor GHC compiler then ... else ... -- compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool compilerCompatFlavor flavor comp = flavor == compilerFlavor comp || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] -- | Is this compiler compatible with the compiler flavour we're interested in, -- and if so what version does it claim to be compatible with. -- -- For example this checks if the compiler is actually GHC-7.x or is another -- compiler that claims to be compatible with some GHC-7.x version. -- -- > case compilerCompatVersion GHC compiler of -- > Just (Version (7:_)) -> ... -- > _ -> ... -- 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) -- ------------------------------------------------------------ -- * Package databases -- ------------------------------------------------------------ -- |Some compilers have a notion of a database of available packages. -- For some there is just one global db of packages, other compilers -- support a per-user or an arbitrary db specified at some location in -- the file system. This can be used to build isloated environments of -- packages, for example to build a collection of related packages -- without installing them globally. -- data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath deriving (Eq, Generic, Ord, Show, Read) instance Binary PackageDB -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include: -- -- > [GlobalPackageDB] -- > [GlobalPackageDB, UserPackageDB] -- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] -- -- Note that the 'GlobalPackageDB' is invariably at the bottom since it -- contains the rts, base and other special compiler-specific packages. -- -- We are not restricted to using just the above combinations. In particular -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used. -- type PackageDBStack = [PackageDB] -- | Return the package that we should register into. This is the package db at -- the top of the stack. -- registrationPackageDB :: PackageDBStack -> PackageDB registrationPackageDB dbs = case safeLast dbs of Nothing -> error "internal error: empty package db set" Just p -> p -- | Make package paths absolute absolutePackageDBPaths :: PackageDBStack -> NoCallStackIO PackageDBStack absolutePackageDBPaths = traverse absolutePackageDBPath absolutePackageDBPath :: PackageDB -> NoCallStackIO PackageDB absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB absolutePackageDBPath UserPackageDB = return UserPackageDB absolutePackageDBPath (SpecificPackageDB db) = SpecificPackageDB `liftM` canonicalizePath db -- ------------------------------------------------------------ -- * Optimisation levels -- ------------------------------------------------------------ -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support. -- data OptimisationLevel = NoOptimisation | NormalOptimisation | MaximumOptimisation deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary 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 -- ------------------------------------------------------------ -- * Debug info levels -- ------------------------------------------------------------ -- | Some compilers support emitting debug info. Some have different -- levels. For compilers that do not the level is just capped to the -- level they do support. -- data DebugInfoLevel = NoDebugInfo | MinimalDebugInfo | NormalDebugInfo | MaximalDebugInfo deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary 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 -- ------------------------------------------------------------ -- * Languages and Extensions -- ------------------------------------------------------------ unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs = [ lang | lang <- langs , isNothing (languageToFlag comp lang) ] languageToFlags :: Compiler -> Maybe Language -> [Flag] languageToFlags comp = filter (not . null) . catMaybes . map (languageToFlag comp) . maybe [Haskell98] (\x->[x]) languageToFlag :: Compiler -> Language -> Maybe Flag languageToFlag comp ext = lookup ext (compilerLanguages comp) -- |For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = [ ext | ext <- exts , isNothing (extensionToFlag' comp ext) ] type Flag = String -- |For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [Flag] extensionsToFlags comp = nub . filter (not . null) . catMaybes . map (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags. extensionToFlag :: Compiler -> Extension -> Maybe Flag extensionToFlag comp ext = join (extensionToFlag' comp ext) -- | Looks up the flag for a given extension, for a given compiler. -- However, the extension may be valid for the compiler but not have a flag. -- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4, -- hence it is considered a supported extension but not an accepted flag. -- -- The outer layer of Maybe indicates whether the extensions is supported, while -- the inner layer indicates whether it has a flag. -- When building strings, it is often more convenient to use 'extensionToFlag', -- which ignores the difference. extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe Flag) extensionToFlag' comp ext = lookup ext (compilerExtensions comp) -- | Does this compiler support parallel --make mode? parmakeSupported :: Compiler -> Bool parmakeSupported = ghcSupported "Support parallel --make" -- | Does this compiler support reexported-modules? reexportedModulesSupported :: Compiler -> Bool reexportedModulesSupported = ghcSupported "Support reexported-modules" -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags" -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs" -- | Does this compiler support package keys? packageKeySupported :: Compiler -> Bool packageKeySupported = ghcSupported "Uses package keys" -- | Does this compiler support unit IDs? unitIdSupported :: Compiler -> Bool unitIdSupported = ghcSupported "Uses unit IDs" -- | Does this compiler support Backpack? backpackSupported :: Compiler -> Bool backpackSupported = ghcSupported "Support Backpack" -- | Does this compiler support a package database entry with: -- "dynamic-library-dirs"? libraryDynDirSupported :: Compiler -> Bool libraryDynDirSupported comp = case compilerFlavor comp of GHC -> -- Not just v >= mkVersion [8,0,1,20161022], as there -- are many GHC 8.1 nightlies which don't support this. ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) || v >= mkVersion [8,1,20161021]) _ -> False where v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). arResponseFilesSupported :: Compiler -> Bool arResponseFilesSupported = ghcSupported "ar supports at file" -- | Does this compiler support Haskell program coverage? coverageSupported :: Compiler -> Bool coverageSupported comp = case compilerFlavor comp of GHC -> True GHCJS -> True _ -> False -- | Does this compiler support profiling? profilingSupported :: Compiler -> Bool profilingSupported comp = case compilerFlavor comp of GHC -> True GHCJS -> True _ -> False -- | Utility function for GHC only features 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 -- ------------------------------------------------------------ -- * Profiling detail level -- ------------------------------------------------------------ -- | Some compilers (notably GHC) support profiling and can instrument -- programs so the system can account costs to different functions. There are -- different levels of detail that can be used for this accounting. -- For compilers that do not support this notion or the particular detail -- levels, this is either ignored or just capped to some similar level -- they do support. -- data ProfDetailLevel = ProfDetailNone | ProfDetailDefault | ProfDetailExportedFunctions | ProfDetailToplevelFunctions | ProfDetailAllFunctions | ProfDetailOther String deriving (Eq, Generic, Read, Show) instance Binary 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