為了讓大家可以簡單地寫 desugar function ， C 使用 Template Haskell ，以便編譯時自動產生程式碼，輸出給 `Haskell.Src.Exts` 用的 desugar function template ，於是做 `if` 的 desugar 時，只要寫：

```
-- 注意：這是最早的版本，沒有使用帶更多資訊的 `Haskell.Src.Exts.Annotated`
deIfExp (If exp1 exp2 exp3) = deIfExp $
	Case exp1
  	[ Alt (SrcLoc "" 0 0) (PApp (UnQual (Ident "False")) []) (UnGuardedRhs exp3) Nothing
    , Alt (SrcLoc "" 0 0) (PApp (UnQual (Ident "True")) []) (UnGuardedRhs exp2) Nothing
    ]
```

省掉手寫處理其他 Syntax 的三百多行。

但身為一個連 Monoid, Functor, Applicative 都還搞不清楚的笨蛋，怎麼可能一下子就懂 TH （Template Haskell）在搞什麼呢？

所以來拆解 [7e37b79](https://github.com/CindyLinz/Haskell.js/commit/7e37b79d3b05c2b315e73d4e343bad910818da58) 吧！看看 TH 到底是怎麼幫助我們的 XD

文末附上的是只處理 `Haskell.Src.Exts.Syntax.Module` 的精簡版，沒有 [7e37b79](https://github.com/CindyLinz/Haskell.js/commit/7e37b79d3b05c2b315e73d4e343bad910818da58) 那麼複雜，以下一點一點說明：

# deriveDesugarTemplate

程式的進入點是 `deriveDesugarTemplate :: String -> Q [Dec]` ，吃的 `String` 是之後用來生 desugar template 的 function 名稱，吐出來的 `Q [Dec]` 在 `$()` 裡面會變成程式，在 Main.hs 中這樣寫：

```
-- 前面有些 code

$(deriveDesugarTemplate "xx")

-- 後面有些 code
```

之後就有個叫 `xx` 的 function 可以用。寫 `xx "DeIf" "deIf"` 就會生出想要的三百多行程式。

```
deriveDesugarTemplate :: String -> Q [Dec]
deriveDesugarTemplate funName = do
  Just moduleName <- lookupTypeName "Module"

  moduleInfo <- reify moduleName
  runIO $ putStrLn $ show moduleInfo

  let code = genDataTransformer "deIf" moduleInfo
  runIO $ putStrLn $ code

  fmap pure $ funD (mkName funName) [clause (map (varP . mkName) ["modName", "funPrefix"]) (normalB (varE (mkName "undefined"))) []]
```

一開始的：

```
Just moduleName <- lookupTypeName "Module"
```

先從看得見的地方（在此例中是 Main.hs 和 DeriveDesugarTemplate import 的 modules），找出叫做 `"Module"` 的 [`Name`](http://hackage.haskell.org/package/template-haskell-2.10.0.0/docs/Language-Haskell-TH-Syntax.html#t:Name) ，再靠：

```
moduleInfo <- reify moduleName
```

把 Module 的形狀拆出來。

`runIO` 則可以幫我們在 `Q` 中印出 `moduleInfo` ，看看接下來該怎麼寫。

# Language.Haskell.Src.Exts.Syntax.Module

[Module](https://hackage.haskell.org/package/haskell-src-exts-1.17.1/docs/Language-Haskell-Exts-Syntax.html#t:Module) ：

```
Module SrcLoc ModuleName [ModulePragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl]
```

在 TH 中長這個樣子：

```
TyConI
  ( DataD
    [] -- Cxt
    Language.Haskell.Exts.Syntax.Module -- Name
    [] -- [TyVarBndr]
    [ NormalC -- [Con]
      Language.Haskell.Exts.Syntax.Module
      [ (NotStrict, ConT Language.Haskell.Exts.SrcLoc.SrcLoc) -- SrcLoc
      , (NotStrict, ConT Language.Haskell.Exts.Syntax.ModuleName) -- ModuleName
      , (NotStrict, AppT ListT (ConT Language.Haskell.Exts.Syntax.ModulePragma)) -- [ModulePragma]
      , (NotStrict, AppT (ConT GHC.Base.Maybe) (ConT Language.Haskell.Exts.Syntax.WarningText)) -- Maybe WarningText
      , (NotStrict, AppT (ConT GHC.Base.Maybe) (AppT ListT (ConT Language.Haskell.Exts.Syntax.ExportSpec))) -- Maybe [ExportSpec]
      , (NotStrict, AppT ListT (ConT Language.Haskell.Exts.Syntax.ImportDecl)) -- [ImportDecl]
      , (NotStrict, AppT ListT (ConT Language.Haskell.Exts.Syntax.Decl)) -- [Decl]
      ]
    ]
    [] -- [Name]
  )
```

我們關心的，主要是 `[Con]` 中那些 Types ， `genDataTransformer` 會幫忙產生處理 Module 的 function 。

# genDataTransformer

`genDataTransformer` 吃新函數的 prefix 和 Module 在 TH 中的形狀。可以拆成兩部分看，先看後半用 [`LambdaCase`](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/syntax-extns.html#lambda-case) 寫的部分：

```
\case
  TyConI (DataD [] (Name (OccName tyNameStr) _) [] cons _) ->
    let
      typeSig = funPrefix ++ tyNameStr ++ " :: " ++ tyNameStr ++ " -> " ++ tyNameStr ++ "\n"
    in
      concat $ typeSig : map (conToDef tyNameStr) cons
  others -> error $ "genDataTransformer " ++ show others ++ " not implemented"
```

在 Module 的例子中， typeSig 會變成 `"deIfModule :: Module -> Module\n"` ，而下面的 `map (conToDef tyNameStr) cons` 生出來的就是 function body 。

```
conToDef tyNameStr (NormalC (Name (OccName conNameStr) _) slots) =
  let
    varNames = varNamesForNormalSlots slots
  in
    funPrefix ++ tyNameStr ++
      " (" ++ intercalate " " (conNameStr : varNames) ++ ") = " ++
      intercalate " " (conNameStr : zipWith (\varNameStr (_, ty) -> exprFromType varNameStr funPrefix ty) varNames slots) ++
      "\n"
```

其中：

```
funPrefix ++ tyNameStr ++
  " (" ++ intercalate " " (conNameStr : varNames) ++ ")"
```

會生出：

```
deIfModule (Module srcLoc moduleName modulePragma warningText exportSpec importDecl decl)
```

也就是說， `varNamesForNormalSlots` 會把 slots 收集起來，變成可以 pattern match 的樣子。

[`intercalate`](http://hackage.haskell.org/package/base-4.8.1.0/docs/Data-List.html#v:intercalate) 在這裡做的事情只是在 name 之間插入空白，再接成 String 。

---

```
intercalate " " (conNameStr : zipWith (\varNameStr (_, ty) -> exprFromType varNameStr funPrefix ty) varNames slots)
```

會生出：

```
Module (deIfSrcLoc srcLoc) (deIfModuleName moduleName) (fmap (deIfModulePragma) modulePragma) (fmap (deIfWarningText) warningText) (fmap (fmap (deIfExportSpec)) exportSpec) (fmap (deIfImportDecl) importDecl) (fmap (deIfDecl) decl)
```

`exprFromType` 生出了遞迴遍歷各個 slot 需要寫的 code 。

# varNamesForNormalSlots

```
finalNames = go M.empty rawNames where
  go nameCount (nameStr : others) =
    if S.member nameStr dupNames then
      let
        nameCount' = M.insertWith (+) nameStr 1 nameCount
        serial = nameCount' M.! nameStr
      in
        (nameStr ++ show serial) : go nameCount' others
    else
      nameStr : go nameCount others
  go _ _ = []
```

這段做的事情是，找出重複的名字，並在名字後面加上數字。這麼一來， `Exp Exp Exp` 就不會變成 `exp exp exp` ，而是可以區分彼此的 `exp1 exp2 exp3` 。先看現在的 `nameStr` 在不在放著重複名字的 `dupNames` 中，如果在的話，就用加上數字的名字（`nameStr ++ show serial`），不然用普通的名字就好（`nameStr`）。

---

```
dupNames :: S.Set String
dupNames = go S.empty S.empty rawNames where
  go res seen (nameStr : others) =
    if S.member nameStr seen then
      go (S.insert nameStr res) seen others
    else
      go res (S.insert nameStr seen) others
  go res _ _ = res
```

`dupNames` 也很好玩，一開始有兩個空的 Set ，前面的用來放重複的名字，後面的用來放看過的名字。從 `rawNames` 中把名字一個一個拿出來看，如果這個名字已經看過了（`S.member nameStr seen`），就塞到 `res` 中；如果沒看過，就塞到 `seen` 中。

---

`rawNames` 又是怎麼來的？靠 varNameFromType 從 slots 裡面拆出來的：

```
rawNames = map (\(_, ty) -> case varNameFromType ty of Name (OccName str) _ -> lowerHead str) slots
```

拆出來後把字首小寫（`lowerHead`）。

# varNameFromType

```
varNameFromType :: Type -> Name
varNameFromType (ConT name) = name
varNameFromType (all @ (AppT f x)) = case maybeVarNameFromType all of
  Just o -> o
  Nothing -> varNameFromType x
varNameFromType others = error $ "varNameFromType " ++ show others ++ " not implemented"
```

拆 Name 出來時，有意思的是那個 `maybeVarNameFromType` 。會濾掉包裝或基本的 Type ：

```
trivialTypes :: S.Set String
trivialTypes = S.fromList ["String", "Maybe", "Int", "Rational", "Char", "Integer", "Bool"]
```

做法是：

```
maybeVarNameFromType :: Type -> Maybe Name
maybevarNameFromType (ConT (name @ (Name (OccName nameStr) _)))
  | S.member nameStr trivialTypes = Nothing
  | otherwise = Just name
maybeVarNameFromType (AppT f x) = maybeVarNameFromType f <|> maybeVarNameFromType x
maybeVarNameFromType _ = Nothing
```

這樣就不用特地把 `Maybe WarnText` 寫成 `mWarnText` ，只要寫成 `warnText` 就好。該如何正確地處理它們，則交給 `exprFromType` 。

# exprFromType 和 transExprFromType

```
exprFromType :: String -> String -> Type -> String
exprFromType name funPrefix ty = "(" ++ transExprFromType funPrefix ty ++ " " ++ name ++ ")"
```

`exprFromType` 套上了最外面的 `()` 與目標物（`name`）。重點在：

```
transExprFromType :: String -> Type -> String
transExprFromType funPrefix = genExpr where
  genExpr = \case
    ConT (Name (OccName name) _)
      | S.member name trivialTypes -> "id"
      | otherwise -> funPrefix ++ name
    AppT ListT x -> "fmap (" ++ genExpr x ++ ")"
    AppT (ConT (Name (OccName "Maybe") _)) x -> "fmap (" ++ genExpr x ++ ")"
    AppT (AppT (TupleT 2) a) b -> "(" ++ genExpr a ++ ") *** (" ++ genExpr b ++ ")"
    others -> error $ "exprFromType " ++ show others ++ " not implemented"
```

這邊才真的看每個 Type 的形狀，決定該不該加 `fmap` ，該加幾層。

那個 [`***`](https://hackage.haskell.org/package/base-4.8.1.0/docs/Control-Arrow.html#v:-42--42--42-) 是 `Control.Arrow` 裡的東西，又提醒我，得把看到一半的文章看完，這樣才有機會搞懂 FRP 。

# 簡化過的 DerivieDesugarTemplate.hs 全文

```
module DeriveTemplate where

import Data.Functor
import Data.List
import Data.Char
import Data.Monoid
import Control.Applicative
import Control.Monad
import qualified Data.Set as S
import qualified Data.Map as M
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

trivialTypes :: S.Set String
trivialTypes = S.fromList ["String", "Maybe", "Int", "Rational", "Char", "Integer", "Bool"]

deriveDesugarTemplate :: String -> Q [Dec]
deriveDesugarTemplate funName = do
  Just moduleName <- lookupTypeName "Module"

  moduleInfo <- reify moduleName
  runIO $ putStrLn $ show moduleInfo

  let code = genDataTransformer "deIf" moduleInfo
  runIO $ putStrLn $ code

  fmap pure $ funD (mkName funName) [clause (map (varP . mkName) ["modName", "funPrefix"]) (normalB (varE (mkName "undefined"))) []]

maybeVarNameFromType :: Type -> Maybe Name
maybevarNameFromType (ConT (name @ (Name (OccName nameStr) _)))
  | S.member nameStr trivialTypes = Nothing
  | otherwise = Just name
maybeVarNameFromType (AppT f x) = maybeVarNameFromType f <|> maybeVarNameFromType x
maybeVarNameFromType _ = Nothing

varNameFromType :: Type -> Name
varNameFromType (ConT name) = name
varNameFromType (all @ (AppT f x)) = case maybeVarNameFromType all of
  Just o -> o
  Nothing -> varNameFromType x
varNameFromType others = error $ "varNameFromType " ++ show others ++ " not implemented"

varNamesForNormalSlots :: [StrictType] -> [String]
varNamesForNormalSlots slots =
  let
    dupNames :: S.Set String
    dupNames = go S.empty S.empty rawNames where
      go res seen (nameStr : others) =
        if S.member nameStr seen then
          go (S.insert nameStr res) seen others
        else
          go res (S.insert nameStr seen) others
      go res _ _ = res

    rawNames = map (\(_, ty) -> case varNameFromType ty of Name (OccName str) _ -> lowerHead str) slots

    finalNames = go M.empty rawNames where
      go nameCount (nameStr : others) =
        if S.member nameStr dupNames then
          let
            nameCount' = M.insertWith (+) nameStr 1 nameCount
            serial = nameCount' M.! nameStr
          in
            (nameStr ++ show serial) : go nameCount' others
        else
          nameStr : go nameCount others
      go _ _ = []
  in
    finalNames

transExprFromType :: String -> Type -> String
transExprFromType funPrefix = genExpr where
  genExpr = \case
    ConT (Name (OccName name) _)
      | S.member name trivialTypes -> "id"
      | otherwise -> funPrefix ++ name
    AppT ListT x -> "fmap (" ++ genExpr x ++ ")"
    AppT (ConT (Name (OccName "Maybe") _)) x -> "fmap (" ++ genExpr x ++ ")"
    AppT (AppT (TupleT 2) a) b -> "(" ++ genExpr a ++ ") *** (" ++ genExpr b ++ ")"
    others -> error $ "exprFromType " ++ show others ++ " not implemented"

exprFromType :: String -> String -> Type -> String
exprFromType name funPrefix ty = "(" ++ transExprFromType funPrefix ty ++ " " ++ name ++ ")"

lowerHead :: String -> String
lowerHead (c:cs) = toLower c : cs

genDataTransformer :: String -> Info -> String
genDataTransformer funPrefix =
  let
    conToDef tyNameStr (NormalC (Name (OccName conNameStr) _) slots) =
      let
        varNames = varNamesForNormalSlots slots
      in
        funPrefix ++ tyNameStr ++
          " (" ++ intercalate " " (conNameStr : varNames) ++ ") = " ++
          intercalate " " (conNameStr : zipWith (\varNameStr (_, ty) -> exprFromType varNameStr funPrefix ty) varNames slots) ++
          "\n"
  in
    \case
      TyConI (DataD [] (Name (OccName tyNameStr) _) [] cons _) ->
        let
          typeSig = funPrefix ++ tyNameStr ++ " :: " ++ tyNameStr ++ " -> " ++ tyNameStr ++ "\n"
        in
          concat $ typeSig : map (conToDef tyNameStr) cons
      others -> error $ "genDataTransformer " ++ show others ++ " not implemented"
```

讀到這裡，認為有機會靠 TH 寫出簡潔的 pretty print ，但還是不確定從何下手才好。

順其自然吧。