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 mapFunction mapType indices =
return
[ DataD [] dataName [] Nothing (indexCons <$> indices) [deriveClause]
, SigD mapFunctionName $ ArrowT `AppT` ConT dataName `AppT` ConT mapType
, FunD mapFunctionName $ mapFunctionClause <$> indices
]
where
dataName = mkName $ name <> suffix
indexName index = mkName $ name <> show index
indexCons index = NormalC (indexName index) []
deriveClause = DerivClause Nothing [ConT ''Bounded, ConT ''Enum, ConT ''Show]
mapFunctionName = mkName mapFunction
mapFunctionBody = NormalB . LitE . IntegerL . integerFromInt
mapFunctionClause index = Clause [ConP (indexName index) [] []] (mapFunctionBody index) []
|
