Horribly messy BuildPlan

Stackage2/BuildPlan.hs

@@ -0,0 +1,302 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | Representation of a concrete build plan, and how to generate a new one
+-- based on constraints.
+module Stackage2.BuildPlan
+    ( BuildPlan (..)
+    , PackageBuild (..)
+    , newBuildPlan
+    ) where
+
+import Distribution.Package            (Dependency (..))
+import Distribution.PackageDescription
+import Distribution.Version            (withinRange, intersectVersionRanges)
+import Stackage2.CorePackages
+import Stackage2.PackageConstraints
+import Stackage2.PackageIndex
+import Stackage2.Prelude
+import Control.Monad.State.Strict (execState, get, put)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Aeson
+
+data BuildPlan desc = BuildPlan
+    { bpCore        :: Map PackageName Version
+    , bpTools       :: Vector (PackageName, Version)
+    , bpExtra       :: Map PackageName (PackageBuild desc)
+    , bpGlobalFlags :: Map FlagName Bool
+    }
+    deriving (Functor, Foldable, Traversable, Show, Eq)
+type instance Element (BuildPlan desc) = desc
+instance MonoFunctor (BuildPlan desc)
+instance MonoFoldable (BuildPlan desc)
+instance MonoTraversable (BuildPlan desc)
+
+instance ToJSON (BuildPlan desc) where
+    toJSON BuildPlan {..} = object
+        [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
+        , "tools" .= map goTool bpTools
+        , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
+        , "global-flags" .= Map.mapKeysWith const (\(FlagName f) -> f) bpGlobalFlags
+        ]
+      where
+        toCore (x, y) = (asText $ display x, asText $ display y)
+        goTool (name, version) = object
+            [ "name" .= asText (display name)
+            , "version" .= asText (display version)
+            ]
+instance desc ~ () => FromJSON (BuildPlan desc) where
+    parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
+        <$> ((o .: "core") >>= goCore)
+        <*> ((o .: "tools") >>= mapM goTool)
+        <*> (goExtra <$> (o .: "extra"))
+        <*> (goFlags <$> (o .: "global-flags"))
+      where
+        goCore =
+            fmap mapFromList . mapM goCore' . mapToList . asHashMap
+          where
+            goCore' (k, v) = do
+                k' <- either (fail . show) return $ simpleParse $ asText k
+                v' <- either (fail . show) return $ simpleParse $ asText v
+                return (k', v')
+
+        goTool = withObject "Tool" $ \o -> (,)
+            <$> ((o .: "name") >>=
+                either (fail . show) return . simpleParse . asText)
+            <*> ((o .: "version") >>=
+                either (fail . show) return . simpleParse . asText)
+
+        goExtra = Map.mapKeysWith const PackageName
+        goFlags = Map.mapKeysWith const FlagName
+
+data PackageBuild desc = PackageBuild
+    { pbVersion           :: Version
+    , pbMaintainer        :: Maybe Maintainer
+    , pbUsers             :: Set PackageName
+    , pbFlags             :: Map FlagName Bool
+    , pbTestState         :: TestState
+    , pbHaddockState      :: TestState
+    , pbTryBuildBenchmark :: Bool
+    , pbDesc              :: desc
+    }
+    deriving (Functor, Foldable, Traversable, Show, Eq)
+type instance Element (PackageBuild desc) = desc
+instance MonoFunctor (PackageBuild desc)
+instance MonoFoldable (PackageBuild desc)
+instance MonoTraversable (PackageBuild desc)
+
+instance ToJSON (PackageBuild desc) where
+    toJSON PackageBuild {..} = object $ concat
+        [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
+        ,
+            [ "version" .= asText (display pbVersion)
+            , "users" .= map unPackageName (unpack pbUsers)
+            , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
+            , "test-state" .= pbTestState
+            , "haddock-state" .= pbHaddockState
+            , "build-benchmark" .= pbTryBuildBenchmark
+            ]
+        ]
+instance desc ~ () => FromJSON (PackageBuild desc) where
+    parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
+        <$> (o .: "version" >>= efail . simpleParse . asText)
+        <*> o .:? "maintainer"
+        <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
+        <*> (toFlags <$> (o .:? "flags" .!= mempty))
+        <*> o .: "test-state"
+        <*> o .: "haddock-state"
+        <*> o .: "build-benchmark"
+        <*> pure ()
+      where
+        toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
+
+        efail = either (fail . show) return
+
+data TestState = ExpectSuccess
+               | ExpectFailure
+               | Don'tBuild -- ^ when the test suite will pull in things we don't want
+    deriving (Show, Eq, Ord, Bounded, Enum)
+
+testStateToText :: TestState -> Text
+testStateToText ExpectSuccess = "expect-success"
+testStateToText ExpectFailure = "expect-failure"
+testStateToText Don'tBuild    = "do-not-build"
+
+instance ToJSON TestState where
+    toJSON = toJSON . testStateToText
+instance FromJSON TestState where
+    parseJSON = withText "TestState" $ \t ->
+        case lookup t states of
+            Nothing -> fail $ "Invalid state: " ++ unpack t
+            Just v -> return v
+      where
+        states = asHashMap $ mapFromList
+               $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
+
+newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
+newBuildPlan = liftIO $ do
+    core <- getCorePackages
+    extraOrig <- getLatestDescriptions (isAllowed core) simplifyDesc
+    let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig
+        extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig
+    return BuildPlan
+        { bpCore = core
+        , bpTools = topologicalSort
+                  $ filter (\(x, _) -> x `member` toolNames)
+                  $ mapToList extra
+        , bpExtra = extra
+        , bpGlobalFlags = defaultGlobalFlags
+        }
+
+topologicalSort :: [(PackageName, PackageBuild FlatComponent)]
+                -> Vector (PackageName, Version)
+topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME
+
+removeUnincluded :: Set PackageName -- ^ tool names
+                 -> Map PackageName (PackageBuild FlatComponent)
+                 -> Map PackageName (PackageBuild FlatComponent)
+removeUnincluded toolNames orig =
+    mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
+  where
+    included :: Set PackageName
+    included = flip execState mempty $ do
+        mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
+        mapM_ add toolNames
+
+    add name = do
+        inc <- get
+        when (name `notMember` inc) $ do
+            put $ insertSet name inc
+            case lookup name orig of
+                Nothing -> return ()
+                Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
+
+populateUsers :: Map PackageName (PackageBuild FlatComponent)
+              -> Map PackageName (PackageBuild FlatComponent)
+populateUsers orig =
+    mapWithKey go orig
+  where
+    go name pb = pb { pbUsers = foldMap (go2 name) (mapToList orig) }
+
+    go2 dep (user, pb)
+        | dep `member` fcDeps (pbDesc pb) = singletonSet user
+        | otherwise = mempty
+
+data SimpleTree = SimpleTree
+    { stDeps :: Map PackageName VersionRange
+    , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]
+    , stExtra :: SimpleExtra
+    }
+    deriving Show
+instance Monoid SimpleTree where
+    mempty = SimpleTree mempty mempty mempty
+    mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree
+        (unionWith intersectVersionRanges a x)
+        (b ++ y)
+        (c ++ z)
+
+data SimpleExtra = SimpleExtra
+    { seTools :: Map PackageName VersionRange
+    }
+    deriving Show
+instance Monoid SimpleExtra where
+    mempty = SimpleExtra mempty
+    mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra
+        (unionWith intersectVersionRanges a x)
+
+getSimpleTrees :: Bool -- ^ include test suites?
+               -> Bool -- ^ include benchmarks?
+               -> GenericPackageDescription
+               -> [SimpleTree]
+getSimpleTrees includeTests includeBench gpd = concat
+    [ maybe [] (return . go libBuildInfo) $ condLibrary gpd
+    , map (go buildInfo . snd) $ condExecutables gpd
+    , if includeTests
+        then map (go testBuildInfo . snd) $ condTestSuites gpd
+        else []
+    , if includeBench
+        then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd
+        else []
+    ]
+  where
+    go getExtra (CondNode dat deps comps) = SimpleTree
+        { stDeps = unionsWith intersectVersionRanges
+                 $ map (\(Dependency x y) -> singletonMap x y) deps
+        , stConds = map (goComp getExtra) comps
+        , stExtra = toSimpleExtra $ getExtra dat
+        }
+
+    goComp getExtra (cond, tree1, mtree2) =
+        (cond, go getExtra tree1, go getExtra <$> mtree2)
+
+    toSimpleExtra bi = SimpleExtra
+        { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
+            $ \(Dependency name range) -> singletonMap name range
+        }
+
+data FlatComponent = FlatComponent
+    { fcDeps :: Map PackageName VersionRange
+    , fcExtra :: SimpleExtra
+    }
+    deriving Show
+instance Monoid FlatComponent where
+    mempty = FlatComponent mempty mempty
+    mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent
+        (unionWith intersectVersionRanges a x)
+        (b ++ y)
+
+flattenComponent :: SimpleTree -> FlatComponent
+flattenComponent (SimpleTree deps conds extra) =
+    mconcat $ here : map goCond conds
+  where
+    here = FlatComponent { fcDeps = deps, fcExtra = extra }
+    goCond (cond, tree1, mtree2)
+        | checkCond cond = flattenComponent tree1
+        | otherwise = maybe mempty flattenComponent mtree2
+
+checkCond :: Condition ConfVar -> Bool
+checkCond _ = False -- FIXME
+
+simplifyDesc :: GenericPackageDescription -> IO (PackageBuild FlatComponent)
+simplifyDesc gpd = do
+    return PackageBuild
+        { pbVersion = version
+        , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
+        , pbUsers = mempty -- must be filled in later
+        , pbFlags = packageFlags name
+        , pbTestState =
+            case () of
+                ()
+                    | not $ tryBuildTest name -> Don'tBuild
+                    | name `member` pcExpectedFailures defaultPackageConstraints
+                        -> ExpectFailure
+                    | otherwise -> ExpectSuccess
+        , pbHaddockState =
+            case () of
+                ()
+                    | name `member` pcExpectedFailures defaultPackageConstraints
+                        -> ExpectFailure
+                    | otherwise -> ExpectSuccess
+        , pbTryBuildBenchmark = tryBuildBenchmark name
+        , pbDesc = foldMap flattenComponent $ getSimpleTrees
+            (tryBuildTest name)
+            (tryBuildBenchmark name)
+            gpd
+        }
+  where
+    PackageIdentifier name version = package $ packageDescription gpd
+
+isAllowed :: Map PackageName Version -- ^ core
+          -> PackageName -> Version -> Bool
+isAllowed core = \name version ->
+    case lookup name core of
+        Just _ -> False -- never reinstall a core package
+        Nothing ->
+            case lookup name $ pcPackages defaultPackageConstraints of
+                Nothing -> True -- no constraints
+                Just (range, _) -> withinRange version range

