Proper conditional tracking

Stackage2/BuildPlan.hs

@@ -28,6 +28,8 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Aeson
 import Stackage2.PackageDescription
+import qualified Distribution.System
+import qualified Distribution.Compiler
 
 data BuildPlan desc = BuildPlan
     { bpCore        :: Map PackageName Version
@@ -251,10 +253,25 @@ isAllowed core = \name version ->
                 Nothing -> True -- no constraints
                 Just (range, _) -> withinRange version range
 
-mkPackageBuild :: Monad m
+mkPackageBuild :: MonadThrow m
                => GenericPackageDescription
                -> m (PackageBuild FlatComponent)
-mkPackageBuild gpd =
+mkPackageBuild gpd = do
+    let overrides = packageFlags name ++ defaultGlobalFlags
+        getFlag MkFlag {..} =
+            (flagName, fromMaybe flagDefault $ lookup flagName overrides)
+    desc <- getFlattenedComponent
+        CheckCond
+            { ccPackageName = name
+            , ccOS = Distribution.System.Linux
+            , ccArch = Distribution.System.X86_64
+            , ccCompilerFlavor = Distribution.Compiler.GHC
+            , ccCompilerVersion = ghcVerCabal
+            , ccFlags = mapFromList $ map getFlag $ genPackageFlags gpd
+            }
+        (tryBuildTest name)
+        (tryBuildBenchmark name)
+        gpd
     return PackageBuild
         { pbVersion = version
         , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
@@ -275,10 +292,7 @@ mkPackageBuild gpd =
                         -> ExpectFailure
                     | otherwise -> ExpectSuccess
         , pbTryBuildBenchmark = tryBuildBenchmark name
-        , pbDesc = getFlattenedComponent
+        , pbDesc = desc
-            (tryBuildTest name)
-            (tryBuildBenchmark name)
-            gpd
         }
   where
     PackageIdentifier name version = package $ packageDescription gpd

Stackage2/PackageConstraints.hs

@@ -9,6 +9,7 @@ module Stackage2.PackageConstraints
     , packageFlags
     , tryBuildTest
     , tryBuildBenchmark
+    , ghcVerCabal
     ) where
 
 import           Stackage2.Prelude
@@ -36,9 +37,14 @@ defaultPackageConstraints = PackageConstraints
     , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
     }
 
+-- FIXME below here shouldn't be so hard-coded
+
 ghcVer :: Old.GhcMajorVersion
 ghcVer = Old.GhcMajorVersion 7 8
 
+ghcVerCabal :: Version
+ghcVerCabal = Version [7, 8, 3] []
+
 oldSettings :: Old.SelectSettings
 oldSettings = Old.defaultSelectSettings ghcVer False
 

Stackage2/PackageDescription.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveFunctor #-}
@@ -11,6 +12,7 @@ module Stackage2.PackageDescription
     ( FlatComponent (..)
     , getFlattenedComponent
     , SimpleExtra (..)
+    , CheckCond (..)
     ) where
 
 import Distribution.Package            (Dependency (..))
@@ -25,6 +27,8 @@ import Control.Monad.State.Strict (execState, get, put)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Aeson
+import Distribution.System (OS, Arch)
+import Distribution.Compiler (CompilerFlavor)
 
 data SimpleTree = SimpleTree
     { stDeps :: Map PackageName VersionRange
@@ -51,12 +55,16 @@ instance Monoid SimpleExtra where
         (b ++ y)
 
 getFlattenedComponent
-    :: Bool -- ^ include test suites?
+    :: MonadThrow m
+    => CheckCond
+    -> Bool -- ^ include test suites?
     -> Bool -- ^ include benchmarks?
     -> GenericPackageDescription
-    -> FlatComponent
+    -> m FlatComponent
-getFlattenedComponent includeTests includeBench gpd =
+getFlattenedComponent checkCond' includeTests includeBench gpd =
-    foldMap flattenComponent $ getSimpleTrees includeTests includeBench gpd
+    liftM fold
+        $ mapM (flattenComponent checkCond')
+        $ getSimpleTrees includeTests includeBench gpd
 
 getSimpleTrees :: Bool -- ^ include test suites?
                -> Bool -- ^ include benchmarks?
@@ -103,14 +111,45 @@ instance Monoid FlatComponent where
         (unionWith intersectVersionRanges a x)
         (b ++ y)
 
-flattenComponent :: SimpleTree -> FlatComponent
+flattenComponent :: MonadThrow m => CheckCond -> SimpleTree -> m FlatComponent
-flattenComponent (SimpleTree deps conds extra) =
+flattenComponent checkCond' (SimpleTree deps conds extra) = do
-    mconcat $ here : map goCond conds
+    conds' <- mapM goCond conds
+    return $ mconcat $ here : conds'
   where
     here = FlatComponent { fcDeps = deps, fcExtra = extra }
-    goCond (cond, tree1, mtree2)
+    goCond (cond, tree1, mtree2) = do
-        | checkCond cond = flattenComponent tree1
+        b <- checkCond checkCond' cond
-        | otherwise = maybe mempty flattenComponent mtree2
+        if b
+            then flattenComponent checkCond' tree1
+            else maybe (return mempty) (flattenComponent checkCond') mtree2
 
-checkCond :: Condition ConfVar -> Bool
+checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool
-checkCond _ = False -- FIXME
+checkCond CheckCond {..} cond0 =
+    go cond0
+  where
+    go (Var (OS os)) = return $ os == ccOS
+    go (Var (Arch arch)) = return $ arch == ccArch
+    go (Var (Flag flag)) =
+        case lookup flag ccFlags of
+            Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0
+            Just b -> return b
+    go (Var (Impl flavor range)) = return
+                                 $ flavor == ccCompilerFlavor
+                                && ccCompilerVersion `withinRange` range
+    go (Lit b) = return b
+    go (CNot c) = not `liftM` go c
+    go (CAnd x y) = (&&) `liftM` go x `ap` go y
+    go (COr x y) = (||) `liftM` go x `ap` go y
+
+data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar)
+    deriving (Show, Typeable)
+instance Exception CheckCondException
+
+data CheckCond = CheckCond
+    { ccPackageName :: PackageName -- for debugging only
+    , ccOS :: OS
+    , ccArch :: Arch
+    , ccFlags :: Map FlagName Bool
+    , ccCompilerFlavor :: CompilerFlavor
+    , ccCompilerVersion :: Version
+    }