git.iko.soy/stackage
on 5cb4f05 help sign in
stackage/Stackage/CheckBuildPlan.hs
117 lines 4.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ViewPatterns #-}
7-- | Confirm that a build plan has a consistent set of dependencies.
8module Stackage.CheckBuildPlan
9 ( checkBuildPlan
10 , BadBuildPlan
11 ) where
13import Control.Monad.Writer.Strict (Writer, execWriter, tell)
14import qualified Data.Text as T
15import Stackage.BuildConstraints
16import Stackage.BuildPlan
17import Stackage.PackageDescription
18import Stackage.Prelude
20-- FIXME check cycles in dependencies, only looking at libraries and
21-- executables
23-- | Check the build plan for missing deps, wrong versions, etc.
24checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
25checkBuildPlan BuildPlan {..}
26 | null errs' = return ()
27 | otherwise = throwM errs
28 where
29 allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
30 errs@(BadBuildPlan errs') =
31 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
33-- | For a given package name and plan, check that its dependencies are:
34--
35-- 1. Existent (existing in the provided package map)
36-- 2. Within version range
37checkDeps :: Map PackageName Version
38 -> (PackageName, PackagePlan)
39 -> Writer BadBuildPlan ()
40checkDeps allPackages (user, pb) =
41 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
42 where
43 go (dep, diRange -> range) =
44 case lookup dep allPackages of
45 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
46 Just version
47 | version `withinRange` range -> return ()
48 | otherwise -> tell $ BadBuildPlan $ singletonMap
49 (dep, Just version)
50 errMap
51 where
52 errMap = singletonMap pu range
53 pu = PkgUser
54 { puName = user
55 , puVersion = ppVersion pb
56 , puMaintainer = pcMaintainer $ ppConstraints pb
57 , puGithubPings = ppGithubPings pb
58 }
60data PkgUser = PkgUser
61 { puName :: PackageName
62 , puVersion :: Version
63 , puMaintainer :: Maybe Maintainer
64 , puGithubPings :: Set Text
65 }
66 deriving (Eq, Ord)
68pkgUserShow1 :: PkgUser -> Text
69pkgUserShow1 PkgUser {..} = concat
70 [ display puName
71 , "-"
72 , display puVersion
73 ]
75pkgUserShow2 :: PkgUser -> Text
76pkgUserShow2 PkgUser {..} = unwords
77 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
78 : map (cons '@') (setToList puGithubPings)
80newtype BadBuildPlan =
81 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
82 deriving Typeable
83instance Exception BadBuildPlan
84instance Show BadBuildPlan where
85 show (BadBuildPlan errs) =
86 unpack $ concatMap go $ mapToList errs
87 where
88 go ((dep, mdepVer), users) = unlines
89 $ ""
90 : showDepVer dep mdepVer
91 : map showUser (mapToList users)
93 showDepVer :: PackageName -> Maybe Version -> Text
94 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
95 showDepVer dep (Just version) = concat
96 [ display dep
97 , "-"
98 , display version
99 , " depended on by:"
100 ]
102 showUser :: (PkgUser, VersionRange) -> Text
103 showUser (pu, range) = concat
104 [ "- "
105 , pkgUserShow1 pu
106 , " ("
107 -- add a space after < to avoid confusing Markdown processors (like
108 -- Github's issue tracker)
109 , T.replace "<" "< " $ display range
110 , "). "
111 , pkgUserShow2 pu
112 ]
114instance Monoid BadBuildPlan where
115 mempty = BadBuildPlan mempty
116 mappend (BadBuildPlan x) (BadBuildPlan y) =
117 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y