Template Haskell

Posted on

Tags: haskell

Today I spent time generating some code with Template Haskell. Template Haskell like Lisp macros is very addicting.

 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
{-# LANGUAGE TemplateHaskell #-}

module GenRegs where

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Data.Char (toLower)

genRegs regs = do
  return [genRegData regs,
          genRegShowInstance regs,
          genMachineState regs,
          genMachineStateShowInstance regs,
          genDefaultMachineFunction regs]

genRegData regs = let dataName = mkName "Register"
                      regNames = map mkName regs
                      regCons = map (flip NormalC []) regNames
                      derivs = map (ConT . mkName) ["Eq"]
                  in (DataD [] dataName [] Nothing regCons derivs)

genRegShowInstance regs = let dataName = mkName "Register"
                              regNames = map mkName regs
                              regCons = map (flip NormalC []) regNames
                          in InstanceD Nothing [] (AppT (ConT $ mkName "Show") (ConT $ dataName)) [(genShowFunc regNames)]
  where
    genShowFunc regNames = FunD (mkName "show") (map showFunc regNames)
    showFunc regName = Clause [ConP regName []] (NormalB (LitE (StringL ("%" ++ (lc $ nameBase regName))))) []
    lc = map toLower

genMachineState regs = let dataName = mkName "MachineState"
                           regNames = map (mkName . ("ms" ++)) regs
                           regVal = mkName "RegVal"
                       in DataD [] dataName [] Nothing [RecC dataName (map (\n -> (n, Bang NoSourceUnpackedness NoSourceStrictness, AppT (ConT (mkName "Maybe")) (ConT regVal))) regNames)] []

genMachineStateShowInstance regs = let dataName = mkName "MachineState"
                                       regNames = map (mkName . lc) regs
                                       regCons = map (flip NormalC []) regNames
                                   in InstanceD Nothing [] (AppT (ConT $ mkName "Show") (ConT $ dataName)) [(genShowFunc dataName regNames)]
  where genShowFunc dataName regNames = FunD (mkName "show") [Clause [(ConP dataName (map VarP regNames))] (NormalB $ genBody regNames) []]
        genBody regNames = let vars = map VarE regNames
                               regs = map (("%" ++) . nameBase) regNames
                           in _intercalate (LitE $ StringL ", ") (zipWith showRV regNames vars)
        lc = map toLower
        showRV r v = UInfixE (UInfixE (LitE $ StringL ("%" ++ nameBase r)) concatE (LitE $ StringL " = ")) concatE (AppE (VarE $ mkName "show") v)
        _intercalate delim exprs = foldl1 (\p q -> UInfixE (UInfixE p concatE delim) concatE q) exprs
        concatE =  (VarE $ mkName "++")

genDefaultMachineFunction regs =  FunD (mkName "emptyMachine") [impl]
  where impl = Clause [] (NormalB $ foldl (\p q -> AppE p q) (ConE $ mkName "MachineState") (replicate (length regs) (ConE (mkName "Nothing")))) []

when applied to $(genRegs ["RAX", "RBX", "RCX", "RDX", "RSI", "RDI", "RSP", "RBP"]), generates:

 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
    data Register
      = RAX | RBX | RCX | RDX | RSI | RDI | RSP | RBP
      deriving (Eq)
    instance Show Register where
      show RAX = "%rax"
      show RBX = "%rbx"
      show RCX = "%rcx"
      show RDX = "%rdx"
      show RSI = "%rsi"
      show RDI = "%rdi"
      show RSP = "%rsp"
      show RBP = "%rbp"
    data MachineState
      = MachineState {msRAX :: (Maybe RegVal),
                      msRBX :: (Maybe RegVal),
                      msRCX :: (Maybe RegVal),
                      msRDX :: (Maybe RegVal),
                      msRSI :: (Maybe RegVal),
                      msRDI :: (Maybe RegVal),
                      msRSP :: (Maybe RegVal),
                      msRBP :: (Maybe RegVal)}
    instance Show MachineState where
      show (MachineState rax rbx rcx rdx rsi rdi rsp rbp)
        = "%rax" ++ " = " ++ show rax ++ ", " ++ "%rbx" ++ " = "
          ++ show rbx
          ++ ", "
          ++ "%rcx"
          ++ " = "
          ++ show rcx
          ++ ", "
          ++ "%rdx"
          ++ " = "
          ++ show rdx
          ++ ", "
          ++ "%rsi"
          ++ " = "
          ++ show rsi
          ++ ", "
          ++ "%rdi"
          ++ " = "
          ++ show rdi
          ++ ", "
          ++ "%rsp"
          ++ " = "
          ++ show rsp
          ++ ", "
          ++ "%rbp"
          ++ " = "
          ++ show rbp
    emptyMachine
      = MachineState
          Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

And, I love it :D. Anyways, time to go to sleep now. おやすみ!