src/Ganeti/THH.hs

{-# LANGUAGE ExistentialQuantification, ParallelListComp, TemplateHaskell #-}

{-| TemplateHaskell helper for Ganeti Haskell code.

As TemplateHaskell require that splices be defined in a separate
module, we combine all the TemplateHaskell functionality that HTools
needs in this module (except the one for unittests).

-}

{-

Copyright (C) 2011, 2012 Google Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module Ganeti.THH ( declareSADT
                  , declareLADT
                  , declareILADT
                  , declareIADT
                  , makeJSONInstance
                  , deCamelCase
                  , genOpID
                  , genAllConstr
                  , genAllOpIDs
                  , PyValue(..)
                  , PyValueEx(..)
                  , OpCodeDescriptor
                  , genOpCode
                  , genStrOfOp
                  , genStrOfKey
                  , genLuxiOp
                  , Field (..)
                  , simpleField
                  , withDoc
                  , defaultField
                  , optionalField
                  , optionalNullSerField
                  , renameField
                  , customField
                  , timeStampFields
                  , uuidFields
                  , serialFields
                  , tagsFields
                  , TagSet
                  , buildObject
                  , buildObjectSerialisation
                  , buildParam
                  , DictObject(..)
                  , genException
                  , excErrMsg
                  ) where

import Control.Monad (liftM)
import Data.Char
import Data.List
import qualified Data.Set as Set
import Language.Haskell.TH

import qualified Text.JSON as JSON
import Text.JSON.Pretty (pp_value)

import Ganeti.JSON

import Data.Maybe
import Data.Functor ((<$>))

-- * Exported types

-- | Class of objects that can be converted to 'JSObject'
-- lists-format.
class DictObject a where
  toDict :: a -> [(String, JSON.JSValue)]

-- | Optional field information.
data OptionalType
  = NotOptional           -- ^ Field is not optional
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
  deriving (Show, Eq)

-- | Serialised field data type.
data Field = Field { fieldName        :: String
                   , fieldType        :: Q Type
                   , fieldRead        :: Maybe (Q Exp)
                   , fieldShow        :: Maybe (Q Exp)
                   , fieldExtraKeys   :: [String]
                   , fieldDefault     :: Maybe (Q Exp)
                   , fieldConstr      :: Maybe String
                   , fieldIsOptional  :: OptionalType
                   , fieldDoc         :: String
                   }

-- | Generates a simple field.
simpleField :: String -> Q Type -> Field
simpleField fname ftype =
  Field { fieldName        = fname
        , fieldType        = ftype
        , fieldRead        = Nothing
        , fieldShow        = Nothing
        , fieldExtraKeys   = []
        , fieldDefault     = Nothing
        , fieldConstr      = Nothing
        , fieldIsOptional  = NotOptional
        , fieldDoc         = ""
        }

withDoc :: String -> Field -> Field
withDoc doc field =
  field { fieldDoc = doc }

-- | Sets the renamed constructor field.
renameField :: String -> Field -> Field
renameField constrName field = field { fieldConstr = Just constrName }

-- | Sets the default value on a field (makes it optional with a
-- default value).
defaultField :: Q Exp -> Field -> Field
defaultField defval field = field { fieldDefault = Just defval }

-- | Marks a field optional (turning its base type into a Maybe).
optionalField :: Field -> Field
optionalField field = field { fieldIsOptional = OptionalOmitNull }

-- | Marks a field optional (turning its base type into a Maybe), but
-- with 'Nothing' serialised explicitly as /null/.
optionalNullSerField :: Field -> Field
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }

-- | Sets custom functions on a field.
customField :: Name      -- ^ The name of the read function
            -> Name      -- ^ The name of the show function
            -> [String]  -- ^ The name of extra field keys
            -> Field     -- ^ The original field
            -> Field     -- ^ Updated field
customField readfn showfn extra field =
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
        , fieldExtraKeys = extra }

-- | Computes the record name for a given field, based on either the
-- string value in the JSON serialisation or the custom named if any
-- exists.
fieldRecordName :: Field -> String
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
  fromMaybe (camelCase name) alias

-- | Computes the preferred variable name to use for the value of this
-- field. If the field has a specific constructor name, then we use a
-- first-letter-lowercased version of that; otherwise, we simply use
-- the field name. See also 'fieldRecordName'.
fieldVariable :: Field -> String
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f

-- | Compute the actual field type (taking into account possible
-- optional status).
actualFieldType :: Field -> Q Type
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
                  | otherwise = t
                  where t = fieldType f

