1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
{-# 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)
|