Stackage2/PackageConstraints.hs

@@ -1,14 +1,23 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
 -- | The constraints on package selection for a new build plan.
 module Stackage2.PackageConstraints
     ( PackageConstraints (..)
     , defaultPackageConstraints
+    , defaultGlobalFlags
+    , packageFlags
+    , tryBuildTest
+    , tryBuildBenchmark
     ) where
 
 import           Stackage2.Prelude
 import qualified Stackage.Config as Old
 import qualified Stackage.Types  as Old
+import qualified Stackage.Select as Old
+
+-- FIXME have the defaults here live in IO to make sure we don't have any
+-- global state floating around. Will make it easier to test.
 
 data PackageConstraints = PackageConstraints
     { pcPackages :: Map PackageName (VersionRange, Maintainer)
@@ -26,5 +35,23 @@ defaultPackageConstraints = PackageConstraints
                <$> Old.defaultStablePackages ghcVer False
     , pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
     }
-  where
+
-    ghcVer = Old.GhcMajorVersion 7 8
+ghcVer :: Old.GhcMajorVersion
+ghcVer = Old.GhcMajorVersion 7 8
+
+oldSettings :: Old.SelectSettings
+oldSettings = Old.defaultSelectSettings ghcVer False
+
+defaultGlobalFlags :: Map FlagName Bool
+defaultGlobalFlags = mapFromList $
+    map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
+    map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
+
+packageFlags :: PackageName -> Map FlagName Bool
+packageFlags _ = mempty
+
+tryBuildTest :: PackageName -> Bool
+tryBuildTest = (`member` Old.skippedTests oldSettings)
+
+tryBuildBenchmark :: PackageName -> Bool
+tryBuildBenchmark _ = True

