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..0fc89e8
--- /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 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) []