git.iko.soy/stackage
on 77fa7fa help sign in
stackage/Stackage/BuildPlan.hs
157 lines 5.4 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4module Stackage.BuildPlan
5 ( readBuildPlan
6 , writeBuildPlan
7 ) where
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Distribution.Text (display, simpleParse)
12import Stackage.Types
13import qualified System.IO.UTF8
14import Data.Char (isSpace)
15import Stackage.Util
17readBuildPlan :: FilePath -> IO BuildPlan
18readBuildPlan fp = do
19 str <- System.IO.UTF8.readFile fp
20 case fromString str of
21 Left s -> error $ "Could not read build plan: " ++ s
22 Right (x, "") -> return x
23 Right (_, _:_) -> error "Trailing content when reading build plan"
25writeBuildPlan :: FilePath -> BuildPlan -> IO ()
26writeBuildPlan fp bp = System.IO.UTF8.writeFile fp $ toString bp
28class AsString a where
29 toString :: a -> String
30 fromString :: String -> Either String (a, String)
32instance AsString BuildPlan where
33 toString BuildPlan {..} = concat
34 [ makeSection "tools" bpTools
35 , makeSection "packages" $ Map.toList bpPackages
36 , makeSection "core" $ Map.toList bpCore
37 , makeSection "optional-core" $ Map.toList bpOptionalCore
38 , makeSection "skipped-tests" $ Set.toList bpSkippedTests
39 , makeSection "expected-failures" $ Set.toList bpExpectedFailures
40 ]
41 fromString s1 = do
42 (tools, s2) <- getSection "tools" s1
43 (packages, s3) <- getSection "packages" s2
44 (core, s4) <- getSection "core" s3
45 (optionalCore, s5) <- getSection "optional-core" s4
46 (skipped, s6) <- getSection "skipped-tests" s5
47 (failures, s7) <- getSection "expected-failures" s6
48 let bp = BuildPlan
49 { bpTools = tools
50 , bpPackages = Map.fromList packages
51 , bpCore = Map.fromList core
52 , bpOptionalCore = Map.fromList optionalCore
53 , bpSkippedTests = Set.fromList skipped
54 , bpExpectedFailures = Set.fromList failures
55 }
56 return (bp, s7)
58makeSection :: AsString a => String -> [a] -> String
59makeSection title contents = unlines
60 $ ("-- BEGIN " ++ title)
61 : map toString contents
62 ++ ["-- END " ++ title, ""]
64instance AsString String where
65 toString = id
66 fromString s = Right (s, "")
68instance AsString PackageName where
69 toString (PackageName pn) = pn
70 fromString s = Right (PackageName s, "")
72instance AsString (Maybe Version) where
73 toString Nothing = ""
74 toString (Just x) = toString x
75 fromString s
76 | all isSpace s = return (Nothing, s)
77 | otherwise = do
78 (v, s') <- fromString s
79 return (Just v, s')
81instance AsString a => AsString (PackageName, a) where
82 toString (PackageName pn, s) = concat [pn, " ", toString s]
83 fromString s = do
84 (pn, rest) <- takeWord s
85 (rest', s') <- fromString rest
86 return ((PackageName pn, rest'), s')
88takeWord :: AsString a => String -> Either String (a, String)
89takeWord s =
90 case break (== ' ') s of
91 (x, _:y) -> do
92 (x', s') <- fromString x
93 if null s'
94 then Right (x', y)
95 else Left $ "Unconsumed input in takeWord call"
96 (_, []) -> Left "takeWord failed"
98instance AsString SelectedPackageInfo where
99 toString SelectedPackageInfo {..} = unwords
100 [ display spiVersion
101 , toString spiHasTests
102 , (\v -> if null v then "@" else v) $ githubMentions spiGithubUser
103 , unMaintainer spiMaintainer
104 ]
105 fromString s1 = do
106 (version, s2) <- takeWord s1
107 (hasTests, s3) <- takeWord s2
108 (gu, m) <- takeWord s3
109 Right (SelectedPackageInfo
110 { spiVersion = version
111 , spiHasTests = hasTests
112 , spiGithubUser = [gu]
113 , spiMaintainer = Maintainer m
114 }, "")
116instance AsString (Maybe String) where
117 toString Nothing = "@"
118 toString (Just x) = "@" ++ x
119 fromString "@" = Right (Nothing, "")
120 fromString ('@':rest) = Right (Just rest, "")
121 fromString x = Left $ "Invalid Github user: " ++ x
123instance AsString Bool where
124 toString True = "test"
125 toString False = "notest"
126 fromString "test" = Right (True, "")
127 fromString "notest" = Right (False, "")
128 fromString x = Left $ "Invalid test value: " ++ x
130instance AsString Version where
131 toString = display
132 fromString s =
133 case simpleParse s of
134 Nothing -> Left $ "Invalid version: " ++ s
135 Just v -> Right (v, "")
137getSection :: AsString a => String -> String -> Either String ([a], String)
138getSection title orig =
139 case lines orig of
140 [] -> Left "Unexpected EOF when looking for a section"
141 l1:ls1
142 | l1 == begin ->
143 case break (== end) ls1 of
144 (here, _:"":rest) -> do
145 here' <- mapM fromString' here
146 Right (here', unlines rest)
147 (_, _) -> Left $ "Could not find section end: " ++ title
148 | otherwise -> Left $ "Could not find section start: " ++ title
149 where
150 begin = "-- BEGIN " ++ title
151 end = "-- END " ++ title
153 fromString' x = do
154 (y, z) <- fromString x
155 if null z
156 then return y
157 else Left $ "Unconsumed input on line: " ++ x