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