module Model.Types.JSON
  ( derivePersistFieldJSON
  , predNFAesonOptions
  ) 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 Data.Aeson as JSON

import Language.Haskell.TH
import Language.Haskell.TH.Datatype

import Utils.PathPiece


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 'toPersistValue
        [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
        ]
      , funD '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 'sqlType
        [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
        ]
      ]
    ]


predNFAesonOptions :: Options
-- ^ Needed for JSON instances of `predCNF` and `predDNF`
--
-- Moved to this module due to stage restriction
predNFAesonOptions = defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , sumEncoding = ObjectWithSingleField
  , tagSingleConstructors = True
  }
  
