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
|
{-# LANGUAGE TemplateHaskellQuotes #-}
module Hsm.Core.Serial
( makeSerial
)
where
import GHC.Num (integerFromInt)
import Language.Haskell.TH
( Body (NormalB)
, Clause (Clause)
, Con (NormalC)
, Dec (DataD, FunD, SigD)
, DerivClause (DerivClause)
, Exp (LitE)
, Lit (IntegerL)
, Name
, Pat (ConP)
, Q
, Type (AppT, ArrowT, ConT)
, mkName
)
-- Generates a serial data type with the given name and a set of constructors,
-- each mapped to a corresponding integer value.
--
-- - The data type derives `Bounded`, `Enum`, and `Show` for convenience.
-- - A companion mapping function is also generated, converting each constructor
-- to its associated integer.
--
-- For debugging purposes, use `-ddump-splices` to inspect the generated code.
--
-- Example:
--
-- $(makeSerial "GPIO" "Pin" "pinLine" ''Int [2, 3, 4])
--
-- Generates a data type `GPIOPin` with constructors `GPIO2`, `GPIO3` `GPIO4`,
-- and a function `pinLine :: GPIOPin -> Int`.
makeSerial :: String -> String -> String -> Name -> [Int] -> Q [Dec]
makeSerial name suffix mapFun mapType idxs =
return
[ DataD [] dtName [] Nothing (idxCons <$> idxs) [derivClause]
, SigD mapFunName . AppT (AppT ArrowT $ ConT dtName) $ ConT mapType
, FunD mapFunName $ mapFunClause <$> idxs
]
where
dtName = mkName $ name <> suffix
idxName idx = mkName $ name <> show idx
idxCons idx = NormalC (idxName idx) []
derivClause = DerivClause Nothing [ConT ''Bounded, ConT ''Enum, ConT ''Show]
mapFunName = mkName mapFun
mapFunBody = NormalB . LitE . IntegerL . integerFromInt
mapFunClause idx = Clause [ConP (idxName idx) [] []] (mapFunBody idx) []
|
