/
Metadata.hs
348 lines (309 loc) · 13.4 KB
/
Metadata.hs
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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
{-# LANGUAGE GADTs, QuasiQuotes, RankNTypes, ScopedTypeVariables,
StandaloneDeriving, TypeFamilies #-}
module Nirum.Package.Metadata ( Author (Author, email, name, uri)
, Metadata ( Metadata
, authors
, target
, version
, description
, license
, keywords
)
, MetadataError ( FieldError
, FieldTypeError
, FieldValueError
, FormatError
)
, MetadataField
, MetadataFieldType
, Node ( VArray
, VBoolean
, VDatetime
, VFloat
, VInteger
, VString
, VTable
, VTArray
)
, Package (Package, metadata, modules)
, Table
, Target ( CompileError
, CompileResult
, compilePackage
, parseTarget
, showCompileError
, targetName
, toByteString
)
, TargetName
, VTArray
, fieldType
, metadataFilename
, metadataPath
, parseMetadata
, packageTarget
, prependMetadataErrorField
, readFromPackage
, readMetadata
, stringField
, tableField
, versionField
) where
import Data.Proxy (Proxy (Proxy))
import Data.Typeable (Typeable)
import GHC.Exts (IsList (fromList, toList))
import Data.ByteString (ByteString)
import qualified Data.HashMap.Strict as HM
import Data.Map.Strict (Map)
import qualified Data.SemVer as SV
import Data.Text (Text, append, snoc, unpack)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.IO as TIO
import System.FilePath ((</>))
import Text.Email.Parser (EmailAddress)
import qualified Text.Email.Validate as EV
import Text.InterpolatedString.Perl6 (qq)
import Text.Parsec.Error (ParseError)
import Text.Toml (parseTomlDoc)
import Text.Toml.Types (Node ( VArray
, VBoolean
, VDatetime
, VFloat
, VInteger
, VString
, VTable
, VTArray
)
, Table
, VTArray
, VArray
)
import Text.URI (URI, parseURI)
import Nirum.Package.ModuleSet (ModuleSet)
-- | The filename of Nirum package metadata.
metadataFilename :: FilePath
metadataFilename = "package.toml"
-- | Represents a package which consists of modules.
data Package t =
Package { metadata :: (Eq t, Ord t, Show t, Target t) => Metadata t
, modules :: ModuleSet
}
deriving instance (Eq t, Target t) => Eq (Package t)
deriving instance (Ord t, Target t) => Ord (Package t)
deriving instance (Show t, Target t) => Show (Package t)
packageTarget :: Target t => Package t -> t
packageTarget Package { metadata = Metadata { target = t } } = t
data Metadata t =
Metadata { version :: SV.Version
, description :: Maybe Text
, license :: Maybe Text
, keywords :: [Text]
, authors :: [Author]
, target :: (Eq t, Ord t, Show t, Target t) => t
}
-- TODO: uri, dependencies
deriving instance (Eq t, Target t) => Eq (Metadata t)
deriving instance (Ord t, Target t) => Ord (Metadata t)
deriving instance (Show t, Target t) => Show (Metadata t)
data Author = Author { name :: Text
, email :: Maybe EmailAddress
, uri :: Maybe URI
} deriving (Eq, Ord, Show)
type TargetName = Text
class (Eq t, Ord t, Show t, Typeable t) => Target t where
type family CompileResult t :: *
type family CompileError t :: *
-- | The name of the given target e.g. @"python"@.
targetName :: Proxy t -> TargetName
-- | Parse the target metadata.
parseTarget :: Table -> Either MetadataError t
-- | Compile the package to a source tree of the target.
compilePackage :: Package t
-> Map FilePath (Either (CompileError t) (CompileResult t))
-- | Show a human-readable message from the given 'CompileError'.
showCompileError :: t -> CompileError t -> Text
-- | Encode the given 'CompileResult' to a 'ByteString'
toByteString :: t -> CompileResult t -> ByteString
-- | Name of package.toml field.
type MetadataField = Text
-- | Typename of package.toml field e.g. @"string"@, @"array of 3 values"@.
type MetadataFieldType = Text
-- | Error related to parsing package.toml.
data MetadataError
-- | A required field is missing.
= FieldError MetadataField
-- | A field has a value of incorrect type e.g. array for @version@ field.
| FieldTypeError MetadataField MetadataFieldType MetadataFieldType
-- | A field has a value of invalid format
-- e.g. @"1/2/3"@ for @version@ field.
| FieldValueError MetadataField String
-- | The given package.toml file is not a valid TOML.
| FormatError ParseError
deriving (Eq, Show)
-- | Prepend the given prefix to a 'MetadataError' value's field information.
-- Note that a period is automatically inserted right after the given prefix.
-- It's useful for handling of accessing nested tables.
prependMetadataErrorField :: MetadataField -> MetadataError -> MetadataError
prependMetadataErrorField prefix e =
case e of
FieldError f -> FieldError $ prepend f
FieldTypeError f e' a -> FieldTypeError (prepend f) e' a
FieldValueError f m -> FieldValueError (prepend f) m
e'@(FormatError _) -> e'
where
prepend :: MetadataField -> MetadataField
prepend = (prefix `snoc` '.' `append`)
parseMetadata :: forall t . Target t
=> FilePath -> Text -> Either MetadataError (Metadata t)
parseMetadata metadataPath' tomlText = do
table <- case parseTomlDoc metadataPath' tomlText of
Left e -> Left $ FormatError e
Right t -> Right t
-- NOTE: When a new field is added please write docs about it in
-- docs/package.md file.
version' <- versionField "version" table
authors' <- authorsField "authors" table
description' <- optional $ stringField "description" table
license' <- optional $ stringField "license" table
keywords' <- textArrayField "keywords" table
targets <- case tableField "targets" table of
Left (FieldError _) -> Right HM.empty
otherwise' -> otherwise'
targetTable <- case tableField targetName' targets of
Left (FieldError _) -> Right HM.empty
Left e -> Left $ prependMetadataErrorField "targets" e
otherwise' -> otherwise'
target' <- case parseTarget targetTable of
Left e -> Left $ prependMetadataErrorField "targets"
$ prependMetadataErrorField targetName' e
otherwise' -> otherwise'
return Metadata { version = version'
, description = description'
, license = license'
, keywords = keywords'
, authors = authors'
, target = target'
}
where
targetName' :: Text
targetName' = targetName (Proxy :: Proxy t)
readMetadata :: Target t => FilePath -> IO (Either MetadataError (Metadata t))
readMetadata metadataPath' = do
tomlText <- TIO.readFile metadataPath'
return $ parseMetadata metadataPath' tomlText
metadataPath :: FilePath -> FilePath
metadataPath = (</> metadataFilename)
readFromPackage :: Target t
=> FilePath -> IO (Either MetadataError (Metadata t))
readFromPackage = readMetadata . metadataPath
-- | Show the typename of the given 'Node'.
fieldType :: Node -> MetadataFieldType
fieldType (VTable t) = if length t == 1
then "table of an item"
else [qq|table of {length t} items|]
fieldType (VTArray a) = [qq|array of {length a} tables|]
fieldType (VString s) = [qq|string ($s)|]
fieldType (VInteger i) = [qq|integer ($i)|]
fieldType (VFloat f) = [qq|float ($f)|]
fieldType (VBoolean True) = "boolean (true)"
fieldType (VBoolean False) = "boolean (false)"
fieldType (VDatetime d) = [qq|datetime ($d)|]
fieldType (VArray a) = if length a == 1
then "array of a value"
else [qq|array of {length a} values|]
field :: MetadataField -> Table -> Either MetadataError Node
field field' table =
case HM.lookup field' table of
Just node -> return node
Nothing -> Left $ FieldError field'
typedField :: MetadataFieldType
-> (Node -> Maybe v)
-> MetadataField
-> Table
-> Either MetadataError v
typedField typename match field' table = do
node <- field field' table
case match node of
Just value -> return value
Nothing -> Left $ FieldTypeError field' typename $ fieldType node
optional :: Either MetadataError a -> Either MetadataError (Maybe a)
optional (Right value) = Right $ Just value
optional (Left (FieldError _)) = Right Nothing
optional (Left error') = Left error'
tableField :: MetadataField -> Table -> Either MetadataError Table
tableField = typedField "table" $ \ n -> case n of
VTable t -> Just t
_ -> Nothing
stringField :: MetadataField -> Table -> Either MetadataError Text
stringField = typedField "string" $ \ n -> case n of
VString s -> Just s
_ -> Nothing
arrayField :: MetadataField -> Table -> Either MetadataError VArray
arrayField f t =
case arrayF f t of
Right vector -> Right vector
Left (FieldError _) -> Right $ fromList []
Left error' -> Left error'
where
arrayF :: MetadataField -> Table -> Either MetadataError VArray
arrayF = typedField "array" $ \ node ->
case node of
VArray array -> Just array
_ -> Nothing
tableArrayField :: MetadataField -> Table -> Either MetadataError VTArray
tableArrayField f t =
case arrayF f t of
Right vector -> Right vector
Left (FieldError _) -> Right $ fromList []
Left error' -> Left error'
where
arrayF :: MetadataField -> Table -> Either MetadataError VTArray
arrayF = typedField "array of tables" $ \ node ->
case node of
VTArray array -> Just array
_ -> Nothing
uriField :: MetadataField -> Table -> Either MetadataError URI
uriField field' table = do
s <- stringField field' table
case parseURI (unpack s) of
Just uri' -> Right uri'
Nothing -> Left $ FieldValueError field'
[qq|expected a URI string, not $s|]
emailField :: MetadataField -> Table -> Either MetadataError EmailAddress
emailField field' table = do
s <- stringField field' table
case EV.validate (encodeUtf8 s) of
Right emailAddress -> Right emailAddress
Left e -> Left $
FieldValueError field' [qq|expected an email address, not $s; $e|]
versionField :: MetadataField -> Table -> Either MetadataError SV.Version
versionField field' table = do
s <- stringField field' table
case SV.fromText s of
Right v -> return v
Left _ -> Left $ FieldValueError field' $
"expected a semver string (e.g. \"1.2.3\"), not " ++ show s
textArrayField :: MetadataField -> Table -> Either MetadataError [Text]
textArrayField field' table = do
array <- arrayField field' table
textArray' <- mapM parseText array
return $ toList textArray'
where
parseText :: Node -> Either MetadataError Text
parseText (VString s) = Right s
parseText a = Left $ FieldTypeError field' "array" $ fieldType a
authorsField :: MetadataField -> Table -> Either MetadataError [Author]
authorsField field' table = do
array <- tableArrayField field' table
authors' <- mapM parseAuthor array
return $ toList authors'
where
parseAuthor :: Table -> Either MetadataError Author
parseAuthor t = do
name' <- stringField "name" t
email' <- optional $ emailField "email" t
uri' <- optional $ uriField "uri" t
return Author { name = name'
, email = email'
, uri = uri'
}