@@ -1,4 +1,5 @@
11{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE RecordWildCards #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE DeriveFunctor #-}
@@ -11,6 +12,7 @@ module Stackage2.PackageDescription
1112 ( FlatComponent (..)
1213 , getFlattenedComponent
1314 , SimpleExtra (..)
15+ , CheckCond (..)
1416 ) where
1517
1618import Distribution.Package (Dependency (..))
@@ -25,6 +27,8 @@ import Control.Monad.State.Strict (execState, get, put)
2527import qualified Data.Map as Map
2628import qualified Data.Set as Set
2729import Data.Aeson
30+import Distribution.System (OS, Arch)
31+import Distribution.Compiler (CompilerFlavor)
2832
2933data SimpleTree = SimpleTree
3034 { stDeps :: Map PackageName VersionRange
@@ -51,12 +55,16 @@ instance Monoid SimpleExtra where
5155 (b ++ y)
5256
5357getFlattenedComponent
54− :: Bool -- ^ include test suites?
58+ :: MonadThrow m
59+ => CheckCond
60+ -> Bool -- ^ include test suites?
5561 -> Bool -- ^ include benchmarks?
5662 -> GenericPackageDescription
57− -> FlatComponent
58−getFlattenedComponent includeTests includeBench gpd =
59− foldMap flattenComponent $ getSimpleTrees includeTests includeBench gpd
63+ -> m FlatComponent
64+getFlattenedComponent checkCond' includeTests includeBench gpd =
65+ liftM fold
66+ $ mapM (flattenComponent checkCond')
67+ $ getSimpleTrees includeTests includeBench gpd
6068
6169getSimpleTrees :: Bool -- ^ include test suites?
6270 -> Bool -- ^ include benchmarks?
@@ -103,14 +111,45 @@ instance Monoid FlatComponent where
103111 (unionWith intersectVersionRanges a x)
104112 (b ++ y)
105113
106−flattenComponent :: SimpleTree -> FlatComponent
107−flattenComponent (SimpleTree deps conds extra) =
108− mconcat $ here : map goCond conds
114+flattenComponent :: MonadThrow m => CheckCond -> SimpleTree -> m FlatComponent
115+flattenComponent checkCond' (SimpleTree deps conds extra) = do
116+ conds' <- mapM goCond conds
117+ return $ mconcat $ here : conds'
109118 where
110119 here = FlatComponent { fcDeps = deps, fcExtra = extra }
111− goCond (cond, tree1, mtree2)
112− | checkCond cond = flattenComponent tree1
113− | otherwise = maybe mempty flattenComponent mtree2
120+ goCond (cond, tree1, mtree2) = do
121+ b <- checkCond checkCond' cond
122+ if b
123+ then flattenComponent checkCond' tree1
124+ else maybe (return mempty) (flattenComponent checkCond') mtree2
114125
115−checkCond :: Condition ConfVar -> Bool
116−checkCond _ = False -- FIXME
126+checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool
127+checkCond CheckCond {..} cond0 =
128+ go cond0
129+ where
130+ go (Var (OS os)) = return $ os == ccOS
131+ go (Var (Arch arch)) = return $ arch == ccArch
132+ go (Var (Flag flag)) =
133+ case lookup flag ccFlags of
134+ Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0
135+ Just b -> return b
136+ go (Var (Impl flavor range)) = return
137+ $ flavor == ccCompilerFlavor
138+ && ccCompilerVersion `withinRange` range
139+ go (Lit b) = return b
140+ go (CNot c) = not `liftM` go c
141+ go (CAnd x y) = (&&) `liftM` go x `ap` go y
142+ go (COr x y) = (||) `liftM` go x `ap` go y
143+
144+data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar)
145+ deriving (Show, Typeable)
146+instance Exception CheckCondException
147+
148+data CheckCond = CheckCond
149+ { ccPackageName :: PackageName -- for debugging only
150+ , ccOS :: OS
151+ , ccArch :: Arch
152+ , ccFlags :: Map FlagName Bool
153+ , ccCompilerFlavor :: CompilerFlavor
154+ , ccCompilerVersion :: Version
155+ }