blob: 603f1a8677903f3af6189d74fdf88022289419c2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
module buildclient.config.BuildConfig where
import buildclient.config.BuildParser
(<?>) :: Maybe b -> a -> Either a b
(<?>) = flip maybeToEither
(<#>) :: (c -> Maybe b) -> a -> (c -> Either a b)
(<#>) f a b = f b <?> a
maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just v) = Right v
maybeToEither e _ = Left e
extractSingleArg :: ASTDirective -> Maybe ASTValue
extractSingleArg (ASTDirective _ [value] []) = Just value
extractSingleArg _ = Nothing
getArgDirective :: String -> [ASTDirective] -> Maybe ASTValue
getArgDirective name directives = findDirective name directives >>= extractSingleArg
getTypedArg :: String -> String -> [ASTDirective] -> (ASTValue -> Maybe a) -> Either String a
getTypedArg name label directives mapper =
(findDirective name directives <?> ("Please add the missing " ++ label))
>>= (extractSingleArg <#> ("Please add an argument to the " ++ label))
>>= (mapper <#> ("Invalid argument type for " ++ label))
getArg :: ASTDirective -> Int -> Maybe ASTValue
getArg (ASTDirective _ args _) = getArg' args
where getArg' (a : _) 0 = Just a
getArg' (a : as) i = getArg' as (i - 1)
getArg' [] _ = Nothing
toString :: ASTValue -> Maybe String
toString (ASTValue.ASTString str) = Just str
toString (ASTValue.ASTWord str) = Just str
toString _ = Nothing
expectString :: ASTValue -> Maybe String
expectString (ASTValue.ASTString str) = Just str
expectString _ = Nothing
expectNumber :: ASTValue -> Maybe Int
expectNumber (ASTValue.ASTNumber num) = Just num
expectNumber _ = Nothing
data BuildSource = GitSource {upstream :: String, branch :: Maybe String}
derive Show BuildSource
findSource :: ASTDirective -> Either String BuildSource
findSource (ASTDirective _ [ASTWord "git"] block) = do
upstream <- getTypedArg "upstream" "git upstream directive" block expectString
return $ GitSource upstream (getArgDirective "branch" block >>= expectString)
findSource (ASTDirective _ [ASTWord name] _) = fail ("Unknown source type " ++ name)
findSource _ = fail "Please provide a source type"
data BuildSystem = GradleBuild { task::String, project :: Maybe String }
derive Show BuildSystem
findBuildSystem :: ASTDirective -> Either String BuildSystem
findBuildSystem (ASTDirective _ [ASTWord "gradle"] block) = do
task <- getTypedArg "task" "gradle task" block expectString
return $ GradleBuild task $ (getArgDirective "project" block >>= expectString)
findBuildSystem _ = fail "Please provide a build system"
parseBuildConfig :: [ASTDirective] -> Either String BuildConfig
parseBuildConfig directives = do
version <- getTypedArg "schema" "schema" directives expectNumber
when (version != 1) $ fail "Invalid schema version. Needs to be 1"
modid <- getTypedArg "modid" "modid" directives expectString
label <- getTypedArg "label" "label" directives expectString
description <- getTypedArg "description" "description" directives expectString
author <- getTypedArg "author" "author" directives expectString
source <- findDirective "source" directives <?> "Please provide a source block" >>= findSource
build <- findDirective "build" directives <?> "Please provide a build block" >>= findBuildSystem
return $ BuildConfig modid label description author (getArgDirective "webpresence" directives >>= expectString) source build
parseBuildConfigStr :: String -> Either String BuildConfig
parseBuildConfigStr str = reportErr tokens >> (runParser parseFile tokens) >>= parseBuildConfig
where reportErr (Token.ERROR position msg:_) = fail ("Error at position " ++ (show position) ++ ": " ++ msg)
reportErr (_:as) = reportErr as
reportErr _ = return ()
tokens = lexer str
data BuildConfig = BuildConfig
{ modid :: String
, label :: String
, description :: String
, author :: String
, webpresence :: Maybe String
, source :: BuildSource
, build :: BuildSystem
}
derive Show BuildConfig
|
