Skip to content
This repository
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 198 lines (166 sloc) 7.469 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
-----------------------------------------------------------------------------
-- |
-- 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 it's 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, compilerFlavor, compilerVersion,

        -- * Support for package databases
        PackageDB(..),
        PackageDBStack,
        registrationPackageDB,
        absolutePackageDBPaths,
        absolutePackageDBPath,

        -- * Support for optimisation levels
        OptimisationLevel(..),
        flagToOptimisationLevel,

        -- * Support for language extensions
        Flag,
        languageToFlags,
        unsupportedLanguages,
        extensionsToFlags,
        unsupportedExtensions,
        parmakeSupported
  ) where

import Distribution.Compiler
import Distribution.Version (Version(..))
import Distribution.Text (display)
import Language.Haskell.Extension (Language(Haskell98), Extension)

import Control.Monad (liftM)
import Data.List (nub)
import qualified Data.Map as M (Map, lookup)
import Data.Maybe (catMaybes, isNothing)
import System.Directory (canonicalizePath)

data Compiler = Compiler {
        compilerId :: CompilerId,
        -- ^ Compiler flavour and version.
        compilerLanguages :: [(Language, Flag)],
        -- ^ Supported language standards.
        compilerExtensions :: [(Extension, Flag)],
        -- ^ Supported extensions.
        compilerProperties :: M.Map String String
        -- ^ A key-value map for properties not covered by the above fields.
    }
    deriving (Show, Read)

showCompilerId :: Compiler -> String
showCompilerId = display . compilerId

compilerFlavor :: Compiler -> CompilerFlavor
compilerFlavor = (\(CompilerId f _) -> f) . compilerId

compilerVersion :: Compiler -> Version
compilerVersion = (\(CompilerId _ v) -> v) . compilerId

-- ------------------------------------------------------------
-- * 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, Ord, Show, Read)

-- | 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 [] = error "internal error: empty package db set"
registrationPackageDB dbs = last dbs

-- | Make package paths absolute


absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths = mapM absolutePackageDBPath

absolutePackageDBPath :: PackageDB -> IO 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 compliers that do not the level is just capped to the level
-- they do support.
--
data OptimisationLevel = NoOptimisation
                       | NormalOptimisation
                       | MaximumOptimisation
    deriving (Eq, Show, Read, Enum, Bounded)

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

-- ------------------------------------------------------------
-- * 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)

extensionToFlag :: Compiler -> Extension -> Maybe Flag
extensionToFlag comp ext = lookup ext (compilerExtensions comp)

-- | Does this compiler support parallel --make mode?
parmakeSupported :: Compiler -> Bool
parmakeSupported comp =
  case compilerFlavor comp of
    GHC -> case M.lookup "Support parallel --make" (compilerProperties comp) of
      Just "YES" -> True
      _ -> False
    _ -> False
Something went wrong with that request. Please try again.