{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.UHC
-- Copyright   :  Andres Loeh 2009
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains most of the UHC-specific code for configuring, building
-- and installing packages.
--
-- Thanks to the authors of the other implementation-specific files, in
-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for
-- inspiration on how to design this module.
module Distribution.Simple.UHC
  ( configure
  , getInstalledPackages
  , buildLib
  , buildExe
  , installLib
  , registerPackage
  , inplacePackageDbPath
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.InstalledPackageInfo
import Distribution.Package hiding (installedUnitId)
import Distribution.PackageDescription
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.MungedPackageId
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
import Language.Haskell.Extension

import qualified Data.Map as Map (empty)
import System.Directory
import System.FilePath (pathSeparator)

-- -----------------------------------------------------------------------------
-- Configuring

configure
  :: Verbosity
  -> Maybe FilePath
  -> Maybe FilePath
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe String
-> Maybe String
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe String
hcPath Maybe String
_hcPkgPath ProgramDb
progdb = do
  (_uhcProg, uhcVersion, progdb') <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
uhcProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
1, Int
0, Int
2]))
      (String -> Maybe String -> ProgramDb -> ProgramDb
userMaybeSpecifyPath String
"uhc" Maybe String
hcPath ProgramDb
progdb)

  let comp =
        Compiler
          { compilerId :: CompilerId
compilerId = CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
UHC Version
uhcVersion
          , compilerAbiTag :: AbiTag
compilerAbiTag = AbiTag
NoAbiTag
          , compilerCompat :: [CompilerId]
compilerCompat = []
          , compilerLanguages :: [(Language, String)]
compilerLanguages = [(Language, String)]
uhcLanguages
          , compilerExtensions :: [(Extension, Maybe String)]
compilerExtensions = [(Extension, Maybe String)]
uhcLanguageExtensions
          , compilerProperties :: Map String String
compilerProperties = Map String String
forall k a. Map k a
Map.empty
          }
      compPlatform = Maybe a
forall a. Maybe a
Nothing
  return (comp, compPlatform, progdb')

uhcLanguages :: [(Language, CompilerFlag)]
uhcLanguages :: [(Language, String)]
uhcLanguages = [(Language
Haskell98, String
"")]

-- | The flags for the supported extensions.
uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]
uhcLanguageExtensions :: [(Extension, Maybe String)]
uhcLanguageExtensions =
  let doFlag :: (KnownExtension, (b, b)) -> [(Extension, b)]
doFlag (KnownExtension
f, (b
enable, b
disable)) =
        [ (KnownExtension -> Extension
EnableExtension KnownExtension
f, b
enable)
        , (KnownExtension -> Extension
DisableExtension KnownExtension
f, b
disable)
        ]
      alwaysOn :: (Maybe a, Maybe a)
alwaysOn = (Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing {- wrong -})
   in ((KnownExtension, (Maybe String, Maybe String))
 -> [(Extension, Maybe String)])
-> [(KnownExtension, (Maybe String, Maybe String))]
-> [(Extension, Maybe String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (KnownExtension, (Maybe String, Maybe String))
-> [(Extension, Maybe String)]
forall {b}. (KnownExtension, (b, b)) -> [(Extension, b)]
doFlag
        [ (KnownExtension
CPP, (String -> Maybe String
forall a. a -> Maybe a
Just String
"--cpp", Maybe String
forall a. Maybe a
Nothing {- wrong -}))
        , (KnownExtension
PolymorphicComponents, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ExistentialQuantification, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ForeignFunctionInterface, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
UndecidableInstances, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
MultiParamTypeClasses, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
Rank2Types, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
PatternSignatures, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
EmptyDataDecls, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ImplicitPrelude, (Maybe String
forall a. Maybe a
Nothing, String -> Maybe String
forall a. a -> Maybe a
Just String
"--no-prelude" {- wrong -}))
        , (KnownExtension
TypeOperators, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
OverlappingInstances, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
FlexibleInstances, (Maybe String, Maybe String)
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        ]

getInstalledPackages
  :: Verbosity
  -> Compiler
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: forall from.
Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs ProgramDb
progdb = do
  let compilerid :: CompilerId
compilerid = Compiler -> CompilerId
compilerId Compiler
comp
  systemPkgDir <- Verbosity -> ProgramDb -> IO String
getGlobalPackageDir Verbosity
verbosity ProgramDb
progdb
  userPkgDir <- getUserPackageDir
  let pkgDirs = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [String])
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB)) -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
-> String
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [String]
forall from.
String
-> String
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [String]
packageDbPaths String
userPkgDir String
systemPkgDir Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir) PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs)
  -- putStrLn $ "pkgdirs: " ++ show pkgDirs
  pkgs <-
    liftM (map addBuiltinVersions . concat) $
      traverse
        (\String
d -> String -> IO [String]
getDirectoryContents String
d IO [String] -> ([String] -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> String -> String -> IO Bool
isPkgDir (CompilerId -> String
forall a. Pretty a => a -> String
prettyShow CompilerId
compilerid) String
d))
        pkgDirs
  -- putStrLn $ "pkgs: " ++ show pkgs
  let iPkgs =
        (PackageIdentifier -> InstalledPackageInfo)
