Auxiliary.hs

{-# LANGUAGE MultiWayIf        #-}
{-# 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 Network.URI                                  as URI
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.Docspec
import HaskellCI.Config.Doctest
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 :: FilePath -> [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)) linuxVersions
    docspecEnabled = any (maybeGHC False (`C.withinRange` cfgDocspecEnabled cfgDocspec)) linuxVersions

    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 :: FilePath -> [C.PrettyField ()]
    extraCabalProjectFields rootdir = buildList $ do
        -- generate package fields for URI packages.
        for_ uris $ \uri ->
            item $ C.PrettyField () "packages" $ PP.text $ if
                | URI.uriScheme uri == "file:" -> rootdir ++ URI.uriPath uri
                | otherwise                    -> 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 ++ "}"