Auxiliary.hs

{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module HaskellCI.Auxiliary (
    Auxiliary (..),
    auxiliary,
    pkgNameDirVariable',
    pkgNameDirVariable,
) where

import HaskellCI.Prelude
import Prelude           (head)

import qualified Data.Set                                     as S
import qualified Distribution.CabalSpecVersion                as C
import qualified Distribution.FieldGrammar.Pretty             as C
import qualified Distribution.Fields.Pretty                   as C
import qualified Distribution.Pretty                          as C
import qualified Distribution.Types.GenericPackageDescription as C
import qualified Distribution.Types.VersionRange              as C
import qualified Text.PrettyPrint                             as PP

import Cabal.Optimization
import Cabal.Project
import Cabal.SourceRepo
import HaskellCI.Compiler
import HaskellCI.Config
import HaskellCI.Config.CopyFields
import HaskellCI.Config.Doctest
import HaskellCI.Config.Docspec
import HaskellCI.Jobs
import HaskellCI.List
import HaskellCI.Package

-- | Auxiliary definitions, probably useful for all backends
data Auxiliary = Auxiliary
    { pkgs                    :: [Package]
    , uris                    :: [URI]
    , projectName             :: String
    , doctestEnabled          :: Bool
    , docspecEnabled          :: Bool
    , hasTests                :: CompilerRange
    , hasLibrary              :: Bool
    , extraCabalProjectFields :: [C.PrettyField ()]
    , testShowDetails         :: String
    }

auxiliary :: Config -> Project URI Void Package -> JobVersions -> Auxiliary
auxiliary Config {..} prj JobVersions {..} = Auxiliary {..}
  where
    pkgs = prjPackages prj
    uris = prjUriPackages prj
    projectName = fromMaybe (pkgName $ Prelude.head pkgs) cfgProjectName

    doctestEnabled = any (maybeGHC False (`C.withinRange` cfgDoctestEnabled cfgDoctest)) versions
    docspecEnabled = any (maybeGHC False (`C.withinRange` cfgDocspecEnabled cfgDocspec)) versions

    testShowDetails
        | cfgTestOutputDirect = " --test-show-details=direct"
        | otherwise           = ""

    -- version range which has tests
    hasTests :: CompilerRange
    hasTests = RangePoints $ S.unions
        [ pkgJobs
        | Pkg{pkgGpd,pkgJobs} <- pkgs
        , not $ null $ C.condTestSuites pkgGpd
        ]

    hasLibrary = any (\Pkg{pkgGpd} -> isJust $ C.condLibrary pkgGpd) pkgs

    extraCabalProjectFields :: [C.PrettyField ()]
    extraCabalProjectFields = buildList $ do
        -- generate package fields for URI packages.
        for_ uris $ \uri ->
            item $ C.PrettyField () "packages" $ PP.text $ uriToString id uri ""

        -- copy fields from original cabal.project
        case cfgCopyFields of
            CopyFieldsNone -> pure ()
            CopyFieldsSome -> copyFieldsSome
            CopyFieldsAll  -> copyFieldsSome *> traverse_ item (prjOtherFields prj)

        -- local ghc-options
        unless (null cfgLocalGhcOptions) $ for_ pkgs $ \Pkg{pkgName} -> do
            let s = unwords $ map (show . C.showToken) cfgLocalGhcOptions
            item $ C.PrettySection () "package" [PP.text pkgName] $ buildList $
                item $ C.PrettyField () "ghc-options" $ PP.text s

        -- raw-project is after local-ghc-options so we can override per package.
        traverse_ item cfgRawProject
      where
        copyFieldsSome :: ListBuilder (C.PrettyField ()) ()
        copyFieldsSome = do
            for_ (prjConstraints prj) $ \xs -> do
                let s = concat (lines xs)
                item $ C.PrettyField () "constraints" $ PP.text s

            for_ (prjAllowNewer prj) $ \xs -> do
                let s = concat (lines xs)
                item $ C.PrettyField () "allow-newer" $ PP.text s

            when (prjReorderGoals prj) $
                item $ C.PrettyField () "reorder-goals" $ PP.text "True"

            for_ (prjMaxBackjumps prj) $ \bj ->
                item $ C.PrettyField () "max-backjumps" $ PP.text $ show bj

            case prjOptimization prj of
                OptimizationOn      -> return ()
                OptimizationOff     -> item $ C.PrettyField () "optimization" $ PP.text "False"
                OptimizationLevel l -> item $ C.PrettyField () "optimization" $ PP.text $ show l

            for_ (prjSourceRepos prj) $ \repo ->
                item $ C.PrettySection () "source-repository-package" [] $
                    C.prettyFieldGrammar C.cabalSpecLatest sourceRepositoryPackageGrammar (srpHoist toList repo)

pkgNameDirVariable' :: String -> String
pkgNameDirVariable' n = "PKGDIR_" ++ map f n where
    f '-' = '_'
    f c   = c

pkgNameDirVariable :: String -> String
pkgNameDirVariable n = "${" ++ pkgNameDirVariable' n ++ "}"