git.iko.soy/stackage
on 78e4802 help sign in
stackage/Stackage2/CheckBuildPlan.hs
78 lines 2.8 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6-- | Confirm that a build plan has a consistent set of dependencies.
7module Stackage2.CheckBuildPlan
8 ( checkBuildPlan
9 ) where
11import Stackage2.Prelude
12import Stackage2.BuildPlan
13import Stackage2.PackageDescription
14import Control.Monad.Writer.Strict (execWriter, Writer, tell)
15import Distribution.Version (intersectVersionRanges, withinRange)
17checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
18checkBuildPlan BuildPlan {..}
19 | null errs' = return ()
20 | otherwise = throwM errs
21 where
22 allPackages = bpCore ++ map pbVersion bpExtra
23 errs@(BadBuildPlan errs') =
24 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
26checkDeps :: Map PackageName Version
27 -> (PackageName, PackageBuild FlatComponent)
28 -> Writer BadBuildPlan ()
29checkDeps allPackages (user, pb) =
30 mapM_ go $ mapToList $ fcDeps $ pbDesc pb
31 where
32 go (dep, range) =
33 case lookup dep allPackages of
34 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
35 Just version
36 | version `withinRange` range -> return ()
37 | otherwise -> tell $ BadBuildPlan $ singletonMap
38 (dep, Just version)
39 errMap
40 where
41 errMap = singletonMap (user, pbVersion pb) range
43newtype BadBuildPlan =
44 BadBuildPlan (Map (PackageName, Maybe Version) (Map (PackageName, Version) VersionRange)) -- FIXME add maintainer and Github ping info
45 deriving Typeable
46instance Exception BadBuildPlan
47instance Show BadBuildPlan where
48 show (BadBuildPlan errs) =
49 concatMap go $ mapToList errs
50 where
51 go ((dep, mdepVer), users) = unlines
52 $ showDepVer dep mdepVer
53 : map showUser (mapToList users)
55 showDepVer :: PackageName -> Maybe Version -> String
56 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
57 showDepVer dep (Just version) = concat
58 [ display dep
59 , "-"
60 , display version
61 , " depended on by:"
62 ]
64 showUser :: ((PackageName, Version), VersionRange) -> String
65 showUser ((user, version), range) = concat
66 [ "- "
67 , display user
68 , "-"
69 , display version
70 , " ("
71 , display range
72 , ")"
73 ]
75instance Monoid BadBuildPlan where
76 mempty = BadBuildPlan mempty
77 mappend (BadBuildPlan x) (BadBuildPlan y) =
78 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y