-- | Checks that a given field is not optional (for object types or
-- fields which should not allow this case).
checkNonOptDef :: (Monad m) => Field -> m ()
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
                      , fieldName = name }) =
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
                      , fieldName = name }) =
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
  fail $ "Default field " ++ name ++ " used in parameter declaration"
checkNonOptDef _ = return ()

-- | Produces the expression that will de-serialise a given
-- field. Since some custom parsing functions might need to use the
-- entire object, we do take and pass the object to any custom read
-- functions.
loadFn :: Field   -- ^ The field definition
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
       -> Q Exp   -- ^ The entire object in JSON object format
       -> Q Exp   -- ^ Resulting expression
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr

-- * Common field declarations

-- | Timestamp fields description.
timeStampFields :: [Field]
timeStampFields =
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
    ]

-- | Serial number fields description.
serialFields :: [Field]
serialFields =
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

-- | UUID fields description.
uuidFields :: [Field]
uuidFields = [ simpleField "uuid" [t| String |] ]

-- | Tag set type alias.
type TagSet = Set.Set String

-- | Tag field description.
tagsFields :: [Field]
tagsFields = [ defaultField [| Set.empty |] $
               simpleField "tags" [t| TagSet |] ]

-- * Internal types

-- | A simple field, in constrast to the customisable 'Field' type.
type SimpleField = (String, Q Type)

-- | A definition for a single constructor for a simple object.
type SimpleConstructor = (String, [SimpleField])

-- | A definition for ADTs with simple fields.
type SimpleObject = [SimpleConstructor]

-- | A type alias for an opcode constructor of a regular object.
type OpCodeConstructor = (String, Q Type, String, [Field], String)

-- | A type alias for a Luxi constructor of a regular object.
type LuxiConstructor = (String, [Field])

-- * Helper functions

-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
-- aaToRaw@.
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

-- | Ensure first letter is uppercase.
--
-- Used to convert constructor name to component
ensureUpper :: String -> String
ensureUpper [] = []
ensureUpper (x:xs) = toUpper x:xs

-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
showJSONE = varE 'JSON.showJSON

-- | makeObj as an expression, for reuse.
makeObjE :: Q Exp
makeObjE = varE 'JSON.makeObj

-- | fromObj (Ganeti specific) as an expression, for reuse.
fromObjE :: Q Exp
fromObjE = varE 'fromObj

-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower

-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower

-- | Converts a name to it's varE\/litE representations.
reprE :: Either String Name -> Q Exp
reprE = either stringE varE

-- | Smarter function application.
--
-- This does simply f x, except that if is 'id', it will skip it, in
-- order to generate more readable code when using -ddump-splices.
appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
          | otherwise = AppE f x

-- | Builds a field for a normal constructor.
buildConsField :: Q Type -> StrictTypeQ
buildConsField ftype = do
  ftype' <- ftype
  return (NotStrict, ftype')

-- | Builds a constructor based on a simple definition (not field-based).
buildSimpleCons :: Name -> SimpleObject -> Q Dec
buildSimpleCons tname cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    fields' <- mapM (buildConsField . snd) fields
                    return $ NormalC (mkName cname) fields') cons
  return $ DataD [] tname [] decl_d [''Show, ''Eq]

-- | Generate the save function for a given type.
genSaveSimpleObj :: Name                            -- ^ Object type
                 -> String                          -- ^ Function name
                 -> SimpleObject                    -- ^ Object definition
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
                 -> Q (Dec, Dec)
genSaveSimpleObj tname sname opdefs fn = do
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
      fname = mkName sname
  cclauses <- mapM fn opdefs
  return $ (SigD fname sigt, FunD fname cclauses)

-- * Template code for simple raw type-equivalent ADTs

-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]

-- | Generates a toRaw function.
--
-- This generates a simple function of the form:
--
-- @
-- nameToRaw :: Name -> /traw/
-- nameToRaw Cons1 = var1
-- nameToRaw Cons2 = \"value2\"
-- @
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToRaw traw fname tname constructors = do
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
  -- the body clauses, matching on the constructor and returning the
  -- raw value
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
                             (normalB (reprE v)) []) constructors
  return [SigD fname sigt, FunD fname clauses]

