{-# 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
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe [Char]
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe [Char]
hcPath 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]))
      ([Char] -> Maybe [Char] -> ProgramDb -> ProgramDb
userMaybeSpecifyPath [Char]
"uhc" Maybe [Char]
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, [Char])]
compilerLanguages = [(Language, [Char])]
uhcLanguages
          , compilerExtensions :: [(Extension, Maybe [Char])]
compilerExtensions = [(Extension, Maybe [Char])]
uhcLanguageExtensions
          , compilerProperties :: Map [Char] [Char]
compilerProperties = Map [Char] [Char]
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, [Char])]
uhcLanguages = [(Language
Haskell98, [Char]
"")]

-- | The flags for the supported extensions.
uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]
uhcLanguageExtensions :: [(Extension, Maybe [Char])]
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 [Char], Maybe [Char]))
 -> [(Extension, Maybe [Char])])
-> [(KnownExtension, (Maybe [Char], Maybe [Char]))]
-> [(Extension, Maybe [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (KnownExtension, (Maybe [Char], Maybe [Char]))
-> [(Extension, Maybe [Char])]
forall {b}. (KnownExtension, (b, b)) -> [(Extension, b)]
doFlag
        [ (KnownExtension
CPP, ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"--cpp", Maybe [Char]
forall a. Maybe a
Nothing {- wrong -}))
        , (KnownExtension
PolymorphicComponents, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ExistentialQuantification, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ForeignFunctionInterface, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
UndecidableInstances, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
MultiParamTypeClasses, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
Rank2Types, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
PatternSignatures, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
EmptyDataDecls, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
ImplicitPrelude, (Maybe [Char]
forall a. Maybe a
Nothing, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"--no-prelude" {- wrong -}))
        , (KnownExtension
TypeOperators, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
OverlappingInstances, (Maybe [Char], Maybe [Char])
forall {a} {a}. (Maybe a, Maybe a)
alwaysOn)
        , (KnownExtension
FlexibleInstances, (Maybe [Char], Maybe [Char])
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 [Char]
getGlobalPackageDir Verbosity
verbosity ProgramDb
progdb
  userPkgDir <- getUserPackageDir
  let pkgDirs = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ((PackageDBX (SymbolicPath from ('Dir PkgDB)) -> [[Char]])
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB)) -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char]
-> [Char]
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [[Char]]
forall from.
[Char]
-> [Char]
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [[Char]]
packageDbPaths [Char]
userPkgDir [Char]
systemPkgDir Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir) PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs)
  -- putStrLn $ "pkgdirs: " ++ show pkgDirs
  pkgs <-
    liftM (map addBuiltinVersions . concat) $
      traverse
        (\[Char]
d -> [Char] -> IO [[Char]]
getDirectoryContents [Char]
d IO [[Char]] -> ([[Char]] -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> [Char] -> [Char] -> IO Bool
isPkgDir (CompilerId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow CompilerId
compilerid) [Char]
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
$
          ([Char] -> [PackageIdentifier]) -> [[Char]] -> [PackageIdentifier]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [PackageIdentifier]
parsePackage ([[Char]] -> [PackageIdentifier])
-> [[Char]] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$
            [[Char]]
pkgs
  -- putStrLn $ "installed pkgs: " ++ show iPkgs
  return (fromList iPkgs)

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

getUserPackageDir :: IO FilePath
getUserPackageDir :: IO [Char]
getUserPackageDir = do
  homeDir <- IO [Char]
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.
[Char]
-> [Char]
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [[Char]]
packageDbPaths [Char]
user [Char]
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 -> [[Char]
system]
    PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB -> [[Char]
user]
    SpecificPackageDB SymbolicPath from ('Dir PkgDB)
path -> [Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
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 :: [Char] -> [Char]
addBuiltinVersions [Char]
xs = [Char]
xs

-- | Name of the installed package config file.
installedPkgConfig :: String
installedPkgConfig :: [Char]
installedPkgConfig = [Char]
"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 :: [Char] -> [Char] -> [Char] -> IO Bool
isPkgDir [Char]
_ [Char]
_ (Char
'.' : [Char]
_) = 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 [Char]
c [Char]
dir [Char]
xs = do
  let candidate :: [Char]
candidate = [Char]
dir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> [Char] -> [Char]
uhcPackageDir [Char]
xs [Char]
c
  -- putStrLn $ "trying: " ++ candidate
  [Char] -> IO Bool
doesFileExist ([Char]
candidate [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
installedPkgConfig)

parsePackage :: String -> [PackageId]
parsePackage :: [Char] -> [PackageIdentifier]
parsePackage = Maybe PackageIdentifier -> [PackageIdentifier]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe PackageIdentifier -> [PackageIdentifier])
-> ([Char] -> Maybe PackageIdentifier)
-> [Char]
-> [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe PackageIdentifier
forall a. Parsec a => [Char] -> 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 [Char]
getGlobalPackageDir Verbosity
verbosity (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  userPkgDir <- getUserPackageDir
  let runUhcProg = Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [[Char]]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [[Char]]
-> 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
        [[Char]
"--pkg-build=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)]
          -- common flags lib/exe
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char]
-> [Char]
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [[Char]]
constructUHCCmdLine
            [Char]
userPkgDir
            [Char]
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
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
            ((Char -> Char) -> [Char] -> [Char]
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 -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
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 [Char]
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
-> [[Char]]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [[Char]]
-> 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 -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD
      uhcArgs =
        -- common flags lib/exe
        [Char]
-> [Char]
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [[Char]]
constructUHCCmdLine
          [Char]
userPkgDir
          [Char]
systemPkgDir
          LocalBuildInfo
lbi
          (Executable -> BuildInfo
buildInfo Executable
exe)
          ComponentLocalBuildInfo
clbi
          (LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi)
          Verbosity
verbosity
          -- output file
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--output", SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> [Char]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build (ZonkAny 0)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Build (ZonkAny 0)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (UnqualComponentName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Executable -> UnqualComponentName
exeName Executable
exe))]
          -- main source module
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char]
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 :: [Char]
-> [Char]
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> Verbosity
-> [[Char]]
constructUHCCmdLine [Char]
user [Char]
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 [[Char]
"-v4"]
      else
        if Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal
          then []
          else [[Char]
"-v0"]
  )
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ CompilerFlavor -> BuildInfo -> [[Char]]
hcOptions CompilerFlavor
UHC BuildInfo
bi
    -- flags for language extensions
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Compiler -> Maybe Language -> [[Char]]
languageToFlags (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (BuildInfo -> Maybe Language
defaultLanguage BuildInfo
bi)
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Compiler -> [Extension] -> [[Char]]
extensionsToFlags (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (BuildInfo -> [Extension]
usedExtensions BuildInfo
bi)
    -- packages
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--hide-all-packages"]
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char] -> PackageDBStack -> [[Char]]
uhcPackageDbOptions [Char]
user [Char]
system (LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi)
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--package=uhcbase"]
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--package=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MungedPackageName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (MungedPackageId -> MungedPackageName
mungedName MungedPackageId
pkgid) | (UnitId
_, MungedPackageId
pkgid) <- ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi]
    -- search paths
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-i" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Build) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u SymbolicPath Pkg ('Dir Build)
odir]
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-i" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
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)]
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-i" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi)]
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-i" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u (LocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenPackageModulesDir LocalBuildInfo
lbi)]
    -- cpp options
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--optP=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opt | [Char]
opt <- BuildInfo -> [[Char]]
cppOptions BuildInfo
bi]
    -- output path
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--odir=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Build) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
u SymbolicPath Pkg ('Dir Build)
odir]
    -- optimization
    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ( case LocalBuildInfo -> OptimisationLevel
withOptimization LocalBuildInfo
lbi of
          OptimisationLevel
NoOptimisation -> [[Char]
"-O0"]
          OptimisationLevel
NormalOptimisation -> [[Char]
"-O1"]
          OptimisationLevel
MaximumOptimisation -> [[Char]
"-O2"]
       )
  where
    u :: SymbolicPathX allowAbsolute from to -> [Char]
u = SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path

uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
uhcPackageDbOptions :: [Char] -> [Char] -> PackageDBStack -> [[Char]]
uhcPackageDbOptions [Char]
user [Char]
system PackageDBStack
db =
  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
    (\[Char]
x -> [Char]
"--pkg-searchpath=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x)
    ((PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> PackageDBStack -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char]
-> [Char]
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
-> [[Char]]
forall from.
[Char]
-> [Char]
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> [[Char]]
packageDbPaths [Char]
user [Char]
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
-> [Char]
-> [Char]
-> [Char]
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
_lbi [Char]
targetDir [Char]
_dynlibTargetDir [Char]
builtDir PackageDescription
pkg Library
_library ComponentLocalBuildInfo
_clbi = do
  -- putStrLn $ "dest:  " ++ targetDir
  -- putStrLn $ "built: " ++ builtDir
  Verbosity -> [Char] -> [Char] -> IO ()
installDirectoryContents Verbosity
verbosity ([Char]
builtDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg)) [Char]
targetDir

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

-- root directory for a package in UHC
uhcPackageDir :: String -> String -> FilePath
uhcPackageSubDir :: String -> FilePath
uhcPackageDir :: [Char] -> [Char] -> [Char]
uhcPackageDir [Char]
pkgid [Char]
compilerid = [Char]
pkgid [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> [Char]
uhcPackageSubDir [Char]
compilerid
uhcPackageSubDir :: [Char] -> [Char]
uhcPackageSubDir [Char]
compilerid = [Char]
compilerid [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
uhcTarget [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
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 [Char]
getGlobalPackageDir Verbosity
verbosity ProgramDb
progdb
    PackageDBX (SymbolicPath from ('Dir PkgDB))
UserPackageDB -> IO [Char]
getUserPackageDir
    SpecificPackageDB SymbolicPath from ('Dir PkgDB)
dir -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPath from ('Dir PkgDB) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir SymbolicPath from ('Dir PkgDB)
dir)
  let pkgdir = [Char]
dbdir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> [Char] -> [Char]
uhcPackageDir (PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageIdentifier
pkgid) (CompilerId -> [Char]
forall a. Pretty a => a -> [Char]
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