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