-- | Generates a fromRaw function.
--
-- The function generated is monadic and can fail parsing the
-- raw value. It is of the form:
--
-- @
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
-- nameFromRaw s | s == var1       = Cons1
--               | s == \"value2\" = Cons2
--               | otherwise = fail /.../
-- @
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
  -- signature of form (Monad m) => String -> m $name
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
  -- clauses for a guarded pattern
  let varp = mkName "s"
      varpe = varE varp
  clauses <- mapM (\(c, v) -> do
                     -- the clause match condition
                     g <- normalG [| $varpe == $(reprE v) |]
                     -- the clause result
                     r <- [| return $(conE (mkName c)) |]
                     return (g, r)) constructors
  -- the otherwise clause (fallback)
  oth_clause <- do
    g <- normalG [| otherwise |]
    r <- [|fail ("Invalid string value for type " ++
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
    return (g, r)
  let fun = FunD fname [Clause [VarP varp]
                        (GuardedB (clauses++[oth_clause])) []]
  return [SigD fname sigt, fun]

-- | Generates a data type from a given raw format.
--
-- The format is expected to multiline. The first line contains the
-- type name, and the rest of the lines must contain two words: the
-- constructor name and then the string representation of the
-- respective constructor.
--
-- The function will generate the data type declaration, and then two
-- functions:
--
-- * /name/ToRaw, which converts the type to a raw type
--
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
--
-- Note that this is basically just a custom show\/read instance,
-- nothing else.
declareADT
  :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
declareADT fn traw sname cons = do
  let name = mkName sname
      ddecl = strADTDecl name (map fst cons)
      -- process cons in the format expected by genToRaw
      cons' = map (\(a, b) -> (a, fn b)) cons
  toraw <- genToRaw traw (toRawName sname) name cons'
  fromraw <- genFromRaw traw (fromRawName sname) name cons'
  return $ ddecl:toraw ++ fromraw

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

declareILADT :: String -> [(String, Int)] -> Q [Dec]
declareILADT sname cons = do
  consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
  consFns <- concat <$> sequence
             [ do sig <- sigD n [t| Int |]
                  let expr = litE (IntegerL (toInteger i))
                  fn <- funD n [clause [] (normalB expr) []]
                  return [sig, fn]
             | n <- consNames
             | (_, i) <- cons ]
  let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
  (consFns ++) <$> declareADT Right ''Int sname cons'

declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT Right ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT Right ''String

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- showJSON = showJSON . /name/ToRaw
-- @
--
-- in an instance JSON /name/ declaration
genShowJSON :: String -> Q Dec
genShowJSON name = do
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
--                Ok s' -> /name/FromRaw s'
--                Error e -> Error /description/
-- @
--
-- in an instance JSON /name/ declaration
genReadJSON :: String -> Q Dec
genReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
               JSON.Ok s' -> $(varE (fromRawName name)) s'
               JSON.Error e ->
                   JSON.Error $ "Can't parse raw value for type " ++
                           $(stringE name) ++ ": " ++ e ++ " from " ++
                           show $(varE s)
           |]
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]

-- | Generates a JSON instance for a given type.
--
-- This assumes that the /name/ToRaw and /name/FromRaw functions
-- have been defined as by the 'declareSADT' function.
makeJSONInstance :: Name -> Q [Dec]
makeJSONInstance name = do
  let base = nameBase name
  showJ <- genShowJSON base
  readJ <- genReadJSON base
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]

-- * Template code for opcodes

-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)

-- | Computes the name of a given constructor.
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

-- | Extract all constructor names from a given type.
reifyConsNames :: Name -> Q [String]
reifyConsNames name = do
  reify_result <- reify name
  case reify_result of
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
                \ type constructor but got '" ++ show o ++ "'"

-- | Builds the generic constructor-to-string function.
--
-- This generates a simple function of the following form:
--
-- @
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
-- @
--
-- This builds a custom list of name\/string pairs and then uses
-- 'genToRaw' to actually generate the function.
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
genConstrToStr trans_fun name fname = do
  cnames <- reifyConsNames name
  let svalues = map (Left . trans_fun) cnames
  genToRaw ''String (mkName fname) name $ zip cnames svalues

-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase

-- | Builds a list with all defined constructor names for a type.
--
-- @
-- vstr :: String
-- vstr = [...]
-- @
--
-- Where the actual values of the string are the constructor names
-- mapped via @trans_fun@.
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
genAllConstr trans_fun name vstr = do
  cnames <- reifyConsNames name
  let svalues = sort $ map trans_fun cnames
      vname = mkName vstr
      sig = SigD vname (AppT ListT (ConT ''String))
      body = NormalB (ListE (map (LitE . StringL) svalues))
  return $ [sig, ValD (VarP vname) body []]

