Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 9d049fb4

History | View | Annotate | Download (46.9 kB)

1 a48daa87 Jose A. Lopes
{-# LANGUAGE ExistentialQuantification, ParallelListComp, TemplateHaskell #-}
2 e9aaa3c6 Iustin Pop
3 18049dad Iustin Pop
{-| TemplateHaskell helper for Ganeti Haskell code.
4 e9aaa3c6 Iustin Pop
5 e9aaa3c6 Iustin Pop
As TemplateHaskell require that splices be defined in a separate
6 e9aaa3c6 Iustin Pop
module, we combine all the TemplateHaskell functionality that HTools
7 e9aaa3c6 Iustin Pop
needs in this module (except the one for unittests).
8 e9aaa3c6 Iustin Pop
9 e9aaa3c6 Iustin Pop
-}
10 e9aaa3c6 Iustin Pop
11 e9aaa3c6 Iustin Pop
{-
12 e9aaa3c6 Iustin Pop
13 b1e81520 Iustin Pop
Copyright (C) 2011, 2012 Google Inc.
14 e9aaa3c6 Iustin Pop
15 e9aaa3c6 Iustin Pop
This program is free software; you can redistribute it and/or modify
16 e9aaa3c6 Iustin Pop
it under the terms of the GNU General Public License as published by
17 e9aaa3c6 Iustin Pop
the Free Software Foundation; either version 2 of the License, or
18 e9aaa3c6 Iustin Pop
(at your option) any later version.
19 e9aaa3c6 Iustin Pop
20 e9aaa3c6 Iustin Pop
This program is distributed in the hope that it will be useful, but
21 e9aaa3c6 Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
22 e9aaa3c6 Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
23 e9aaa3c6 Iustin Pop
General Public License for more details.
24 e9aaa3c6 Iustin Pop
25 e9aaa3c6 Iustin Pop
You should have received a copy of the GNU General Public License
26 e9aaa3c6 Iustin Pop
along with this program; if not, write to the Free Software
27 e9aaa3c6 Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 e9aaa3c6 Iustin Pop
02110-1301, USA.
29 e9aaa3c6 Iustin Pop
30 e9aaa3c6 Iustin Pop
-}
31 e9aaa3c6 Iustin Pop
32 b20cbf06 Iustin Pop
module Ganeti.THH ( declareSADT
33 e82d1e98 Jose A. Lopes
                  , declareLADT
34 a48daa87 Jose A. Lopes
                  , declareILADT
35 260d0bda Agata Murawska
                  , declareIADT
36 e9aaa3c6 Iustin Pop
                  , makeJSONInstance
37 d34c79b6 Jose A. Lopes
                  , deCamelCase
38 6111e296 Iustin Pop
                  , genOpID
39 471b6c46 Iustin Pop
                  , genAllConstr
40 a583ec5d Iustin Pop
                  , genAllOpIDs
41 34af39e8 Jose A. Lopes
                  , PyValue(..)
42 34af39e8 Jose A. Lopes
                  , PyValueEx(..)
43 34af39e8 Jose A. Lopes
                  , OpCodeDescriptor
44 12c19659 Iustin Pop
                  , genOpCode
45 a0090487 Agata Murawska
                  , genStrOfOp
46 a0090487 Agata Murawska
                  , genStrOfKey
47 a0090487 Agata Murawska
                  , genLuxiOp
48 34af39e8 Jose A. Lopes
                  , Field (..)
49 879273e3 Iustin Pop
                  , simpleField
50 34af39e8 Jose A. Lopes
                  , withDoc
51 879273e3 Iustin Pop
                  , defaultField
52 879273e3 Iustin Pop
                  , optionalField
53 9b156883 Iustin Pop
                  , optionalNullSerField
54 879273e3 Iustin Pop
                  , renameField
55 879273e3 Iustin Pop
                  , customField
56 879273e3 Iustin Pop
                  , timeStampFields
57 879273e3 Iustin Pop
                  , uuidFields
58 879273e3 Iustin Pop
                  , serialFields
59 02cccecd Iustin Pop
                  , tagsFields
60 9924d61e Iustin Pop
                  , TagSet
61 879273e3 Iustin Pop
                  , buildObject
62 879273e3 Iustin Pop
                  , buildObjectSerialisation
63 879273e3 Iustin Pop
                  , buildParam
64 2af78b97 Iustin Pop
                  , DictObject(..)
65 ef3ad027 Iustin Pop
                  , genException
66 ef3ad027 Iustin Pop
                  , excErrMsg
67 e9aaa3c6 Iustin Pop
                  ) where
68 e9aaa3c6 Iustin Pop
69 4b71f30c Iustin Pop
import Control.Monad (liftM)
70 e9aaa3c6 Iustin Pop
import Data.Char
71 6111e296 Iustin Pop
import Data.List
72 02cccecd Iustin Pop
import qualified Data.Set as Set
73 e9aaa3c6 Iustin Pop
import Language.Haskell.TH
74 e9aaa3c6 Iustin Pop
75 e9aaa3c6 Iustin Pop
import qualified Text.JSON as JSON
76 ef3ad027 Iustin Pop
import Text.JSON.Pretty (pp_value)
77 e9aaa3c6 Iustin Pop
78 32a569fe Iustin Pop
import Ganeti.JSON
79 32a569fe Iustin Pop
80 34af39e8 Jose A. Lopes
import Data.Maybe
81 34af39e8 Jose A. Lopes
import Data.Functor ((<$>))
82 34af39e8 Jose A. Lopes
83 879273e3 Iustin Pop
-- * Exported types
84 879273e3 Iustin Pop
85 2af78b97 Iustin Pop
-- | Class of objects that can be converted to 'JSObject'
86 2af78b97 Iustin Pop
-- lists-format.
87 2af78b97 Iustin Pop
class DictObject a where
88 2af78b97 Iustin Pop
  toDict :: a -> [(String, JSON.JSValue)]
89 2af78b97 Iustin Pop
90 9b156883 Iustin Pop
-- | Optional field information.
91 9b156883 Iustin Pop
data OptionalType
92 9b156883 Iustin Pop
  = NotOptional           -- ^ Field is not optional
93 9b156883 Iustin Pop
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
94 9b156883 Iustin Pop
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
95 9b156883 Iustin Pop
  deriving (Show, Eq)
96 9b156883 Iustin Pop
97 879273e3 Iustin Pop
-- | Serialised field data type.
98 879273e3 Iustin Pop
data Field = Field { fieldName        :: String
99 879273e3 Iustin Pop
                   , fieldType        :: Q Type
100 879273e3 Iustin Pop
                   , fieldRead        :: Maybe (Q Exp)
101 879273e3 Iustin Pop
                   , fieldShow        :: Maybe (Q Exp)
102 fa10983e Iustin Pop
                   , fieldExtraKeys   :: [String]
103 879273e3 Iustin Pop
                   , fieldDefault     :: Maybe (Q Exp)
104 879273e3 Iustin Pop
                   , fieldConstr      :: Maybe String
105 9b156883 Iustin Pop
                   , fieldIsOptional  :: OptionalType
106 34af39e8 Jose A. Lopes
                   , fieldDoc         :: String
107 879273e3 Iustin Pop
                   }
108 879273e3 Iustin Pop
109 879273e3 Iustin Pop
-- | Generates a simple field.
110 879273e3 Iustin Pop
simpleField :: String -> Q Type -> Field
111 879273e3 Iustin Pop
simpleField fname ftype =
112 879273e3 Iustin Pop
  Field { fieldName        = fname
113 879273e3 Iustin Pop
        , fieldType        = ftype
114 879273e3 Iustin Pop
        , fieldRead        = Nothing
115 879273e3 Iustin Pop
        , fieldShow        = Nothing
116 fa10983e Iustin Pop
        , fieldExtraKeys   = []
117 879273e3 Iustin Pop
        , fieldDefault     = Nothing
118 879273e3 Iustin Pop
        , fieldConstr      = Nothing
119 9b156883 Iustin Pop
        , fieldIsOptional  = NotOptional
120 34af39e8 Jose A. Lopes
        , fieldDoc         = ""
121 879273e3 Iustin Pop
        }
122 879273e3 Iustin Pop
123 34af39e8 Jose A. Lopes
withDoc :: String -> Field -> Field
124 34af39e8 Jose A. Lopes
withDoc doc field =
125 34af39e8 Jose A. Lopes
  field { fieldDoc = doc }
126 34af39e8 Jose A. Lopes
127 879273e3 Iustin Pop
-- | Sets the renamed constructor field.
128 879273e3 Iustin Pop
renameField :: String -> Field -> Field
129 879273e3 Iustin Pop
renameField constrName field = field { fieldConstr = Just constrName }
130 879273e3 Iustin Pop
131 879273e3 Iustin Pop
-- | Sets the default value on a field (makes it optional with a
132 879273e3 Iustin Pop
-- default value).
133 879273e3 Iustin Pop
defaultField :: Q Exp -> Field -> Field
134 879273e3 Iustin Pop
defaultField defval field = field { fieldDefault = Just defval }
135 879273e3 Iustin Pop
136 879273e3 Iustin Pop
-- | Marks a field optional (turning its base type into a Maybe).
137 879273e3 Iustin Pop
optionalField :: Field -> Field
138 9b156883 Iustin Pop
optionalField field = field { fieldIsOptional = OptionalOmitNull }
139 9b156883 Iustin Pop
140 9b156883 Iustin Pop
-- | Marks a field optional (turning its base type into a Maybe), but
141 9b156883 Iustin Pop
-- with 'Nothing' serialised explicitly as /null/.
142 9b156883 Iustin Pop
optionalNullSerField :: Field -> Field
143 9b156883 Iustin Pop
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
144 879273e3 Iustin Pop
145 879273e3 Iustin Pop
-- | Sets custom functions on a field.
146 fa10983e Iustin Pop
customField :: Name      -- ^ The name of the read function
147 fa10983e Iustin Pop
            -> Name      -- ^ The name of the show function
148 fa10983e Iustin Pop
            -> [String]  -- ^ The name of extra field keys
149 fa10983e Iustin Pop
            -> Field     -- ^ The original field
150 fa10983e Iustin Pop
            -> Field     -- ^ Updated field
151 fa10983e Iustin Pop
customField readfn showfn extra field =
152 fa10983e Iustin Pop
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
153 fa10983e Iustin Pop
        , fieldExtraKeys = extra }
154 879273e3 Iustin Pop
155 12e8358c Iustin Pop
-- | Computes the record name for a given field, based on either the
156 12e8358c Iustin Pop
-- string value in the JSON serialisation or the custom named if any
157 12e8358c Iustin Pop
-- exists.
158 879273e3 Iustin Pop
fieldRecordName :: Field -> String
159 879273e3 Iustin Pop
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
160 12e8358c Iustin Pop
  fromMaybe (camelCase name) alias
161 879273e3 Iustin Pop
162 a1505857 Iustin Pop
-- | Computes the preferred variable name to use for the value of this
163 a1505857 Iustin Pop
-- field. If the field has a specific constructor name, then we use a
164 a1505857 Iustin Pop
-- first-letter-lowercased version of that; otherwise, we simply use
165 a1505857 Iustin Pop
-- the field name. See also 'fieldRecordName'.
166 879273e3 Iustin Pop
fieldVariable :: Field -> String
167 a1505857 Iustin Pop
fieldVariable f =
168 a1505857 Iustin Pop
  case (fieldConstr f) of
