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