-- | Generates a list of all defined opcode IDs.
genAllOpIDs :: Name -> String -> Q [Dec]
genAllOpIDs = genAllConstr deCamelCase

-- | OpCode parameter (field) type.
type OpParam = (String, Q Type, Q Exp)

-- * Python code generation

-- | Converts Haskell values into Python values
--
-- This is necessary for the default values of opcode parameters and
-- return values.  For example, if a default value or return type is a
-- Data.Map, then it must be shown as a Python dictioanry.
class PyValue a where
  showValue :: a -> String

-- | Encapsulates Python default values
data PyValueEx = forall a. PyValue a => PyValueEx a

instance PyValue PyValueEx where
  showValue (PyValueEx x) = showValue x

-- | Transfers opcode data between the opcode description (through
-- @genOpCode@) and the Python code generation functions.
type OpCodeDescriptor =
  (String, String, String, [String],
   [String], [Maybe PyValueEx], [String], String)

-- | Strips out the module name
--
-- @
-- pyBaseName "Data.Map" = "Map"
-- @
pyBaseName :: String -> String
pyBaseName str =
  case span (/= '.') str of
    (x, []) -> x
    (_, _:x) -> pyBaseName x

-- | Converts a Haskell type name into a Python type name.
--
-- @
-- pyTypename "Bool" = "ht.TBool"
-- @
pyTypeName :: Show a => a -> String
pyTypeName name =
  "ht.T" ++ (case pyBaseName (show name) of
                "()" -> "None"
                "Map" -> "DictOf"
                "Set" -> "SetOf"
                "ListSet" -> "SetOf"
                "Either" -> "Or"
                "GenericContainer" -> "DictOf"
                "JSValue" -> "Any"
                "JSObject" -> "Object"
                str -> str)

-- | Converts a Haskell type into a Python type.
--
-- @
-- pyType [Int] = "ht.TListOf(ht.TInt)"
-- @
pyType :: Type -> Q String
pyType (AppT typ1 typ2) =
  do t <- pyCall typ1 typ2
     return $ t ++ ")"

pyType (ConT name) = return (pyTypeName name)
pyType ListT = return "ht.TListOf"
pyType (TupleT 0) = return "ht.TNone"
pyType (TupleT _) = return "ht.TTupleOf"
pyType typ = error $ "unhandled case for type " ++ show typ
        
-- | Converts a Haskell type application into a Python type.
--
-- @
-- Maybe Int = "ht.TMaybe(ht.TInt)"
-- @
pyCall :: Type -> Type -> Q String
pyCall (AppT typ1 typ2) arg =
  do t <- pyCall typ1 typ2
     targ <- pyType arg
     return $ t ++ ", " ++ targ

pyCall typ1 typ2 =
  do t1 <- pyType typ1
     t2 <- pyType typ2
     return $ t1 ++ "(" ++ t2

-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
-- where @opt@ determines if the converted type is optional (i.e.,
-- Maybe).
--
-- @
-- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
-- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
-- @
pyOptionalType :: Bool -> Type -> Q String
pyOptionalType opt typ
  | opt = do t <- pyType typ
             return $ "ht.TMaybe(" ++ t ++ ")"
  | otherwise = pyType typ

-- | Optionally encapsulates default values in @PyValueEx@.
--
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
-- expression with @Nothing@.
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
maybeApp Nothing _ =
  [| Nothing |]

maybeApp (Just expr) typ =
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]


-- | Generates a Python type according to whether the field is
-- optional
genPyType :: OptionalType -> Q Type -> Q ExpQ
genPyType opt typ =
  do t <- typ
     stringE <$> pyOptionalType (opt /= NotOptional) t

-- | Generates Python types from opcode parameters.
genPyTypes :: [Field] -> Q ExpQ
genPyTypes fs =
  listE <$> mapM (\f -> genPyType (fieldIsOptional f) (fieldType f)) fs

-- | Generates Python default values from opcode parameters.
genPyDefaults :: [Field] -> ExpQ
genPyDefaults fs =
  listE $ map (\f -> maybeApp (fieldDefault f) (fieldType f)) fs

