{-|
Module: BattlePlace.Util
Description: General utilities.
License: MIT
-}

{-# LANGUAGE LambdaCase, TemplateHaskell #-}

module BattlePlace.Util
  ( jsonOptions
  , jsonOptionsWithTag
  , swaggerSchemaOptions
  , declareStruct
  ) where

import Control.Monad
import qualified Data.Aeson as J
import qualified Data.Swagger as SW
import GHC.Generics(Generic)
import Language.Haskell.TH

jsonOptions :: J.Options
jsonOptions = jsonOptionsWithTag "status"

jsonOptionsWithTag :: String -> J.Options
jsonOptionsWithTag tag = J.defaultOptions
  { J.fieldLabelModifier = dropBeforeUnderscore
  , J.constructorTagModifier = dropBeforeUnderscore
  , J.sumEncoding = J.TaggedObject
    { J.tagFieldName = tag
    , J.contentsFieldName = "contents"
    }
  }

swaggerSchemaOptions :: SW.SchemaOptions
swaggerSchemaOptions = SW.defaultSchemaOptions
  { SW.fieldLabelModifier = dropBeforeUnderscore
  , SW.constructorTagModifier = dropBeforeUnderscore
  }

dropBeforeUnderscore :: String -> String
dropBeforeUnderscore = \case
  x : xs -> case x of
    '_' -> xs
    _ -> dropBeforeUnderscore xs
  [] -> []

declareStruct :: [Name] -> Q [Dec]
declareStruct names = fmap concat . forM names $ \t -> sequence
  [ standaloneDerivD (pure []) [t| Generic $(conT t) |]
  , instanceD (pure []) [t| J.FromJSON $(conT t) |]
    [ funD 'J.parseJSON
      [ clause [] (normalB [| J.genericParseJSON jsonOptions |]) []
      ]
    ]
  , instanceD (pure []) [t| J.ToJSON $(conT t) |]
    [ funD 'J.toJSON
      [ clause [] (normalB [| J.genericToJSON jsonOptions |]) []
      ]
    , funD 'J.toEncoding
      [ clause [] (normalB [| J.genericToEncoding jsonOptions |]) []
      ]
    ]
  , instanceD (pure []) [t| SW.ToSchema $(conT t) |]
    [ funD 'SW.declareNamedSchema
      [ clause [] (normalB [| SW.genericDeclareNamedSchemaUnrestricted swaggerSchemaOptions |]) []
      ]
    ]
  ]