ConfigureOpts.hs

{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE NoFieldSelectors    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.ConfigureOpts
License     : BSD-3-Clause
-}

module Stack.ConfigureOpts
  ( configureOptsFromBase
  , configureOptsFromDb
  , renderConfigureOpts
  , packageConfigureOptsFromPackage
  ) where

import qualified Data.Map as Map
import qualified Data.Text as T
import           Database.Persist ( Entity, entityVal )
import           Distribution.Types.MungedPackageName
                   ( decodeCompatPackageName )
import           Distribution.Types.PackageName ( unPackageName )
import           Distribution.Types.UnqualComponentName
                   ( unUnqualComponentName )
import           GHC.Records ( HasField )
import           Path ( (</>), parseRelDir )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Stack.Constants
                   ( bindirSuffix, compilerOptionsCabalFlag, docDirSuffix
                   , relDirEtc, relDirLib, relDirLibexec, relDirShare
                   )
import           Stack.Prelude
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.Compiler ( whichCompiler )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..)
                   , PackageConfigureOpts (..) )
import           Stack.Types.EnvConfig ( EnvConfig, actualCompilerVersionL )
import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.Package ( Package(..), packageIdentifier )
import           System.FilePath ( pathSeparator )

packageConfigureOptsFromPackage ::
     Package
  -> PackageConfigureOpts
packageConfigureOptsFromPackage pkg = PackageConfigureOpts
  { pkgCabalConfigOpts = pkg.cabalConfigOpts
  , pkgGhcOptions = pkg.ghcOptions
  , pkgFlags = pkg.flags
  , pkgDefaultFlags = pkg.defaultFlags
  , pkgIdentifier = packageIdentifier pkg
  }

configureOptsFromDb ::
     ( HasField "configCacheDirOptionValue" b1 String
     , HasField "configCacheNoDirOptionValue" b2 String
     )
  => [Entity b1]
  -> [Entity b2]
  -> ConfigureOpts
configureOptsFromDb x y = ConfigureOpts
  { pathRelated = map ((.configCacheDirOptionValue) . entityVal) x
  , nonPathRelated = map ((.configCacheNoDirOptionValue) . entityVal) y
  }

-- | Render a @BaseConfigOpts@ to an actual list of options
configureOptsFromBase ::
     EnvConfig
  -> BaseConfigOpts
  -> Map PackageIdentifier GhcPkgId -- ^ dependencies
  -> Bool -- ^ local non-extra-dep?
  -> IsMutable
  -> PackageConfigureOpts
  -> ConfigureOpts
configureOptsFromBase econfig bco deps isLocal isMutable pkgConfigureOpts =
  ConfigureOpts
    { pathRelated = configureOptsPathRelated bco isMutable pkgConfigureOpts
    , nonPathRelated =
        configureOptsNonPathRelated econfig bco deps isLocal pkgConfigureOpts
    }

configureOptsPathRelated ::
     BaseConfigOpts
  -> IsMutable
  -> PackageConfigureOpts
  -> [String]
configureOptsPathRelated bco isMutable pkgOpts = concat
  [ ["--user", "--package-db=clear", "--package-db=global"]
  , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case isMutable of
      Immutable -> bco.extraDBs ++ [bco.snapDB]
      Mutable -> bco.extraDBs ++ [bco.snapDB] ++ [bco.localDB]
  , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLib)
    , "--bindir=" ++ toFilePathNoTrailingSep (installRoot </> bindirSuffix)
    , "--datadir=" ++ toFilePathNoTrailingSep (installRoot </> relDirShare)
    , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLibexec)
    , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirEtc)
    , "--docdir=" ++ toFilePathNoTrailingSep docDir
    , "--htmldir=" ++ toFilePathNoTrailingSep docDir
    , "--haddockdir=" ++ toFilePathNoTrailingSep docDir]
  ]
 where
  installRoot =
    case isMutable of
      Immutable -> bco.snapInstallRoot
      Mutable -> bco.localInstallRoot
  docDir =
    case pkgVerDir of
      Nothing -> installRoot </> docDirSuffix
      Just dir -> installRoot </> docDirSuffix </> dir
  pkgVerDir = parseRelDir
    (  packageIdentifierString pkgOpts.pkgIdentifier
    ++ [pathSeparator]
    )