-- | Generates a Haskell function call to "showPyClass" with the
-- necessary information on how to build the Python class string.
pyClass :: OpCodeConstructor -> ExpQ
pyClass (consName, consType, consDoc, consFields, consDscField) =
  do let pyClassVar = varNameE "showPyClass"
         consName' = stringE consName
     consType' <- genPyType NotOptional consType
     let consDoc' = stringE consDoc
         consFieldNames = listE $ map (stringE . fieldName) consFields
         consFieldDocs = listE $ map (stringE . fieldDoc) consFields
     consFieldTypes <- genPyTypes consFields
     let consFieldDefaults = genPyDefaults consFields
     [| ($consName',
         $consType',
         $consDoc',
         $consFieldNames,
         $consFieldTypes,
         $consFieldDefaults,
         $consFieldDocs,
         consDscField) |]

-- | Generates a function called "pyClasses" that holds the list of
-- all the opcode descriptors necessary for generating the Python
-- opcodes.
pyClasses :: [OpCodeConstructor] -> Q [Dec]
pyClasses cons =
  do let name = mkName "pyClasses"
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
     fn <- FunD name <$> (:[]) <$> declClause cons
     return [sig, fn]
  where declClause c =
          clause [] (normalB (ListE <$> mapM pyClass c)) []

-- | Converts from an opcode constructor to a Luxi constructor.
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)

-- | Generates the OpCode data type.
--
-- This takes an opcode logical definition, and builds both the
-- datatype and the JSON serialisation out of it. We can't use a
-- generic serialisation since we need to be compatible with Ganeti's
-- own, so we have a few quirks to work around.
genOpCode :: String              -- ^ Type name to use
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
          -> Q [Dec]
genOpCode name cons = do
  let tname = mkName name
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
                    -- we only need the type of the field, without Q
                    fields' <- mapM (fieldTypeInfo "op") fields
                    return $ RecC (mkName cname) fields')
            cons
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
               (map opcodeConsToLuxiCons cons) saveConstructor True
  (loadsig, loadfn) <- genLoadOpCode cons
  pyDecls <- pyClasses cons
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls

-- | Generates the function pattern returning the list of fields for a
-- given constructor.
genOpConsFields :: OpCodeConstructor -> Clause
genOpConsFields (cname, _, _, fields, _) =
  let op_id = deCamelCase cname
      fvals = map (LitE . StringL) . sort . nub $
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []

-- | Generates a list of all fields of an opcode constructor.
genAllOpFields  :: String              -- ^ Function name
                -> [OpCodeConstructor] -- ^ Object definition
                -> (Dec, Dec)
genAllOpFields sname opdefs =
  let cclauses = map genOpConsFields opdefs
      other = Clause [WildP] (NormalB (ListE [])) []
      fname = mkName sname
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
  in (SigD fname sigt, FunD fname (cclauses++[other]))

-- | Generates the \"save\" clause for an entire opcode constructor.
--
-- This matches the opcode with variables named the same as the
-- constructor fields (just so that the spliced in code looks nicer),
-- and passes those name plus the parameter definition to 'saveObjectField'.
saveConstructor :: LuxiConstructor -- ^ The constructor
                -> Q Clause        -- ^ Resulting clause
saveConstructor (sname, fields) = do
  let cname = mkName sname
  fnames <- mapM (newName . fieldVariable) fields
  let pat = conP cname (map varP fnames)
  let felems = map (uncurry saveObjectField) (zip fnames fields)
      -- now build the OP_ID serialisation
      opid = [| [( $(stringE "OP_ID"),
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
      flist' = [| concat $flist |]
  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
genSaveOpCode :: Name                          -- ^ Object ype
              -> String                        -- ^ To 'JSValue' function name
              -> String                        -- ^ To 'JSObject' function name
              -> [LuxiConstructor]             -- ^ Object definition
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
              -> Bool                          -- ^ Whether to generate
                                               -- obj or just a
                                               -- list\/tuple of values
              -> Q [Dec]
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
  tdclauses <- mapM fn opdefs
  let typecon = ConT tname
      jvalname = mkName jvalstr
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
      tdname = mkName tdstr
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
  jvalclause <- if gen_object
                  then [| $makeObjE . $(varE tdname) |]
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
  return [ SigD tdname tdsig
         , FunD tdname tdclauses
         , SigD jvalname jvalsig
         , ValD (VarP jvalname) (NormalB jvalclause) []]

-- | Generates load code for a single constructor of the opcode data type.
loadConstructor :: OpCodeConstructor -> Q Exp
loadConstructor (sname, _, _, fields, _) = do
  let name = mkName sname
  fbinds <- mapM loadObjectField fields
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
  return $ DoE fstmts'

-- | Generates the loadOpCode function.
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
genLoadOpCode opdefs = do
  let fname = mkName "loadOpCode"
      arg1 = mkName "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
  -- the match results (per-constructor blocks)
  mexps <- mapM loadConstructor opdefs
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
  let mpats = map (\(me, (consName, _, _, _, _)) ->
                       let mp = LitP . StringL . deCamelCase $ consName
                       in Match mp (NormalB me) []
                  ) $ zip mexps opdefs
      defmatch = Match WildP (NormalB fails) []
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
      body = DoE [st1, st2, cst]
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])

-- * Template code for luxi

-- | Constructor-to-string for LuxiOp.
genStrOfOp :: Name -> String -> Q [Dec]
genStrOfOp = genConstrToStr id

-- | Constructor-to-string for MsgKeys.
genStrOfKey :: Name -> String -> Q [Dec]
genStrOfKey = genConstrToStr ensureLower

-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
-- datatype and the function transforming the arguments to JSON.
-- We can't use anything less generic, because the way different
-- operations are serialized differs on both parameter- and top-level.
--
-- There are two things to be defined for each parameter:
--
-- * name
--
-- * type
--
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
genLuxiOp name cons = do
  let tname = mkName name
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
                    fields' <- mapM actualFieldType fields
                    let fields'' = zip (repeat NotStrict) fields'
                    return $ NormalC (mkName cname) fields'')
            cons
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
               cons saveLuxiConstructor False
  req_defs <- declareSADT "LuxiReq" .
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
                  cons
  return $ declD:save_decs ++ req_defs

