git.iko.soy/stackage
on aa5a30e help sign in
stackage/Stackage/BuildPlan.hs
139 lines 4.6 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleInstances #-}
3module Stackage.BuildPlan
4 ( readBuildPlan
5 , writeBuildPlan
6 ) where
8import Stackage.Types
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Distribution.Text (simpleParse, display)
12import Distribution.Package (PackageName (..))
13import Control.Applicative ((<$>), (<*>))
15readBuildPlan :: FilePath -> IO BuildPlan
16readBuildPlan fp = do
17 str <- 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 = 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 ]
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 let bp = BuildPlan
43 { bpTools = tools
44 , bpPackages = Map.fromList packages
45 , bpCore = Set.fromList core
46 , bpOptionalCore = Map.fromList optionalCore
47 }
48 return (bp, s5)
50makeSection :: AsString a => String -> [a] -> String
51makeSection title contents = unlines
52 $ ("-- BEGIN " ++ title)
53 : map toString contents
54 ++ ["-- END " ++ title, ""]
56instance AsString String where
57 toString = id
58 fromString s = Right (s, "")
60instance AsString PackageName where
61 toString (PackageName pn) = pn
62 fromString s = Right (PackageName s, "")
64instance AsString a => AsString (PackageName, a) where
65 toString (PackageName pn, s) = concat [pn, " ", toString s]
66 fromString s = do
67 (pn, rest) <- takeWord s
68 (rest', s') <- fromString rest
69 return ((PackageName pn, rest'), s')
71takeWord :: AsString a => String -> Either String (a, String)
72takeWord s =
73 case break (== ' ') s of
74 (x, _:y) -> do
75 (x', s') <- fromString x
76 if null s'
77 then Right (x', y)
78 else Left $ "Unconsumed input in takeWord call"
80instance AsString SelectedPackageInfo where
81 toString SelectedPackageInfo {..} = unwords
82 [ display spiVersion
83 , toString spiHasTests
84 , maybe "@" ("@" ++) spiGithubUser
85 , unMaintainer spiMaintainer
86 ]
87 fromString s1 = do
88 (version, s2) <- takeWord s1
89 (hasTests, s3) <- takeWord s2
90 (gu, m) <- takeWord s3
91 Right (SelectedPackageInfo
92 { spiVersion = version
93 , spiHasTests = hasTests
94 , spiGithubUser = gu
95 , spiMaintainer = Maintainer m
96 }, "")
98instance AsString (Maybe String) where
99 toString Nothing = "@"
100 toString (Just x) = "@" ++ x
101 fromString "@" = Right (Nothing, "")
102 fromString ('@':rest) = Right (Just rest, "")
103 fromString x = Left $ "Invalid Github user: " ++ x
105instance AsString Bool where
106 toString True = "test"
107 toString False = "notest"
108 fromString "test" = Right (True, "")
109 fromString "notest" = Right (False, "")
110 fromString x = Left $ "Invalid test value: " ++ x
112instance AsString Version where
113 toString = display
114 fromString s =
115 case simpleParse s of
116 Nothing -> Left $ "Invalid version: " ++ s
117 Just v -> Right (v, "")
119getSection :: AsString a => String -> String -> Either String ([a], String)
120getSection title orig =
121 case lines orig of
122 [] -> Left "Unexpected EOF when looking for a section"
123 l1:ls1
124 | l1 == begin ->
125 case break (== end) ls1 of
126 (here, _:"":rest) -> do
127 here' <- mapM fromString' here
128 Right (here', unlines rest)
129 (_, _) -> Left $ "Could not find section end: " ++ title
130 | otherwise -> Left $ "Could not find section start: " ++ title
131 where
132 begin = "-- BEGIN " ++ title
133 end = "-- END " ++ title
135 fromString' x = do
136 (y, z) <- fromString x
137 if null z
138 then return y
139 else Left $ "Unconsumed input on line: " ++ x