git.iko.soy/stackage
on 7eac8e2 help sign in
stackage/Stackage/BuildPlan.hs
186 lines 6.4 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4module Stackage.BuildPlan
5 ( readBuildPlan
6 , writeBuildPlan
7 , writeBuildPlanCsv
8 ) where
10import qualified Data.Map as Map
11import qualified Data.Set as Set
12import Distribution.Text (display, simpleParse)
13import Stackage.Types
14import qualified System.IO.UTF8
15import Data.Char (isSpace)
16import Stackage.Util
17import Data.List (intercalate)
19readBuildPlan :: FilePath -> IO BuildPlan
20readBuildPlan fp = do
21 str <- System.IO.UTF8.readFile fp
22 case fromString str of
23 Left s -> error $ "Could not read build plan: " ++ s
24 Right (x, "") -> return x
25 Right (_, _:_) -> error "Trailing content when reading build plan"
27writeBuildPlan :: FilePath -> BuildPlan -> IO ()
28writeBuildPlan fp bp = System.IO.UTF8.writeFile fp $ toString bp
30class AsString a where
31 toString :: a -> String
32 fromString :: String -> Either String (a, String)
34instance AsString BuildPlan where
35 toString BuildPlan {..} = concat
36 [ makeSection "tools" bpTools
37 , makeSection "packages" $ Map.toList bpPackages
38 , makeSection "core" $ Map.toList bpCore
39 , makeSection "optional-core" $ Map.toList bpOptionalCore
40 , makeSection "skipped-tests" $ Set.toList bpSkippedTests
41 , makeSection "expected-failures" $ Set.toList bpExpectedFailures
42 ]
43 fromString s1 = do
44 (tools, s2) <- getSection "tools" s1
45 (packages, s3) <- getSection "packages" s2
46 (core, s4) <- getSection "core" s3
47 (optionalCore, s5) <- getSection "optional-core" s4
48 (skipped, s6) <- getSection "skipped-tests" s5
49 (failures, s7) <- getSection "expected-failures" s6
50 let bp = BuildPlan
51 { bpTools = tools
52 , bpPackages = Map.fromList packages
53 , bpCore = Map.fromList core
54 , bpOptionalCore = Map.fromList optionalCore
55 , bpSkippedTests = Set.fromList skipped
56 , bpExpectedFailures = Set.fromList failures
57 }
58 return (bp, s7)
60makeSection :: AsString a => String -> [a] -> String
61makeSection title contents = unlines
62 $ ("-- BEGIN " ++ title)
63 : map toString contents
64 ++ ["-- END " ++ title, ""]
66instance AsString String where
67 toString = id
68 fromString s = Right (s, "")
70instance AsString PackageName where
71 toString (PackageName pn) = pn
72 fromString s = Right (PackageName s, "")
74instance AsString (Maybe Version) where
75 toString Nothing = ""
76 toString (Just x) = toString x
77 fromString s
78 | all isSpace s = return (Nothing, s)
79 | otherwise = do
80 (v, s') <- fromString s
81 return (Just v, s')
83instance AsString a => AsString (PackageName, a) where
84 toString (PackageName pn, s) = concat [pn, " ", toString s]
85 fromString s = do
86 (pn, rest) <- takeWord s
87 (rest', s') <- fromString rest
88 return ((PackageName pn, rest'), s')
90takeWord :: AsString a => String -> Either String (a, String)
91takeWord s =
92 case break (== ' ') s of
93 (x, _:y) -> do
94 (x', s') <- fromString x
95 if null s'
96 then Right (x', y)
97 else Left $ "Unconsumed input in takeWord call"
98 (_, []) -> Left "takeWord failed"
100instance AsString SelectedPackageInfo where
101 toString SelectedPackageInfo {..} = unwords
102 [ display spiVersion
103 , toString spiHasTests
104 , (\v -> if null v then "@" else v) $ githubMentions spiGithubUser
105 , unMaintainer spiMaintainer
106 ]
107 fromString s1 = do
108 (version, s2) <- takeWord s1
109 (hasTests, s3) <- takeWord s2
110 (gu, m) <- takeWord s3
111 Right (SelectedPackageInfo
112 { spiVersion = version
113 , spiHasTests = hasTests
114 , spiGithubUser = [gu]
115 , spiMaintainer = Maintainer m
116 }, "")
118instance AsString (Maybe String) where
119 toString Nothing = "@"
120 toString (Just x) = "@" ++ x
121 fromString "@" = Right (Nothing, "")
122 fromString ('@':rest) = Right (Just rest, "")
123 fromString x = Left $ "Invalid Github user: " ++ x
125instance AsString Bool where
126 toString True = "test"
127 toString False = "notest"
128 fromString "test" = Right (True, "")
129 fromString "notest" = Right (False, "")
130 fromString x = Left $ "Invalid test value: " ++ x
132instance AsString Version where
133 toString = display
134 fromString s =
135 case simpleParse s of
136 Nothing -> Left $ "Invalid version: " ++ s
137 Just v -> Right (v, "")
139getSection :: AsString a => String -> String -> Either String ([a], String)
140getSection title orig =
141 case lines orig of
142 [] -> Left "Unexpected EOF when looking for a section"
143 l1:ls1
144 | l1 == begin ->
145 case break (== end) ls1 of
146 (here, _:"":rest) -> do
147 here' <- mapM fromString' here
148 Right (here', unlines rest)
149 (_, _) -> Left $ "Could not find section end: " ++ title
150 | otherwise -> Left $ "Could not find section start: " ++ title
151 where
152 begin = "-- BEGIN " ++ title
153 end = "-- END " ++ title
155 fromString' x = do
156 (y, z) <- fromString x
157 if null z
158 then return y
159 else Left $ "Unconsumed input on line: " ++ x
161-- | Used for Hackage distribution purposes.
162writeBuildPlanCsv :: FilePath -> BuildPlan -> IO ()
163writeBuildPlanCsv fp bp =
164 -- Obviously a proper CSV library should be used... but we're minimizing
165 -- deps
166 System.IO.UTF8.writeFile fp $ unlines' $ map toRow $ Map.toList fullMap
167 where
168 -- Hackage server is buggy, and won't accept trailing newlines. See:
169 -- https://github.com/haskell/hackage-server/issues/141#issuecomment-34615935
170 unlines' = intercalate "\n"
172 fullMap = Map.unions
173 [ fmap spiVersion $ bpPackages bp
174 , Map.mapMaybe id $ bpCore bp
175 , bpOptionalCore bp
176 ]
178 toRow (PackageName name, version) = concat
179 [ "\""
180 , name
181 , "\",\""
182 , display version
183 , "\",\"http://www.stackage.org/package/"
184 , name
185 , "\""
186 ]