src/Distribution/Simple/HaskellSuite.hs

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

    module Distribution.Simple.HaskellSuite where

    import Prelude ()
    import Distribution.Compat.Prelude

    import qualified Data.List.NonEmpty as NE

    import Distribution.Simple.Program
    import Distribution.Simple.Compiler
    import Distribution.Simple.Utils
    import Distribution.Simple.BuildPaths
    import Distribution.Verbosity
    import Distribution.Version
    import Distribution.Pretty
    import Distribution.Parsec (simpleParsec)
    import Distribution.Package
    import Distribution.InstalledPackageInfo hiding (includeDirs)
    import Distribution.Simple.PackageIndex as PackageIndex
    import Distribution.PackageDescription
    import Distribution.Simple.LocalBuildInfo
    import Distribution.System (Platform)
    import Distribution.Utils.Path
    import Language.Haskell.Extension
    import Distribution.Simple.Program.Builtin

    configure
      :: Verbosity -> Maybe FilePath -> Maybe FilePath
      -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
    configure verbosity mbHcPath hcPkgPath progdb0 = do

      -- We have no idea how a haskell-suite tool is named, so we require at
      -- least some information from the user.
      hcPath <-
        let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)"
        in maybe (die' verbosity msg) return mbHcPath

      when (isJust hcPkgPath) $
        warn verbosity "--with-hc-pkg option is ignored for haskell-suite"

      (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0

      -- Update our pkg tool. It uses the same executable as the compiler, but
      -- all command start with "pkg"
      (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1
      let progdb2 =
            updateProgram
              confdPkg
                { programLocation = programLocation confdCompiler
                , programDefaultArgs = ["pkg"]
                }
              progdb1

      return (comp, Nothing, progdb2)

      where
        configureCompiler hcPath progdb0' = do
          let
            haskellSuiteProgram' =
              haskellSuiteProgram
                { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath }

          -- NB: cannot call requireProgram right away — it'd think that
          -- the program is already configured and won't reconfigure it again.
          -- Instead, call configureProgram directly first.
          progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0'
          (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1

          extensions <- getExtensions verbosity confdCompiler
          languages  <- getLanguages  verbosity confdCompiler
          (compName, compVersion) <-
            getCompilerVersion verbosity confdCompiler

          let
            comp = Compiler {
              compilerId             = CompilerId (HaskellSuite compName) compVersion,
              compilerAbiTag         = NoAbiTag,
              compilerCompat         = [],
              compilerLanguages      = languages,
              compilerExtensions     = extensions,
              compilerProperties     = mempty
            }

          return (comp, confdCompiler, progdb2)

    hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)
    hstoolVersion = findProgramVersion "--hspkg-version" id

    numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)
    numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words)

    getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)
    getCompilerVersion verbosity prog = do
      output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]
      let
        parts = words output
        name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway
        versionStr = fromMaybe "" $ safeLast parts
      version <-
        maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $
          simpleParsec versionStr
      return (name, version)

    getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]
    getExtensions verbosity prog = do
      extStrs <-
        lines `fmap`
        rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]
      return
        [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ]

    getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)]
    getLanguages verbosity prog = do
      langStrs <-
        lines `fmap`
        rawSystemStdout verbosity (programPath prog) ["--supported-languages"]
      return
        [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ]

    -- Other compilers do some kind of a packagedb stack check here. Not sure
    -- if we need something like that as well.
    getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
                         -> IO InstalledPackageIndex
    getInstalledPackages verbosity packagedbs progdb =
      liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb ->
        do str <-
            getDbProgramOutput verbosity haskellSuitePkgProgram progdb
                    ["dump", packageDbOpt packagedb]
             `catchExit` \_ -> die' verbosity $ "pkg dump failed"
           case parsePackages str of
             Right ok -> return ok
             _       -> die' verbosity "failed to parse output of 'pkg dump'"

      where
        parsePackages str =
            case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of
                ([], ok)   -> Right [ pkg | (_, pkg) <- ok ]
                (msgss, _) -> Left (foldMap NE.toList msgss)

        splitPkgs :: String -> [String]
        splitPkgs = map unlines . splitWith ("---" ==) . lines
          where
            splitWith :: (a -> Bool) -> [a] -> [[a]]
            splitWith p xs = ys : case zs of
                               []   -> []
                               _:ws -> splitWith p ws
              where (ys,zs) = break p xs

    buildLib
      :: Verbosity -> PackageDescription -> LocalBuildInfo
      -> Library -> ComponentLocalBuildInfo -> IO ()
    buildLib verbosity pkg_descr lbi lib clbi = do
      -- In future, there should be a mechanism for the compiler to request any
      -- number of the above parameters (or their parts) — in particular,
      -- pieces of PackageDescription.
      --
      -- For now, we only pass those that we know are used.

      let odir = buildDir lbi
          bi = libBuildInfo lib
          srcDirs = map getSymbolicPath (hsSourceDirs bi) ++ [odir]
          dbStack = withPackageDB lbi
          language = fromMaybe Haskell98 (defaultLanguage bi)
          progdb = withPrograms lbi
          pkgid = packageId pkg_descr

      runDbProgram verbosity haskellSuiteProgram progdb $
        [ "compile", "--build-dir", odir ] ++
        concat [ ["-i", d] | d <- srcDirs ] ++
        concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi
                                  ,autogenPackageModulesDir lbi
                                  ,odir] ++ includeDirs bi ] ++
        [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++
        [ "--package-name", prettyShow pkgid ] ++
        concat [ ["--package-id", prettyShow ipkgid ]
               | (ipkgid, _) <- componentPackageDeps clbi ] ++
        ["-G", prettyShow language] ++
        concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++
        cppOptions (libBuildInfo lib) ++
        [ prettyShow modu | modu <- allLibModules lib clbi ]

    installLib
      :: Verbosity
      -> LocalBuildInfo
      -> FilePath  -- ^install location
      -> FilePath  -- ^install location for dynamic libraries
      -> FilePath  -- ^Build location
      -> PackageDescription
      -> Library
      -> ComponentLocalBuildInfo
      -> IO ()
    installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do
      let progdb = withPrograms lbi
      runDbProgram verbosity haskellSuitePkgProgram progdb $
        [ "install-library"
        , "--build-dir", builtDir
        , "--target-dir", targetDir
        , "--dynlib-target-dir", dynlibTargetDir
        , "--package-id", prettyShow $ packageId pkg
        ] ++ map prettyShow (allLibModules lib clbi)

    registerPackage
      :: Verbosity
      -> ProgramDb
      -> PackageDBStack
      -> InstalledPackageInfo
      -> IO ()
    registerPackage verbosity progdb packageDbs installedPkgInfo = do
      (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb

      runProgramInvocation verbosity $
        (programInvocation hspkg
          ["update", packageDbOpt $ registrationPackageDB packageDbs])
          { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo }

    initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()
    initPackageDB verbosity progdb dbPath =
      runDbProgram verbosity haskellSuitePkgProgram progdb
        ["init", dbPath]

    packageDbOpt :: PackageDB -> String
    packageDbOpt GlobalPackageDB        = "--global"
    packageDbOpt UserPackageDB          = "--user"
    packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db