169 a1505857 Iustin Pop
    Just name -> ensureLower name
170 d8cb8e13 Iustin Pop
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
171 879273e3 Iustin Pop
172 9b156883 Iustin Pop
-- | Compute the actual field type (taking into account possible
173 9b156883 Iustin Pop
-- optional status).
174 879273e3 Iustin Pop
actualFieldType :: Field -> Q Type
175 9b156883 Iustin Pop
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
176 879273e3 Iustin Pop
                  | otherwise = t
177 879273e3 Iustin Pop
                  where t = fieldType f
178 879273e3 Iustin Pop
179 9b156883 Iustin Pop
-- | Checks that a given field is not optional (for object types or
180 9b156883 Iustin Pop
-- fields which should not allow this case).
181 879273e3 Iustin Pop
checkNonOptDef :: (Monad m) => Field -> m ()
182 9b156883 Iustin Pop
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
183 9b156883 Iustin Pop
                      , fieldName = name }) =
184 9b156883 Iustin Pop
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
185 9b156883 Iustin Pop
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
186 9b156883 Iustin Pop
                      , fieldName = name }) =
187 879273e3 Iustin Pop
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
188 879273e3 Iustin Pop
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
189 879273e3 Iustin Pop
  fail $ "Default field " ++ name ++ " used in parameter declaration"
190 879273e3 Iustin Pop
checkNonOptDef _ = return ()
191 879273e3 Iustin Pop
192 1c7bda0a Iustin Pop
-- | Produces the expression that will de-serialise a given
193 1c7bda0a Iustin Pop
-- field. Since some custom parsing functions might need to use the
194 1c7bda0a Iustin Pop
-- entire object, we do take and pass the object to any custom read
195 1c7bda0a Iustin Pop
-- functions.
196 1c7bda0a Iustin Pop
loadFn :: Field   -- ^ The field definition
197 1c7bda0a Iustin Pop
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
198 1c7bda0a Iustin Pop
       -> Q Exp   -- ^ The entire object in JSON object format
199 1c7bda0a Iustin Pop
       -> Q Exp   -- ^ Resulting expression
200 1c7bda0a Iustin Pop
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
201 1c7bda0a Iustin Pop
loadFn _ expr _ = expr
202 879273e3 Iustin Pop
203 879273e3 Iustin Pop
-- * Common field declarations
204 879273e3 Iustin Pop
205 12e8358c Iustin Pop
-- | Timestamp fields description.
206 879273e3 Iustin Pop
timeStampFields :: [Field]
207 879273e3 Iustin Pop
timeStampFields =
208 879273e3 Iustin Pop
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
209 879273e3 Iustin Pop
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
210 879273e3 Iustin Pop
    ]
211 879273e3 Iustin Pop
212 12e8358c Iustin Pop
-- | Serial number fields description.
213 879273e3 Iustin Pop
serialFields :: [Field]
214 879273e3 Iustin Pop
serialFields =
215 879273e3 Iustin Pop
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
216 879273e3 Iustin Pop
217 12e8358c Iustin Pop
-- | UUID fields description.
218 879273e3 Iustin Pop
uuidFields :: [Field]
219 879273e3 Iustin Pop
uuidFields = [ simpleField "uuid" [t| String |] ]
220 879273e3 Iustin Pop
221 9924d61e Iustin Pop
-- | Tag set type alias.
222 9924d61e Iustin Pop
type TagSet = Set.Set String
223 9924d61e Iustin Pop
224 02cccecd Iustin Pop
-- | Tag field description.
225 02cccecd Iustin Pop
tagsFields :: [Field]
226 02cccecd Iustin Pop
tagsFields = [ defaultField [| Set.empty |] $
227 9924d61e Iustin Pop
               simpleField "tags" [t| TagSet |] ]
228 02cccecd Iustin Pop
229 2e202a9b Iustin Pop
-- * Internal types
230 2e202a9b Iustin Pop
231 2e202a9b Iustin Pop
-- | A simple field, in constrast to the customisable 'Field' type.
232 2e202a9b Iustin Pop
type SimpleField = (String, Q Type)
233 2e202a9b Iustin Pop
234 2e202a9b Iustin Pop
-- | A definition for a single constructor for a simple object.
235 2e202a9b Iustin Pop
type SimpleConstructor = (String, [SimpleField])
236 2e202a9b Iustin Pop
237 2e202a9b Iustin Pop
-- | A definition for ADTs with simple fields.
238 2e202a9b Iustin Pop
type SimpleObject = [SimpleConstructor]
239 2e202a9b Iustin Pop
240 34af39e8 Jose A. Lopes
-- | A type alias for an opcode constructor of a regular object.
241 34af39e8 Jose A. Lopes
type OpCodeConstructor = (String, Q Type, String, [Field], String)
242 34af39e8 Jose A. Lopes
243 34af39e8 Jose A. Lopes
-- | A type alias for a Luxi constructor of a regular object.
244 34af39e8 Jose A. Lopes
type LuxiConstructor = (String, [Field])
245 e45be9d4 Iustin Pop
246 53664e15 Iustin Pop
-- * Helper functions
247 53664e15 Iustin Pop
248 e9aaa3c6 Iustin Pop
-- | Ensure first letter is lowercase.
249 e9aaa3c6 Iustin Pop
--
250 e9aaa3c6 Iustin Pop
-- Used to convert type name to function prefix, e.g. in @data Aa ->
251 5f828ce4 Agata Murawska
-- aaToRaw@.
252 e9aaa3c6 Iustin Pop
ensureLower :: String -> String
253 e9aaa3c6 Iustin Pop
ensureLower [] = []
254 e9aaa3c6 Iustin Pop
ensureLower (x:xs) = toLower x:xs
255 e9aaa3c6 Iustin Pop
256 879273e3 Iustin Pop
-- | Ensure first letter is uppercase.
257 879273e3 Iustin Pop
--
258 879273e3 Iustin Pop
-- Used to convert constructor name to component
259 879273e3 Iustin Pop
ensureUpper :: String -> String
260 879273e3 Iustin Pop
ensureUpper [] = []
261 879273e3 Iustin Pop
ensureUpper (x:xs) = toUpper x:xs
262 879273e3 Iustin Pop
263 53664e15 Iustin Pop
-- | Helper for quoted expressions.
264 53664e15 Iustin Pop
varNameE :: String -> Q Exp
265 53664e15 Iustin Pop
varNameE = varE . mkName
266 53664e15 Iustin Pop
267 53664e15 Iustin Pop
-- | showJSON as an expression, for reuse.
268 53664e15 Iustin Pop
showJSONE :: Q Exp
269 32a569fe Iustin Pop
showJSONE = varE 'JSON.showJSON
270 32a569fe Iustin Pop
271 32a569fe Iustin Pop
-- | makeObj as an expression, for reuse.
272 32a569fe Iustin Pop
makeObjE :: Q Exp
273 32a569fe Iustin Pop
makeObjE = varE 'JSON.makeObj
274 32a569fe Iustin Pop
275 32a569fe Iustin Pop
-- | fromObj (Ganeti specific) as an expression, for reuse.
276 32a569fe Iustin Pop
fromObjE :: Q Exp
277 32a569fe Iustin Pop
fromObjE = varE 'fromObj
278 53664e15 Iustin Pop
279 5f828ce4 Agata Murawska
-- | ToRaw function name.
280 5f828ce4 Agata Murawska
toRawName :: String -> Name
281 5f828ce4 Agata Murawska
toRawName = mkName . (++ "ToRaw") . ensureLower
282 e9aaa3c6 Iustin Pop
283 5f828ce4 Agata Murawska
-- | FromRaw function name.
284 5f828ce4 Agata Murawska
fromRawName :: String -> Name
285 5f828ce4 Agata Murawska
fromRawName = mkName . (++ "FromRaw") . ensureLower
286 260d0bda Agata Murawska
287 12e8358c Iustin Pop
-- | Converts a name to it's varE\/litE representations.
288 6111e296 Iustin Pop
reprE :: Either String Name -> Q Exp
289 53664e15 Iustin Pop
reprE = either stringE varE
290 53664e15 Iustin Pop
291 60de49c3 Iustin Pop
-- | Smarter function application.
292 60de49c3 Iustin Pop
--
293 60de49c3 Iustin Pop
-- This does simply f x, except that if is 'id', it will skip it, in
294 60de49c3 Iustin Pop
-- order to generate more readable code when using -ddump-splices.
295 60de49c3 Iustin Pop
appFn :: Exp -> Exp -> Exp
296 60de49c3 Iustin Pop
appFn f x | f == VarE 'id = x
297 60de49c3 Iustin Pop
          | otherwise = AppE f x
298 60de49c3 Iustin Pop
299 185b5b0d Iustin Pop
-- | Builds a field for a normal constructor.
300 185b5b0d Iustin Pop
buildConsField :: Q Type -> StrictTypeQ
301 185b5b0d Iustin Pop
buildConsField ftype = do
302 185b5b0d Iustin Pop
  ftype' <- ftype