-- | Generates the \"save\" clause for entire LuxiOp constructor.
saveLuxiConstructor :: LuxiConstructor -> Q Clause
saveLuxiConstructor (sname, fields) = do
  let cname = mkName sname
  fnames <- mapM (newName . fieldVariable) fields
  let pat = conP cname (map varP fnames)
  let felems = map (uncurry saveObjectField) (zip fnames fields)
      flist = [| concat $(listE felems) |]
  clause [pat] (normalB flist) []

-- * "Objects" functionality

-- | Extract the field's declaration from a Field structure.
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
fieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
  return (n, NotStrict, t)

-- | Build an object declaration.
buildObject :: String -> String -> [Field] -> Q [Dec]
buildObject sname field_pfx fields = do
  let name = mkName sname
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
  let decl_d = RecC name fields_d
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
  ser_decls <- buildObjectSerialisation sname fields
  return $ declD:ser_decls

-- | Generates an object definition: data type and its JSON instance.
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
buildObjectSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject saveObjectField sname fields
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
                 [rdjson, shjson]
  return $ savedecls ++ [loadsig, loadfn, instdecl]

-- | The toDict function name for a given type.
toDictName :: String -> Name
toDictName sname = mkName ("toDict" ++ sname)

-- | Generates the save object functionality.
genSaveObject :: (Name -> Field -> Q Exp)
              -> String -> [Field] -> Q [Dec]
genSaveObject save_fn sname fields = do
  let name = mkName sname
  fnames <- mapM (newName . fieldVariable) fields
  let pat = conP name (map varP fnames)
  let tdname = toDictName sname
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]

  let felems = map (uncurry save_fn) (zip fnames fields)
      flist = listE felems
      -- and finally convert all this to a json object
      tdlist = [| concat $flist |]
      iname = mkName "i"
  tclause <- clause [pat] (normalB tdlist) []
  cclause <- [| $makeObjE . $(varE tdname) |]
  let fname = mkName ("save" ++ sname)
  sigt <- [t| $(conT name) -> JSON.JSValue |]
  return [SigD tdname tdsigt, FunD tdname [tclause],
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]

-- | Generates the code for saving an object's field, handling the
-- various types of fields that we have.
saveObjectField :: Name -> Field -> Q Exp
saveObjectField fvar field =
  case fieldIsOptional field of
    OptionalOmitNull -> [| case $(varE fvar) of
                             Nothing -> []
                             Just v  -> [( $nameE, JSON.showJSON v )]
                         |]
    OptionalSerializeNull -> [| case $(varE fvar) of
                                  Nothing -> [( $nameE, JSON.JSNull )]
                                  Just v  -> [( $nameE, JSON.showJSON v )]
                              |]
    NotOptional ->
      case fieldShow field of
        -- Note: the order of actual:extra is important, since for
        -- some serialisation types (e.g. Luxi), we use tuples
        -- (positional info) rather than object (name info)
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
        Just fn -> [| let (actual, extra) = $fn $fvarE
                      in ($nameE, JSON.showJSON actual):extra
                    |]
  where nameE = stringE (fieldName field)
        fvarE = varE fvar

