fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2018-08-29 15:25:25 +02:00
parent 5b9bb68011
commit f22a95d3be
1 changed files with 32 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
src/Model/Types/JSON.hs
View File

@ -22,29 +22,35 @@ import Language.Haskell.TH.Datatype
derivePersistFieldJSON :: Name -> DecsQ
derivePersistFieldJSON n = do
DatatypeInfo{..} <- reifyDatatype n
case datatypeVars of
[] -> [d|
instance PersistField $(conT n) where
toPersistValue = PersistDbSpecific . LBS.toStrict . JSON.encode
fromPersistValue (PersistDbSpecific bs) = first pack $ JSON.eitherDecodeStrict' bs
fromPersistValue (PersistByteString bs) = first pack $ JSON.eitherDecodeStrict' bs
fromPersistValue (PersistText t ) = first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 t
fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
instance PersistFieldSql $(conT n) where
sqlType _ = SqlOther "json"
|]
_ -> do
vars <- forM datatypeVars (const $ newName "a")
let t = foldl (\t n -> t `appT` conT n) (conT n) vars
[d|
instance (ToJSON $(t), FromJSON $(t)) => PersistField $(t) where
toPersistValue = PersistDbSpecific . LBS.toStrict . JSON.encode
fromPersistValue (PersistDbSpecific bs) = first pack $ JSON.eitherDecodeStrict' bs
fromPersistValue (PersistByteString bs) = first pack $ JSON.eitherDecodeStrict' bs
fromPersistValue (PersistText t ) = first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 t
fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
instance PersistFieldSql $(t) where
sqlType _ = SqlOther "json"
|]
vars <- forM datatypeVars (const $ newName "a")
let t = foldl (\t n -> t `appT` varT n) (conT n) vars
iCxt
| null vars = cxt []
| otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t]
sqlCxt
| null vars = cxt []
| otherwise = cxt [[t|PersistField|] `appT` t]
sequence
[ instanceD iCxt ([t|PersistField|] `appT` t)
[ funD (mkName "toPersistValue")
[ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
]
, funD (mkName "fromPersistValue")
[ do
bs <- newName "bs"
clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
, do
bs <- newName "bs"
clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
, do
t <- newName "t"
clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) []
, clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) []
]
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD (mkName "sqlType")
[ clause [wildP] (normalB [e|SqlOther "json"|]) []
]
]
]