1 files changed, 53 insertions, 0 deletions
diff --git a/hsm-core/Hsm/Core/Serial.hs b/hsm-core/Hsm/Core/Serial.hs
new file mode 100644
index 0000000..7c607ff
--- /dev/null
+++ b/hsm-core/Hsm/Core/Serial.hs
@@ -0,0 +1,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) []