Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 11e90588

History | View | Annotate | Download (40.5 kB)

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