{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Hsm.Log.Options
  ( makeLoggerOptionParser
  ) where

import Data.Proxy (Proxy(Proxy))
import GHC.TypeLits (symbolVal)
import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
import Hsm.Log (LoggerOptionPrefix, Severity)
import Language.Haskell.TH
  ( Bang(Bang)
  , Body(NormalB)
  , Clause(Clause)
  , Con(RecC)
  , Dec(DataD, FunD, SigD)
  , Exp(AppE, ConE, LitE, ParensE, UInfixE, VarE)
  , Lit(StringL)
  , Name
  , Q
  , SourceStrictness(NoSourceStrictness)
  , SourceUnpackedness(NoSourceUnpackedness)
  , Type(AppT, ConT)
  , mkName
  )
import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value)

-- Generates an optparse-applicative parser for multiple logger severity levels
--
-- Creates a record type with configurable log levels and a corresponding parser
-- that accepts command-line arguments like `--log-cam` and `--log-web`.
--
-- Example:
--
--   $(makeLoggerOptionParser @'[ "cam", "web"] "Options" "parser" 'Info)
--
-- Generates:
-- * Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }`
-- * Parser: `parser :: Parser Options` with default values set to `Info`
makeLoggerOptionParser ::
     forall ls. KnownSymbols ls
  => String
  -> String
  -> Name
  -> Q [Dec]
makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
  return
    [ DataD [] dataName [] Nothing [RecC dataName $ field <$> loggers] []
    , SigD parserName $ ConT ''Parser `AppT` ConT dataName
    , FunD parserName [Clause [] (NormalB $ foldl parserApply parserBase loggers) []]
    ]
  where
    loggers = symbolVals @ls
    -- Record
    dataName = mkName dataNameString
    fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix
    fieldName logger = mkName $ fieldPrefix <> logger
    fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
    fieldType = ConT ''Severity
    field logger = (fieldName logger, fieldBang, fieldType)
    -- Parser
    parserName = mkName parserNameString
    parserBase = VarE 'pure `AppE` ConE dataName
    parserConfigApply expr = UInfixE expr $ VarE '(<>)
    parserOptionLong logger = VarE 'long `AppE` LitE (StringL $ "log-" <> logger)
    parserOptionHelp logger = VarE 'help `AppE` LitE (StringL $ "Sets log level for logger " <> logger)
    parserOptionShowDefault = VarE 'showDefault
    parserOptionValue = VarE 'value `AppE` ConE defaultSeverity
    parserOptionMetavar = VarE 'metavar `AppE` LitE (StringL "LEVEL")
    parserOptions logger = [parserOptionLong logger, parserOptionHelp logger, parserOptionShowDefault, parserOptionValue, parserOptionMetavar]
    parserApply expr logger = UInfixE expr (VarE '(<*>)) $ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)