-> [PackageIdentifier] -> [InstalledPackageInfo]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> InstalledPackageInfo
mkInstalledPackageInfo ([PackageIdentifier] -> [InstalledPackageInfo])
-> [PackageIdentifier] -> [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$
          (String -> [PackageIdentifier]) -> [String] -> [PackageIdentifier]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [PackageIdentifier]
parsePackage ([String] -> [PackageIdentifier])
-> [String] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$
            [String]
pkgs
  -- putStrLn $ "installed pkgs: " ++ show iPkgs
  return (fromList iPkgs)

getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
getGlobalPackageDir :: Verbosity -> ProgramDb -> IO String
getGlobalPackageDir Verbosity
verbosity ProgramDb
progdb = do
  output <-
    Verbosity -> Program -> ProgramDb -> [String] -> IO String
getDbProgramOutput
      Verbosity
verbosity
      Program
uhcProgram
      ProgramDb
progdb
      [String
"--meta-pkgdir-system"]
  -- we need to trim because pkgdir contains an extra newline at the end
  let pkgdir = String -> String
trimEnd String
output
  return pkgdir
  where
    trimEnd :: String -> String
trimEnd = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

getUserPackageDir :: IO FilePath
getUserPackageDir :: IO String
getUserPackageDir = do
  homeDir <- IO String
getHomeDirectory
  return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way

packageDbPaths
  :: FilePath
  -> FilePath
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> [FilePath]
packageDbPaths :: forall from.
String
-> String
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [String]
packageDbPaths String
user String
system Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
db =
  case PackageDBX (SymbolicPath from ('Dir PkgDB))
db of
    PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB -> [String
system]
    PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB -> [String
user]
    SpecificPackageDB SymbolicPath from ('Dir PkgDB)
path -> [Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
path]

-- | Hack to add version numbers to UHC-built-in packages. This should sooner or
-- later be fixed on the UHC side.
addBuiltinVersions :: String -> String
{-
addBuiltinVersions "uhcbase"  = "uhcbase-1.0"
addBuiltinVersions "base"  = "base-3.0"
addBuiltinVersions "array" = "array-0.2"
-}
addBuiltinVersions :: String -> String
addBuiltinVersions String
xs = String
xs

-- | Name of the installed package config file.
installedPkgConfig :: String
installedPkgConfig :: String
installedPkgConfig = String
"installed-pkg-config"

-- | Check if a certain dir contains a valid package. Currently, we are
-- looking only for the presence of an installed package configuration.
-- TODO: Actually make use of the information provided in the file.
isPkgDir :: String -> String -> String -> IO Bool
isPkgDir :: String -> String -> String -> IO Bool
isPkgDir String
_ String
_ (Char
'.' : String
_) = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- ignore files starting with a .
isPkgDir String
c String
dir String
xs = do
  let candidate :: String
candidate = String
dir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String -> String -> String
uhcPackageDir String
xs String
c
  -- putStrLn $ "trying: " ++ candidate
  String -> IO Bool
doesFileExist (String
candidate String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
installedPkgConfig)

parsePackage :: String -> [PackageId]
parsePackage :: String -> [PackageIdentifier]
parsePackage = Maybe PackageIdentifier -> [PackageIdentifier]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe PackageIdentifier -> [PackageIdentifier])
-> (String -> Maybe PackageIdentifier)
-> String
-> [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe PackageIdentifier
forall a. Parsec a => String -> Maybe a
simpleParsec

-- | Create a trivial package info from a directory name.
mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
mkInstalledPackageInfo :: PackageIdentifier -> InstalledPackageInfo
mkInstalledPackageInfo PackageIdentifier
p =
  InstalledPackageInfo
emptyInstalledPackageInfo
    { installedUnitId = mkLegacyUnitId p
    , sourcePackageId = p
    }

-- -----------------------------------------------------------------------------
-- Building

buildLib
  :: Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
buildLib :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
  systemPkgDir <- Verbosity -> ProgramDb -> IO String
getGlobalPackageDir Verbosity
verbosity (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  userPkgDir <- getUserPackageDir
  let runUhcProg = Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [String]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [String]
-> IO ()
runDbProgramCwd Verbosity
verbosity (LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi) Program
uhcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  let uhcArgs =
        -- set package name
        [String
"--pkg-build=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)]
          -- common flags lib/exe
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
-> String
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [String]
constructUHCCmdLine
            String
userPkgDir
            String
systemPkgDir
            LocalBuildInfo
lbi
            (Library -> BuildInfo
libBuildInfo Library
lib)
            ComponentLocalBuildInfo
clbi
            (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi)
            Verbosity
verbosity
          -- source files
          -- suboptimal: UHC does not understand module names, so
          -- we replace periods by path separators
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
            ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
pathSeparator else Char
c))
            ((ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
forall a. Pretty a => a -> String
prettyShow (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi))

  runUhcProg uhcArgs

  return ()

buildExe
  :: Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
buildExe :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
buildExe Verbosity
verbosity PackageDescription
_pkg_descr LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi = do
  systemPkgDir <- Verbosity -> ProgramDb -> IO String
getGlobalPackageDir Verbosity
verbosity (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  userPkgDir <- getUserPackageDir
  let mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
  srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe)
  let runUhcProg = Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [String]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [String]
-> IO ()
runDbProgramCwd Verbosity
verbosity (LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi) Program
uhcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
      u = SymbolicPathX allowAbsolute from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD
      uhcArgs =
        -- common flags lib/exe
        String
-> String
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [String]
constructUHCCmdLine
          String
userPkgDir
          String
systemPkgDir
          LocalBuildInfo
lbi
          (Executable -> BuildInfo
buildInfo Executable
exe)
          ComponentLocalBuildInfo
clbi
          (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi)
          Verbosity
verbosity
          -- output file
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--output", SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Build)
-> RelativePath Build (ZonkAny 0)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Build (ZonkAny 0)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow (Executable -> UnqualComponentName
exeName Executable
exe))]
          -- main source module
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (SymbolicPathX 'AllowAbsolute Pkg 'File -> String)
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg 'File
srcMainPath]
  runUhcProg uhcArgs

constructUHCCmdLine
  :: FilePath
  -> FilePath
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir Build)
  -> Verbosity
  -> [String]
constructUHCCmdLine :: String
-> String
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [String]
constructUHCCmdLine String
user String
system LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Build)
odir Verbosity
verbosity =
  -- verbosity
  ( if Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening
      then [String
"-v4"]
      else
        if Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
          then []
          else [String
"-v0"]
  )
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CompilerFlavor -> BuildInfo -> [String]
hcOptions CompilerFlavor
UHC BuildInfo
bi
    -- flags for language extensions
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Compiler -> Maybe Language -> [String]
languageToFlags (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (BuildInfo -> Maybe Language
defaultLanguage BuildInfo
bi)
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Compiler -> [Extension] -> [String]
extensionsToFlags (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (BuildInfo -> [Extension]
usedExtensions BuildInfo
bi)
    -- packages
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--hide-all-packages"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> String -> PackageDBStack -> [String]
uhcPackageDbOptions String
user String
system (LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi)
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--package=uhcbase"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--package=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ MungedPackageName -> String
forall a. Pretty a => a -> String
prettyShow (MungedPackageId -> MungedPackageName
mungedName MungedPackageId
pkgid) | (UnitId
_, MungedPackageId
pkgid) <- ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi]
    -- search paths
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Build) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u SymbolicPath Pkg ('Dir Build)
odir]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u SymbolicPath Pkg ('Dir Source)
l | SymbolicPath Pkg ('Dir Source)
l <- [SymbolicPath Pkg ('Dir Source)]
-> [SymbolicPath Pkg ('Dir Source)]
forall a. Eq a => [a] -> [a]
nub (BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs BuildInfo
bi)]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi)]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u (LocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenPackageModulesDir LocalBuildInfo
lbi)]
    -- cpp options
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--optP=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opt | String
opt <- BuildInfo -> [String]
cppOptions BuildInfo
bi]
    -- output path
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--odir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Build) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
u SymbolicPath Pkg ('Dir Build)
odir]
    -- optimization
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( case LocalBuildInfo -> OptimisationLevel
withOptimization LocalBuildInfo
lbi of
          OptimisationLevel
NoOptimisation -> [String
"-O0"]
          OptimisationLevel
NormalOptimisation -> [String
"-O1"]
          OptimisationLevel
MaximumOptimisation -> [String
"-O2"]
       )
  where
    u :: SymbolicPathX allowAbsolute from to -> String
