Cabal/src/Distribution/Simple/Compiler.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Simple.Compiler
   8 -- Copyright   :  Isaac Jones 2003-2004
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This should be a much more sophisticated abstraction than it is. Currently
  15 -- it's just a bit of data about the compiler, like its flavour and name and
  16 -- version. The reason it's just data is because currently it has to be in
  17 -- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The
  18 -- only interesting bit of info it contains is a mapping between language
  19 -- extensions and compiler command line flags. This module also defines a
  20 -- 'PackageDB' type which is used to refer to package databases. Most compilers
  21 -- only know about a single global package collection but GHC has a global and
  22 -- per-user one and it lets you create arbitrary other package databases. We do
  23 -- not yet fully support this latter feature.
  24 module Distribution.Simple.Compiler
  25   ( -- * Haskell implementations
  26       module Distribution.Compiler
  27   , Compiler (..)
  28   , showCompilerId
  29   , showCompilerIdWithAbi
  30   , compilerFlavor
  31   , compilerVersion
  32   , compilerCompatFlavor
  33   , compilerCompatVersion
  34   , compilerInfo
  35
  36     -- * Support for package databases
  37   , PackageDB (..)
  38   , PackageDBStack
  39   , registrationPackageDB
  40   , absolutePackageDBPaths
  41   , absolutePackageDBPath
  42
  43     -- * Support for optimisation levels
  44   , OptimisationLevel (..)
  45   , flagToOptimisationLevel
  46
  47     -- * Support for debug info levels
  48   , DebugInfoLevel (..)
  49   , flagToDebugInfoLevel
  50
  51     -- * Support for language extensions
  52   , CompilerFlag
  53   , languageToFlags
  54   , unsupportedLanguages
  55   , extensionsToFlags
  56   , unsupportedExtensions
  57   , parmakeSupported
  58   , reexportedModulesSupported
  59   , renamingPackageFlagsSupported
  60   , unifiedIPIDRequired
  61   , packageKeySupported
  62   , unitIdSupported
  63   , coverageSupported
  64   , profilingSupported
  65   , backpackSupported
  66   , arResponseFilesSupported
  67   , arDashLSupported
  68   , libraryDynDirSupported
  69   , libraryVisibilitySupported
  70   , jsemSupported
  71
  72     -- * Support for profiling detail levels
  73   , ProfDetailLevel (..)
  74   , knownProfDetailLevels
  75   , flagToProfDetailLevel
  76   , showProfDetailLevel
  77   ) where
  78
  79 import Distribution.Compat.Prelude
  80 import Distribution.Pretty
  81 import Prelude ()
  82
  83 import Distribution.Compiler
  84 import Distribution.Simple.Utils
  85 import Distribution.Version
  86 import Language.Haskell.Extension
  87
  88 import qualified Data.Map as Map (lookup)
  89 import System.Directory (canonicalizePath)
  90
  91 data Compiler = Compiler
  92   { compilerId :: CompilerId
  93   -- ^ Compiler flavour and version.
  94   , compilerAbiTag :: AbiTag
  95   -- ^ Tag for distinguishing incompatible ABI's on the same
  96   -- architecture/os.
  97   , compilerCompat :: [CompilerId]
  98   -- ^ Other implementations that this compiler claims to be
  99   -- compatible with.
 100   , compilerLanguages :: [(Language, CompilerFlag)]
 101   -- ^ Supported language standards.
 102   , compilerExtensions :: [(Extension, Maybe CompilerFlag)]
 103   -- ^ Supported extensions.
 104   , compilerProperties :: Map String String
 105   -- ^ A key-value map for properties not covered by the above fields.
 106   }
 107   deriving (Eq, Generic, Typeable, Show, Read)
 108
 109 instance Binary Compiler
 110 instance Structured Compiler
 111
 112 showCompilerId :: Compiler -> String
 113 showCompilerId = prettyShow . compilerId
 114
 115 showCompilerIdWithAbi :: Compiler -> String
 116 showCompilerIdWithAbi comp =
 117   prettyShow (compilerId comp)
 118     ++ case compilerAbiTag comp of
 119       NoAbiTag -> []
 120       AbiTag xs -> '-' : xs
 121
 122 compilerFlavor :: Compiler -> CompilerFlavor
 123 compilerFlavor = (\(CompilerId f _) -> f) . compilerId
 124
 125 compilerVersion :: Compiler -> Version
 126 compilerVersion = (\(CompilerId _ v) -> v) . compilerId
 127
 128 -- | Is this compiler compatible with the compiler flavour we're interested in?
 129 --
 130 -- For example this checks if the compiler is actually GHC or is another
 131 -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS.
 132 --
 133 -- > if compilerCompatFlavor GHC compiler then ... else ...
 134 compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool
 135 compilerCompatFlavor flavor comp =
 136   flavor == compilerFlavor comp
 137     || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp]
 138
 139 -- | Is this compiler compatible with the compiler flavour we're interested in,
 140 -- and if so what version does it claim to be compatible with.
 141 --
 142 -- For example this checks if the compiler is actually GHC-7.x or is another
 143 -- compiler that claims to be compatible with some GHC-7.x version.
 144 --
 145 -- > case compilerCompatVersion GHC compiler of
 146 -- >   Just (Version (7:_)) -> ...
 147 -- >   _                    -> ...
 148 compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
 149 compilerCompatVersion flavor comp
 150   | compilerFlavor comp == flavor = Just (compilerVersion comp)
 151   | otherwise =
 152       listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor]
 153
 154 compilerInfo :: Compiler -> CompilerInfo
 155 compilerInfo c =
 156   CompilerInfo
 157     (compilerId c)
 158     (compilerAbiTag c)
 159     (Just . compilerCompat $ c)
 160     (Just . map fst . compilerLanguages $ c)
 161     (Just . map fst . compilerExtensions $ c)
 162
 163 -- ------------------------------------------------------------
 164
 165 -- * Package databases
 166
 167 -- ------------------------------------------------------------
 168
 169 -- | Some compilers have a notion of a database of available packages.
 170 --  For some there is just one global db of packages, other compilers
 171 --  support a per-user or an arbitrary db specified at some location in
 172 --  the file system. This can be used to build isolated environments of
 173 --  packages, for example to build a collection of related packages
 174 --  without installing them globally.
 175 data PackageDB
 176   = GlobalPackageDB
 177   | UserPackageDB
 178   | SpecificPackageDB FilePath
 179   deriving (Eq, Generic, Ord, Show, Read, Typeable)
 180
 181 instance Binary PackageDB
 182 instance Structured PackageDB
 183
 184 -- | We typically get packages from several databases, and stack them
 185 -- together. This type lets us be explicit about that stacking. For example
 186 -- typical stacks include:
 187 --
 188 -- > [GlobalPackageDB]
 189 -- > [GlobalPackageDB, UserPackageDB]
 190 -- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"]
 191 --
 192 -- Note that the 'GlobalPackageDB' is invariably at the bottom since it
 193 -- contains the rts, base and other special compiler-specific packages.
 194 --
 195 -- We are not restricted to using just the above combinations. In particular
 196 -- we can use several custom package dbs and the user package db together.
 197 --
 198 -- When it comes to writing, the top most (last) package is used.
 199 type PackageDBStack = [PackageDB]
 200
 201 -- | Return the package that we should register into. This is the package db at
 202 -- the top of the stack.
 203 registrationPackageDB :: PackageDBStack -> PackageDB
 204 registrationPackageDB dbs = case safeLast dbs of
 205   Nothing -> error "internal error: empty package db set"
 206   Just p -> p
 207
 208 -- | Make package paths absolute
 209 absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
 210 absolutePackageDBPaths = traverse absolutePackageDBPath
 211
 212 absolutePackageDBPath :: PackageDB -> IO PackageDB
 213 absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
 214 absolutePackageDBPath UserPackageDB = return UserPackageDB
 215 absolutePackageDBPath (SpecificPackageDB db) =
 216   SpecificPackageDB `liftM` canonicalizePath db
 217
 218 -- ------------------------------------------------------------
 219
 220 -- * Optimisation levels
 221
 222 -- ------------------------------------------------------------
 223
 224 -- | Some compilers support optimising. Some have different levels.
 225 -- For compilers that do not the level is just capped to the level
 226 -- they do support.
 227 data OptimisationLevel
 228   = NoOptimisation
 229   | NormalOptimisation
 230   | MaximumOptimisation
 231   deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
 232
 233 instance Binary OptimisationLevel
 234 instance Structured OptimisationLevel
 235
 236 flagToOptimisationLevel :: Maybe String -> OptimisationLevel
 237 flagToOptimisationLevel Nothing = NormalOptimisation
 238 flagToOptimisationLevel (Just s) = case reads s of
 239   [(i, "")]
 240     | i >= fromEnum (minBound :: OptimisationLevel)
 241         && i <= fromEnum (maxBound :: OptimisationLevel) ->
 242         toEnum i
 243     | otherwise ->
 244         error $
 245           "Bad optimisation level: "
 246             ++ show i
 247             ++ ". Valid values are 0..2"
 248   _ -> error $ "Can't parse optimisation level " ++ s
 249
 250 -- ------------------------------------------------------------
 251
 252 -- * Debug info levels
 253
 254 -- ------------------------------------------------------------
 255
 256 -- | Some compilers support emitting debug info. Some have different
 257 -- levels.  For compilers that do not the level is just capped to the
 258 -- level they do support.
 259 data DebugInfoLevel
 260   = NoDebugInfo
 261   | MinimalDebugInfo
 262   | NormalDebugInfo
 263   | MaximalDebugInfo
 264   deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
 265
 266 instance Binary DebugInfoLevel
 267 instance Structured DebugInfoLevel
 268
 269 flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
 270 flagToDebugInfoLevel Nothing = NormalDebugInfo
 271 flagToDebugInfoLevel (Just s) = case reads s of
 272   [(i, "")]
 273     | i >= fromEnum (minBound :: DebugInfoLevel)
 274         && i <= fromEnum (maxBound :: DebugInfoLevel) ->
 275         toEnum i
 276     | otherwise ->
 277         error $
 278           "Bad debug info level: "
 279             ++ show i
 280             ++ ". Valid values are 0..3"
 281   _ -> error $ "Can't parse debug info level " ++ s
 282
 283 -- ------------------------------------------------------------
 284
 285 -- * Languages and Extensions
 286
 287 -- ------------------------------------------------------------
 288
 289 unsupportedLanguages :: Compiler -> [Language] -> [Language]
 290 unsupportedLanguages comp langs =
 291   [ lang | lang <- langs, isNothing (languageToFlag comp lang)
 292   ]
 293
 294 languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag]
 295 languageToFlags comp =
 296   filter (not . null)
 297     . catMaybes
 298     . map (languageToFlag comp)
 299     . maybe [Haskell98] (\x -> [x])
 300
 301 languageToFlag :: Compiler -> Language -> Maybe CompilerFlag
 302 languageToFlag comp ext = lookup ext (compilerLanguages comp)
 303
 304 -- | For the given compiler, return the extensions it does not support.
 305 unsupportedExtensions :: Compiler -> [Extension] -> [Extension]
 306 unsupportedExtensions comp exts =
 307   [ ext | ext <- exts, isNothing (extensionToFlag' comp ext)
 308   ]
 309
 310 type CompilerFlag = String
 311
 312 -- | For the given compiler, return the flags for the supported extensions.
 313 extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag]
 314 extensionsToFlags comp =
 315   nub
 316     . filter (not . null)
 317     . catMaybes
 318     . map (extensionToFlag comp)
 319
 320 -- | Looks up the flag for a given extension, for a given compiler.
 321 -- Ignores the subtlety of extensions which lack associated flags.
 322 extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag
 323 extensionToFlag comp ext = join (extensionToFlag' comp ext)
 324
 325 -- | Looks up the flag for a given extension, for a given compiler.
 326 -- However, the extension may be valid for the compiler but not have a flag.
 327 -- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4,
 328 -- hence it is considered a supported extension but not an accepted flag.
 329 --
 330 -- The outer layer of Maybe indicates whether the extensions is supported, while
 331 -- the inner layer indicates whether it has a flag.
 332 -- When building strings, it is often more convenient to use 'extensionToFlag',
 333 -- which ignores the difference.
 334 extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag)
 335 extensionToFlag' comp ext = lookup ext (compilerExtensions comp)
 336
 337 -- | Does this compiler support parallel --make mode?
 338 parmakeSupported :: Compiler -> Bool
 339 parmakeSupported = ghcSupported "Support parallel --make"
 340
 341 -- | Does this compiler support reexported-modules?
 342 reexportedModulesSupported :: Compiler -> Bool
 343 reexportedModulesSupported = ghcSupported "Support reexported-modules"
 344
 345 -- | Does this compiler support thinning/renaming on package flags?
 346 renamingPackageFlagsSupported :: Compiler -> Bool
 347 renamingPackageFlagsSupported =
 348   ghcSupported
 349     "Support thinning and renaming package flags"
 350
 351 -- | Does this compiler have unified IPIDs (so no package keys)
 352 unifiedIPIDRequired :: Compiler -> Bool
 353 unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs"
 354
 355 -- | Does this compiler support package keys?
 356 packageKeySupported :: Compiler -> Bool
 357 packageKeySupported = ghcSupported "Uses package keys"
 358
 359 -- | Does this compiler support unit IDs?
 360 unitIdSupported :: Compiler -> Bool
 361 unitIdSupported = ghcSupported "Uses unit IDs"
 362
 363 -- | Does this compiler support Backpack?
 364 backpackSupported :: Compiler -> Bool
 365 backpackSupported = ghcSupported "Support Backpack"
 366
 367 -- | Does this compiler support the -jsem option?
 368 jsemSupported :: Compiler -> Bool
 369 jsemSupported comp = case compilerFlavor comp of
 370   GHC -> v >= mkVersion [9, 7]
 371   _ -> False
 372   where
 373     v = compilerVersion comp
 374
 375 -- | Does this compiler support a package database entry with:
 376 -- "dynamic-library-dirs"?
 377 libraryDynDirSupported :: Compiler -> Bool
 378 libraryDynDirSupported comp = case compilerFlavor comp of
 379   GHC ->
 380     -- Not just v >= mkVersion [8,0,1,20161022], as there
 381     -- are many GHC 8.1 nightlies which don't support this.
 382     ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1])
 383         || v >= mkVersion [8, 1, 20161021]
 384     )
 385   _ -> False
 386   where
 387     v = compilerVersion comp
 388
 389 -- | Does this compiler's "ar" command supports response file
 390 -- arguments (i.e. @file-style arguments).
 391 arResponseFilesSupported :: Compiler -> Bool
 392 arResponseFilesSupported = ghcSupported "ar supports at file"
 393
 394 -- | Does this compiler's "ar" command support llvm-ar's -L flag,
 395 -- which compels the archiver to add an input archive's members
 396 -- rather than adding the archive itself.
 397 arDashLSupported :: Compiler -> Bool
 398 arDashLSupported = ghcSupported "ar supports -L"
 399
 400 -- | Does this compiler support Haskell program coverage?
 401 coverageSupported :: Compiler -> Bool
 402 coverageSupported comp =
 403   case compilerFlavor comp of
 404     GHC -> True
 405     GHCJS -> True
 406     _ -> False
 407
 408 -- | Does this compiler support profiling?
 409 profilingSupported :: Compiler -> Bool
 410 profilingSupported comp =
 411   case compilerFlavor comp of
 412     GHC -> True
 413     GHCJS -> True
 414     _ -> False
 415
 416 -- | Does this compiler support a package database entry with:
 417 -- "visibility"?
 418 libraryVisibilitySupported :: Compiler -> Bool
 419 libraryVisibilitySupported comp = case compilerFlavor comp of
 420   GHC -> v >= mkVersion [8, 8]
 421   _ -> False
 422   where
 423     v = compilerVersion comp
 424
 425 -- | Utility function for GHC only features
 426 ghcSupported :: String -> Compiler -> Bool
 427 ghcSupported key comp =
 428   case compilerFlavor comp of
 429     GHC -> checkProp
 430     GHCJS -> checkProp
 431     _ -> False
 432   where
 433     checkProp =
 434       case Map.lookup key (compilerProperties comp) of
 435         Just "YES" -> True
 436         _ -> False
 437
 438 -- ------------------------------------------------------------
 439
 440 -- * Profiling detail level
 441
 442 -- ------------------------------------------------------------
 443
 444 -- | Some compilers (notably GHC) support profiling and can instrument
 445 -- programs so the system can account costs to different functions. There are
 446 -- different levels of detail that can be used for this accounting.
 447 -- For compilers that do not support this notion or the particular detail
 448 -- levels, this is either ignored or just capped to some similar level
 449 -- they do support.
 450 data ProfDetailLevel
 451   = ProfDetailNone
 452   | ProfDetailDefault
 453   | ProfDetailExportedFunctions
 454   | ProfDetailToplevelFunctions
 455   | ProfDetailAllFunctions
 456   | ProfDetailTopLate
 457   | ProfDetailOther String
 458   deriving (Eq, Generic, Read, Show, Typeable)
 459
 460 instance Binary ProfDetailLevel
 461 instance Structured ProfDetailLevel
 462
 463 flagToProfDetailLevel :: String -> ProfDetailLevel
 464 flagToProfDetailLevel "" = ProfDetailDefault
 465 flagToProfDetailLevel s =
 466   case lookup
 467     (lowercase s)
 468     [ (name, value)
 469     | (primary, aliases, value) <- knownProfDetailLevels
 470     , name <- primary : aliases
 471     ] of
 472     Just value -> value
 473     Nothing -> ProfDetailOther s
 474
 475 knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]
 476 knownProfDetailLevels =
 477   [ ("default", [], ProfDetailDefault)
 478   , ("none", [], ProfDetailNone)
 479   , ("exported-functions", ["exported"], ProfDetailExportedFunctions)
 480   , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)
 481   , ("all-functions", ["all"], ProfDetailAllFunctions)
 482   , ("late-toplevel", ["late"], ProfDetailTopLate)
 483   ]
 484
 485 showProfDetailLevel :: ProfDetailLevel -> String
 486 showProfDetailLevel dl = case dl of
 487   ProfDetailNone -> "none"
 488   ProfDetailDefault -> "default"
 489   ProfDetailExportedFunctions -> "exported-functions"
 490   ProfDetailToplevelFunctions -> "toplevel-functions"
 491   ProfDetailAllFunctions -> "all-functions"
 492   ProfDetailTopLate -> "late-toplevel"
 493   ProfDetailOther other -> other