{-# 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 :: Package -> PackageConfigureOpts
packageConfigureOptsFromPackage Package
pkg = PackageConfigureOpts
  { pkgCabalConfigOpts :: [Text]
pkgCabalConfigOpts = Package
pkg.cabalConfigOpts
  , pkgGhcOptions :: [Text]
pkgGhcOptions = Package
pkg.ghcOptions
  , pkgFlags :: Map FlagName Bool
pkgFlags = Package
pkg.flags
  , pkgDefaultFlags :: Map FlagName Bool
pkgDefaultFlags = Package
pkg.defaultFlags
  , pkgIdentifier :: PackageIdentifier
pkgIdentifier = Package -> PackageIdentifier
packageIdentifier Package
pkg
  }

configureOptsFromDb ::
     ( HasField "configCacheDirOptionValue" b1 String
     , HasField "configCacheNoDirOptionValue" b2 String
     )
  => [Entity b1]
  -> [Entity b2]
  -> ConfigureOpts
configureOptsFromDb :: forall b1 b2.
(HasField "configCacheDirOptionValue" b1 String,
 HasField "configCacheNoDirOptionValue" b2 String) =>
[Entity b1] -> [Entity b2] -> ConfigureOpts
configureOptsFromDb [Entity b1]
x [Entity b2]
y = ConfigureOpts
  { pathRelated :: [String]
pathRelated = (Entity b1 -> String) -> [Entity b1] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((.configCacheDirOptionValue) (b1 -> String) -> (Entity b1 -> b1) -> Entity b1 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity b1 -> b1
forall record. Entity record -> record
entityVal) [Entity b1]
x
  , nonPathRelated :: [String]
nonPathRelated = (Entity b2 -> String) -> [Entity b2] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((.configCacheNoDirOptionValue) (b2 -> String) -> (Entity b2 -> b2) -> Entity b2 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity b2 -> b2
forall record. Entity record -> record
entityVal) [Entity b2]
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 :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> PackageConfigureOpts
-> ConfigureOpts
configureOptsFromBase EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal IsMutable
isMutable PackageConfigureOpts
pkgConfigureOpts =
  ConfigureOpts
    { pathRelated :: [String]
pathRelated = BaseConfigOpts -> IsMutable -> PackageConfigureOpts -> [String]
configureOptsPathRelated BaseConfigOpts
bco IsMutable
isMutable PackageConfigureOpts
pkgConfigureOpts
    , nonPathRelated :: [String]
nonPathRelated =
        EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> PackageConfigureOpts
-> [String]
configureOptsNonPathRelated EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal PackageConfigureOpts
pkgConfigureOpts
    }

configureOptsPathRelated ::
     BaseConfigOpts
  -> IsMutable
  -> PackageConfigureOpts
  -> [String]
configureOptsPathRelated :: BaseConfigOpts -> IsMutable -> PackageConfigureOpts -> [String]
configureOptsPathRelated BaseConfigOpts
bco IsMutable
isMutable PackageConfigureOpts
pkgOpts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [String
"--user", String
"--package-db=clear", String
"--package-db=global"]
  , (Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep) ([Path Abs Dir] -> [String]) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> a -> b
$ case IsMutable
isMutable of
      IsMutable
Immutable -> BaseConfigOpts
bco.extraDBs [Path Abs Dir] -> [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts
bco.snapDB]
      IsMutable
Mutable -> BaseConfigOpts
bco.extraDBs [Path Abs Dir] -> [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts
bco.snapDB] [Path Abs Dir] -> [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a] -> [a]
++ [BaseConfigOpts
bco.localDB]
  , [ String
"--libdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLib)
    , String
"--bindir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix)
    , String
"--datadir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirShare)
    , String
"--libexecdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLibexec)
    , String
"--sysconfdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirEtc)
    , String
"--docdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir
    , String
"--htmldir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir
    , String
"--haddockdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
docDir]
  ]
 where
  installRoot :: Path Abs Dir
installRoot =
    case IsMutable
isMutable of
      IsMutable
Immutable -> BaseConfigOpts
bco.snapInstallRoot
      IsMutable
Mutable -> BaseConfigOpts
bco.localInstallRoot
  docDir :: Path Abs Dir
docDir =
    case Maybe (Path Rel Dir)
pkgVerDir of
      Maybe (Path Rel Dir)
Nothing -> Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix
      Just Path Rel Dir
dir -> Path Abs Dir
installRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
docDirSuffix Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
dir
  pkgVerDir :: Maybe (Path Rel Dir)
pkgVerDir = String -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir
    (  PackageIdentifier -> String
packageIdentifierString PackageConfigureOpts
pkgOpts.pkgIdentifier
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
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 :: EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> PackageConfigureOpts
-> [String]
configureOptsNonPathRelated EnvConfig
econfig BaseConfigOpts
bco Map PackageIdentifier GhcPkgId
deps Bool
isLocal PackageConfigureOpts
package = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [String]
depOptions
  , [ String
"--enable-library-profiling"
    | BuildOpts
bopts.libProfile Bool -> Bool -> Bool
|| BuildOpts
bopts.exeProfile
    ]
  , [String
"--enable-profiling" | BuildOpts
bopts.exeProfile Bool -> Bool -> Bool
&& Bool
isLocal]
  , [String
"--enable-split-objs" | BuildOpts
bopts.splitObjs]
  , [ String
"--disable-library-stripping"
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ BuildOpts
bopts.libStrip Bool -> Bool -> Bool
|| BuildOpts
bopts.exeStrip
    ]
  , [String
"--disable-executable-stripping" | Bool -> Bool
not BuildOpts
bopts.exeStrip Bool -> Bool -> Bool
&& Bool
isLocal]
  , [String]
flags
  , (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack PackageConfigureOpts
package.pkgCabalConfigOpts
  , [Text] -> [String]
processGhcOptions PackageConfigureOpts
package.pkgGhcOptions
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"--extra-include-dirs=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) Config
config.extraIncludeDirs
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"--extra-lib-dirs=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) Config
config.extraLibDirs
  , [String]
-> (Path Abs File -> [String]) -> Maybe (Path Abs File) -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      []
      (\Path Abs File
customGcc -> [String
"--with-gcc=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
customGcc])
      Config
config.overrideGccPath
  , [String
"--exact-configuration"]
  , [String
"--ghc-option=-fhide-source-paths" | Bool
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 :: [Text] -> [String]
processGhcOptions [Text]
args =
    let ([Text]
preRtsArgs, [Text]
mid) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"+RTS" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) [Text]
args
        ([Text]
rtsArgs, [Text]
end) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"-RTS" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) [Text]
mid
        fullRtsArgs :: [Text]
fullRtsArgs =
          case [Text]
rtsArgs of
            [] ->
              -- This means that we didn't have any RTS args - no `+RTS` - and

              -- therefore no need for a `-RTS`.

              []
            [Text]
_ ->
              -- 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.

              [[Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
rtsArgs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"-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 :: [Text]
postRtsArgs = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
end
        newArgs :: [Text]
newArgs = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]
preRtsArgs, [Text]
fullRtsArgs, [Text]
postRtsArgs]
    in  (Text -> [String]) -> [Text] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Text
x -> [WhichCompiler -> String
compilerOptionsCabalFlag WhichCompiler
wc, Text -> String
T.unpack Text
x]) [Text]
newArgs

  wc :: WhichCompiler
wc = Getting WhichCompiler EnvConfig WhichCompiler
-> EnvConfig -> WhichCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting WhichCompiler EnvConfig ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter EnvConfig ActualCompiler
actualCompilerVersionL Getting WhichCompiler EnvConfig ActualCompiler
-> ((WhichCompiler -> Const WhichCompiler WhichCompiler)
    -> ActualCompiler -> Const WhichCompiler ActualCompiler)
-> Getting WhichCompiler EnvConfig WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActualCompiler -> WhichCompiler)
-> SimpleGetter ActualCompiler WhichCompiler
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> WhichCompiler
whichCompiler) EnvConfig
econfig

  hideSourcePaths :: Bool