u = SymbolicPathX allowAbsolute from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path

uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
uhcPackageDbOptions :: String -> String -> PackageDBStack -> [String]
uhcPackageDbOptions String
user String
system PackageDBStack
db =
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
    (\String
x -> String
"--pkg-searchpath=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
    ((PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [String])
-> PackageDBStack -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
-> String
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
-> [String]
forall from.
String
-> String
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [String]
packageDbPaths String
user String
system Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing) PackageDBStack
db)

-- -----------------------------------------------------------------------------
-- Installation

installLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -> FilePath
  -> FilePath
  -> PackageDescription
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
installLib :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> String
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
_lbi String
targetDir String
_dynlibTargetDir String
builtDir PackageDescription
pkg Library
_library ComponentLocalBuildInfo
_clbi = do
  -- putStrLn $ "dest:  " ++ targetDir
  -- putStrLn $ "built: " ++ builtDir
  Verbosity -> String -> String -> IO ()
installDirectoryContents Verbosity
verbosity (String
builtDir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg)) String
targetDir

-- currently hard-coded UHC code generator and variant to use
uhcTarget, uhcTargetVariant :: String
uhcTarget :: String
uhcTarget = String
"bc"
uhcTargetVariant :: String
uhcTargetVariant = String
"plain"

-- root directory for a package in UHC
uhcPackageDir :: String -> String -> FilePath
uhcPackageSubDir :: String -> FilePath
uhcPackageDir :: String -> String -> String
uhcPackageDir String
pkgid String
compilerid = String
pkgid String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String -> String
uhcPackageSubDir String
compilerid
uhcPackageSubDir :: String -> String
uhcPackageSubDir String
compilerid = String
compilerid String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
uhcTarget String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
uhcTargetVariant

