Revision e82d1e98 src/Ganeti/THH.hs

b/src/Ganeti/THH.hs
30 30
-}
31 31

  
32 32
module Ganeti.THH ( declareSADT
33
                  , declareLADT
33 34
                  , declareIADT
34 35
                  , makeJSONInstance
35 36
                  , deCamelCase
......
360 361
--               | s == \"value2\" = Cons2
361 362
--               | otherwise = fail /.../
362 363
-- @
363
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
364
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
364 365
genFromRaw traw fname tname constructors = do
365 366
  -- signature of form (Monad m) => String -> m $name
366 367
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
......
369 370
      varpe = varE varp
370 371
  clauses <- mapM (\(c, v) -> do
371 372
                     -- the clause match condition
372
                     g <- normalG [| $varpe == $(varE v) |]
373
                     g <- normalG [| $varpe == $(reprE v) |]
373 374
                     -- the clause result
374 375
                     r <- [| return $(conE (mkName c)) |]
375 376
                     return (g, r)) constructors
......
399 400
--
400 401
-- Note that this is basically just a custom show\/read instance,
401 402
-- nothing else.
402
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
403
declareADT traw sname cons = do
403
declareADT
404
  :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
405
declareADT fn traw sname cons = do
404 406
  let name = mkName sname
405 407
      ddecl = strADTDecl name (map fst cons)
406 408
      -- process cons in the format expected by genToRaw
407
      cons' = map (\(a, b) -> (a, Right b)) cons
409
      cons' = map (\(a, b) -> (a, fn b)) cons
408 410
  toraw <- genToRaw traw (toRawName sname) name cons'
409
  fromraw <- genFromRaw traw (fromRawName sname) name cons
411
  fromraw <- genFromRaw traw (fromRawName sname) name cons'
410 412
  return $ ddecl:toraw ++ fromraw
411 413

  
414
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
415
declareLADT = declareADT Left
416

  
412 417
declareIADT :: String -> [(String, Name)] -> Q [Dec]
413
declareIADT = declareADT ''Int
418
declareIADT = declareADT Right ''Int
414 419

  
415 420
declareSADT :: String -> [(String, Name)] -> Q [Dec]
416
declareSADT = declareADT ''String
421
declareSADT = declareADT Right ''String
417 422

  
418 423
-- | Creates the showJSON member of a JSON instance declaration.
419 424
--

Also available in: Unified diff