1
{-# OPTIONS_GHC -fno-warn-orphans #-}
2
{-# LANGUAGE FlexibleInstances          #-}
3
{-# LANGUAGE TemplateHaskell            #-}
4
{-# LANGUAGE TupleSections              #-}
5
{-# LANGUAGE CPP                        #-}
6
7
module Data.Aeson.Schema.CodeGen
8
  ( Declaration (..)
9
  , Code
10
  , generate
11
  , generateTH
12
  , generateModule
13
  ) where
14
15
import           Control.Applicative         ((<|>))
16
import           Control.Arrow               (first, second)
17
import           Control.Monad               (forM_, unless, when, zipWithM)
18
import           Control.Monad.RWS.Lazy      (MonadReader (..),
19
                                              MonadWriter (..), evalRWST)
20
import           Data.Aeson           hiding (Options)
21
import           Data.Aeson.Types            (parse)
22
import           Data.Char                   (isAlphaNum, isLetter, toLower,
23
                                              toUpper)
24
import qualified Data.HashMap.Lazy           as HM
25
import qualified Data.HashSet                as HS
26
import           Data.List                   (mapAccumL, sort, unzip5)
27
import qualified Data.Map                    as M
28
import           Data.Maybe                  (catMaybes, isNothing, maybeToList)
29
import           Data.Monoid                 ((<>))
30
import           Data.Scientific             (Scientific, floatingOrInteger,
31
                                              isInteger)
32
import           Data.Text                   (Text, pack, unpack)
33
import qualified Data.Text                   as T
34
import           Data.Traversable            (forM)
35
import           Data.Tuple                  (swap)
36
import qualified Data.Vector                 as V
37
import           Language.Haskell.TH
38
import           Language.Haskell.TH.Syntax
39
import qualified Text.Regex.PCRE             as PCRE
40
import           Text.Regex.PCRE.String      (Regex)
41
42
import           Data.Aeson.Schema.Choice
43
import           Data.Aeson.Schema.CodeGenM
44
import           Data.Aeson.Schema.Helpers
45
import           Data.Aeson.Schema.Types
46
import           Data.Aeson.Schema.Validator
47
import           Data.Aeson.TH.Lift          ()
48
49
type SchemaTypes = M.Map Text Name
50
51
instance (Lift k, Lift v) => Lift (M.Map k v) where
52
  lift m = [| M.fromList $(lift $ M.toList m) |]
53
54
-- | Extracts all TH declarations
55
getDecs :: Code -> [Dec]
56
getDecs code = [ dec | Declaration dec _ <- code ]
57
58
-- | Generate data-types and FromJSON instances for all schemas
59
generateTH :: Graph Schema Text -- ^ Set of schemas
60
           -> Options
61
           -> Q ([Dec], M.Map Text Name) -- ^ Generated code and mapping from schema identifiers to type names
62
generateTH g = fmap (first getDecs) . generate g
63
64
-- | Generated a self-contained module that parses and validates values of
65
-- a set of given schemas.
66
generateModule :: Text -- ^ Name of the generated module
67
               -> Graph Schema Text -- ^ Set of schemas
68
               -> Options
69
               -> Q (Text, M.Map Text Name) -- ^ Module code and mapping from schema identifiers to type names
70
generateModule modName g opts = fmap (first $ renderCode . map rewrite) $ generate g opts
71
  where
72
    renderCode :: Code -> Text
73
    renderCode code = T.intercalate "\n\n" $ [langExts <> ghcOpts, modDec, T.intercalate "\n" imprts] ++ map renderDeclaration code
74
      where
75
        mods = sort $ _extraModules opts ++ getUsedModules (getDecs code)
76
        imprts = map (\m -> "import " <> pack m) mods
77
        modDec = "module " <> modName <> " where"
78
        -- TH has no support for file-header pragmas so we splice the text in here
79
        mkHeaderPragmas t = T.intercalate "\n" . map (\s -> T.unwords ["{-#", t, s, "#-}"])
80
        langExts = mkHeaderPragmas "LANGUAGE" $ _languageExtensions opts
81
        ghcOpts = mkHeaderPragmas "OPTIONS_GHC" $ _ghcOptsPragmas opts
82
    rewrite :: Declaration -> Declaration
83
    rewrite (Declaration dec text) = Declaration (replaceHiddenModules (cleanPatterns dec) (_replaceModules opts)) text
84
    rewrite a = a
85
86
-- | Generate a generalized representation of the code in a Haskell module
87
generate :: Graph Schema Text -> Options -> Q (Code, M.Map Text Name)
88
generate graph opts = swap <$> evalRWST (unCodeGenM $ generateTopLevel graph >> return typeMap) (opts, typeMap) used
89
  where
90
    (used, typeMap) = second M.fromList $ mapAccumL nameAccum HS.empty (M.keys graph)
91
    nameAccum usedNames schemaName = second (schemaName,) $ swap $ codeGenNewName (firstUpper $ unpack schemaName) usedNames
92
93
generateTopLevel :: Graph Schema Text -> CodeGenM SchemaTypes ()
94
generateTopLevel graph = do
95
  (opts, typeMap) <- ask
96
  graphN <- qNewName "graph"
97
  when (nameBase graphN /= "graph") $ fail "name graph is already taken"
98
  graphDecType <- runQ $ sigD graphN [t| Graph Schema Text |]
99
  graphDec <- runQ $ valD (varP graphN) (normalB $ lift graph) []
100
  tell [Declaration graphDecType Nothing, Declaration graphDec Nothing]
101
  forM_ (M.toList graph) $ \(name, schema) -> do
102
    let typeName = typeMap M.! name
103
    ((typeQ, fromJsonQ, toJsonQ), defNewtype) <- generateSchema (Just typeName) name schema
104
    when defNewtype $ do
105
106
#if MIN_VERSION_template_haskell(2,12,0)
107
      let newtypeCon = normalC typeName [bangType (pure $ Bang NoSourceUnpackedness NoSourceStrictness) typeQ]
108
      let deriv = derivClause Nothing $ map conT $ _derivingTypeclasses opts
109
      newtypeDec <- runQ $ newtypeD (cxt []) typeName [] Nothing newtypeCon [deriv]
110
#elif MIN_VERSION_template_haskell(2,11,0)
111
      let newtypeCon = normalC typeName [bangType (pure $ Bang NoSourceUnpackedness NoSourceStrictness) typeQ]
112
      newtypeDec <- runQ $ newtypeD (cxt []) typeName [] Nothing newtypeCon (mapM conT $ _derivingTypeclasses opts)
113
#else
114
      let newtypeCon = normalC typeName [strictType notStrict typeQ]
115
      newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon (_derivingTypeclasses opts)
116
#endif
117
118
      fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` conT typeName)
119
        [ valD (varP $ mkName "parseJSON") (normalB [| fmap $(conE typeName) . $fromJsonQ |]) []
120
        ]
121
      toJSONInst <- runQ $ instanceD (cxt []) (conT ''ToJSON `appT` conT typeName)
122
        [ funD (mkName "toJSON")
123
          [ clause [conP typeName [varP $ mkName "val"]] (normalB $ toJsonQ `appE` varE (mkName "val")) []
124
          ]
125
        ]
126
      tell
127
        [ Declaration newtypeDec Nothing
128
        , Declaration fromJSONInst Nothing
129
        , Declaration toJSONInst Nothing
130
        ]
131
132
generateSchema :: Maybe Name -- ^ Name to be used by type declarations
133
               -> Text -- ^ Describes the position in the schema
134
               -> Schema Text
135
               -> CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool) -- ^ ((type of the generated representation (a), function :: Value -> Parser a), whether a newtype wrapper is necessary)
136
generateSchema decName name schema = case schemaDRef schema of
137
  Just ref -> askEnv >>= \typesMap -> case M.lookup ref typesMap of
138
    Nothing -> fail "couldn't find referenced schema"
139
    Just referencedSchema -> return ((conT referencedSchema, [| parseJSON |], [| toJSON |]), True)
140
  Nothing -> first (\(typ,from,to) -> (typ,wrap from,to)) <$> case schemaType schema of
141
    [] -> fail "empty type"
142
    [Choice1of2 typ] -> generateSimpleType decName name typ
143
    [Choice2of2 sch] -> generateSchema decName name sch
144
    unionType -> do
145
      let l = pack . show $ length unionType
146
      let names = map (\i -> name <> "Choice" <> pack (show i) <> "of" <> l) ([1..] :: [Int])
147
      subs <- fmap (map fst) $ zipWithM (choice2 (flip $ generateSimpleType Nothing) (flip $ generateSchema Nothing)) unionType names
148
      (,True) <$> generateUnionType subs
149
  where
150
    generateSimpleType :: Maybe Name -> Text -> SchemaType -> CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool)
151
    generateSimpleType decName' name' typ = case typ of
152
      StringType  -> (,True) <$> generateString schema
153
      NumberType  -> (,True) <$> generateNumber schema
154
      IntegerType -> (,True) <$> generateInteger schema
155
      BooleanType -> (,True) <$> generateBoolean
156
      ObjectType  -> case checkers of
157
        [] -> generateObject decName' name' schema
158
        _  -> (,True) . fst <$> generateObject Nothing name' schema
159
      ArrayType   -> (,True) <$> generateArray name' schema
160
      NullType    -> (,True) <$> generateNull
161
      AnyType     -> (,True) <$> generateAny schema
162
    generateUnionType :: [(TypeQ, ExpQ, ExpQ)] -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
163
    generateUnionType union = return (typ, lamE [varP val] fromQ, toQ)
164
      where
165
        n = length union
166
        (types, froms, tos) = unzip3 union
167
        unionParsers = zipWith (\i parser -> [| $(choiceConE i n) <$> $parser $(varE val) |]) [1..] froms
168
        choiceConE :: Int -> Int -> ExpQ
169
        choiceConE i j = conE $ mkName $ "Data.Aeson.Schema.Choice.Choice" ++ show i ++ "of" ++ show j
170
        choiceT i = conT $ mkName $ "Data.Aeson.Schema.Choice.Choice" ++ show i
171
        typ = foldl appT (choiceT n) types
172
        fromQ = foldr (\choiceParser unionParser -> [| $choiceParser <|> $unionParser |]) [| fail "no type in union" |] unionParsers
173
        toQ = foldl appE (varE $ mkName $ "Data.Aeson.Schema.Choice.choice" ++ show n) tos
174
    val = mkName "val"
175
    checkEnum xs = assertStmt [| $(varE val) `elem` xs |] "not one of the values in enum"
176
    checkDisallow dis = noBindS $ doE $ map (noBindS . choice2 disallowType disallowSchema) dis
177
    disallowType StringType  = disallowPattern (conP 'String [wildP]) "strings are disallowed"
178
    disallowType NumberType  = disallowPattern (conP 'Number [wildP]) "numbers are disallowed"
179
    disallowType IntegerType =
180
      [| case $(varE val) of
181
           Number num | isInteger num -> fail "integers are disallowed"
182
           _ -> return ()
183
      |]
184
    disallowType BooleanType = disallowPattern (conP 'Bool [wildP]) "booleans are disallowed"
185
    disallowType ObjectType  = disallowPattern (conP 'Object [wildP]) "objects are disallowed"
186
    disallowType ArrayType   = disallowPattern (conP 'Array [wildP]) "arrays are disallowed"
187
    disallowType NullType    = disallowPattern (conP 'Null []) "null is disallowed"
188
    disallowType AnyType     = [| fail "Nothing is allowed here. Sorry." |]
189
    disallowPattern :: PatQ -> String -> ExpQ
190
    disallowPattern pat err = caseE (varE val)
191
      [ match pat (normalB [| fail err |])[]
192
      , match wildP (normalB [| return () |]) []
193
      ]
194
    disallowSchema sch =
195
      [| case validate $(varE $ mkName "graph") $(lift sch) $(varE val) of
196
           [] -> fail "disallowed"
197
           _  -> return ()
198
      |]
199
    checkExtends exts = noBindS $ doE $ flip map exts $ flip assertValidates (varE val) . lift
200
    checkers = catMaybes
201
      [ checkEnum <$> schemaEnum schema
202
      , if null (schemaDisallow schema) then Nothing else Just (checkDisallow $ schemaDisallow schema)
203
      , if null (schemaExtends schema) then Nothing else Just (checkExtends $ schemaExtends schema)
204
      ]
205
    wrap parser = if null checkers
206
      then parser
207
      else lamE [varP val] $ doE $ checkers ++ [noBindS $ parser `appE` varE val]
208
209
assertStmt :: ExpQ -> String -> StmtQ
210
assertStmt expr err = noBindS [| unless $(expr) (fail err) |]
211
212
assertValidates :: ExpQ -> ExpQ -> StmtQ
213
assertValidates schema value = noBindS $ parensE
214
  [| case validate $(varE $ mkName "graph") $schema $value of
215
       [] -> return ()
216
       es -> fail $ unlines es
217
  |]
218
219
lambdaPattern :: PatQ -> ExpQ -> ExpQ -> ExpQ
220
lambdaPattern pat body err = lamE [varP val] $ caseE (varE val)
221
  [ match pat (normalB body) []
222
  , match wildP (normalB err) []
223
  ]
224
  where val = mkName "val"
225
226
generateString :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
227
generateString schema = return (conT ''Text, code, [| String |])
228
  where
229
    str = mkName "str"
230
    checkMinLength l = assertStmt [| T.length $(varE str) >= l |] $ "string must have at least " ++ show l ++ " characters"
231
    checkMaxLength l = assertStmt [| T.length $(varE str) <= l |] $ "string must have at most " ++ show l ++ " characters"
232
    checkPattern (Pattern p _) = noBindS $ doE
233
      [ bindS (varP $ mkName "regex") [| PCRE.makeRegexM $(lift (T.unpack p)) |]
234
      , assertStmt [| PCRE.match ($(varE $ mkName "regex") :: Regex) (unpack $(varE str)) |] $ "string must match pattern " ++ show p
235
      ]
236
    checkFormat format = noBindS [| maybe (return ()) fail (validateFormat $(lift format) $(varE str)) |]
237
    checkers = catMaybes
238
      [ if schemaMinLength schema > 0 then Just (checkMinLength $ schemaMinLength schema) else Nothing
239
      , checkMaxLength <$> schemaMaxLength schema
240
      , checkPattern <$> schemaPattern schema
241
      , checkFormat <$> schemaFormat schema
242
      ]
243
    code = lambdaPattern (conP 'String [varP str])
244
                         (doE $ checkers ++ [noBindS [| return $(varE str) |]])
245
                         [| fail "not a string" |]
246
247
generateNumber :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
248
generateNumber schema = return (conT ''Scientific, code, [| Number |])
249
  where
250
    num = mkName "num"
251
    code = lambdaPattern (conP 'Number [varP num])
252
                         (doE $ numberCheckers num schema ++ [noBindS [| return $(varE num) |]])
253
                         [| fail "not a number" |]
254
255
generateInteger :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
256
generateInteger schema = return (conT ''Integer, code, [| Number . fromInteger |])
257
  where
258
    num = mkName "num"
259
    code = lambdaPattern (conP 'Number [varP num])
260
                         [| case floatingOrInteger $(varE num) of
261
                              Right i -> $(doE $ numberCheckers num schema ++
262
                                                 [noBindS [| return i |]])
263
                              _ -> fail "not an integer"
264
                         |]
265
                         [| fail "not an integer" |]
266
267
numberCheckers :: Name -> Schema Text -> [StmtQ]
268
numberCheckers num schema = catMaybes
269
  [ checkMinimum (schemaExclusiveMinimum schema) <$> schemaMinimum schema
270
  , checkMaximum (schemaExclusiveMaximum schema) <$> schemaMaximum schema
271
  , checkDivisibleBy <$> schemaDivisibleBy schema
272
  ]
273
  where
274
    checkMinimum, checkMaximum :: Bool -> Scientific -> StmtQ
275
    checkMinimum excl m = if excl
276
      then assertStmt [| $(varE num) >  m |] $ "number must be greater than " ++ show m
277
      else assertStmt [| $(varE num) >= m |] $ "number must be greater than or equal " ++ show m
278
    checkMaximum excl m = if excl
279
      then assertStmt [| $(varE num) <  m |] $ "number must be less than " ++ show m
280
      else assertStmt [| $(varE num) <= m |] $ "number must be less than or equal " ++ show m
281
    checkDivisibleBy devisor = assertStmt [| $(varE num) `isDivisibleBy` devisor |] $ "number must be devisible by " ++ show devisor
282
283
generateBoolean :: CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
284
generateBoolean = return ([t| Bool |], [| parseJSON |], [| Bool |])
285
286
generateNull :: CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
287
generateNull = return (tupleT 0, code, [| const Null |])
288
  where
289
    code = lambdaPattern (conP 'Null [])
290
                         [| return () |]
291
                         [| fail "not null" |]
292
293
cleanName :: String -> String
294
cleanName str = charFirst
295
  where
296
    isAllowed c = isAlphaNum c || c `elem` ("'_"::String)
297
    cleaned = filter isAllowed str
298
    charFirst = case cleaned of
299
      (chr:_) | not (isLetter chr || chr == '_') -> '_':cleaned
300
      _ -> cleaned
301
firstUpper, firstLower :: String -> String
302
firstUpper "" = ""
303
firstUpper (c:cs) = toUpper c : cs
304
firstLower "" = ""
305
firstLower (c:cs) = toLower c : cs
306
307
generateObject :: Maybe Name -- ^ Name to be used by data declaration
308
               -> Text
309
               -> Schema Text
310
               -> CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool)
311
generateObject decName name schema = case (propertiesList, schemaAdditionalProperties schema) of
312
  ([], Choice2of2 additionalSchema) -> generateMap additionalSchema
313
  _                                 -> generateDataDecl
314
  where
315
    propertiesList = HM.toList $ schemaProperties schema
316
    generateMap :: Schema Text -> CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool)
317
    generateMap additionalSchema = case schemaPatternProperties schema of
318
      [] -> do
319
        ((additionalType, additionalParser, additionalTo), _) <-
320
          generateSchema Nothing (name <> "Item") additionalSchema
321
        let parseAdditional = [| fmap M.fromList $ mapM (\(k,v) -> (,) k <$> $(additionalParser) v) $ HM.toList $(varE obj) |]
322
        let parser = lambdaPattern (conP 'Object [varP obj])
323
                                   (doE $ checkers ++ [noBindS parseAdditional])
324
                                   [| fail "not an object" |]
325
        let typ = [t| M.Map Text $(additionalType) |]
326
        let to = [| Object . HM.fromList . map (second $(additionalTo)) . M.toList |]
327
        return ((typ, parser, to), True)
328
      _  -> do
329
        let validatesStmt = assertValidates (lift schema) [| Object $(varE obj) |]
330
        let parser = lambdaPattern (conP 'Object [varP obj])
331
                                   (doE $ validatesStmt : [noBindS [| return $ M.fromList $ HM.toList $(varE obj) |]])
332
                                   [| fail "not an object" |]
333
        return (([t| M.Map Text Value |], parser, [| Object . HM.fromList . M.toList |]), True)
334
    generateDataDecl :: CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool)
335
    generateDataDecl = do
336
      (propertyNames, propertyTypes, propertyParsers, propertyTos, defaultParsers) <- fmap unzip5 $ forM propertiesList $ \(fieldName, propertySchema) -> do
337
        let cleanedFieldName = cleanName $ unpack name ++ firstUpper (unpack fieldName)
338
        propertyName <- qNewName $ firstLower cleanedFieldName
339
        ((typ, fromExpr, toExpr), _) <-
340
          generateSchema Nothing (pack (firstUpper cleanedFieldName)) propertySchema
341
        let lookupProperty = [| HM.lookup $(lift fieldName) $(varE obj) |]
342
        case schemaDefault propertySchema of
343
          Just defaultValue -> do
344
            defaultName <- qNewName $ "default" <> firstUpper cleanedFieldName
345
            return ( propertyName
346
                   , typ
347
                   , [| maybe (return $(varE defaultName)) $fromExpr $lookupProperty |]
348
                   , [| Just . $toExpr |]
349
                   , Just $ valD (conP 'Success [varP defaultName]) (normalB [| parse $fromExpr $(lift defaultValue) |]) []
350
                   )
351
          Nothing -> return $ if schemaRequired propertySchema
352
            then ( propertyName
353
                 , typ
354
                 , [| maybe (fail $(lift $ "required property " ++ unpack fieldName ++ " missing")) $fromExpr $lookupProperty |]
355
                 , [| Just . $toExpr |]
356
                 , Nothing
357
                 )
358
            else ( propertyName
359
                 , conT ''Maybe `appT` typ
360
                 , [| traverse $fromExpr $lookupProperty |]
361
                 , [| fmap $toExpr |]
362
                 , Nothing
363
                 )
364
      conName <- maybe (qNewName $ firstUpper $ unpack name) return decName
365
      tcs <- _derivingTypeclasses <$> askOpts
366
      rMods <- _replaceModules <$> askOpts
367
      userInstanceGen <- _extraInstances <$> askOpts
368
      recordDeclaration <- runQ $ genRecord conName
369
                                            (zip3 propertyNames
370
                                                  (map (fmap (`replaceHiddenModules` rMods)) propertyTypes)
371
                                                  (map (schemaDescription . snd) propertiesList))
372
                                            (map (`replaceHiddenModules` rMods) tcs)
373
      let typ = conT conName
374
      let parser = foldl (\oparser propertyParser -> [| $oparser <*> $propertyParser |]) [| pure $(conE conName) |] propertyParsers
375
      fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` typ)
376
        [ funD (mkName "parseJSON") -- cannot use a qualified name here
377
            [ clause [conP 'Object [varP obj]] (normalB $ doE $ checkers ++ [noBindS parser]) (catMaybes defaultParsers)
378
            , clause [wildP] (normalB [| fail "not an object" |]) []
379
            ]
380
        ]
381
      let paramNames = map (mkName . ("a" ++) . show) $ take (length propertyTos) ([1..] :: [Int])
382
383
      userInstances <- runQ . sequence $ userInstanceGen conName
384
      toJSONInst <- runQ $ instanceD (cxt []) (conT ''ToJSON `appT` typ)
385
        [ funD (mkName "toJSON") -- cannot use a qualified name here
386
          [ clause [conP conName $ map varP paramNames] (normalB [| Object $ HM.fromList $ catMaybes $(listE $ zipWith3 (\fieldName to param -> [| (,) $(lift fieldName) <$> $to $(varE param) |]) (map fst propertiesList) propertyTos paramNames) |]) []
387
          ]
388
        ]
389
      tell $
390
        [ recordDeclaration ]
391
        ++ map (flip Declaration Nothing) userInstances ++
392
        [ Declaration fromJSONInst Nothing
393
        , Declaration toJSONInst Nothing
394
        ]
395
      return ((typ, [| parseJSON |], [| toJSON |]), False)
396
    obj = mkName "obj"
397
    checkDependencies deps = noBindS
398
      [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, _) -> case HM.lookup pname $(lift deps) of
399
           Nothing -> return ()
400
           Just (Choice1of2 props) -> forM_ props $ \prop -> when (isNothing (HM.lookup prop $(varE obj))) $
401
             fail $ unpack pname ++ " requires property " ++ unpack prop
402
           Just (Choice2of2 depSchema) -> $(doE [assertValidates [| depSchema |] [| Object $(varE obj) |]])
403
      |]
404
    checkAdditionalProperties _ (Choice1of2 True) = [| return () |]
405
    checkAdditionalProperties _ (Choice1of2 False) = [| fail "additional properties are not allowed" |]
406
    checkAdditionalProperties value (Choice2of2 sch) = doE [assertValidates (lift sch) value]
407
    -- TODO Once https://ghc.haskell.org/trac/ghc/ticket/10734 is
408
    -- fixed, use a ‘let’ again for matchingPatterns and
409
    -- isAdditionalProperty
410
    checkPatternAndAdditionalProperties patterns additional = noBindS
411
      [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, value) -> do
412
           matchingPatterns <- return (filter (flip PCRE.match (unpack pname) . patternCompiled . fst) $(lift patterns))
413
           forM_ matchingPatterns $ \(_, sch) -> $(doE [assertValidates [| sch |] [| value |]])
414
           isAdditionalProperty <- return (null matchingPatterns && pname `notElem` $(lift $ map fst $ HM.toList $ schemaProperties schema))
415
           when isAdditionalProperty $(checkAdditionalProperties [| value |] additional)
416
      |]
417
    additionalPropertiesAllowed (Choice1of2 True) = True
418
    additionalPropertiesAllowed _ = False
419
    checkers = catMaybes
420
      [ if HM.null (schemaDependencies schema) then Nothing else Just (checkDependencies $ schemaDependencies schema)
421
      , if null (schemaPatternProperties schema) && additionalPropertiesAllowed (schemaAdditionalProperties schema)
422
        then Nothing
423
        else Just (checkPatternAndAdditionalProperties (schemaPatternProperties schema) (schemaAdditionalProperties schema))
424
      ]
425
426
generateArray :: Text -> Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
427
generateArray name schema = case schemaItems schema of
428
  Nothing -> monomorphicArray (conT ''Value) [| parseJSON |] [| toJSON |]
429
  Just (Choice1of2 itemsSchema) -> do
430
    ((itemType, itemParse, itemTo), _) <- generateSchema Nothing (name <> "Item") itemsSchema
431
    monomorphicArray itemType itemParse itemTo
432
  Just (Choice2of2 itemSchemas) -> do
433
    let names = map (\i -> name <> "Item" <> pack (show i)) ([0..] :: [Int])
434
    items <- fmap (map fst) $ zipWithM (generateSchema Nothing) names itemSchemas
435
    additionalItems <- case schemaAdditionalItems schema of
436
      Choice1of2 b -> return $ Choice1of2 b
437
      Choice2of2 sch -> Choice2of2 . fst <$> generateSchema Nothing (name <> "AdditionalItems") sch
438
    tupleArray items additionalItems
439
  where
440
    tupleArray :: [(TypeQ, ExpQ, ExpQ)]
441
               -> Choice2 Bool (TypeQ, ExpQ, ExpQ)
442
               -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
443
    tupleArray items additionalItems = return (tupleType, code $ additionalCheckers ++ [noBindS tupleParser], tupleTo)
444
      where
445
        items' = flip map (zip [0::Int ..] items) $ \(i, (itemType, itemParser, itemTo)) ->
446
          let simpleParser = [| $(itemParser) (V.unsafeIndex $(varE arr) i) |]
447
          in if i < schemaMinItems schema
448
             then (itemType, simpleParser, [| return . $itemTo |])
449
             else ( conT ''Maybe `appT` itemType
450
                  , [| if V.length $(varE arr) > i then Just <$> $(simpleParser) else return Nothing|]
451
                  , [| maybeToList . fmap $itemTo |]
452
                  )
453
        (additionalCheckers, maybeAdditionalTypeAndParser) = case additionalItems of
454
          Choice1of2 b -> if b
455
            then ([], Nothing)
456
            else ([assertStmt [| V.length $(varE arr) <= $(lift $ length items') |] "no additional items allowed"], Nothing)
457
          Choice2of2 (additionalType, additionalParser, additionalTo) ->
458
            ( []
459
            , Just ( listT `appT` additionalType
460
                   , [| mapM $(additionalParser) (V.toList $ V.drop $(lift $ length items') $(varE arr)) |]
461
                   , [| map $additionalTo |]
462
                   )
463
            )
464
        items'' = items' ++ maybeToList maybeAdditionalTypeAndParser
465
        (_itemTypes, _itemParsers, itemTos) = unzip3 items''
466
        (tupleType, tupleParser, tupleTo) = case items'' of
467
          [(itemType, itemParser, itemTo)] -> (itemType, itemParser, [| Array . V.fromList . $itemTo |])
468
          _ -> let tupleFields = map (mkName . ("f" ++) . show) $ take (length items'') ([1..] :: [Int])
469
                   (a, b) = foldl (\(typ, parser) (itemType, itemParser, _) -> (typ `appT` itemType, [| $(parser) <*> $(itemParser) |]))
470
                     (tupleT $ length items'', [| pure $(conE $ tupleDataName $ length items'') |])
471
                     items''
472
                   to = lamE [tupP $ map varP tupleFields]
473
                             [| Array $ V.fromList $ concat $(listE $ zipWith appE itemTos (map varE tupleFields)) |]
474
               in (a, b, to)
475
476
    monomorphicArray :: TypeQ -> ExpQ -> ExpQ -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
477
    monomorphicArray itemType itemParse itemTo = return
478
      ( listT `appT` itemType
479
      , code [noBindS [| mapM $(itemParse) (V.toList $(varE arr)) |]]
480
      , [| Array . V.fromList . map $itemTo |]
481
      )
482
483
    arr = mkName "arr"
484
    code parser = lambdaPattern (conP 'Array [varP arr])
485
                                (doE $ checkers ++ parser)
486
                                [| fail "not an array" |]
487
    checkMinItems m = assertStmt [| V.length $(varE arr) >= m |] $ "array must have at least " ++ show m ++ " items"
488
    checkMaxItems m = assertStmt [| V.length $(varE arr) <= m |] $ "array must have at most " ++ show m ++ " items"
489
    checkUnique = assertStmt [| vectorUnique $(varE arr) |] "array items must be unique"
490
    checkers = catMaybes
491
      [ if schemaMinItems schema > 0 then Just (checkMinItems $ schemaMinItems schema) else Nothing
492
      , checkMaxItems <$> schemaMaxItems schema
493
      , if schemaUniqueItems schema then Just checkUnique else Nothing
494
      ]
495
496
generateAny :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ, ExpQ)
497
generateAny schema = return (conT ''Value, code, [| id |])
498
  where
499
    val = mkName "val"
500
    code = lamE [varP val]
501
                (doE [ assertValidates (lift schema) (varE val)
502
                     , noBindS [| return $(varE val) |]
503
                     ])