Stackage2/PackageIndex.hs

@@ -112,12 +112,11 @@ instance Exception CabalParseException
 -- given criterion.
 getLatestDescriptions :: MonadIO m
                       => (PackageName -> Version -> Bool)
-                      -> m (Map PackageName (Version, GenericPackageDescription))
+                      -> (GenericPackageDescription -> IO desc)
-getLatestDescriptions f = liftIO $ do
+                      -> m (Map PackageName desc)
+getLatestDescriptions f parseDesc = liftIO $ do
     m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
-    forM m $ \ucf -> do
+    forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc
-        gpd <- ucfParse ucf
-        return (ucfVersion ucf, gpd)
   where
     f' ucf = f (ucfName ucf) (ucfVersion ucf)
     add m ucf =

Stackage2/Prelude.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Stackage2.Prelude
     ( module X
     , module Stackage2.Prelude
@@ -12,9 +13,11 @@ import           Data.Conduit.Process  as X
 import           Data.Typeable         (TypeRep, typeOf)
 import           Distribution.Package  as X (PackageIdentifier (..),
                                              PackageName (PackageName))
+import           Distribution.PackageDescription  as X (FlagName (..), GenericPackageDescription)
 import qualified Distribution.Text     as DT
 import           Distribution.Version  as X (Version (..), VersionRange)
 import           System.Exit           (ExitCode (ExitSuccess))
+import Data.Aeson (ToJSON, FromJSON)
 
 unPackageName :: PackageName -> Text
 unPackageName (PackageName str) = pack str
@@ -74,3 +77,4 @@ withCheckedProcess cp f = do
     return res
 
 newtype Maintainer = Maintainer { unMaintainer :: Text }
+    deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)

