git.iko.soy/stackage
on 4e156eb help sign in
stackage/Stackage/PackageDescription.hs
200 lines 7.4 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFoldable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE NoImplicitPrelude #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RecordWildCards #-}
9{-# LANGUAGE TypeFamilies #-}
10-- | Manipulate @GenericPackageDescription@ from Cabal into something more
11-- useful for us.
12module Stackage.PackageDescription
13 ( SimpleDesc (..)
14 , toSimpleDesc
15 , CheckCond (..)
16 , Component (..)
17 , DepInfo (..)
18 ) where
20import Control.Monad.Writer.Strict (MonadWriter, execWriterT,
21 tell)
22import Data.Aeson
23import qualified Data.Map as Map
24import Distribution.Compiler (CompilerFlavor)
25import Distribution.Package (Dependency (..))
26import Distribution.PackageDescription
27import Distribution.System (Arch, OS)
28import Stackage.Prelude
30data Component = CompLibrary
31 | CompExecutable
32 | CompTestSuite
33 | CompBenchmark
34 deriving (Show, Read, Eq, Ord, Enum, Bounded)
36compToText :: Component -> Text
37compToText CompLibrary = "library"
38compToText CompExecutable = "executable"
39compToText CompTestSuite = "test-suite"
40compToText CompBenchmark = "benchmark"
42instance ToJSON Component where
43 toJSON = toJSON . compToText
44instance FromJSON Component where
45 parseJSON = withText "Component" $ \t -> maybe
46 (fail $ "Invalid component: " ++ unpack t)
47 return
48 (lookup t comps)
49 where
50 comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound]
52data DepInfo = DepInfo
53 { diComponents :: Set Component
54 , diRange :: VersionRange
55 }
56 deriving (Show, Eq)
58instance Semigroup DepInfo where
59 DepInfo a x <> DepInfo b y = DepInfo
60 (a <> b)
61 (intersectVersionRanges x y)
62instance ToJSON DepInfo where
63 toJSON DepInfo {..} = object
64 [ "components" .= diComponents
65 , "range" .= display diRange
66 ]
67instance FromJSON DepInfo where
68 parseJSON = withObject "DepInfo" $ \o -> do
69 diComponents <- o .: "components"
70 diRange <- o .: "range" >>= either (fail . show) return . simpleParse
71 return DepInfo {..}
73-- | A simplified package description that tracks:
74--
75-- * Package dependencies
76--
77-- * Build tool dependencies
78--
79-- * Provided executables
80--
81-- It has fully resolved all conditionals
82data SimpleDesc = SimpleDesc
83 { sdPackages :: Map PackageName DepInfo
84 , sdTools :: Map ExeName DepInfo
85 , sdProvidedExes :: Set ExeName
86 , sdModules :: Set Text
87 -- ^ modules exported by the library
88 }
89 deriving (Show, Eq)
90instance Monoid SimpleDesc where
91 mempty = SimpleDesc mempty mempty mempty mempty
92 mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc
93 (unionWith (<>) a w)
94 (unionWith (<>) b x)
95 (c ++ y)
96 (d ++ z)
97instance ToJSON SimpleDesc where
98 toJSON SimpleDesc {..} = object
99 [ "packages" .= Map.mapKeysWith const unPackageName sdPackages
100 , "tools" .= Map.mapKeysWith const unExeName sdTools
101 , "provided-exes" .= sdProvidedExes
102 , "modules" .= sdModules
103 ]
104instance FromJSON SimpleDesc where
105 parseJSON = withObject "SimpleDesc" $ \o -> do
106 sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
107 sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools")
108 sdProvidedExes <- o .: "provided-exes"
109 sdModules <- o .: "modules"
110 return SimpleDesc {..}
112-- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the
113-- constraints in the provided 'CheckCond'.
114toSimpleDesc :: MonadThrow m
115 => CheckCond
116 -> GenericPackageDescription
117 -> m SimpleDesc
118toSimpleDesc cc gpd = execWriterT $ do
119 forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo getModules
120 forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo noModules . snd
121 tell mempty { sdProvidedExes = setFromList
122 $ map (fromString . fst)
123 $ condExecutables gpd
124 }
125 when (ccIncludeTests cc) $ forM_ (condTestSuites gpd)
126 $ tellTree cc CompTestSuite testBuildInfo noModules . snd
127 when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd)
128 $ tellTree cc CompBenchmark benchmarkBuildInfo noModules . snd
129 where
130 noModules = const mempty
131 getModules = setFromList . map display . exposedModules
133-- | Convert a single CondTree to a 'SimpleDesc'.
134tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)
135 => CheckCond
136 -> Component
137 -> (a -> BuildInfo)
138 -> (a -> Set Text) -- ^ get module names
139 -> CondTree ConfVar [Dependency] a
140 -> m ()
141tellTree cc component getBI getModules =
142 loop
143 where
144 loop (CondNode dat deps comps) = do
145 tell mempty
146 { sdPackages = unionsWith (<>) $ flip map deps
147 $ \(Dependency x y) -> singletonMap x DepInfo
148 { diComponents = singletonSet component
149 , diRange = simplifyVersionRange y
150 }
151 , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat)
152 $ \(Dependency name range) -> singletonMap
153 -- In practice, cabal files refer to the exe name, not the
154 -- package name.
155 (ExeName $ unPackageName name)
156 DepInfo
157 { diComponents = singletonSet component
158 , diRange = simplifyVersionRange range
159 }
160 , sdModules = getModules dat
161 }
162 forM_ comps $ \(cond, ontrue, onfalse) -> do
163 b <- checkCond cc cond
164 if b
165 then loop ontrue
166 else maybe (return ()) loop onfalse
168-- | Resolve a condition to a boolean based on the provided 'CheckCond'.
169checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool
170checkCond CheckCond {..} cond0 =
171 go cond0
172 where
173 go (Var (OS os)) = return $ os == ccOS
174 go (Var (Arch arch)) = return $ arch == ccArch
175 go (Var (Flag flag)) =
176 case lookup flag ccFlags of
177 Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0
178 Just b -> return b
179 go (Var (Impl flavor range)) = return
180 $ flavor == ccCompilerFlavor
181 && ccCompilerVersion `withinRange` range
182 go (Lit b) = return b
183 go (CNot c) = not `liftM` go c
184 go (CAnd x y) = (&&) `liftM` go x `ap` go y
185 go (COr x y) = (||) `liftM` go x `ap` go y
187data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar)
188 deriving (Show, Typeable)
189instance Exception CheckCondException
191data CheckCond = CheckCond
192 { ccPackageName :: PackageName -- for debugging only
193 , ccOS :: OS
194 , ccArch :: Arch
195 , ccFlags :: Map FlagName Bool
196 , ccCompilerFlavor :: CompilerFlavor
197 , ccCompilerVersion :: Version
198 , ccIncludeTests :: Bool
199 , ccIncludeBenchmarks :: Bool
200 }