@@ -0,0 +1,139 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+module Stackage.BuildPlan
4+ ( readBuildPlan
5+ , writeBuildPlan
6+ ) where
7+
8+import Stackage.Types
9+import qualified Data.Map as Map
10+import qualified Data.Set as Set
11+import Distribution.Text (simpleParse, display)
12+import Distribution.Package (PackageName (..))
13+import Control.Applicative ((<$>), (<*>))
14+
15+readBuildPlan :: FilePath -> IO BuildPlan
16+readBuildPlan 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"
22+
23+writeBuildPlan :: FilePath -> BuildPlan -> IO ()
24+writeBuildPlan fp bp = writeFile fp $ toString bp
25+
26+class AsString a where
27+ toString :: a -> String
28+ fromString :: String -> Either String (a, String)
29+
30+instance 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)
49+
50+makeSection :: AsString a => String -> [a] -> String
51+makeSection title contents = unlines
52+ $ ("-- BEGIN " ++ title)
53+ : map toString contents
54+ ++ ["-- END " ++ title, ""]
55+
56+instance AsString String where
57+ toString = id
58+ fromString s = Right (s, "")
59+
60+instance AsString PackageName where
61+ toString (PackageName pn) = pn
62+ fromString s = Right (PackageName s, "")
63+
64+instance 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')
70+
71+takeWord :: AsString a => String -> Either String (a, String)
72+takeWord 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"
79+
80+instance 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+ }, "")
97+
98+instance 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
104+
105+instance 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
111+
112+instance 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, "")
118+
119+getSection :: AsString a => String -> String -> Either String ([a], String)
120+getSection 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
134+
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