-- | Generates the showJSON clause for a given object name.
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]

-- | Generates the load object functionality.
genLoadObject :: (Field -> Q (Name, Stmt))
              -> String -> [Field] -> Q (Dec, Dec)
genLoadObject load_fn sname fields = do
  let name = mkName sname
      funname = mkName $ "load" ++ sname
      arg1 = mkName $ if null fields then "_" else "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
  fbinds <- mapM load_fn fields
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
      -- FIXME: should we require an empty dict for an empty type?
      -- this allows any JSValue right now
      fstmts' = if null fields
                  then retstmt
                  else st1:fstmts ++ retstmt
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
  return $ (SigD funname sigt,
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

-- | Generates code for loading an object's field.
loadObjectField :: Field -> Q (Name, Stmt)
loadObjectField field = do
  let name = fieldVariable field
  fvar <- newName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE (fieldName field)
      loadexp =
        if fieldIsOptional field /= NotOptional
          -- we treat both optional types the same, since
          -- 'maybeFromObj' can deal with both missing and null values
          -- appropriately (the same)
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
          else case fieldDefault field of
                 Just defv ->
                   [| $(varE 'fromObjWithDefault) $objvar
                      $objfield $defv |]
                 Nothing -> [| $fromObjE $objvar $objfield |]
  bexp <- loadFn field loadexp objvar

  return (fvar, BindS (VarP fvar) bexp)

-- | Builds the readJSON instance for a given object name.
objectReadJSON :: String -> Q Dec
objectReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
               JSON.Error e ->
                 JSON.Error $ "Can't parse value for type " ++
                       $(stringE name) ++ ": " ++ e
           |]
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]

-- * Inheritable parameter tables implementation

-- | Compute parameter type names.
paramTypeNames :: String -> (String, String)
paramTypeNames root = ("Filled"  ++ root ++ "Params",
                       "Partial" ++ root ++ "Params")

-- | Compute information about the type of a parameter field.
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
paramFieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (++ "P") . (field_pfx ++) .
          fieldRecordName $ fd
  return (n, NotStrict, AppT (ConT ''Maybe) t)

-- | Build a parameter declaration.
--
-- This function builds two different data structures: a /filled/ one,
-- in which all fields are required, and a /partial/ one, in which all
-- fields are optional. Due to the current record syntax issues, the
-- fields need to be named differrently for the two structures, so the
-- partial ones get a /P/ suffix.
buildParam :: String -> String -> [Field] -> Q [Dec]
buildParam sname field_pfx fields = do
  let (sname_f, sname_p) = paramTypeNames sname
      name_f = mkName sname_f
      name_p = mkName sname_p
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
  let decl_f = RecC name_f fields_f
      decl_p = RecC name_p fields_p
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
  ser_decls_f <- buildObjectSerialisation sname_f fields
  ser_decls_p <- buildPParamSerialisation sname_p fields
  fill_decls <- fillParam sname field_pfx fields
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
           buildParamAllFields sname fields ++
           buildDictObjectInst name_f sname_f

-- | Builds a list of all fields of a parameter.
buildParamAllFields :: String -> [Field] -> [Dec]
buildParamAllFields sname fields =
  let vname = mkName ("all" ++ sname ++ "ParamFields")
      sig = SigD vname (AppT ListT (ConT ''String))
      val = ListE $ map (LitE . StringL . fieldName) fields
  in [sig, ValD (VarP vname) (NormalB val) []]

-- | Builds the 'DictObject' instance for a filled parameter.
buildDictObjectInst :: Name -> String -> [Dec]
buildDictObjectInst name sname =
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]

-- | Generates the serialisation for a partial parameter.
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
buildPParamSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject savePParamField sname fields
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
                 [rdjson, shjson]
  return $ savedecls ++ [loadsig, loadfn, instdecl]

