module Model.Types.JSON
  ( derivePersistFieldJSON
  ) where

import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import Data.List (foldl)
import Database.Persist.Sql

import qualified Data.ByteString.Lazy as LBS
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 tName = do
  DatatypeInfo{..} <- reifyDatatype tName
  vars <- forM datatypeVars (const $ newName "a")
  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) 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
            text <- newName "text"
            clause [[p|PersistText $(varP text)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE text)|]) []
        , 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 "jsonb"|]) []
        ]
      ]
    ]