hideSourcePaths = Config
config.hideSourcePaths

  config :: Config
config = Getting Config EnvConfig Config -> EnvConfig -> Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL EnvConfig
econfig
  bopts :: BuildOpts
bopts = BaseConfigOpts
bco.buildOpts
  mapAndAppend :: (k -> a -> a) -> [a] -> Map k a -> [a]
mapAndAppend k -> a -> a
fn = (k -> a -> [a] -> [a]) -> [a] -> Map k a -> [a]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' ((a -> [a] -> [a]) -> (a -> a) -> a -> [a] -> [a]
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (:) ((a -> a) -> a -> [a] -> [a])
-> (k -> a -> a) -> k -> a -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> a -> a
fn)
  -- Unioning atop defaults is needed so that all flags are specified with

  -- --exact-configuration.

  flags :: [String]
flags = (FlagName -> Bool -> String)
-> [String] -> Map FlagName Bool -> [String]
forall {k} {a} {a}. (k -> a -> a) -> [a] -> Map k a -> [a]
mapAndAppend
    FlagName -> Bool -> String
renderFlags
    []
    (PackageConfigureOpts
package.pkgFlags Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` PackageConfigureOpts
package.pkgDefaultFlags)
  renderFlags :: FlagName -> Bool -> String
renderFlags FlagName
name Bool
enabled =
       String
"-f"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if Bool
enabled then String
"" else String
"-")
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FlagName -> String
flagNameString FlagName
name

  depOptions :: [String]
depOptions = (PackageIdentifier -> GhcPkgId -> String)
-> [String] -> Map PackageIdentifier GhcPkgId -> [String]
forall {k} {a} {a}. (k -> a -> a) -> [a] -> Map k a -> [a]
mapAndAppend PackageIdentifier -> GhcPkgId -> String
toDepOption [] Map PackageIdentifier GhcPkgId
deps

  toDepOption :: PackageIdentifier -> GhcPkgId -> String
toDepOption (PackageIdentifier PackageName
name Version
_) GhcPkgId
gid = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"--dependency="
    , String
depOptionKey
    , String
"="
    , GhcPkgId -> String
ghcPkgIdString GhcPkgId
gid
    ]
   where
    MungedPackageName PackageName
subPkgName LibraryName
lib = PackageName -> MungedPackageName
decodeCompatPackageName PackageName
name
    depOptionKey :: String
depOptionKey = case LibraryName
lib of
      LibraryName
LMainLibName -> PackageName -> String
unPackageName PackageName
name
      LSubLibName UnqualComponentName
cn ->
        PackageName -> String
unPackageName PackageName
subPkgName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
cn

-- | Render configure options as a single list of options.

renderConfigureOpts :: ConfigureOpts -> [String]
renderConfigureOpts :: ConfigureOpts -> [String]
renderConfigureOpts ConfigureOpts
copts = ConfigureOpts
copts.pathRelated [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ConfigureOpts
copts.nonPathRelated