stackage.cabal

@@ -35,6 +35,7 @@ library
                        Stackage2.PackageConstraints
                        Stackage2.CorePackages
                        Stackage2.PackageIndex
+                       Stackage2.BuildPlan
   build-depends:       base >= 4 && < 5
                      , containers
                      , Cabal >= 1.14
@@ -53,6 +54,8 @@ library
                      , classy-prelude-conduit
                      , text
                      , system-fileio
+                     , mtl
+                     , aeson
 
 executable stackage
   default-language:    Haskell2010
@@ -69,12 +72,15 @@ test-suite spec
   main-is:             Spec.hs
   other-modules:       Stackage2.CorePackagesSpec
                        Stackage2.PackageIndexSpec
+                       Stackage2.BuildPlanSpec
   build-depends:       base
                      , stackage
                      , hspec
                      , QuickCheck
                      , text
                      , classy-prelude-conduit
+                     , Cabal
+                     , yaml
 
 source-repository head
   type:     git

test/Stackage2/BuildPlanSpec.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
+module Stackage2.BuildPlanSpec (spec) where
+
+import Stackage2.BuildPlan
+import Stackage2.Prelude
+import Test.Hspec
+import qualified Data.Yaml as Y
+import Control.Exception (evaluate)
+
+spec :: Spec
+spec = it "works" $ do
+    bp <- newBuildPlan
+    let bs = Y.encode bp
+        mbp' = Y.decode bs
+    mbp' `shouldBe` Just (() <$ bp)

test/Stackage2/PackageIndexSpec.hs

@@ -4,6 +4,7 @@ module Stackage2.PackageIndexSpec (spec) where
 import Stackage2.PackageIndex
 import Stackage2.Prelude
 import Test.Hspec
+import Distribution.Package (packageId, pkgVersion)
 
 spec :: Spec
 spec = do
@@ -13,8 +14,8 @@ spec = do
                 [ (asText "base", asText "4.5.0.0")
                 , ("does-not-exist", "9999999999999999999")
                 ])
-        m <- getLatestDescriptions f
+        m <- getLatestDescriptions f return
         length m `shouldBe` 1
         p <- simpleParse $ asText "base"
         v <- simpleParse $ asText "4.5.0.0"
-        (fst <$> m) `shouldBe` singletonMap p v
+        (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v