Handle parametrized types in derivePersistFieldJSON

package.yaml

@@ -91,6 +91,7 @@ dependencies:
 - universe
 - universe-base
 - random-shuffle
+- th-abstraction
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Model/Types/JSON.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 
 module Model.Types.JSON
@@ -6,6 +7,7 @@ module Model.Types.JSON
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Data.List (foldl)
 import Database.Persist.Sql
 
 import qualified Data.ByteString.Lazy as LBS
@@ -14,17 +16,35 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.Aeson as JSON
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
 
 
 derivePersistFieldJSON :: Name -> DecsQ
-derivePersistFieldJSON n = [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"
+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"
-  |]
+      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"
+        |]