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