BuildPlanSpec.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.BuildPlanSpec where

import Stack.BuildPlan
import Control.Monad.Logger
import Control.Exception hiding (try)
import Control.Monad.Catch (try)
import Data.Monoid
import qualified Data.Map as Map
import qualified Data.Set as Set
import Prelude -- Fix redundant import warnings
import System.Directory
import System.Environment
import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec
import Stack.Config
import Stack.Types.BuildPlan
import Stack.Types.PackageName
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Compiler
import Stack.Types.StackT

setup :: IO ()
setup = unsetEnv "STACK_YAML"

main :: IO ()
main = hspec spec

spec :: Spec
spec = beforeAll setup $ do
    let logLevel = LevelDebug
    let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing Nothing)
    let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False
    let inTempDir action = do
            currentDirectory <- getCurrentDirectory
            withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do
                let enterDir = setCurrentDirectory tempDir
                let exitDir = setCurrentDirectory currentDirectory
                bracket_ enterDir exitDir action
    it "finds missing transitive dependencies #159" $ inTempDir $ do
        -- Note: this test is somewhat fragile, depending on packages on
        -- Hackage remaining in a certain state. If it fails, confirm that
        -- github still depends on failure.
        writeFile "stack.yaml" "resolver: lts-2.9"
        LoadConfig{..} <- loadConfig'
        bconfig <- loadBuildConfigRest (lcLoadBuildConfig Nothing)
        runStackT bconfig logLevel True False ColorAuto False $ do
            mbp <- loadMiniBuildPlan $ LTS 2 9
            eres <- try $ resolveBuildPlan
                mbp
                (const False)
                (Map.fromList
                    [ ($(mkPackageName "github"), Set.empty)
                    ])
            case eres of
                Left (UnknownPackages _ unknown _) -> do
                    case Map.lookup $(mkPackageName "github") unknown of
                        Nothing -> error "doesn't list github as unknown"
                        Just _ -> return ()

                    {- Currently not implemented, see: https://github.com/fpco/stack/issues/159#issuecomment-107809418
                    case Map.lookup $(mkPackageName "failure") unknown of
                        Nothing -> error "failure not listed"
                        Just _ -> return ()
                    -}
                _ -> error $ "Unexpected result from resolveBuildPlan: " ++ show eres
            return ()

    describe "shadowMiniBuildPlan" $ do
        let version = $(mkVersion "1.0.0") -- unimportant for this test
            pn = either throw id . parsePackageNameFromString
            mkMPI deps = MiniPackageInfo
                { mpiVersion = version
                , mpiFlags = Map.empty
                , mpiGhcOptions = []
                , mpiPackageDeps = Set.fromList $ map pn $ words deps
                , mpiToolDeps = Set.empty
                , mpiExes = Set.empty
                , mpiHasLibrary = True
                , mpiGitSHA1 = Nothing
                }
            go x y = (pn x, mkMPI y)
            resourcet = go "resourcet" ""
            conduit = go "conduit" "resourcet"
            conduitExtra = go "conduit-extra" "conduit"
            text = go "text" ""
            attoparsec = go "attoparsec" "text"
            aeson = go "aeson" "text attoparsec"
            mkMBP pkgs = MiniBuildPlan
                { mbpCompilerVersion = GhcVersion version
                , mbpPackages = Map.fromList pkgs
                }
            mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson]
            test name input shadowed output extra =
                it name $ const $
                    shadowMiniBuildPlan input (Set.fromList $ map pn $ words shadowed)
                    `shouldBe` (output, Map.fromList extra)
        test "no shadowing" mbpAll "" mbpAll []
        test "shadow something that isn't there" mbpAll "does-not-exist" mbpAll []
        test "shadow a leaf" mbpAll "conduit-extra"
                (mkMBP [resourcet, conduit, text, attoparsec, aeson])
                []
        test "shadow direct dep" mbpAll "conduit"
                (mkMBP [resourcet, text, attoparsec, aeson])
                [conduitExtra]
        test "shadow deep dep" mbpAll "resourcet"
                (mkMBP [text, attoparsec, aeson])
                [conduit, conduitExtra]
        test "shadow deep dep and leaf" mbpAll "resourcet aeson"
                (mkMBP [text, attoparsec])
                [conduit, conduitExtra]
        test "shadow deep dep and direct dep" mbpAll "resourcet conduit"
                (mkMBP [text, attoparsec, aeson])
                [conduitExtra]