git.iko.soy/stackage
on fe1df29 help sign in
stackage/Stackage2/CheckBuildPlan.hs
77 lines 2.7 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)
16checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m ()
17checkBuildPlan BuildPlan {..}
18 | null errs' = return ()
19 | otherwise = throwM errs
20 where
21 allPackages = bpCore ++ map pbVersion bpExtra
22 errs@(BadBuildPlan errs') =
23 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpExtra
25checkDeps :: Map PackageName Version
26 -> (PackageName, PackageBuild FlatComponent)
27 -> Writer BadBuildPlan ()
28checkDeps allPackages (user, pb) =
29 mapM_ go $ mapToList $ fcDeps $ pbDesc pb
30 where
31 go (dep, range) =
32 case lookup dep allPackages of
33 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
34 Just version
35 | version `withinRange` range -> return ()
36 | otherwise -> tell $ BadBuildPlan $ singletonMap
37 (dep, Just version)
38 errMap
39 where
40 errMap = singletonMap (user, pbVersion pb) range
42newtype BadBuildPlan =
43 BadBuildPlan (Map (PackageName, Maybe Version) (Map (PackageName, Version) VersionRange)) -- FIXME add maintainer and Github ping info
44 deriving Typeable
45instance Exception BadBuildPlan
46instance Show BadBuildPlan where
47 show (BadBuildPlan errs) =
48 concatMap go $ mapToList errs
49 where
50 go ((dep, mdepVer), users) = unlines
51 $ showDepVer dep mdepVer
52 : map showUser (mapToList users)
54 showDepVer :: PackageName -> Maybe Version -> String
55 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
56 showDepVer dep (Just version) = concat
57 [ display dep
58 , "-"
59 , display version
60 , " depended on by:"
61 ]
63 showUser :: ((PackageName, Version), VersionRange) -> String
64 showUser ((user, version), range) = concat
65 [ "- "
66 , display user
67 , "-"
68 , display version
69 , " ("
70 , display range
71 , ")"
72 ]
74instance Monoid BadBuildPlan where
75 mempty = BadBuildPlan mempty
76 mappend (BadBuildPlan x) (BadBuildPlan y) =
77 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y