-- | Same as 'configureOpts', but does not include directory path options
configureOptsNonPathRelated ::
     EnvConfig
  -> BaseConfigOpts
  -> Map PackageIdentifier GhcPkgId -- ^ Dependencies.
  -> Bool -- ^ Is this a local, non-extra-dep?
  -> PackageConfigureOpts
  -> [String]
configureOptsNonPathRelated econfig bco deps isLocal package = concat
  [ depOptions
  , [ "--enable-library-profiling"
    | bopts.libProfile || bopts.exeProfile
    ]
  , ["--enable-profiling" | bopts.exeProfile && isLocal]
  , ["--enable-split-objs" | bopts.splitObjs]
  , [ "--disable-library-stripping"
    | not $ bopts.libStrip || bopts.exeStrip
    ]
  , ["--disable-executable-stripping" | not bopts.exeStrip && isLocal]
  , flags
  , map T.unpack package.pkgCabalConfigOpts
  , processGhcOptions package.pkgGhcOptions
  , map ("--extra-include-dirs=" ++) config.extraIncludeDirs
  , map ("--extra-lib-dirs=" ++) config.extraLibDirs
  , maybe
      []
      (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc])
      config.overrideGccPath
  , ["--exact-configuration"]
  , ["--ghc-option=-fhide-source-paths" | hideSourcePaths]
  ]
 where
  -- This function parses the GHC options that are providing in the
  -- stack.yaml file. In order to handle RTS arguments correctly, we need
  -- to provide the RTS arguments as a single argument.
  processGhcOptions :: [Text] -> [String]
  processGhcOptions args =
    let (preRtsArgs, mid) = break ("+RTS" ==) args
        (rtsArgs, end) = break ("-RTS" ==) mid
        fullRtsArgs =
          case rtsArgs of
            [] ->
              -- This means that we didn't have any RTS args - no `+RTS` - and
              -- therefore no need for a `-RTS`.
              []
            _ ->
              -- In this case, we have some RTS args. `break` puts the `"-RTS"`
              -- string in the `snd` list, so we want to append it on the end of
              -- `rtsArgs` here.
              --
              -- We're not checking that `-RTS` is the first element of `end`.
              -- This is because the GHC RTS allows you to omit a trailing -RTS
              -- if that's the last of the arguments. This permits a GHC options
              -- in stack.yaml that matches what you might pass directly to GHC.
              [T.unwords $ rtsArgs ++ ["-RTS"]]
        -- We drop the first element from `end`, because it is always either
        -- `"-RTS"` (and we don't want that as a separate argument) or the list
        -- is empty (and `drop _ [] = []`).
        postRtsArgs = drop 1 end
        newArgs = concat [preRtsArgs, fullRtsArgs, postRtsArgs]
    in  concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) newArgs

  wc = view (actualCompilerVersionL . to whichCompiler) econfig

  hideSourcePaths = config.hideSourcePaths

  config = view configL econfig
  bopts = bco.buildOpts
  mapAndAppend fn = Map.foldrWithKey' (fmap (:) . fn)
  -- Unioning atop defaults is needed so that all flags are specified with
  -- --exact-configuration.
  flags = mapAndAppend
    renderFlags
    []
    (package.pkgFlags `Map.union` package.pkgDefaultFlags)
  renderFlags name enabled =
       "-f"
    <> (if enabled then "" else "-")
    <> flagNameString name

  depOptions = mapAndAppend toDepOption [] deps

  toDepOption (PackageIdentifier name _) gid = concat
    [ "--dependency="
    , depOptionKey
    , "="
    , ghcPkgIdString gid
    ]
   where
    MungedPackageName subPkgName lib = decodeCompatPackageName name
    depOptionKey = case lib of
      LMainLibName -> unPackageName name
      LSubLibName cn ->
        unPackageName subPkgName <> ":" <> unUnqualComponentName cn

-- | Render configure options as a single list of options.
renderConfigureOpts :: ConfigureOpts -> [String]
renderConfigureOpts copts = copts.pathRelated ++ copts.nonPathRelated