-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Model.Types.TH.JSON where

import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, toPersistValueJSON, fromPersistValueJSON, Proxy(..))
import Data.List (foldl)
import Database.Persist.Sql hiding (toPersistValueJSON, fromPersistValueJSON)

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

import Utils.Persist
import Data.Proxy


toPersistValueJSON :: ToJSON a => a -> PersistValue
toPersistValueJSON = PersistLiteralEscaped . LBS.toStrict . JSON.encode

fromPersistValueJSON :: forall a. (FromJSON a, PersistFieldSql a, Typeable a) => PersistValue -> Either Text a
fromPersistValueJSON = \case
  PersistLiteralEscaped bs   -> decodeBS bs
  PersistByteString bs       -> decodeBS bs
  PersistText       text     -> decodeBS $ Text.encodeUtf8 text
  x                          -> Left $ fromPersistValueErrorSql (Proxy @a) x
  where decodeBS = first pack . JSON.eitherDecodeStrict'
{-# SCC fromPersistValueJSON #-}

sqlTypeJSON :: SqlType
sqlTypeJSON = SqlOther "jsonb"


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, [t|Typeable|] `appT` t]
      sqlCxt
        | null vars = cxt []
        | otherwise = cxt [[t|PersistField|] `appT` t]
  sequence
    [ instanceD iCxt ([t|PersistField|] `appT` t)
      [ funD 'toPersistValue
        [ clause [] (normalB [e|toPersistValueJSON|]) []
        ]
      , funD 'fromPersistValue
        [ clause [] (normalB [e|fromPersistValueJSON|]) []
        ]
      ]
    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
      [ funD 'sqlType
        [ clause [wildP] (normalB [e|sqlTypeJSON|]) []
        ]
      ]
    ]


predNFAesonOptions :: Options
-- ^ Needed for JSON instances of `predCNF` and `predDNF`
--
-- Moved to this module due to stage restriction
predNFAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece
  , tagSingleConstructors = False
  }
  

externalApiConfigAesonOptions :: Options
externalApiConfigAesonOptions = defaultOptions
  { tagSingleConstructors = True
  , unwrapUnaryRecords = False
  , sumEncoding = TaggedObject "type" "config"
  , allNullaryToStringTag = False
  , constructorTagModifier = camelToPathPiece' 2
  , fieldLabelModifier = camelToPathPiece' 2
  }


externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions, externalApiPongResponseAesonOptions :: Options
externalApiCreationRequestAesonOptions = defaultOptions
  { tagSingleConstructors = False
  , fieldLabelModifier = camelToPathPiece' 1
  }
externalApiCreationResponseAesonOptions = defaultOptions
  { tagSingleConstructors = False
  , fieldLabelModifier = camelToPathPiece' 1
  }
externalApiCreationRestrictionsAesonOptions = defaultOptions
  { tagSingleConstructors = False
  , unwrapUnaryRecords = False
  , fieldLabelModifier = camelToPathPiece' 1
  }
externalApiPongResponseAesonOptions = defaultOptions
  { tagSingleConstructors = False
  , unwrapUnaryRecords = False
  , fieldLabelModifier = camelToPathPiece' 1
  }
  
workflowGraphEdgeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions, workflowEdgeMessageAesonOptions :: Options
workflowGraphEdgeAesonOptions = defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  , fieldLabelModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "mode" $ error "There should be no field called ‘mode’"
  }
workflowActionAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  }
workflowPayloadViewAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  }
workflowNodeViewAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  }
workflowNodeMessageAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  }
workflowEdgeMessageAesonOptions = defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  }
