Revision e9aaa3c6
b/Makefile.am | ||
---|---|---|
364 | 364 |
htools/Ganeti/HTools/Program/Hspace.hs \ |
365 | 365 |
htools/Ganeti/Jobs.hs \ |
366 | 366 |
htools/Ganeti/Luxi.hs \ |
367 |
htools/Ganeti/OpCodes.hs |
|
367 |
htools/Ganeti/OpCodes.hs \ |
|
368 |
htools/Ganeti/THH.hs |
|
368 | 369 |
|
369 | 370 |
HS_BUILT_SRCS = htools/Ganeti/HTools/Version.hs htools/Ganeti/Constants.hs |
370 | 371 |
HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS)) |
b/htools/Ganeti/HTools/Types.hs | ||
---|---|---|
1 |
{-# LANGUAGE TemplateHaskell #-} |
|
2 |
|
|
1 | 3 |
{-| Some common types. |
2 | 4 |
|
3 | 5 |
-} |
... | ... | |
72 | 74 |
import qualified Text.JSON as JSON |
73 | 75 |
|
74 | 76 |
import qualified Ganeti.Constants as C |
77 |
import qualified Ganeti.THH as THH |
|
75 | 78 |
|
76 | 79 |
-- | The instance index type. |
77 | 80 |
type Idx = Int |
... | ... | |
100 | 103 |
-- Ord instance will order them in the order they are defined, so when |
101 | 104 |
-- changing this data type be careful about the interaction with the |
102 | 105 |
-- desired sorting order. |
103 |
data AllocPolicy |
|
104 |
= AllocPreferred -- ^ This is the normal status, the group |
|
105 |
-- should be used normally during allocations |
|
106 |
| AllocLastResort -- ^ This group should be used only as |
|
107 |
-- last-resort, after the preferred groups |
|
108 |
| AllocUnallocable -- ^ This group must not be used for new |
|
109 |
-- allocations |
|
110 |
deriving (Show, Read, Eq, Ord, Enum, Bounded) |
|
111 |
|
|
112 |
-- | Convert a string to an alloc policy. |
|
113 |
allocPolicyFromString :: (Monad m) => String -> m AllocPolicy |
|
114 |
allocPolicyFromString s = |
|
115 |
case () of |
|
116 |
_ | s == C.allocPolicyPreferred -> return AllocPreferred |
|
117 |
| s == C.allocPolicyLastResort -> return AllocLastResort |
|
118 |
| s == C.allocPolicyUnallocable -> return AllocUnallocable |
|
119 |
| otherwise -> fail $ "Invalid alloc policy mode: " ++ s |
|
120 |
|
|
121 |
-- | Convert an alloc policy to the Ganeti string equivalent. |
|
122 |
allocPolicyToString :: AllocPolicy -> String |
|
123 |
allocPolicyToString AllocPreferred = C.allocPolicyPreferred |
|
124 |
allocPolicyToString AllocLastResort = C.allocPolicyLastResort |
|
125 |
allocPolicyToString AllocUnallocable = C.allocPolicyUnallocable |
|
126 |
|
|
127 |
instance JSON.JSON AllocPolicy where |
|
128 |
showJSON = JSON.showJSON . allocPolicyToString |
|
129 |
readJSON s = case JSON.readJSON s of |
|
130 |
JSON.Ok s' -> allocPolicyFromString s' |
|
131 |
JSON.Error e -> JSON.Error $ |
|
132 |
"Can't parse alloc_policy: " ++ e |
|
106 |
$(THH.declareSADT "AllocPolicy" |
|
107 |
[ ("AllocPreferred", 'C.allocPolicyPreferred) |
|
108 |
, ("AllocLastResort", 'C.allocPolicyLastResort) |
|
109 |
, ("AllocUnallocable", 'C.allocPolicyUnallocable) |
|
110 |
]) |
|
111 |
$(THH.makeJSONInstance ''AllocPolicy) |
|
133 | 112 |
|
134 | 113 |
-- | The resource spec type. |
135 | 114 |
data RSpec = RSpec |
... | ... | |
182 | 161 |
deriving (Show, Read) |
183 | 162 |
|
184 | 163 |
-- | Instance disk template type. |
185 |
data DiskTemplate = DTDiskless |
|
186 |
| DTFile |
|
187 |
| DTSharedFile |
|
188 |
| DTPlain |
|
189 |
| DTBlock |
|
190 |
| DTDrbd8 |
|
191 |
deriving (Show, Read, Eq, Enum, Bounded) |
|
192 |
|
|
193 |
-- | Converts a DiskTemplate to String. |
|
194 |
diskTemplateToString :: DiskTemplate -> String |
|
195 |
diskTemplateToString DTDiskless = C.dtDiskless |
|
196 |
diskTemplateToString DTFile = C.dtFile |
|
197 |
diskTemplateToString DTSharedFile = C.dtSharedFile |
|
198 |
diskTemplateToString DTPlain = C.dtPlain |
|
199 |
diskTemplateToString DTBlock = C.dtBlock |
|
200 |
diskTemplateToString DTDrbd8 = C.dtDrbd8 |
|
201 |
|
|
202 |
-- | Converts a DiskTemplate from String. |
|
203 |
diskTemplateFromString :: (Monad m) => String -> m DiskTemplate |
|
204 |
diskTemplateFromString s = |
|
205 |
case () of |
|
206 |
_ | s == C.dtDiskless -> return DTDiskless |
|
207 |
| s == C.dtFile -> return DTFile |
|
208 |
| s == C.dtSharedFile -> return DTSharedFile |
|
209 |
| s == C.dtPlain -> return DTPlain |
|
210 |
| s == C.dtBlock -> return DTBlock |
|
211 |
| s == C.dtDrbd8 -> return DTDrbd8 |
|
212 |
| otherwise -> fail $ "Invalid disk template: " ++ s |
|
213 |
|
|
214 |
instance JSON.JSON DiskTemplate where |
|
215 |
showJSON = JSON.showJSON . diskTemplateToString |
|
216 |
readJSON s = case JSON.readJSON s of |
|
217 |
JSON.Ok s' -> diskTemplateFromString s' |
|
218 |
JSON.Error e -> JSON.Error $ |
|
219 |
"Can't parse disk_template as string: " ++ e |
|
164 |
$(THH.declareSADT "DiskTemplate" |
|
165 |
[ ("DTDiskless", 'C.dtDiskless) |
|
166 |
, ("DTFile", 'C.dtFile) |
|
167 |
, ("DTSharedFile", 'C.dtSharedFile) |
|
168 |
, ("DTPlain", 'C.dtPlain) |
|
169 |
, ("DTBlock", 'C.dtBlock) |
|
170 |
, ("DTDrbd8", 'C.dtDrbd8) |
|
171 |
]) |
|
172 |
$(THH.makeJSONInstance ''DiskTemplate) |
|
220 | 173 |
|
221 | 174 |
-- | Formatted solution output for one move (involved nodes and |
222 | 175 |
-- commands. |
... | ... | |
347 | 300 |
setIdx :: a -> Int -> a |
348 | 301 |
|
349 | 302 |
-- | The iallocator node-evacuate evac_mode type. |
350 |
data EvacMode = ChangePrimary |
|
351 |
| ChangeSecondary |
|
352 |
| ChangeAll |
|
353 |
deriving (Show, Read) |
|
354 |
|
|
355 |
instance JSON.JSON EvacMode where |
|
356 |
showJSON mode = case mode of |
|
357 |
ChangeAll -> JSON.showJSON C.iallocatorNevacAll |
|
358 |
ChangePrimary -> JSON.showJSON C.iallocatorNevacPri |
|
359 |
ChangeSecondary -> JSON.showJSON C.iallocatorNevacSec |
|
360 |
readJSON v = |
|
361 |
case JSON.readJSON v of |
|
362 |
JSON.Ok s | s == C.iallocatorNevacAll -> return ChangeAll |
|
363 |
| s == C.iallocatorNevacPri -> return ChangePrimary |
|
364 |
| s == C.iallocatorNevacSec -> return ChangeSecondary |
|
365 |
| otherwise -> fail $ "Invalid evacuate mode " ++ s |
|
366 |
JSON.Error e -> JSON.Error $ |
|
367 |
"Can't parse evacuate mode as string: " ++ e |
|
303 |
$(THH.declareSADT "EvacMode" |
|
304 |
[ ("ChangePrimary", 'C.iallocatorNevacPri) |
|
305 |
, ("ChangeSecondary", 'C.iallocatorNevacSec) |
|
306 |
, ("ChangeAll", 'C.iallocatorNevacAll) |
|
307 |
]) |
|
308 |
$(THH.makeJSONInstance ''EvacMode) |
b/htools/Ganeti/Jobs.hs | ||
---|---|---|
1 |
{-# LANGUAGE TemplateHaskell #-} |
|
2 |
|
|
1 | 3 |
{-| Implementation of the job information. |
2 | 4 |
|
3 | 5 |
-} |
... | ... | |
32 | 34 |
import qualified Text.JSON as J |
33 | 35 |
|
34 | 36 |
import qualified Ganeti.Constants as C |
37 |
import qualified Ganeti.THH as THH |
|
35 | 38 |
|
36 | 39 |
-- | Our ADT for the OpCode status at runtime (while in a job). |
37 |
data OpStatus = OP_STATUS_QUEUED |
|
38 |
| OP_STATUS_WAITING |
|
39 |
| OP_STATUS_CANCELING |
|
40 |
| OP_STATUS_RUNNING |
|
41 |
| OP_STATUS_CANCELED |
|
42 |
| OP_STATUS_SUCCESS |
|
43 |
| OP_STATUS_ERROR |
|
44 |
deriving (Eq, Enum, Bounded, Show, Read) |
|
45 |
|
|
46 |
instance JSON OpStatus where |
|
47 |
showJSON os = showJSON w |
|
48 |
where w = case os of |
|
49 |
OP_STATUS_QUEUED -> C.opStatusQueued |
|
50 |
OP_STATUS_WAITING -> C.opStatusWaiting |
|
51 |
OP_STATUS_CANCELING -> C.opStatusCanceling |
|
52 |
OP_STATUS_RUNNING -> C.opStatusRunning |
|
53 |
OP_STATUS_CANCELED -> C.opStatusCanceled |
|
54 |
OP_STATUS_SUCCESS -> C.opStatusSuccess |
|
55 |
OP_STATUS_ERROR -> C.opStatusError |
|
56 |
readJSON s = case readJSON s of |
|
57 |
J.Ok v | v == C.opStatusQueued -> J.Ok OP_STATUS_QUEUED |
|
58 |
| v == C.opStatusWaiting -> J.Ok OP_STATUS_WAITING |
|
59 |
| v == C.opStatusCanceling -> J.Ok OP_STATUS_CANCELING |
|
60 |
| v == C.opStatusRunning -> J.Ok OP_STATUS_RUNNING |
|
61 |
| v == C.opStatusCanceled -> J.Ok OP_STATUS_CANCELED |
|
62 |
| v == C.opStatusSuccess -> J.Ok OP_STATUS_SUCCESS |
|
63 |
| v == C.opStatusError -> J.Ok OP_STATUS_ERROR |
|
64 |
| otherwise -> J.Error ("Unknown opcode status " ++ v) |
|
65 |
_ -> J.Error ("Cannot parse opcode status " ++ show s) |
|
40 |
$(THH.declareSADT "OpStatus" |
|
41 |
[ ("OP_STATUS_QUEUED", 'C.opStatusQueued) |
|
42 |
, ("OP_STATUS_WAITING", 'C.opStatusWaiting) |
|
43 |
, ("OP_STATUS_CANCELING", 'C.opStatusCanceling) |
|
44 |
, ("OP_STATUS_RUNNING", 'C.opStatusRunning) |
|
45 |
, ("OP_STATUS_CANCELED", 'C.opStatusCanceled) |
|
46 |
, ("OP_STATUS_SUCCESS", 'C.opStatusSuccess) |
|
47 |
, ("OP_STATUS_ERROR", 'C.opStatusError) |
|
48 |
]) |
|
49 |
$(THH.makeJSONInstance ''OpStatus) |
|
66 | 50 |
|
67 | 51 |
-- | The JobStatus data type. Note that this is ordered especially |
68 | 52 |
-- such that greater\/lesser comparison on values of this type makes |
69 | 53 |
-- sense. |
70 |
data JobStatus = JOB_STATUS_QUEUED |
|
71 |
| JOB_STATUS_WAITING |
|
72 |
| JOB_STATUS_RUNNING |
|
73 |
| JOB_STATUS_SUCCESS |
|
74 |
| JOB_STATUS_CANCELING |
|
75 |
| JOB_STATUS_CANCELED |
|
76 |
| JOB_STATUS_ERROR |
|
77 |
deriving (Eq, Enum, Ord, Bounded, Show, Read) |
|
78 |
|
|
79 |
instance JSON JobStatus where |
|
80 |
showJSON js = showJSON w |
|
81 |
where w = case js of |
|
82 |
JOB_STATUS_QUEUED -> C.jobStatusQueued |
|
83 |
JOB_STATUS_WAITING -> C.jobStatusWaiting |
|
84 |
JOB_STATUS_CANCELING -> C.jobStatusCanceling |
|
85 |
JOB_STATUS_RUNNING -> C.jobStatusRunning |
|
86 |
JOB_STATUS_CANCELED -> C.jobStatusCanceled |
|
87 |
JOB_STATUS_SUCCESS -> C.jobStatusSuccess |
|
88 |
JOB_STATUS_ERROR -> C.jobStatusError |
|
89 |
readJSON s = case readJSON s of |
|
90 |
J.Ok v | v == C.jobStatusQueued -> J.Ok JOB_STATUS_QUEUED |
|
91 |
| v == C.jobStatusWaiting -> J.Ok JOB_STATUS_WAITING |
|
92 |
| v == C.jobStatusCanceling -> J.Ok JOB_STATUS_CANCELING |
|
93 |
| v == C.jobStatusRunning -> J.Ok JOB_STATUS_RUNNING |
|
94 |
| v == C.jobStatusSuccess -> J.Ok JOB_STATUS_SUCCESS |
|
95 |
| v == C.jobStatusCanceled -> J.Ok JOB_STATUS_CANCELED |
|
96 |
| v == C.jobStatusError -> J.Ok JOB_STATUS_ERROR |
|
97 |
| otherwise -> J.Error ("Unknown job status " ++ v) |
|
98 |
_ -> J.Error ("Unknown job status " ++ show s) |
|
54 |
$(THH.declareSADT "JobStatus" |
|
55 |
[ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued) |
|
56 |
, ("JOB_STATUS_WAITING", 'C.jobStatusWaiting) |
|
57 |
, ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling) |
|
58 |
, ("JOB_STATUS_RUNNING", 'C.jobStatusRunning) |
|
59 |
, ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled) |
|
60 |
, ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess) |
|
61 |
, ("JOB_STATUS_ERROR", 'C.jobStatusError) |
|
62 |
]) |
|
63 |
$(THH.makeJSONInstance ''JobStatus) |
b/htools/Ganeti/OpCodes.hs | ||
---|---|---|
1 |
{-# LANGUAGE TemplateHaskell #-} |
|
2 |
|
|
1 | 3 |
{-| Implementation of the opcodes. |
2 | 4 |
|
3 | 5 |
-} |
... | ... | |
34 | 36 |
import qualified Text.JSON as J |
35 | 37 |
import Text.JSON.Types |
36 | 38 |
|
39 |
import qualified Ganeti.Constants as C |
|
40 |
import qualified Ganeti.THH as THH |
|
41 |
|
|
37 | 42 |
import Ganeti.HTools.Utils |
38 | 43 |
|
39 | 44 |
-- | Replace disks type. |
40 |
data ReplaceDisksMode = ReplaceOnPrimary |
|
41 |
| ReplaceOnSecondary |
|
42 |
| ReplaceNewSecondary |
|
43 |
| ReplaceAuto |
|
44 |
deriving (Show, Read, Eq) |
|
45 |
|
|
46 |
instance JSON ReplaceDisksMode where |
|
47 |
showJSON m = case m of |
|
48 |
ReplaceOnPrimary -> showJSON "replace_on_primary" |
|
49 |
ReplaceOnSecondary -> showJSON "replace_on_secondary" |
|
50 |
ReplaceNewSecondary -> showJSON "replace_new_secondary" |
|
51 |
ReplaceAuto -> showJSON "replace_auto" |
|
52 |
readJSON s = case readJSON s of |
|
53 |
J.Ok "replace_on_primary" -> J.Ok ReplaceOnPrimary |
|
54 |
J.Ok "replace_on_secondary" -> J.Ok ReplaceOnSecondary |
|
55 |
J.Ok "replace_new_secondary" -> J.Ok ReplaceNewSecondary |
|
56 |
J.Ok "replace_auto" -> J.Ok ReplaceAuto |
|
57 |
_ -> J.Error "Can't parse a valid ReplaceDisksMode" |
|
45 |
$(THH.declareSADT "ReplaceDisksMode" |
|
46 |
[ ("ReplaceOnPrimary", 'C.replaceDiskPri) |
|
47 |
, ("ReplaceOnSecondary", 'C.replaceDiskSec) |
|
48 |
, ("ReplaceNewSecondary", 'C.replaceDiskChg) |
|
49 |
, ("ReplaceAuto", 'C.replaceDiskAuto) |
|
50 |
]) |
|
51 |
$(THH.makeJSONInstance ''ReplaceDisksMode) |
|
58 | 52 |
|
59 | 53 |
-- | OpCode representation. |
60 | 54 |
-- |
b/htools/Ganeti/THH.hs | ||
---|---|---|
1 |
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} |
|
2 |
|
|
3 |
{-| TemplateHaskell helper for HTools. |
|
4 |
|
|
5 |
As TemplateHaskell require that splices be defined in a separate |
|
6 |
module, we combine all the TemplateHaskell functionality that HTools |
|
7 |
needs in this module (except the one for unittests). |
|
8 |
|
|
9 |
-} |
|
10 |
|
|
11 |
{- |
|
12 |
|
|
13 |
Copyright (C) 2011 Google Inc. |
|
14 |
|
|
15 |
This program is free software; you can redistribute it and/or modify |
|
16 |
it under the terms of the GNU General Public License as published by |
|
17 |
the Free Software Foundation; either version 2 of the License, or |
|
18 |
(at your option) any later version. |
|
19 |
|
|
20 |
This program is distributed in the hope that it will be useful, but |
|
21 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
|
22 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|
23 |
General Public License for more details. |
|
24 |
|
|
25 |
You should have received a copy of the GNU General Public License |
|
26 |
along with this program; if not, write to the Free Software |
|
27 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
|
28 |
02110-1301, USA. |
|
29 |
|
|
30 |
-} |
|
31 |
|
|
32 |
module Ganeti.THH ( declareSADT |
|
33 |
, makeJSONInstance |
|
34 |
) where |
|
35 |
|
|
36 |
import Data.Char |
|
37 |
import Language.Haskell.TH |
|
38 |
|
|
39 |
import qualified Text.JSON as JSON |
|
40 |
|
|
41 |
-- | Ensure first letter is lowercase. |
|
42 |
-- |
|
43 |
-- Used to convert type name to function prefix, e.g. in @data Aa -> |
|
44 |
-- aaToString@. |
|
45 |
ensureLower :: String -> String |
|
46 |
ensureLower [] = [] |
|
47 |
ensureLower (x:xs) = toLower x:xs |
|
48 |
|
|
49 |
-- | ToString function name. |
|
50 |
toStrName :: String -> Name |
|
51 |
toStrName = mkName . (++ "ToString") . ensureLower |
|
52 |
|
|
53 |
-- | FromString function name. |
|
54 |
fromStrName :: String -> Name |
|
55 |
fromStrName = mkName . (++ "FromString") . ensureLower |
|
56 |
|
|
57 |
-- | Generates a data type declaration. |
|
58 |
-- |
|
59 |
-- The type will have a fixed list of instances. |
|
60 |
strADTDecl :: Name -> [String] -> Dec |
|
61 |
strADTDecl name constructors = |
|
62 |
DataD [] name [] |
|
63 |
(map (flip NormalC [] . mkName) constructors) |
|
64 |
[''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord] |
|
65 |
|
|
66 |
-- | Generates a toString function. |
|
67 |
-- |
|
68 |
-- This generates a simple function of the form: |
|
69 |
-- |
|
70 |
-- @ |
|
71 |
-- nameToString :: Name -> String |
|
72 |
-- nameToString Cons1 = var1 |
|
73 |
-- nameToString Cons2 = \"value2\" |
|
74 |
-- @ |
|
75 |
genToString :: Name -> Name -> [(String, Name)] -> Q [Dec] |
|
76 |
genToString fname tname constructors = do |
|
77 |
sigt <- [t| $(conT tname) -> String |] |
|
78 |
-- the body clauses, matching on the constructor and returning the |
|
79 |
-- string value |
|
80 |
clauses <- mapM (\(c, v) -> clause [recP (mkName c) []] |
|
81 |
(normalB (varE v)) []) constructors |
|
82 |
return [SigD fname sigt, FunD fname clauses] |
|
83 |
|
|
84 |
-- | Generates a fromString function. |
|
85 |
-- |
|
86 |
-- The function generated is monadic and can fail parsing the |
|
87 |
-- string. It is of the form: |
|
88 |
-- |
|
89 |
-- @ |
|
90 |
-- nameFromString :: (Monad m) => String -> m Name |
|
91 |
-- nameFromString s | s == var1 = Cons1 |
|
92 |
-- | s == \"value2\" = Cons2 |
|
93 |
-- | otherwise = fail /.../ |
|
94 |
-- @ |
|
95 |
genFromString :: Name -> Name -> [(String, Name)] -> Q [Dec] |
|
96 |
genFromString fname tname constructors = do |
|
97 |
-- signature of form (Monad m) => String -> m $name |
|
98 |
sigt <- [t| (Monad m) => String -> m $(conT tname) |] |
|
99 |
-- clauses for a guarded pattern |
|
100 |
let varp = mkName "s" |
|
101 |
varpe = varE varp |
|
102 |
clauses <- mapM (\(c, v) -> do |
|
103 |
-- the clause match condition |
|
104 |
g <- normalG [| $varpe == $(varE v) |] |
|
105 |
-- the clause result |
|
106 |
r <- [| return $(conE (mkName c)) |] |
|
107 |
return (g, r)) constructors |
|
108 |
-- the otherwise clause (fallback) |
|
109 |
oth_clause <- do |
|
110 |
g <- normalG [| otherwise |] |
|
111 |
r <- [|fail ("Invalid string value for type " ++ |
|
112 |
$(litE (stringL (nameBase tname))) ++ ": " ++ $varpe) |] |
|
113 |
return (g, r) |
|
114 |
let fun = FunD fname [Clause [VarP varp] |
|
115 |
(GuardedB (clauses++[oth_clause])) []] |
|
116 |
return [SigD fname sigt, fun] |
|
117 |
|
|
118 |
-- | Generates a data type from a given string format. |
|
119 |
-- |
|
120 |
-- The format is expected to multiline. The first line contains the |
|
121 |
-- type name, and the rest of the lines must contain two words: the |
|
122 |
-- constructor name and then the string representation of the |
|
123 |
-- respective constructor. |
|
124 |
-- |
|
125 |
-- The function will generate the data type declaration, and then two |
|
126 |
-- functions: |
|
127 |
-- |
|
128 |
-- * /name/ToString, which converts the type to a string |
|
129 |
-- |
|
130 |
-- * /name/FromString, which (monadically) converts from a string to the type |
|
131 |
-- |
|
132 |
-- Note that this is basically just a custom show/read instance, |
|
133 |
-- nothing else. |
|
134 |
declareSADT :: String -> [(String, Name)] -> Q [Dec] |
|
135 |
declareSADT sname cons = do |
|
136 |
let name = mkName sname |
|
137 |
ddecl = strADTDecl name (map fst cons) |
|
138 |
tostr <- genToString (toStrName sname) name cons |
|
139 |
fromstr <- genFromString (fromStrName sname) name cons |
|
140 |
return $ ddecl:tostr ++ fromstr |
|
141 |
|
|
142 |
|
|
143 |
-- | Creates the showJSON member of a JSON instance declaration. |
|
144 |
-- |
|
145 |
-- This will create what is the equivalent of: |
|
146 |
-- |
|
147 |
-- @ |
|
148 |
-- showJSON = showJSON . /name/ToString |
|
149 |
-- @ |
|
150 |
-- |
|
151 |
-- in an instance JSON /name/ declaration |
|
152 |
genShowJSON :: String -> Q [Dec] |
|
153 |
genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toStrName name)) |] |
|
154 |
|
|
155 |
-- | Creates the readJSON member of a JSON instance declaration. |
|
156 |
-- |
|
157 |
-- This will create what is the equivalent of: |
|
158 |
-- |
|
159 |
-- @ |
|
160 |
-- readJSON s = case readJSON s of |
|
161 |
-- Ok s' -> /name/FromString s' |
|
162 |
-- Error e -> Error /description/ |
|
163 |
-- @ |
|
164 |
-- |
|
165 |
-- in an instance JSON /name/ declaration |
|
166 |
genReadJSON :: String -> Q Dec |
|
167 |
genReadJSON name = do |
|
168 |
let s = mkName "s" |
|
169 |
body <- [| case JSON.readJSON $(varE s) of |
|
170 |
JSON.Ok s' -> $(varE (fromStrName name)) s' |
|
171 |
JSON.Error e -> |
|
172 |
JSON.Error $ "Can't parse string value for type " ++ |
|
173 |
$(litE (StringL name)) ++ ": " ++ e |
|
174 |
|] |
|
175 |
return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] |
|
176 |
|
|
177 |
-- | Generates a JSON instance for a given type. |
|
178 |
-- |
|
179 |
-- This assumes that the /name/ToString and /name/FromString functions |
|
180 |
-- have been defined as by the 'declareSADT' function. |
|
181 |
makeJSONInstance :: Name -> Q [Dec] |
|
182 |
makeJSONInstance name = do |
|
183 |
let base = nameBase name |
|
184 |
showJ <- genShowJSON base |
|
185 |
readJ <- genReadJSON base |
|
186 |
return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)] |
Also available in: Unified diff