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