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

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