git.iko.soy/stackage
on 7d2ca47 help sign in
stackage/Stackage/BuildPlan.hs
143 lines 4.9 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
15readBuildPlan :: FilePath -> IO BuildPlan
16readBuildPlan fp = do
17 str <- System.IO.UTF8.readFile fp
18 case fromString str of
19 Left s -> error $ "Could not read build plan: " ++ s
20 Right (x, "") -> return x
21 Right (_, _:_) -> error "Trailing content when reading build plan"
23writeBuildPlan :: FilePath -> BuildPlan -> IO ()
24writeBuildPlan fp bp = System.IO.UTF8.writeFile fp $ toString bp
26class AsString a where
27 toString :: a -> String
28 fromString :: String -> Either String (a, String)
30instance AsString BuildPlan where
31 toString BuildPlan {..} = concat
32 [ makeSection "tools" bpTools
33 , makeSection "packages" $ Map.toList bpPackages
34 , makeSection "core" $ Set.toList bpCore
35 , makeSection "optional-core" $ Map.toList bpOptionalCore
36 , makeSection "skipped-tests" $ Set.toList bpSkippedTests
37 ]
38 fromString s1 = do
39 (tools, s2) <- getSection "tools" s1
40 (packages, s3) <- getSection "packages" s2
41 (core, s4) <- getSection "core" s3
42 (optionalCore, s5) <- getSection "optional-core" s4
43 (skipped, s6) <- getSection "skipped-tests" s5
44 let bp = BuildPlan
45 { bpTools = tools
46 , bpPackages = Map.fromList packages
47 , bpCore = Set.fromList core
48 , bpOptionalCore = Map.fromList optionalCore
49 , bpSkippedTests = Set.fromList skipped
50 }
51 return (bp, s6)
53makeSection :: AsString a => String -> [a] -> String
54makeSection title contents = unlines
55 $ ("-- BEGIN " ++ title)
56 : map toString contents
57 ++ ["-- END " ++ title, ""]
59instance AsString String where
60 toString = id
61 fromString s = Right (s, "")
63instance AsString PackageName where
64 toString (PackageName pn) = pn
65 fromString s = Right (PackageName s, "")
67instance AsString a => AsString (PackageName, a) where
68 toString (PackageName pn, s) = concat [pn, " ", toString s]
69 fromString s = do
70 (pn, rest) <- takeWord s
71 (rest', s') <- fromString rest
72 return ((PackageName pn, rest'), s')
74takeWord :: AsString a => String -> Either String (a, String)
75takeWord s =
76 case break (== ' ') s of
77 (x, _:y) -> do
78 (x', s') <- fromString x
79 if null s'
80 then Right (x', y)
81 else Left $ "Unconsumed input in takeWord call"
82 (_, []) -> Left "takeWord failed"
84instance AsString SelectedPackageInfo where
85 toString SelectedPackageInfo {..} = unwords
86 [ display spiVersion
87 , toString spiHasTests
88 , maybe "@" ("@" ++) spiGithubUser
89 , unMaintainer spiMaintainer
90 ]
91 fromString s1 = do
92 (version, s2) <- takeWord s1
93 (hasTests, s3) <- takeWord s2
94 (gu, m) <- takeWord s3
95 Right (SelectedPackageInfo
96 { spiVersion = version
97 , spiHasTests = hasTests
98 , spiGithubUser = gu
99 , spiMaintainer = Maintainer m
100 }, "")
102instance AsString (Maybe String) where
103 toString Nothing = "@"
104 toString (Just x) = "@" ++ x
105 fromString "@" = Right (Nothing, "")
106 fromString ('@':rest) = Right (Just rest, "")
107 fromString x = Left $ "Invalid Github user: " ++ x
109instance AsString Bool where
110 toString True = "test"
111 toString False = "notest"
112 fromString "test" = Right (True, "")
113 fromString "notest" = Right (False, "")
114 fromString x = Left $ "Invalid test value: " ++ x
116instance AsString Version where
117 toString = display
118 fromString s =
119 case simpleParse s of
120 Nothing -> Left $ "Invalid version: " ++ s
121 Just v -> Right (v, "")
123getSection :: AsString a => String -> String -> Either String ([a], String)
124getSection title orig =
125 case lines orig of
126 [] -> Left "Unexpected EOF when looking for a section"
127 l1:ls1
128 | l1 == begin ->
129 case break (== end) ls1 of
130 (here, _:"":rest) -> do
131 here' <- mapM fromString' here
132 Right (here', unlines rest)
133 (_, _) -> Left $ "Could not find section end: " ++ title
134 | otherwise -> Left $ "Could not find section start: " ++ title
135 where
136 begin = "-- BEGIN " ++ title
137 end = "-- END " ++ title
139 fromString' x = do
140 (y, z) <- fromString x
141 if null z
142 then return y
143 else Left $ "Unconsumed input on line: " ++ x