-- | Generates code to save an optional parameter field.
savePParamField :: Name -> Field -> Q Exp
savePParamField fvar field = do
  checkNonOptDef field
  let actualVal = mkName "v"
  normalexpr <- saveObjectField actualVal field
  -- we have to construct the block here manually, because we can't
  -- splice-in-splice
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
                                       (NormalB (ConE '[])) []
                             , Match (ConP 'Just [VarP actualVal])
                                       (NormalB normalexpr) []
                             ]

-- | Generates code to load an optional parameter field.
loadPParamField :: Field -> Q (Name, Stmt)
loadPParamField field = do
  checkNonOptDef field
  let name = fieldName field
  fvar <- newName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE name
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
  bexp <- loadFn field loadexp objvar
  return (fvar, BindS (VarP fvar) bexp)

-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
buildFromMaybe :: String -> Q Dec
buildFromMaybe fname =
  valD (varP (mkName $ "n_" ++ fname))
         (normalB [| $(varE 'fromMaybe)
                        $(varNameE $ "f_" ++ fname)
                        $(varNameE $ "p_" ++ fname) |]) []

-- | Builds a function that executes the filling of partial parameter
-- from a full copy (similar to Python's fillDict).
fillParam :: String -> String -> [Field] -> Q [Dec]
fillParam sname field_pfx fields = do
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
      (sname_f, sname_p) = paramTypeNames sname
      oname_f = "fobj"
      oname_p = "pobj"
      name_f = mkName sname_f
      name_p = mkName sname_p
      fun_name = mkName $ "fill" ++ sname ++ "Params"
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_f) []
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_p) []
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
                $ map (mkName . ("n_" ++)) fnames
  le_new <- mapM buildFromMaybe fnames
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
  let sig = SigD fun_name funt
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
      fun = FunD fun_name [fclause]
  return [sig, fun]

-- * Template code for exceptions

-- | Exception simple error message field.
excErrMsg :: (String, Q Type)
excErrMsg = ("errMsg", [t| String |])

-- | Builds an exception type definition.
genException :: String                  -- ^ Name of new type
             -> SimpleObject -- ^ Constructor name and parameters
             -> Q [Dec]
genException name cons = do
  let tname = mkName name
  declD <- buildSimpleCons tname cons
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
                         uncurry saveExcCons
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
  return [declD, loadsig, loadfn, savesig, savefn]

-- | Generates the \"save\" clause for an entire exception constructor.
--
-- This matches the exception with variables named the same as the
-- constructor fields (just so that the spliced in code looks nicer),
-- and calls showJSON on it.
saveExcCons :: String        -- ^ The constructor name
            -> [SimpleField] -- ^ The parameter definitions for this
                             -- constructor
            -> Q Clause      -- ^ Resulting clause
saveExcCons sname fields = do
  let cname = mkName sname
  fnames <- mapM (newName . fst) fields
  let pat = conP cname (map varP fnames)
      felems = if null fnames
                 then conE '() -- otherwise, empty list has no type
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
  let tup = tupE [ litE (stringL sname), felems ]
  clause [pat] (normalB [| JSON.showJSON $tup |]) []

-- | Generates load code for a single constructor of an exception.
--
-- Generates the code (if there's only one argument, we will use a
-- list, not a tuple:
--
-- @
-- do
--  (x1, x2, ...) <- readJSON args
--  return $ Cons x1 x2 ...
-- @
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
loadExcConstructor inname sname fields = do
  let name = mkName sname
  f_names <- mapM (newName . fst) fields
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
  let binds = case f_names of
                [x] -> BindS (ListP [VarP x])
                _   -> BindS (TupP (map VarP f_names))
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]

{-| Generates the loadException function.

This generates a quite complicated function, along the lines of:

@
loadFn (JSArray [JSString name, args]) = case name of
   "A1" -> do
     (x1, x2, ...) <- readJSON args
     return $ A1 x1 x2 ...
   "a2" -> ...
   s -> fail $ "Unknown exception" ++ s
loadFn v = fail $ "Expected array but got " ++ show v
@
-}
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
genLoadExc tname sname opdefs = do
  let fname = mkName sname
  exc_name <- newName "name"
  exc_args <- newName "args"
  exc_else <- newName "s"
  arg_else <- newName "v"
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
  -- default match for unknown exception name
  let defmatch = Match (VarP exc_else) (NormalB fails) []
  -- the match results (per-constructor blocks)
  str_matches <-
    mapM (\(s, params) -> do
            body_exp <- loadExcConstructor exc_args s params
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
    opdefs
  -- the first function clause; we can't use [| |] due to TH
  -- limitations, so we have to build the AST by hand
  let clause1 = Clause [ConP 'JSON.JSArray
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
                                            VarP exc_args]]]
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
                                        (VarE exc_name))
                          (str_matches ++ [defmatch]))) []
  -- the fail expression for the second function clause
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
                |]
  -- the second function clause
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
  return $ (SigD fname sigt, FunD fname [clause1, clause2])