-- -----------------------------------------------------------------------------
-- Registering

registerPackage
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> Compiler
  -> ProgramDb
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> IO ()
registerPackage :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> Compiler
-> ProgramDb
-> PackageDBStackS from
-> InstalledPackageInfo
-> IO ()
registerPackage Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir Compiler
comp ProgramDb
progdb PackageDBStackS from
packageDbs InstalledPackageInfo
installedPkgInfo = do
  dbdir <- case PackageDBStackS from -> PackageDBX (SymbolicPath from ('Dir PkgDB))
forall from. PackageDBStackX from -> PackageDBX from
registrationPackageDB PackageDBStackS from
packageDbs of
    PackageDBX (SymbolicPath from ('Dir PkgDB))
GlobalPackageDB -> Verbosity -> ProgramDb -> IO String
getGlobalPackageDir Verbosity
verbosity ProgramDb
progdb
    PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB -> IO String
getUserPackageDir
    SpecificPackageDB SymbolicPath from ('Dir PkgDB)
dir -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
dir)
  let pkgdir = String
dbdir String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String -> String -> String
uhcPackageDir (PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid) (CompilerId -> String
forall a. Pretty a => a -> String
prettyShow CompilerId
compilerid)
  createDirectoryIfMissingVerbose verbosity True pkgdir
  writeUTF8File
    (pkgdir </> installedPkgConfig)
    (showInstalledPackageInfo installedPkgInfo)
  where
    pkgid :: PackageIdentifier
pkgid = InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
installedPkgInfo
    compilerid :: CompilerId
compilerid = Compiler -> CompilerId
compilerId Compiler
comp

inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB)
inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg ('Dir PkgDB)
inplacePackageDbPath LocalBuildInfo
lbi = SymbolicPath Pkg ('Dir Build) -> SymbolicPath Pkg ('Dir PkgDB)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath (SymbolicPath Pkg ('Dir Build) -> SymbolicPath Pkg ('Dir PkgDB))
-> SymbolicPath Pkg ('Dir Build) -> SymbolicPath Pkg ('Dir PkgDB)
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi