stackage/Stackage/Select.hs

{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE CPP #-}
module Stackage.Select
    ( select
    , defaultSelectSettings
    ) where

import           Data.Either          (partitionEithers)
import qualified Data.Map             as Map
import           Data.Maybe           (mapMaybe)
import           Data.Set             (empty)
import qualified Data.Set             as Set
import           Distribution.Text    (simpleParse)
import           Distribution.Version (withinRange)
import           Prelude              hiding (pi)
import           Stackage.Config
import           Stackage.InstallInfo
import           Stackage.Types
import           Stackage.Util

defaultSelectSettings :: GhcMajorVersion -> SelectSettings
defaultSelectSettings version = SelectSettings
    { extraCore = defaultExtraCore version
    , expectedFailuresSelect = defaultExpectedFailures version
    , stablePackages = defaultStablePackages version
    , haskellPlatformDir = "hp"
    , requireHaskellPlatform = True
    , ignoreUpgradeableCore = False
    , excludedPackages = empty
    , flags = \coreMap ->
        Set.fromList (words "blaze_html_0_5 small_base https") `Set.union`

#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
        -- Needed on Windows to get unix-compat to compile
        (if version >= GhcMajorVersion 7 6 then Set.empty else Set.fromList (words "old-time"))
            `Set.union`
#endif
        -- Support for containers-unicode-symbols
        (case Map.lookup (PackageName "containers") coreMap of
            Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
                -> Set.singleton "containers-old"
            _ -> Set.empty)
    , disabledFlags = Set.fromList (words "bytestring-in-base test-hlint network-uri")
        `Set.union`
        (if version <= GhcMajorVersion 7 4
            then Set.singleton "bytestring-builder"
            else Set.empty)

        -- SHA and binary

        `Set.union`
        (if version <= GhcMajorVersion 7 6
            then Set.singleton "decoderinterface"
            else Set.empty)
    , allowedPackage = const $ Right ()
    , useGlobalDatabase = False
    , skippedTests =
        if version >= GhcMajorVersion 7 8
            then Set.fromList
                    [ PackageName "punycode" -- pulls in encoding
                    , PackageName "scientific" -- pulls in tasty-ant-xml
                    ]
            else Set.empty
    , selectGhcVersion = version
    , selectTarballDir = "patching/tarballs"
    , selectUnderlayPackageDirs = []
    }

select :: SelectSettings -> IO BuildPlan
select settings' = do
    ii <- getInstallInfo settings'

    bt <-
        case iiBuildTools ii of
            Left s -> error $ "Could not topologically sort build tools: " ++ s
            Right x -> return x

    return BuildPlan
        { bpTools = bt
        , bpPackages = iiPackages ii
        , bpOptionalCore = iiOptionalCore ii
        , bpCore = iiCore ii
        , bpSkippedTests = skippedTests settings'
        }

-- | Get all of the build tools required.
iiBuildTools :: InstallInfo -> Either String [String]
iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
    fmap (map packageVersionString)
  $ topSort
  $ map addDependencies
  $ filter (flip Set.notMember coreTools . fst)
  $ Set.toList
  $ Set.fromList
  $ mapMaybe (flip Map.lookup buildToolMap)
  $ Set.toList
  $ Set.unions
  $ map piBuildToolsAll
  $ Map.elems
  $ Map.filterWithKey isSelected m
  where
    isSelected name _ = name `Set.member` selected
    selected = Set.fromList $ Map.keys packages

    -- Build tools shipped with GHC which we should not attempt to build
    -- ourselves.
    coreTools = Set.fromList $ map PackageName $ words "hsc2hs"

    -- The map from build tool name to the package it comes from.
    buildToolMap :: Map Executable (PackageName, Version)
    buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m

    toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
    toBuildToolMap (pn, pi) = Map.unions
                            $ map (flip Map.singleton (pn, piVersion pi))
                            $ Set.toList
                            $ piExecs pi

    addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
    addDependencies (pn, pv) =
        ((pn, pv), deps)
      where
        deps =
            case Map.lookup pn m of
                Nothing -> Set.empty
                Just pi -> Set.fromList
                         $ mapMaybe (flip Map.lookup buildToolMap)
                         $ Set.toList
                         $ piBuildToolsExe pi

topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
topSort orig =
    uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
  where
    splitter (x, y)
        | Set.null y = Left x
        | otherwise = Right (x, y)

    go x [] = Right x
    go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
    go (x:xs) ys = do
        let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
        rest <- go (xs ++ xs') ys'
        return $ x : rest

    dropDep x (y, z) = (y, Set.delete x z)

    allVertices = Set.fromList $ map fst orig
    limitDeps (x, y) = (x, Set.intersection allVertices y)