303 185b5b0d Iustin Pop
  return (NotStrict, ftype')
304 185b5b0d Iustin Pop
305 185b5b0d Iustin Pop
-- | Builds a constructor based on a simple definition (not field-based).
306 185b5b0d Iustin Pop
buildSimpleCons :: Name -> SimpleObject -> Q Dec
307 185b5b0d Iustin Pop
buildSimpleCons tname cons = do
308 185b5b0d Iustin Pop
  decl_d <- mapM (\(cname, fields) -> do
309 185b5b0d Iustin Pop
                    fields' <- mapM (buildConsField . snd) fields
310 185b5b0d Iustin Pop
                    return $ NormalC (mkName cname) fields') cons
311 139c0683 Iustin Pop
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
312 185b5b0d Iustin Pop
313 185b5b0d Iustin Pop
-- | Generate the save function for a given type.
314 185b5b0d Iustin Pop
genSaveSimpleObj :: Name                            -- ^ Object type
315 185b5b0d Iustin Pop
                 -> String                          -- ^ Function name
316 185b5b0d Iustin Pop
                 -> SimpleObject                    -- ^ Object definition
317 185b5b0d Iustin Pop
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
318 185b5b0d Iustin Pop
                 -> Q (Dec, Dec)
319 185b5b0d Iustin Pop
genSaveSimpleObj tname sname opdefs fn = do
320 185b5b0d Iustin Pop
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
321 185b5b0d Iustin Pop
      fname = mkName sname
322 185b5b0d Iustin Pop
  cclauses <- mapM fn opdefs
323 185b5b0d Iustin Pop
  return $ (SigD fname sigt, FunD fname cclauses)
324 185b5b0d Iustin Pop
325 5f828ce4 Agata Murawska
-- * Template code for simple raw type-equivalent ADTs
326 6111e296 Iustin Pop
327 e9aaa3c6 Iustin Pop
-- | Generates a data type declaration.
328 e9aaa3c6 Iustin Pop
--
329 e9aaa3c6 Iustin Pop
-- The type will have a fixed list of instances.
330 e9aaa3c6 Iustin Pop
strADTDecl :: Name -> [String] -> Dec
331 e9aaa3c6 Iustin Pop
strADTDecl name constructors =
332 ebf38064 Iustin Pop
  DataD [] name []
333 ebf38064 Iustin Pop
          (map (flip NormalC [] . mkName) constructors)
334 139c0683 Iustin Pop
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
335 e9aaa3c6 Iustin Pop
336 5f828ce4 Agata Murawska
-- | Generates a toRaw function.
337 e9aaa3c6 Iustin Pop
--
338 e9aaa3c6 Iustin Pop
-- This generates a simple function of the form:
339 e9aaa3c6 Iustin Pop
--
340 e9aaa3c6 Iustin Pop
-- @
341 5f828ce4 Agata Murawska
-- nameToRaw :: Name -> /traw/
342 5f828ce4 Agata Murawska
-- nameToRaw Cons1 = var1
343 5f828ce4 Agata Murawska
-- nameToRaw Cons2 = \"value2\"
344 e9aaa3c6 Iustin Pop
-- @
345 5f828ce4 Agata Murawska
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
346 5f828ce4 Agata Murawska
genToRaw traw fname tname constructors = do
347 d80e3485 Iustin Pop
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
348 e9aaa3c6 Iustin Pop
  -- the body clauses, matching on the constructor and returning the
349 5f828ce4 Agata Murawska
  -- raw value
350 e9aaa3c6 Iustin Pop
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
351 6111e296 Iustin Pop
                             (normalB (reprE v)) []) constructors
352 e9aaa3c6 Iustin Pop
  return [SigD fname sigt, FunD fname clauses]
353 e9aaa3c6 Iustin Pop
354 5f828ce4 Agata Murawska
-- | Generates a fromRaw function.
355 e9aaa3c6 Iustin Pop
--
356 e9aaa3c6 Iustin Pop
-- The function generated is monadic and can fail parsing the
357 5f828ce4 Agata Murawska
-- raw value. It is of the form:
358 e9aaa3c6 Iustin Pop
--
359 e9aaa3c6 Iustin Pop
-- @
360 5f828ce4 Agata Murawska
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
361 5f828ce4 Agata Murawska
-- nameFromRaw s | s == var1       = Cons1
362 5f828ce4 Agata Murawska
--               | s == \"value2\" = Cons2
363 5f828ce4 Agata Murawska
--               | otherwise = fail /.../
364 e9aaa3c6 Iustin Pop
-- @
365 e82d1e98 Jose A. Lopes
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
366 5f828ce4 Agata Murawska
genFromRaw traw fname tname constructors = do
367 e9aaa3c6 Iustin Pop
  -- signature of form (Monad m) => String -> m $name
368 5f828ce4 Agata Murawska
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
369 e9aaa3c6 Iustin Pop
  -- clauses for a guarded pattern
370 e9aaa3c6 Iustin Pop
  let varp = mkName "s"
371 e9aaa3c6 Iustin Pop
      varpe = varE varp
372 e9aaa3c6 Iustin Pop
  clauses <- mapM (\(c, v) -> do
373 e9aaa3c6 Iustin Pop
                     -- the clause match condition
374 e82d1e98 Jose A. Lopes
                     g <- normalG [| $varpe == $(reprE v) |]
375 e9aaa3c6 Iustin Pop
                     -- the clause result
376 e9aaa3c6 Iustin Pop
                     r <- [| return $(conE (mkName c)) |]
377 e9aaa3c6 Iustin Pop
                     return (g, r)) constructors
378 e9aaa3c6 Iustin Pop
  -- the otherwise clause (fallback)
379 e9aaa3c6 Iustin Pop
  oth_clause <- do
380 e9aaa3c6 Iustin Pop
    g <- normalG [| otherwise |]
381 e9aaa3c6 Iustin Pop
    r <- [|fail ("Invalid string value for type " ++
382 5f828ce4 Agata Murawska
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
383 e9aaa3c6 Iustin Pop
    return (g, r)
384 e9aaa3c6 Iustin Pop
  let fun = FunD fname [Clause [VarP varp]
385 e9aaa3c6 Iustin Pop
                        (GuardedB (clauses++[oth_clause])) []]
386 e9aaa3c6 Iustin Pop
  return [SigD fname sigt, fun]
387 e9aaa3c6 Iustin Pop
388 5f828ce4 Agata Murawska
-- | Generates a data type from a given raw format.
389 e9aaa3c6 Iustin Pop
--
390 e9aaa3c6 Iustin Pop
-- The format is expected to multiline. The first line contains the
391 e9aaa3c6 Iustin Pop
-- type name, and the rest of the lines must contain two words: the
392 e9aaa3c6 Iustin Pop
-- constructor name and then the string representation of the
393 e9aaa3c6 Iustin Pop
-- respective constructor.
394 e9aaa3c6 Iustin Pop
--
395 e9aaa3c6 Iustin Pop
-- The function will generate the data type declaration, and then two
396 e9aaa3c6 Iustin Pop
-- functions:
397 e9aaa3c6 Iustin Pop
--
398 5f828ce4 Agata Murawska
-- * /name/ToRaw, which converts the type to a raw type
399 e9aaa3c6 Iustin Pop
--
400 5f828ce4 Agata Murawska
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
401 e9aaa3c6 Iustin Pop
--
402 12e8358c Iustin Pop
-- Note that this is basically just a custom show\/read instance,
403 e9aaa3c6 Iustin Pop
-- nothing else.
404 e82d1e98 Jose A. Lopes
declareADT
405 e82d1e98 Jose A. Lopes
  :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
406 e82d1e98 Jose A. Lopes
declareADT fn traw sname cons = do
407 e9aaa3c6 Iustin Pop
  let name = mkName sname
408 e9aaa3c6 Iustin Pop
      ddecl = strADTDecl name (map fst cons)
409 5f828ce4 Agata Murawska
      -- process cons in the format expected by genToRaw
410 e82d1e98 Jose A. Lopes
      cons' = map (\(a, b) -> (a, fn b)) cons
411 5f828ce4 Agata Murawska
  toraw <- genToRaw traw (toRawName sname) name cons'
412 e82d1e98 Jose A. Lopes
  fromraw <- genFromRaw traw (fromRawName sname) name cons'
413 5f828ce4 Agata Murawska
  return $ ddecl:toraw ++ fromraw
414 e9aaa3c6 Iustin Pop
415 e82d1e98 Jose A. Lopes
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
416 e82d1e98 Jose A. Lopes
declareLADT = declareADT Left
417 e82d1e98 Jose A. Lopes
418 a48daa87 Jose A. Lopes
declareILADT :: String -> [(String, Int)] -> Q [Dec]
419 a48daa87 Jose A. Lopes
declareILADT sname cons = do
420 a48daa87 Jose A. Lopes
  consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
421 a48daa87 Jose A. Lopes
  consFns <- concat <$> sequence
422 a48daa87 Jose A. Lopes
             [ do sig <- sigD n [t| Int |]
423 a48daa87 Jose A. Lopes
                  let expr = litE (IntegerL (toInteger i))
424 a48daa87 Jose A. Lopes
                  fn <- funD n [clause [] (normalB expr) []]
425 a48daa87 Jose A. Lopes
                  return [sig, fn]
426 a48daa87 Jose A. Lopes
             | n <- consNames
427 a48daa87 Jose A. Lopes
             | (_, i) <- cons ]
428 a48daa87 Jose A. Lopes
  let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
429 a48daa87 Jose A. Lopes
  (consFns ++) <$> declareADT Right ''Int sname cons'
430 a48daa87 Jose A. Lopes
431 5f828ce4 Agata Murawska
declareIADT :: String -> [(String, Name)] -> Q [Dec]
432 e82d1e98 Jose A. Lopes
declareIADT = declareADT Right ''Int
433 5f828ce4 Agata Murawska
434 5f828ce4 Agata Murawska
declareSADT :: String -> [(String, Name)] -> Q [Dec]
435 e82d1e98 Jose A. Lopes
declareSADT = declareADT Right ''String
436 e9aaa3c6 Iustin Pop
437 e9aaa3c6 Iustin Pop
-- | Creates the showJSON member of a JSON instance declaration.
438 e9aaa3c6 Iustin Pop
--
439 e9aaa3c6 Iustin Pop
-- This will create what is the equivalent of:
440 e9aaa3c6 Iustin Pop
--
441 e9aaa3c6 Iustin Pop
-- @
442 5f828ce4 Agata Murawska
-- showJSON = showJSON . /name/ToRaw
443 e9aaa3c6 Iustin Pop
-- @
444 e9aaa3c6 Iustin Pop
--
445 e9aaa3c6 Iustin Pop
-- in an instance JSON /name/ declaration
446 ffbd9592 Iustin Pop
genShowJSON :: String -> Q Dec
447 ffbd9592 Iustin Pop
genShowJSON name = do
448 ffbd9592 Iustin Pop
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
449 32a569fe Iustin Pop
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
450 e9aaa3c6 Iustin Pop
451 e9aaa3c6 Iustin Pop
-- | Creates the readJSON member of a JSON instance declaration.
452 e9aaa3c6 Iustin Pop
--
453 e9aaa3c6 Iustin Pop
-- This will create what is the equivalent of:
454 e9aaa3c6 Iustin Pop
--
455 e9aaa3c6 Iustin Pop
-- @
456 e9aaa3c6 Iustin Pop
-- readJSON s = case readJSON s of
457 5f828ce4 Agata Murawska
--                Ok s' -> /name/FromRaw s'
458 e9aaa3c6 Iustin Pop
--                Error e -> Error /description/
459 e9aaa3c6 Iustin Pop
-- @
460 e9aaa3c6 Iustin Pop
--
461 e9aaa3c6 Iustin Pop
-- in an instance JSON /name/ declaration
462 e9aaa3c6 Iustin Pop
genReadJSON :: String -> Q Dec
463 e9aaa3c6 Iustin Pop
genReadJSON name = do
464 e9aaa3c6 Iustin Pop
  let s = mkName "s"
465 e9aaa3c6 Iustin Pop
  body <- [| case JSON.readJSON $(varE s) of
466 5f828ce4 Agata Murawska
               JSON.Ok s' -> $(varE (fromRawName name)) s'
467 e9aaa3c6 Iustin Pop
               JSON.Error e ->
468 5f828ce4 Agata Murawska
                   JSON.Error $ "Can't parse raw value for type " ++
469 6bd26f00 Iustin Pop
                           $(stringE name) ++ ": " ++ e ++ " from " ++
470 6bd26f00 Iustin Pop
                           show $(varE s)
471 e9aaa3c6 Iustin Pop
           |]
472 32a569fe Iustin Pop
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
473 e9aaa3c6 Iustin Pop
474 e9aaa3c6 Iustin Pop
-- | Generates a JSON instance for a given type.
475 e9aaa3c6 Iustin Pop
--
476 5f828ce4 Agata Murawska
-- This assumes that the /name/ToRaw and /name/FromRaw functions
477 e9aaa3c6 Iustin Pop
-- have been defined as by the 'declareSADT' function.
478 e9aaa3c6 Iustin Pop
makeJSONInstance :: Name -> Q [Dec]
479 e9aaa3c6 Iustin Pop
makeJSONInstance name = do
480 e9aaa3c6 Iustin Pop
  let base = nameBase name
481 e9aaa3c6 Iustin Pop
  showJ <- genShowJSON base
482 e9aaa3c6 Iustin Pop
  readJ <- genReadJSON base
483 ffbd9592 Iustin Pop
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
484 6111e296 Iustin Pop
485 53664e15 Iustin Pop
-- * Template code for opcodes
486 53664e15 Iustin Pop
487 6111e296 Iustin Pop
-- | Transforms a CamelCase string into an_underscore_based_one.
488 6111e296 Iustin Pop
deCamelCase :: String -> String
489 6111e296 Iustin Pop
deCamelCase =
490 6111e296 Iustin Pop
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
491 6111e296 Iustin Pop
492 879273e3 Iustin Pop
-- | Transform an underscore_name into a CamelCase one.
493 879273e3 Iustin Pop
camelCase :: String -> String
494 879273e3 Iustin Pop
camelCase = concatMap (ensureUpper . drop 1) .
495 d8cb8e13 Iustin Pop
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
496 879273e3 Iustin Pop
497 05ff7a00 Agata Murawska
-- | Computes the name of a given constructor.
498 6111e296 Iustin Pop
constructorName :: Con -> Q Name
499 6111e296 Iustin Pop
constructorName (NormalC name _) = return name
500 6111e296 Iustin Pop
constructorName (RecC name _)    = return name
501 6111e296 Iustin Pop
constructorName x                = fail $ "Unhandled constructor " ++ show x
502 6111e296 Iustin Pop
503 94518cdb Iustin Pop
-- | Extract all constructor names from a given type.
504 94518cdb Iustin Pop
reifyConsNames :: Name -> Q [String]
505 94518cdb Iustin Pop
reifyConsNames name = do
506 94518cdb Iustin Pop
  reify_result <- reify name
507 94518cdb Iustin Pop
  case reify_result of
508 94518cdb Iustin Pop
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
509 94518cdb Iustin Pop
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
510 94518cdb Iustin Pop
                \ type constructor but got '" ++ show o ++ "'"
511 94518cdb Iustin Pop
512 a0090487 Agata Murawska
-- | Builds the generic constructor-to-string function.
513 6111e296 Iustin Pop
--
514 6111e296 Iustin Pop
-- This generates a simple function of the following form:
515 6111e296 Iustin Pop
--
516 6111e296 Iustin Pop
-- @
517 a0090487 Agata Murawska
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
518 a0090487 Agata Murawska
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
519 6111e296 Iustin Pop
-- @
520 6111e296 Iustin Pop
--
521 12e8358c Iustin Pop
-- This builds a custom list of name\/string pairs and then uses
522 12e8358c Iustin Pop
-- 'genToRaw' to actually generate the function.
523 a0090487 Agata Murawska
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
524 a0090487 Agata Murawska
genConstrToStr trans_fun name fname = do
525 94518cdb Iustin Pop
  cnames <- reifyConsNames name
526 a0090487 Agata Murawska
  let svalues = map (Left . trans_fun) cnames
527 5f828ce4 Agata Murawska
  genToRaw ''String (mkName fname) name $ zip cnames svalues
528 12c19659 Iustin Pop
529 a0090487 Agata Murawska
-- | Constructor-to-string for OpCode.
530 a0090487 Agata Murawska
genOpID :: Name -> String -> Q [Dec]
531 a0090487 Agata Murawska
genOpID = genConstrToStr deCamelCase
532 12c19659 Iustin Pop
533 a583ec5d Iustin Pop
-- | Builds a list with all defined constructor names for a type.
534 a583ec5d Iustin Pop
--
535 a583ec5d Iustin Pop
-- @
536 a583ec5d Iustin Pop
-- vstr :: String
537 a583ec5d Iustin Pop
-- vstr = [...]
538 a583ec5d Iustin Pop
-- @
539 a583ec5d Iustin Pop
--
540 a583ec5d Iustin Pop
-- Where the actual values of the string are the constructor names
541 a583ec5d Iustin Pop
-- mapped via @trans_fun@.
542 a583ec5d Iustin Pop
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
543 a583ec5d Iustin Pop
genAllConstr trans_fun name vstr = do
544 a583ec5d Iustin Pop
  cnames <- reifyConsNames name
545 a583ec5d Iustin Pop
  let svalues = sort $ map trans_fun cnames
546 a583ec5d Iustin Pop
      vname = mkName vstr
547 a583ec5d Iustin Pop
      sig = SigD vname (AppT ListT (ConT ''String))
548 a583ec5d Iustin Pop
      body = NormalB (ListE (map (LitE . StringL) svalues))
549 a583ec5d Iustin Pop
  return $ [sig, ValD (VarP vname) body []]
550 a583ec5d Iustin Pop
551 a583ec5d Iustin Pop
-- | Generates a list of all defined opcode IDs.
552 a583ec5d Iustin Pop
genAllOpIDs :: Name -> String -> Q [Dec]
553 a583ec5d Iustin Pop
genAllOpIDs = genAllConstr deCamelCase
554 a583ec5d Iustin Pop
555 05ff7a00 Agata Murawska
-- | OpCode parameter (field) type.
556 12c19659 Iustin Pop
type OpParam = (String, Q Type, Q Exp)
557 12c19659 Iustin Pop
558 34af39e8 Jose A. Lopes
-- * Python code generation
559 34af39e8 Jose A. Lopes
560 34af39e8 Jose A. Lopes
-- | Converts Haskell values into Python values
561 34af39e8 Jose A. Lopes
--
562 34af39e8 Jose A. Lopes
-- This is necessary for the default values of opcode parameters and
563 34af39e8 Jose A. Lopes
-- return values.  For example, if a default value or return type is a
564 34af39e8 Jose A. Lopes
-- Data.Map, then it must be shown as a Python dictioanry.
565 85bcb1de Jose A. Lopes
class PyValue a where
566 34af39e8 Jose A. Lopes
  showValue :: a -> String
567 34af39e8 Jose A. Lopes
568 34af39e8 Jose A. Lopes
-- | Encapsulates Python default values
569 34af39e8 Jose A. Lopes
data PyValueEx = forall a. PyValue a => PyValueEx a
570 34af39e8 Jose A. Lopes
571 47ea2344 Jose A. Lopes
instance PyValue PyValueEx where
572 47ea2344 Jose A. Lopes
  showValue (PyValueEx x) = showValue x
573 47ea2344 Jose A. Lopes
574 34af39e8 Jose A. Lopes
-- | Transfers opcode data between the opcode description (through
575 34af39e8 Jose A. Lopes
-- @genOpCode@) and the Python code generation functions.
576 34af39e8 Jose A. Lopes
type OpCodeDescriptor =
577 34af39e8 Jose A. Lopes
  (String, String, String, [String],
578 34af39e8 Jose A. Lopes
   [String], [Maybe PyValueEx], [String], String)
579 34af39e8 Jose A. Lopes
580 34af39e8 Jose A. Lopes
-- | Strips out the module name
581 34af39e8 Jose A. Lopes
--
582 34af39e8 Jose A. Lopes
-- @
583 34af39e8 Jose A. Lopes
-- pyBaseName "Data.Map" = "Map"
584 34af39e8 Jose A. Lopes
-- @
585 34af39e8 Jose A. Lopes
pyBaseName :: String -> String
586 34af39e8 Jose A. Lopes
pyBaseName str =
587 34af39e8 Jose A. Lopes
  case span (/= '.') str of
588 34af39e8 Jose A. Lopes
    (x, []) -> x
589 34af39e8 Jose A. Lopes
    (_, _:x) -> pyBaseName x
590 34af39e8 Jose A. Lopes
591 34af39e8 Jose A. Lopes
-- | Converts a Haskell type name into a Python type name.
592 34af39e8 Jose A. Lopes
--
593 34af39e8 Jose A. Lopes
-- @
594 34af39e8 Jose A. Lopes
-- pyTypename "Bool" = "ht.TBool"
595 34af39e8 Jose A. Lopes
-- @
596 34af39e8 Jose A. Lopes
pyTypeName :: Show a => a -> String
597 34af39e8 Jose A. Lopes
pyTypeName name =
598 34af39e8 Jose A. Lopes
  "ht.T" ++ (case pyBaseName (show name) of
599 34af39e8 Jose A. Lopes
                "()" -> "None"
600 34af39e8 Jose A. Lopes
                "Map" -> "DictOf"
601 34af39e8 Jose A. Lopes
                "Set" -> "SetOf"
602 4651c69f Jose A. Lopes
                "ListSet" -> "SetOf"
603 34af39e8 Jose A. Lopes
                "Either" -> "Or"
604 34af39e8 Jose A. Lopes
                "GenericContainer" -> "DictOf"
605 34af39e8 Jose A. Lopes
                "JSValue" -> "Any"
606 34af39e8 Jose A. Lopes
                "JSObject" -> "Object"
607 34af39e8 Jose A. Lopes
                str -> str)
608 34af39e8 Jose A. Lopes
609 34af39e8 Jose A. Lopes
-- | Converts a Haskell type into a Python type.
610 34af39e8 Jose A. Lopes
--
611 34af39e8 Jose A. Lopes
-- @
612 34af39e8 Jose A. Lopes
-- pyType [Int] = "ht.TListOf(ht.TInt)"
613 34af39e8 Jose A. Lopes
-- @
614 34af39e8 Jose A. Lopes
pyType :: Type -> Q String
615 34af39e8 Jose A. Lopes
pyType (AppT typ1 typ2) =
616 34af39e8 Jose A. Lopes
  do t <- pyCall typ1 typ2
617 34af39e8 Jose A. Lopes
     return $ t ++ ")"
618 34af39e8 Jose A. Lopes
619 34af39e8 Jose A. Lopes
pyType (ConT name) = return (pyTypeName name)
620 34af39e8 Jose A. Lopes
pyType ListT = return "ht.TListOf"
621 ce1b0c05 Jose A. Lopes
pyType (TupleT 0) = return "ht.TNone"
622 34af39e8 Jose A. Lopes
pyType (TupleT _) = return "ht.TTupleOf"
623 34af39e8 Jose A. Lopes
pyType typ = error $ "unhandled case for type " ++ show typ
624 34af39e8 Jose A. Lopes
        
625 34af39e8 Jose A. Lopes
-- | Converts a Haskell type application into a Python type.
626 34af39e8 Jose A. Lopes
--
627 34af39e8 Jose A. Lopes
-- @
628 34af39e8 Jose A. Lopes
-- Maybe Int = "ht.TMaybe(ht.TInt)"
629 34af39e8 Jose A. Lopes
-- @
630 34af39e8 Jose A. Lopes
pyCall :: Type -> Type -> Q String
631 34af39e8 Jose A. Lopes
pyCall (AppT typ1 typ2) arg =
632 34af39e8 Jose A. Lopes
  do t <- pyCall typ1 typ2
633 34af39e8 Jose A. Lopes
     targ <- pyType arg
634 34af39e8 Jose A. Lopes
     return $ t ++ ", " ++ targ
635 34af39e8 Jose A. Lopes
636 34af39e8 Jose A. Lopes
pyCall typ1 typ2 =
637 34af39e8 Jose A. Lopes
  do t1 <- pyType typ1
638 34af39e8 Jose A. Lopes
     t2 <- pyType typ2
639 34af39e8 Jose A. Lopes
     return $ t1 ++ "(" ++ t2
640 34af39e8 Jose A. Lopes
641 34af39e8 Jose A. Lopes
-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
642 34af39e8 Jose A. Lopes
-- where @opt@ determines if the converted type is optional (i.e.,
643 34af39e8 Jose A. Lopes
-- Maybe).
644 34af39e8 Jose A. Lopes
--
645 34af39e8 Jose A. Lopes
-- @
646 34af39e8 Jose A. Lopes
-- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
647 34af39e8 Jose A. Lopes
-- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
648 34af39e8 Jose A. Lopes
-- @
649 34af39e8 Jose A. Lopes
pyOptionalType :: Bool -> Type -> Q String
650 34af39e8 Jose A. Lopes
pyOptionalType opt typ
651 34af39e8 Jose A. Lopes
  | opt = do t <- pyType typ
652 34af39e8 Jose A. Lopes
             return $ "ht.TMaybe(" ++ t ++ ")"
653 34af39e8 Jose A. Lopes
  | otherwise = pyType typ
654 34af39e8 Jose A. Lopes
655 34af39e8 Jose A. Lopes
-- | Optionally encapsulates default values in @PyValueEx@.
656 34af39e8 Jose A. Lopes
--
657 34af39e8 Jose A. Lopes
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
658 34af39e8 Jose A. Lopes
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
659 34af39e8 Jose A. Lopes
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
660 34af39e8 Jose A. Lopes
-- expression with @Nothing@.
661 34af39e8 Jose A. Lopes
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
662 34af39e8 Jose A. Lopes
maybeApp Nothing _ =
663 34af39e8 Jose A. Lopes
  [| Nothing |]
664 34af39e8 Jose A. Lopes
665 34af39e8 Jose A. Lopes
maybeApp (Just expr) typ =
666 34af39e8 Jose A. Lopes
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
667 34af39e8 Jose A. Lopes
668 34af39e8 Jose A. Lopes
669 34af39e8 Jose A. Lopes
-- | Generates a Python type according to whether the field is
670 34af39e8 Jose A. Lopes
-- optional
671 34af39e8 Jose A. Lopes
genPyType :: OptionalType -> Q Type -> Q ExpQ
672 34af39e8 Jose A. Lopes
genPyType opt typ =
673 34af39e8 Jose A. Lopes
  do t <- typ
674 34af39e8 Jose A. Lopes
     stringE <$> pyOptionalType (opt /= NotOptional) t
675 34af39e8 Jose A. Lopes
676 34af39e8 Jose A. Lopes
-- | Generates Python types from opcode parameters.
677 34af39e8 Jose A. Lopes
genPyTypes :: [Field] -> Q ExpQ
678 34af39e8 Jose A. Lopes
genPyTypes fs =
679 34af39e8 Jose A. Lopes
  listE <$> mapM (\f -> genPyType (fieldIsOptional f) (fieldType f)) fs
680 34af39e8 Jose A. Lopes
681 34af39e8 Jose A. Lopes
-- | Generates Python default values from opcode parameters.
682 34af39e8 Jose A. Lopes
genPyDefaults :: [Field] -> ExpQ
683 34af39e8 Jose A. Lopes
genPyDefaults fs =
684 34af39e8 Jose A. Lopes
  listE $ map (\f -> maybeApp (fieldDefault f) (fieldType f)) fs
685 34af39e8 Jose A. Lopes
686 34af39e8 Jose A. Lopes
-- | Generates a Haskell function call to "showPyClass" with the
687 34af39e8 Jose A. Lopes
-- necessary information on how to build the Python class string.
688 34af39e8 Jose A. Lopes
pyClass :: OpCodeConstructor -> ExpQ
689 34af39e8 Jose A. Lopes
pyClass (consName, consType, consDoc, consFields, consDscField) =
690 34af39e8 Jose A. Lopes
  do let pyClassVar = varNameE "showPyClass"
691 34af39e8 Jose A. Lopes
         consName' = stringE consName
692 34af39e8 Jose A. Lopes
     consType' <- genPyType NotOptional consType
693 34af39e8 Jose A. Lopes
     let consDoc' = stringE consDoc
694 34af39e8 Jose A. Lopes
         consFieldNames = listE $ map (stringE . fieldName) consFields
695 34af39e8 Jose A. Lopes
         consFieldDocs = listE $ map (stringE . fieldDoc) consFields
696 34af39e8 Jose A. Lopes
     consFieldTypes <- genPyTypes consFields
697 34af39e8 Jose A. Lopes
     let consFieldDefaults = genPyDefaults consFields
698 34af39e8 Jose A. Lopes
     [| ($consName',
699 34af39e8 Jose A. Lopes
         $consType',
700 34af39e8 Jose A. Lopes
         $consDoc',
701 34af39e8 Jose A. Lopes
         $consFieldNames,
702 34af39e8 Jose A. Lopes
         $consFieldTypes,
703 34af39e8 Jose A. Lopes
         $consFieldDefaults,
704 34af39e8 Jose A. Lopes
         $consFieldDocs,
705 34af39e8 Jose A. Lopes
         consDscField) |]
706 34af39e8 Jose A. Lopes
707 34af39e8 Jose A. Lopes
-- | Generates a function called "pyClasses" that holds the list of
708 34af39e8 Jose A. Lopes
-- all the opcode descriptors necessary for generating the Python
709 34af39e8 Jose A. Lopes
-- opcodes.
710 34af39e8 Jose A. Lopes
pyClasses :: [OpCodeConstructor] -> Q [Dec]
711 34af39e8 Jose A. Lopes
pyClasses cons =
712 34af39e8 Jose A. Lopes
  do let name = mkName "pyClasses"
713 34af39e8 Jose A. Lopes
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
714 34af39e8 Jose A. Lopes
     fn <- FunD name <$> (:[]) <$> declClause cons
715 34af39e8 Jose A. Lopes
     return [sig, fn]
716 34af39e8 Jose A. Lopes
  where declClause c =
717 34af39e8 Jose A. Lopes
          clause [] (normalB (ListE <$> mapM pyClass c)) []
718 34af39e8 Jose A. Lopes
719 34af39e8 Jose A. Lopes
-- | Converts from an opcode constructor to a Luxi constructor.
720 34af39e8 Jose A. Lopes
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
721 34af39e8 Jose A. Lopes
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
722 34af39e8 Jose A. Lopes
723 12c19659 Iustin Pop
-- | Generates the OpCode data type.
724 12c19659 Iustin Pop
--
725 12c19659 Iustin Pop
-- This takes an opcode logical definition, and builds both the
726 12c19659 Iustin Pop
-- datatype and the JSON serialisation out of it. We can't use a
727 12c19659 Iustin Pop
-- generic serialisation since we need to be compatible with Ganeti's
728 12c19659 Iustin Pop
-- own, so we have a few quirks to work around.
729 34af39e8 Jose A. Lopes
genOpCode :: String              -- ^ Type name to use
730 34af39e8 Jose A. Lopes
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
731 12c19659 Iustin Pop
          -> Q [Dec]
732 12c19659 Iustin Pop
genOpCode name cons = do
733 92ad1f44 Iustin Pop
  let tname = mkName name
734 34af39e8 Jose A. Lopes
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
735 12c19659 Iustin Pop
                    -- we only need the type of the field, without Q
736 8ee2994a Iustin Pop
                    fields' <- mapM (fieldTypeInfo "op") fields
737 8ee2994a Iustin Pop
                    return $ RecC (mkName cname) fields')
738 12c19659 Iustin Pop
            cons
739 139c0683 Iustin Pop
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
740 3929e782 Iustin Pop
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
741 84c2e6ca Iustin Pop
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
742 34af39e8 Jose A. Lopes
               (map opcodeConsToLuxiCons cons) saveConstructor True
743 12c19659 Iustin Pop
  (loadsig, loadfn) <- genLoadOpCode cons
744 34af39e8 Jose A. Lopes
  pyDecls <- pyClasses cons
745 34af39e8 Jose A. Lopes
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls
746 3929e782 Iustin Pop
747 3929e782 Iustin Pop
-- | Generates the function pattern returning the list of fields for a
748 3929e782 Iustin Pop
-- given constructor.
749 34af39e8 Jose A. Lopes
genOpConsFields :: OpCodeConstructor -> Clause
750 34af39e8 Jose A. Lopes
genOpConsFields (cname, _, _, fields, _) =
751 3929e782 Iustin Pop
  let op_id = deCamelCase cname
752 3929e782 Iustin Pop
      fvals = map (LitE . StringL) . sort . nub $
753 3929e782 Iustin Pop
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
754 3929e782 Iustin Pop
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
755 3929e782 Iustin Pop
756 3929e782 Iustin Pop
-- | Generates a list of all fields of an opcode constructor.
757 34af39e8 Jose A. Lopes
genAllOpFields  :: String              -- ^ Function name
758 34af39e8 Jose A. Lopes
                -> [OpCodeConstructor] -- ^ Object definition
759 3929e782 Iustin Pop
                -> (Dec, Dec)
760 3929e782 Iustin Pop
genAllOpFields sname opdefs =
761 3929e782 Iustin Pop
  let cclauses = map genOpConsFields opdefs
762 3929e782 Iustin Pop
      other = Clause [WildP] (NormalB (ListE [])) []
763 3929e782 Iustin Pop
      fname = mkName sname
764 3929e782 Iustin Pop
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
765 3929e782 Iustin Pop
  in (SigD fname sigt, FunD fname (cclauses++[other]))
766 12c19659 Iustin Pop
767 12c19659 Iustin Pop
-- | Generates the \"save\" clause for an entire opcode constructor.
768 12c19659 Iustin Pop
--
769 12c19659 Iustin Pop
-- This matches the opcode with variables named the same as the
770 12c19659 Iustin Pop
-- constructor fields (just so that the spliced in code looks nicer),
771 a1505857 Iustin Pop
-- and passes those name plus the parameter definition to 'saveObjectField'.
772 34af39e8 Jose A. Lopes
saveConstructor :: LuxiConstructor -- ^ The constructor
773 34af39e8 Jose A. Lopes
                -> Q Clause        -- ^ Resulting clause
774 34af39e8 Jose A. Lopes
saveConstructor (sname, fields) = do
775 12c19659 Iustin Pop
  let cname = mkName sname
776 d8cb8e13 Iustin Pop
  fnames <- mapM (newName . fieldVariable) fields
777 12c19659 Iustin Pop
  let pat = conP cname (map varP fnames)
778 a1505857 Iustin Pop
  let felems = map (uncurry saveObjectField) (zip fnames fields)
779 12c19659 Iustin Pop
      -- now build the OP_ID serialisation
780 53664e15 Iustin Pop
      opid = [| [( $(stringE "OP_ID"),
781 a07343b2 Iustin Pop
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
782 12c19659 Iustin Pop
      flist = listE (opid:felems)
783 12c19659 Iustin Pop
      -- and finally convert all this to a json object
784 84c2e6ca Iustin Pop
      flist' = [| concat $flist |]
785 12c19659 Iustin Pop
  clause [pat] (normalB flist') []
786 12c19659 Iustin Pop
787 12c19659 Iustin Pop
-- | Generates the main save opcode function.
788 12c19659 Iustin Pop
--
789 12c19659 Iustin Pop
-- This builds a per-constructor match clause that contains the
790 12c19659 Iustin Pop
-- respective constructor-serialisation code.
791 34af39e8 Jose A. Lopes
genSaveOpCode :: Name                          -- ^ Object ype
792 34af39e8 Jose A. Lopes
              -> String                        -- ^ To 'JSValue' function name
793 34af39e8 Jose A. Lopes
              -> String                        -- ^ To 'JSObject' function name
794 34af39e8 Jose A. Lopes
              -> [LuxiConstructor]             -- ^ Object definition
795 34af39e8 Jose A. Lopes
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
796 34af39e8 Jose A. Lopes
              -> Bool                          -- ^ Whether to generate
797 34af39e8 Jose A. Lopes
                                               -- obj or just a
798 34af39e8 Jose A. Lopes
                                               -- list\/tuple of values
799 84c2e6ca Iustin Pop
              -> Q [Dec]
800 84c2e6ca Iustin Pop
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
801 84c2e6ca Iustin Pop
  tdclauses <- mapM fn opdefs
802 84c2e6ca Iustin Pop
  let typecon = ConT tname
803 84c2e6ca Iustin Pop
      jvalname = mkName jvalstr
804 84c2e6ca Iustin Pop
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
805 84c2e6ca Iustin Pop
      tdname = mkName tdstr
806 84c2e6ca Iustin Pop
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
807 84c2e6ca Iustin Pop
  jvalclause <- if gen_object
808 84c2e6ca Iustin Pop
                  then [| $makeObjE . $(varE tdname) |]
809 84c2e6ca Iustin Pop
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
810 84c2e6ca Iustin Pop
  return [ SigD tdname tdsig
811 84c2e6ca Iustin Pop
         , FunD tdname tdclauses
812 84c2e6ca Iustin Pop
         , SigD jvalname jvalsig
813 84c2e6ca Iustin Pop
         , ValD (VarP jvalname) (NormalB jvalclause) []]
814 12c19659 Iustin Pop
815 12e8358c Iustin Pop
-- | Generates load code for a single constructor of the opcode data type.
816 34af39e8 Jose A. Lopes
loadConstructor :: OpCodeConstructor -> Q Exp
817 34af39e8 Jose A. Lopes
loadConstructor (sname, _, _, fields, _) = do
818 12c19659 Iustin Pop
  let name = mkName sname
819 a1505857 Iustin Pop
  fbinds <- mapM loadObjectField fields
820 12c19659 Iustin Pop
  let (fnames, fstmts) = unzip fbinds
821 12c19659 Iustin Pop
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
822 12c19659 Iustin Pop
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
823 12c19659 Iustin Pop
  return $ DoE fstmts'
824 12c19659 Iustin Pop
825 12e8358c Iustin Pop
-- | Generates the loadOpCode function.
826 34af39e8 Jose A. Lopes
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
827 12c19659 Iustin Pop
genLoadOpCode opdefs = do
828 12c19659 Iustin Pop
  let fname = mkName "loadOpCode"
829 12c19659 Iustin Pop
      arg1 = mkName "v"
830 12c19659 Iustin Pop
      objname = mkName "o"
831 12c19659 Iustin Pop
      opid = mkName "op_id"
832 12c19659 Iustin Pop
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
833 12c19659 Iustin Pop
                                 (JSON.readJSON $(varE arg1)) |]
834 32a569fe Iustin Pop
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
835 12c19659 Iustin Pop
  -- the match results (per-constructor blocks)
836 34af39e8 Jose A. Lopes
  mexps <- mapM loadConstructor opdefs
837 12c19659 Iustin Pop
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
838 34af39e8 Jose A. Lopes
  let mpats = map (\(me, (consName, _, _, _, _)) ->
839 34af39e8 Jose A. Lopes
                       let mp = LitP . StringL . deCamelCase $ consName
840 12c19659 Iustin Pop
                       in Match mp (NormalB me) []
841 12c19659 Iustin Pop
                  ) $ zip mexps opdefs
842 12c19659 Iustin Pop
      defmatch = Match WildP (NormalB fails) []
843 12c19659 Iustin Pop
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
844 12c19659 Iustin Pop
      body = DoE [st1, st2, cst]
845 12c19659 Iustin Pop
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
846 12c19659 Iustin Pop
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
847 12c19659 Iustin Pop
848 a0090487 Agata Murawska
-- * Template code for luxi
849 a0090487 Agata Murawska
850 a0090487 Agata Murawska
-- | Constructor-to-string for LuxiOp.
851 a0090487 Agata Murawska
genStrOfOp :: Name -> String -> Q [Dec]
852 a0090487 Agata Murawska
genStrOfOp = genConstrToStr id
853 a0090487 Agata Murawska
854 a0090487 Agata Murawska
-- | Constructor-to-string for MsgKeys.
855 a0090487 Agata Murawska
genStrOfKey :: Name -> String -> Q [Dec]
856 a0090487 Agata Murawska
genStrOfKey = genConstrToStr ensureLower
857 a0090487 Agata Murawska
858 a0090487 Agata Murawska
-- | Generates the LuxiOp data type.
859 a0090487 Agata Murawska
--
860 a0090487 Agata Murawska
-- This takes a Luxi operation definition and builds both the
861 61f3d56e Klaus Aehlig
-- datatype and the function transforming the arguments to JSON.
862 a0090487 Agata Murawska
-- We can't use anything less generic, because the way different
863 a0090487 Agata Murawska
-- operations are serialized differs on both parameter- and top-level.
864 a0090487 Agata Murawska
--
865 4b71f30c Iustin Pop
-- There are two things to be defined for each parameter:
866 a0090487 Agata Murawska
--
867 a0090487 Agata Murawska
-- * name
868 a0090487 Agata Murawska
--
869 a0090487 Agata Murawska
-- * type
870 a0090487 Agata Murawska
--
871 34af39e8 Jose A. Lopes
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
872 a0090487 Agata Murawska
genLuxiOp name cons = do
873 185b5b0d Iustin Pop
  let tname = mkName name
874 88609f00 Iustin Pop
  decl_d <- mapM (\(cname, fields) -> do
875 88609f00 Iustin Pop
                    -- we only need the type of the field, without Q
876 88609f00 Iustin Pop
                    fields' <- mapM actualFieldType fields
877 88609f00 Iustin Pop
                    let fields'' = zip (repeat NotStrict) fields'
878 88609f00 Iustin Pop
                    return $ NormalC (mkName cname) fields'')
879 88609f00 Iustin Pop
            cons
880 139c0683 Iustin Pop
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
881 84c2e6ca Iustin Pop
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
882 84c2e6ca Iustin Pop
               cons saveLuxiConstructor False
883 95d0d502 Iustin Pop
  req_defs <- declareSADT "LuxiReq" .
884 95d0d502 Iustin Pop
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
885 95d0d502 Iustin Pop
                  cons
886 84c2e6ca Iustin Pop
  return $ declD:save_decs ++ req_defs
887 a0090487 Agata Murawska
888 a0090487 Agata Murawska
-- | Generates the \"save\" clause for entire LuxiOp constructor.
889 34af39e8 Jose A. Lopes
saveLuxiConstructor :: LuxiConstructor -> Q Clause
890 b20cbf06 Iustin Pop
saveLuxiConstructor (sname, fields) = do
891 a0090487 Agata Murawska
  let cname = mkName sname
892 88609f00 Iustin Pop
  fnames <- mapM (newName . fieldVariable) fields
893 88609f00 Iustin Pop
  let pat = conP cname (map varP fnames)
894 88609f00 Iustin Pop
  let felems = map (uncurry saveObjectField) (zip fnames fields)
895 84c2e6ca Iustin Pop
      flist = [| concat $(listE felems) |]
896 88609f00 Iustin Pop
  clause [pat] (normalB flist) []
897 a0090487 Agata Murawska
898 879273e3 Iustin Pop
-- * "Objects" functionality
899 879273e3 Iustin Pop
900 879273e3 Iustin Pop
-- | Extract the field's declaration from a Field structure.
901 879273e3 Iustin Pop
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
902 879273e3 Iustin Pop
fieldTypeInfo field_pfx fd = do
903 879273e3 Iustin Pop
  t <- actualFieldType fd
904 879273e3 Iustin Pop
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
905 879273e3 Iustin Pop
  return (n, NotStrict, t)
906 879273e3 Iustin Pop
907 879273e3 Iustin Pop
-- | Build an object declaration.
908 879273e3 Iustin Pop
buildObject :: String -> String -> [Field] -> Q [Dec]
909 879273e3 Iustin Pop
buildObject sname field_pfx fields = do
910 879273e3 Iustin Pop
  let name = mkName sname
911 879273e3 Iustin Pop
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
912 879273e3 Iustin Pop
  let decl_d = RecC name fields_d
913 139c0683 Iustin Pop
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
914 879273e3 Iustin Pop
  ser_decls <- buildObjectSerialisation sname fields
915 879273e3 Iustin Pop
  return $ declD:ser_decls
916 879273e3 Iustin Pop
917 12e8358c Iustin Pop
-- | Generates an object definition: data type and its JSON instance.
918 879273e3 Iustin Pop
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
919 879273e3 Iustin Pop
buildObjectSerialisation sname fields = do
920 879273e3 Iustin Pop
  let name = mkName sname
921 879273e3 Iustin Pop
  savedecls <- genSaveObject saveObjectField sname fields
922 879273e3 Iustin Pop
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
923 879273e3 Iustin Pop
  shjson <- objectShowJSON sname
924 879273e3 Iustin Pop
  rdjson <- objectReadJSON sname
925 879273e3 Iustin Pop
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
926 ffbd9592 Iustin Pop
                 [rdjson, shjson]
927 879273e3 Iustin Pop
  return $ savedecls ++ [loadsig, loadfn, instdecl]
928 879273e3 Iustin Pop
929 2af78b97 Iustin Pop
-- | The toDict function name for a given type.
930 2af78b97 Iustin Pop
toDictName :: String -> Name
931 2af78b97 Iustin Pop
toDictName sname = mkName ("toDict" ++ sname)
932 2af78b97 Iustin Pop
933 12e8358c Iustin Pop
-- | Generates the save object functionality.
934 879273e3 Iustin Pop
genSaveObject :: (Name -> Field -> Q Exp)
935 879273e3 Iustin Pop
              -> String -> [Field] -> Q [Dec]
936 879273e3 Iustin Pop
genSaveObject save_fn sname fields = do
937 879273e3 Iustin Pop
  let name = mkName sname
938 d8cb8e13 Iustin Pop
  fnames <- mapM (newName . fieldVariable) fields
939 879273e3 Iustin Pop
  let pat = conP name (map varP fnames)
940 2af78b97 Iustin Pop
  let tdname = toDictName sname
941 879273e3 Iustin Pop
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
942 879273e3 Iustin Pop
943 879273e3 Iustin Pop
  let felems = map (uncurry save_fn) (zip fnames fields)
944 879273e3 Iustin Pop
      flist = listE felems
945 879273e3 Iustin Pop
      -- and finally convert all this to a json object
946 879273e3 Iustin Pop
      tdlist = [| concat $flist |]
947 879273e3 Iustin Pop
      iname = mkName "i"
948 879273e3 Iustin Pop
  tclause <- clause [pat] (normalB tdlist) []
949 32a569fe Iustin Pop
  cclause <- [| $makeObjE . $(varE tdname) |]
950 879273e3 Iustin Pop
  let fname = mkName ("save" ++ sname)
951 879273e3 Iustin Pop
  sigt <- [t| $(conT name) -> JSON.JSValue |]
952 879273e3 Iustin Pop
  return [SigD tdname tdsigt, FunD tdname [tclause],
953 879273e3 Iustin Pop
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
954 879273e3 Iustin Pop
955 12e8358c Iustin Pop
-- | Generates the code for saving an object's field, handling the
956 12e8358c Iustin Pop
-- various types of fields that we have.
957 879273e3 Iustin Pop
saveObjectField :: Name -> Field -> Q Exp
958 9b156883 Iustin Pop
saveObjectField fvar field =
959 9b156883 Iustin Pop
  case fieldIsOptional field of
960 9b156883 Iustin Pop
    OptionalOmitNull -> [| case $(varE fvar) of
961 9b156883 Iustin Pop
                             Nothing -> []
962 9b156883 Iustin Pop
                             Just v  -> [( $nameE, JSON.showJSON v )]
963 9b156883 Iustin Pop
                         |]
964 9b156883 Iustin Pop
    OptionalSerializeNull -> [| case $(varE fvar) of
965 9b156883 Iustin Pop
                                  Nothing -> [( $nameE, JSON.JSNull )]
966 9b156883 Iustin Pop
                                  Just v  -> [( $nameE, JSON.showJSON v )]
967 9b156883 Iustin Pop
                              |]
968 9b156883 Iustin Pop
    NotOptional ->
969 9b156883 Iustin Pop
      case fieldShow field of
970 88609f00 Iustin Pop
        -- Note: the order of actual:extra is important, since for
971 88609f00 Iustin Pop
        -- some serialisation types (e.g. Luxi), we use tuples
972 88609f00 Iustin Pop
        -- (positional info) rather than object (name info)
973 9b156883 Iustin Pop
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
974 9b156883 Iustin Pop
        Just fn -> [| let (actual, extra) = $fn $fvarE
975 88609f00 Iustin Pop
                      in ($nameE, JSON.showJSON actual):extra
976 9b156883 Iustin Pop
                    |]
977 9b156883 Iustin Pop
  where nameE = stringE (fieldName field)
978 879273e3 Iustin Pop
        fvarE = varE fvar
979 879273e3 Iustin Pop
980 12e8358c Iustin Pop
-- | Generates the showJSON clause for a given object name.
981 ffbd9592 Iustin Pop
objectShowJSON :: String -> Q Dec
982 ffbd9592 Iustin Pop
objectShowJSON name = do
983 ffbd9592 Iustin Pop
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
984 32a569fe Iustin Pop
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
985 879273e3 Iustin Pop
986 12e8358c Iustin Pop
-- | Generates the load object functionality.
987 879273e3 Iustin Pop
genLoadObject :: (Field -> Q (Name, Stmt))
988 879273e3 Iustin Pop
              -> String -> [Field] -> Q (Dec, Dec)
989 879273e3 Iustin Pop
genLoadObject load_fn sname fields = do
990 879273e3 Iustin Pop
  let name = mkName sname
991 879273e3 Iustin Pop
      funname = mkName $ "load" ++ sname
992 08f7d24d Iustin Pop
      arg1 = mkName $ if null fields then "_" else "v"
993 879273e3 Iustin Pop
      objname = mkName "o"
994 879273e3 Iustin Pop
      opid = mkName "op_id"
995 879273e3 Iustin Pop
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
996 879273e3 Iustin Pop
                                 (JSON.readJSON $(varE arg1)) |]
997 879273e3 Iustin Pop
  fbinds <- mapM load_fn fields
998 879273e3 Iustin Pop
  let (fnames, fstmts) = unzip fbinds
999 879273e3 Iustin Pop
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
1000 08f7d24d Iustin Pop
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
1001 08f7d24d Iustin Pop
      -- FIXME: should we require an empty dict for an empty type?
1002 08f7d24d Iustin Pop
      -- this allows any JSValue right now
1003 08f7d24d Iustin Pop
      fstmts' = if null fields
1004 08f7d24d Iustin Pop
                  then retstmt
1005 08f7d24d Iustin Pop
                  else st1:fstmts ++ retstmt
1006 879273e3 Iustin Pop
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
1007 879273e3 Iustin Pop
  return $ (SigD funname sigt,
1008 879273e3 Iustin Pop
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
1009 879273e3 Iustin Pop
1010 12e8358c Iustin Pop
-- | Generates code for loading an object's field.
1011 879273e3 Iustin Pop
loadObjectField :: Field -> Q (Name, Stmt)
1012 879273e3 Iustin Pop
loadObjectField field = do
1013 879273e3 Iustin Pop
  let name = fieldVariable field
1014 d8cb8e13 Iustin Pop
  fvar <- newName name
1015 879273e3 Iustin Pop
  -- these are used in all patterns below
1016 879273e3 Iustin Pop
  let objvar = varNameE "o"
1017 879273e3 Iustin Pop
      objfield = stringE (fieldName field)
1018 879273e3 Iustin Pop
      loadexp =
1019 9b156883 Iustin Pop
        if fieldIsOptional field /= NotOptional
1020 9b156883 Iustin Pop
          -- we treat both optional types the same, since
1021 9b156883 Iustin Pop
          -- 'maybeFromObj' can deal with both missing and null values
1022 9b156883 Iustin Pop
          -- appropriately (the same)
1023 32a569fe Iustin Pop
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
1024 879273e3 Iustin Pop
          else case fieldDefault field of
1025 879273e3 Iustin Pop
                 Just defv ->
1026 32a569fe Iustin Pop
                   [| $(varE 'fromObjWithDefault) $objvar
1027 879273e3 Iustin Pop
                      $objfield $defv |]
1028 32a569fe Iustin Pop
                 Nothing -> [| $fromObjE $objvar $objfield |]
1029 1c7bda0a Iustin Pop
  bexp <- loadFn field loadexp objvar
1030 879273e3 Iustin Pop
1031 879273e3 Iustin Pop
  return (fvar, BindS (VarP fvar) bexp)
1032 879273e3 Iustin Pop
1033 12e8358c Iustin Pop
-- | Builds the readJSON instance for a given object name.
1034 879273e3 Iustin Pop
objectReadJSON :: String -> Q Dec
1035 879273e3 Iustin Pop
objectReadJSON name = do
1036 879273e3 Iustin Pop
  let s = mkName "s"
1037 879273e3 Iustin Pop
  body <- [| case JSON.readJSON $(varE s) of
1038 879273e3 Iustin Pop
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
1039 879273e3 Iustin Pop
               JSON.Error e ->
1040 879273e3 Iustin Pop
                 JSON.Error $ "Can't parse value for type " ++
1041 879273e3 Iustin Pop
                       $(stringE name) ++ ": " ++ e
1042 879273e3 Iustin Pop
           |]
1043 32a569fe Iustin Pop
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1044 879273e3 Iustin Pop
1045 879273e3 Iustin Pop
-- * Inheritable parameter tables implementation
1046 879273e3 Iustin Pop
1047 879273e3 Iustin Pop
-- | Compute parameter type names.
1048 879273e3 Iustin Pop
paramTypeNames :: String -> (String, String)
1049 879273e3 Iustin Pop
paramTypeNames root = ("Filled"  ++ root ++ "Params",
1050 879273e3 Iustin Pop
                       "Partial" ++ root ++ "Params")
1051 879273e3 Iustin Pop
1052 879273e3 Iustin Pop
-- | Compute information about the type of a parameter field.
1053 879273e3 Iustin Pop
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1054 879273e3 Iustin Pop
paramFieldTypeInfo field_pfx fd = do
1055 879273e3 Iustin Pop
  t <- actualFieldType fd
1056 879273e3 Iustin Pop
  let n = mkName . (++ "P") . (field_pfx ++) .
1057 879273e3 Iustin Pop
          fieldRecordName $ fd
1058 879273e3 Iustin Pop
  return (n, NotStrict, AppT (ConT ''Maybe) t)
1059 879273e3 Iustin Pop
1060 879273e3 Iustin Pop
-- | Build a parameter declaration.
1061 879273e3 Iustin Pop
--
1062 879273e3 Iustin Pop
-- This function builds two different data structures: a /filled/ one,
1063 879273e3 Iustin Pop
-- in which all fields are required, and a /partial/ one, in which all
1064 879273e3 Iustin Pop
-- fields are optional. Due to the current record syntax issues, the
1065 879273e3 Iustin Pop
-- fields need to be named differrently for the two structures, so the
1066 879273e3 Iustin Pop
-- partial ones get a /P/ suffix.
1067 879273e3 Iustin Pop
buildParam :: String -> String -> [Field] -> Q [Dec]
1068 879273e3 Iustin Pop
buildParam sname field_pfx fields = do
1069 879273e3 Iustin Pop
  let (sname_f, sname_p) = paramTypeNames sname
1070 879273e3 Iustin Pop
      name_f = mkName sname_f
1071 879273e3 Iustin Pop
      name_p = mkName sname_p
1072 879273e3 Iustin Pop
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
1073 879273e3 Iustin Pop
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
1074 879273e3 Iustin Pop
  let decl_f = RecC name_f fields_f
1075 879273e3 Iustin Pop
      decl_p = RecC name_p fields_p
1076 139c0683 Iustin Pop
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
1077 139c0683 Iustin Pop
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1078 879273e3 Iustin Pop
  ser_decls_f <- buildObjectSerialisation sname_f fields
1079 879273e3 Iustin Pop
  ser_decls_p <- buildPParamSerialisation sname_p fields
1080 879273e3 Iustin Pop
  fill_decls <- fillParam sname field_pfx fields
1081 2af78b97 Iustin Pop
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
1082 2af78b97 Iustin Pop
           buildParamAllFields sname fields ++
1083 2af78b97 Iustin Pop
           buildDictObjectInst name_f sname_f
1084 2af78b97 Iustin Pop
1085 2af78b97 Iustin Pop
-- | Builds a list of all fields of a parameter.
1086 2af78b97 Iustin Pop
buildParamAllFields :: String -> [Field] -> [Dec]
1087 2af78b97 Iustin Pop
buildParamAllFields sname fields =
1088 2af78b97 Iustin Pop
  let vname = mkName ("all" ++ sname ++ "ParamFields")
1089 2af78b97 Iustin Pop
      sig = SigD vname (AppT ListT (ConT ''String))
1090 2af78b97 Iustin Pop
      val = ListE $ map (LitE . StringL . fieldName) fields
1091 2af78b97 Iustin Pop
  in [sig, ValD (VarP vname) (NormalB val) []]
1092 2af78b97 Iustin Pop
1093 2af78b97 Iustin Pop
-- | Builds the 'DictObject' instance for a filled parameter.
1094 2af78b97 Iustin Pop
buildDictObjectInst :: Name -> String -> [Dec]
1095 2af78b97 Iustin Pop
buildDictObjectInst name sname =
1096 2af78b97 Iustin Pop
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1097 2af78b97 Iustin Pop
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
1098 879273e3 Iustin Pop
1099 12e8358c Iustin Pop
-- | Generates the serialisation for a partial parameter.
1100 879273e3 Iustin Pop
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1101 879273e3 Iustin Pop
buildPParamSerialisation sname fields = do
1102 879273e3 Iustin Pop
  let name = mkName sname
1103 879273e3 Iustin Pop
  savedecls <- genSaveObject savePParamField sname fields
1104 879273e3 Iustin Pop
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
1105 879273e3 Iustin Pop
  shjson <- objectShowJSON sname
1106 879273e3 Iustin Pop
  rdjson <- objectReadJSON sname
1107 879273e3 Iustin Pop
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1108 ffbd9592 Iustin Pop
                 [rdjson, shjson]
1109 879273e3 Iustin Pop
  return $ savedecls ++ [loadsig, loadfn, instdecl]
1110 879273e3 Iustin Pop
1111 12e8358c Iustin Pop
-- | Generates code to save an optional parameter field.
1112 879273e3 Iustin Pop
savePParamField :: Name -> Field -> Q Exp
1113 879273e3 Iustin Pop
savePParamField fvar field = do
1114 879273e3 Iustin Pop
  checkNonOptDef field
1115 879273e3 Iustin Pop
  let actualVal = mkName "v"
1116 879273e3 Iustin Pop
  normalexpr <- saveObjectField actualVal field
1117 879273e3 Iustin Pop
  -- we have to construct the block here manually, because we can't
1118 879273e3 Iustin Pop
  -- splice-in-splice
1119 879273e3 Iustin Pop
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1120 879273e3 Iustin Pop
                                       (NormalB (ConE '[])) []
1121 879273e3 Iustin Pop
                             , Match (ConP 'Just [VarP actualVal])
1122 879273e3 Iustin Pop
                                       (NormalB normalexpr) []
1123 879273e3 Iustin Pop
                             ]
1124 12e8358c Iustin Pop
1125 12e8358c Iustin Pop
-- | Generates code to load an optional parameter field.
1126 879273e3 Iustin Pop
loadPParamField :: Field -> Q (Name, Stmt)
1127 879273e3 Iustin Pop
loadPParamField field = do
1128 879273e3 Iustin Pop
  checkNonOptDef field
1129 879273e3 Iustin Pop
  let name = fieldName field
1130 d8cb8e13 Iustin Pop
  fvar <- newName name
1131 879273e3 Iustin Pop
  -- these are used in all patterns below
1132 879273e3 Iustin Pop
  let objvar = varNameE "o"
1133 879273e3 Iustin Pop
      objfield = stringE name
1134 32a569fe Iustin Pop
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1135 1c7bda0a Iustin Pop
  bexp <- loadFn field loadexp objvar
1136 879273e3 Iustin Pop
  return (fvar, BindS (VarP fvar) bexp)
1137 879273e3 Iustin Pop
1138 879273e3 Iustin Pop
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1139 879273e3 Iustin Pop
buildFromMaybe :: String -> Q Dec
1140 879273e3 Iustin Pop
buildFromMaybe fname =
1141 879273e3 Iustin Pop
  valD (varP (mkName $ "n_" ++ fname))
1142 32a569fe Iustin Pop
         (normalB [| $(varE 'fromMaybe)
1143 879273e3 Iustin Pop
                        $(varNameE $ "f_" ++ fname)
1144 879273e3 Iustin Pop
                        $(varNameE $ "p_" ++ fname) |]) []
1145 879273e3 Iustin Pop
1146 12e8358c Iustin Pop
-- | Builds a function that executes the filling of partial parameter
1147 12e8358c Iustin Pop
-- from a full copy (similar to Python's fillDict).
1148 879273e3 Iustin Pop
fillParam :: String -> String -> [Field] -> Q [Dec]
1149 879273e3 Iustin Pop
fillParam sname field_pfx fields = do
1150 879273e3 Iustin Pop
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
1151 879273e3 Iustin Pop
      (sname_f, sname_p) = paramTypeNames sname
1152 879273e3 Iustin Pop
      oname_f = "fobj"
1153 879273e3 Iustin Pop
      oname_p = "pobj"
1154 879273e3 Iustin Pop
      name_f = mkName sname_f
1155 879273e3 Iustin Pop
      name_p = mkName sname_p
1156 879273e3 Iustin Pop
      fun_name = mkName $ "fill" ++ sname ++ "Params"
1157 879273e3 Iustin Pop
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
1158 879273e3 Iustin Pop
                (NormalB . VarE . mkName $ oname_f) []
1159 879273e3 Iustin Pop
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
1160 879273e3 Iustin Pop
                (NormalB . VarE . mkName $ oname_p) []
1161 879273e3 Iustin Pop
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
1162 879273e3 Iustin Pop
                $ map (mkName . ("n_" ++)) fnames
1163 879273e3 Iustin Pop
  le_new <- mapM buildFromMaybe fnames
1164 879273e3 Iustin Pop
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
1165 879273e3 Iustin Pop
  let sig = SigD fun_name funt
1166 879273e3 Iustin Pop
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
1167 879273e3 Iustin Pop
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
1168 879273e3 Iustin Pop
      fun = FunD fun_name [fclause]
1169 879273e3 Iustin Pop
  return [sig, fun]
1170 ef3ad027 Iustin Pop
1171 ef3ad027 Iustin Pop
-- * Template code for exceptions
1172 ef3ad027 Iustin Pop
1173 ef3ad027 Iustin Pop
-- | Exception simple error message field.
1174 ef3ad027 Iustin Pop
excErrMsg :: (String, Q Type)
1175 ef3ad027 Iustin Pop
excErrMsg = ("errMsg", [t| String |])
1176 ef3ad027 Iustin Pop
1177 ef3ad027 Iustin Pop
-- | Builds an exception type definition.
1178 ef3ad027 Iustin Pop
genException :: String                  -- ^ Name of new type
1179 ef3ad027 Iustin Pop
             -> SimpleObject -- ^ Constructor name and parameters
1180 ef3ad027 Iustin Pop
             -> Q [Dec]
1181 ef3ad027 Iustin Pop
genException name cons = do
1182 ef3ad027 Iustin Pop
  let tname = mkName name
1183 ef3ad027 Iustin Pop
  declD <- buildSimpleCons tname cons
1184 ef3ad027 Iustin Pop
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1185 ef3ad027 Iustin Pop
                         uncurry saveExcCons
1186 ef3ad027 Iustin Pop
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1187 ef3ad027 Iustin Pop
  return [declD, loadsig, loadfn, savesig, savefn]
1188 ef3ad027 Iustin Pop
1189 ef3ad027 Iustin Pop
-- | Generates the \"save\" clause for an entire exception constructor.
1190 ef3ad027 Iustin Pop
--
1191 ef3ad027 Iustin Pop
-- This matches the exception with variables named the same as the
1192 ef3ad027 Iustin Pop
-- constructor fields (just so that the spliced in code looks nicer),
1193 ef3ad027 Iustin Pop
-- and calls showJSON on it.
1194 ef3ad027 Iustin Pop
saveExcCons :: String        -- ^ The constructor name
1195 ef3ad027 Iustin Pop
            -> [SimpleField] -- ^ The parameter definitions for this
1196 ef3ad027 Iustin Pop
                             -- constructor
1197 ef3ad027 Iustin Pop
            -> Q Clause      -- ^ Resulting clause
1198 ef3ad027 Iustin Pop
saveExcCons sname fields = do
1199 ef3ad027 Iustin Pop
  let cname = mkName sname
1200 ef3ad027 Iustin Pop
  fnames <- mapM (newName . fst) fields
1201 ef3ad027 Iustin Pop
  let pat = conP cname (map varP fnames)
1202 ef3ad027 Iustin Pop
      felems = if null fnames
1203 ef3ad027 Iustin Pop
                 then conE '() -- otherwise, empty list has no type
1204 ef3ad027 Iustin Pop
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1205 ef3ad027 Iustin Pop
  let tup = tupE [ litE (stringL sname), felems ]
1206 ef3ad027 Iustin Pop
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
1207 ef3ad027 Iustin Pop
1208 ef3ad027 Iustin Pop
-- | Generates load code for a single constructor of an exception.
1209 ef3ad027 Iustin Pop
--
1210 ef3ad027 Iustin Pop
-- Generates the code (if there's only one argument, we will use a
1211 ef3ad027 Iustin Pop
-- list, not a tuple:
1212 ef3ad027 Iustin Pop
--
1213 ef3ad027 Iustin Pop
-- @
1214 ef3ad027 Iustin Pop
-- do
1215 ef3ad027 Iustin Pop
--  (x1, x2, ...) <- readJSON args
1216 ef3ad027 Iustin Pop
--  return $ Cons x1 x2 ...
1217 ef3ad027 Iustin Pop
-- @
1218 ef3ad027 Iustin Pop
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1219 ef3ad027 Iustin Pop
loadExcConstructor inname sname fields = do
1220 ef3ad027 Iustin Pop
  let name = mkName sname
1221 ef3ad027 Iustin Pop
  f_names <- mapM (newName . fst) fields
1222 ef3ad027 Iustin Pop
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1223 ef3ad027 Iustin Pop
  let binds = case f_names of
1224 ef3ad027 Iustin Pop
                [x] -> BindS (ListP [VarP x])
1225 ef3ad027 Iustin Pop
                _   -> BindS (TupP (map VarP f_names))
1226 ef3ad027 Iustin Pop
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
1227 ef3ad027 Iustin Pop
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1228 ef3ad027 Iustin Pop
1229 ef3ad027 Iustin Pop
{-| Generates the loadException function.
1230 ef3ad027 Iustin Pop
1231 ef3ad027 Iustin Pop
This generates a quite complicated function, along the lines of:
1232 ef3ad027 Iustin Pop
1233 ef3ad027 Iustin Pop
@
1234 ef3ad027 Iustin Pop
loadFn (JSArray [JSString name, args]) = case name of
1235 ef3ad027 Iustin Pop
   "A1" -> do
1236 ef3ad027 Iustin Pop
     (x1, x2, ...) <- readJSON args
1237 ef3ad027 Iustin Pop
     return $ A1 x1 x2 ...
1238 ef3ad027 Iustin Pop
   "a2" -> ...
1239 ef3ad027 Iustin Pop
   s -> fail $ "Unknown exception" ++ s
1240 ef3ad027 Iustin Pop
loadFn v = fail $ "Expected array but got " ++ show v
1241 ef3ad027 Iustin Pop
@
1242 ef3ad027 Iustin Pop
-}
1243 ef3ad027 Iustin Pop
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1244 ef3ad027 Iustin Pop
genLoadExc tname sname opdefs = do
1245 ef3ad027 Iustin Pop
  let fname = mkName sname
1246 ef3ad027 Iustin Pop
  exc_name <- newName "name"
1247 ef3ad027 Iustin Pop
  exc_args <- newName "args"
1248 ef3ad027 Iustin Pop
  exc_else <- newName "s"
1249 ef3ad027 Iustin Pop
  arg_else <- newName "v"
1250 ef3ad027 Iustin Pop
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1251 ef3ad027 Iustin Pop
  -- default match for unknown exception name
1252 ef3ad027 Iustin Pop
  let defmatch = Match (VarP exc_else) (NormalB fails) []
1253 ef3ad027 Iustin Pop
  -- the match results (per-constructor blocks)
1254 ef3ad027 Iustin Pop
  str_matches <-
1255 ef3ad027 Iustin Pop
    mapM (\(s, params) -> do
1256 ef3ad027 Iustin Pop
            body_exp <- loadExcConstructor exc_args s params
1257 ef3ad027 Iustin Pop
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1258 ef3ad027 Iustin Pop
    opdefs
1259 ef3ad027 Iustin Pop
  -- the first function clause; we can't use [| |] due to TH
1260 ef3ad027 Iustin Pop
  -- limitations, so we have to build the AST by hand
1261 ef3ad027 Iustin Pop
  let clause1 = Clause [ConP 'JSON.JSArray
1262 ef3ad027 Iustin Pop
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
1263 ef3ad027 Iustin Pop
                                            VarP exc_args]]]
1264 ef3ad027 Iustin Pop
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1265 ef3ad027 Iustin Pop
                                        (VarE exc_name))
1266 ef3ad027 Iustin Pop
                          (str_matches ++ [defmatch]))) []
1267 ef3ad027 Iustin Pop
  -- the fail expression for the second function clause
1268 ef3ad027 Iustin Pop
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1269 ef3ad027 Iustin Pop
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1270 ef3ad027 Iustin Pop
                |]
1271 ef3ad027 Iustin Pop
  -- the second function clause
1272 ef3ad027 Iustin Pop
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1273 ef3ad027 Iustin Pop
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1274 ef3ad027 Iustin Pop
  return $ (SigD fname sigt, FunD fname [clause1, clause2])