From 5b9bb68011cc553779104223d34be9ad50a58f1e Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 29 Aug 2018 13:57:53 +0200
Subject: [PATCH] Handle parametrized types in derivePersistFieldJSON

---
 package.yaml            |  1 +
 src/Model/Types/JSON.hs | 40 ++++++++++++++++++++++++++++++----------
 2 files changed, 31 insertions(+), 10 deletions(-)

diff --git a/package.yaml b/package.yaml
index b6d579e8d..613489a82 100644
--- a/package.yaml
+++ b/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.
diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs
index 8517ac011..8d937da6b 100644
--- a/src/Model/Types/JSON.hs
+++ b/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"
+        |]