如何收集Haskell代码库中分散的CSS样式值

我用Haskell开发Web应用（客户端基于ghcjs，服务端基于ghc），需要收集分散在各个模块中的CSS代码片段。目前的实现方式是通过CssStyle类型类结合Template Haskell：每个模块要导出CSS时，必须定义一个无意义的空类型，并为其实现CssStyle实例；最后在统一收集的模块中，用TH的reifyInstances获取所有可见的CssStyle实例，再转换为实际CSS。

这个方案有两个明显缺点：

• 必须额外定义无意义的空类型来绑定实例，冗余且不直观；
• 必须确保所有包含CssStyle实例的模块都被导入到收集模块中，否则实例会被遗漏。

现有方案的代码示例：

{-# LANGUAGE AllowAmbiguousTypes, OverloadedStrings, MultiParamTypeClasses, TemplateHaskell, LambdaCase, FunctionalDependencies, TypeApplications #-}

import Clay
import Control.Lens hiding ((&))
import Data.Proxy
import Language.Haskell.TH

class CssStyle a where cssStyle :: Css

-- 收集所有可见的CssStyle实例，生成[(FilePath, Css)]类型的表达式
reifyCss :: Q Exp
reifyCss = do
  insts <- reifyInstances ''CssStyle [VarT (mkName "a")]
  listE (concatMap (\case 
                      InstanceD _ _cxt (AppT _cls typ@(ConT tname)) _decs ->
                        [ [|($(litE (stringL (show tname))), $(appTypeE [|cssStyle|] (pure typ)))|] ]
                      _ -> []) insts)

-- 定义无意义类型并实现实例
data T1 = T1
instance CssStyle T1 where cssStyle = byClass "c1" & flexDirection row
data T2 = T2
instance CssStyle T2 where cssStyle = byClass "c2" & flexDirection column

-- 解释器中执行（规避TH阶段限制）：
-- > fmap (over _2 (renderWith compact [])) ($reifyCss :: [(String, Css)])
-- [("Main.T2",".c2{flex-direction:column}"),("Main.T1",".c1{flex-direction:row}")]

注意：所有被导入到当前模块的CssStyle实例都会被收集，而非仅本地定义的实例。

方案1：Template Haskell自动注册（无冗余类型） #

核心思路是用TH宏直接注册CSS片段，无需绑定到空类型。我们可以在编译时维护一个全局的CSS注册表，每个模块用宏将自己的CSS片段加入注册表，最后在收集点用宏取出所有片段。

实现代码： #

首先定义TH工具模块：

{-# LANGUAGE TemplateHaskell #-}
module CssRegistry where

import Clay
import Language.Haskell.TH
import qualified Data.Map as Map

-- 用TH的Name作为注册表的全局标识
cssRegistryName :: Name
cssRegistryName = mkName "cssRegistry"

-- 注册CSS片段的宏：接受名称和Css表达式，将其加入注册表
defineCss :: String -> Q Exp -> Q [Dec]
defineCss name cssExp = do
  -- 检查注册表是否已初始化
  _ <- reify cssRegistryName >>= \case
    VarI _ (ConT ''Map.Map `AppT` ConT ''String `AppT` ConT ''Css) _ -> pure ()
    _ -> reportError "cssRegistry未初始化，需先调用initCssRegistry" >> pure ()
  -- 生成更新注册表的声明
  [d|
    $(varP cssRegistryName) = Map.insert $(litE (stringL name)) $(cssExp) $(varE cssRegistryName)
  |]

-- 初始化注册表的宏，需在收集模块最顶层调用
initCssRegistry :: Q [Dec]
initCssRegistry = [d|
    cssRegistry :: Map.Map String Css
    cssRegistry = Map.empty
  |]

-- 生成包含所有注册CSS的列表表达式
collectCss :: Q Exp
collectCss = [|Map.toList cssRegistry|]

业务模块中使用：

{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Component1 where

import Clay
import CssRegistry

-- 直接注册CSS，无需空类型
$(defineCss "c1" [|byClass "c1" & flexDirection row|])

收集模块中汇总：

{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module CssCollector where

import Clay
import CssRegistry
import Component1  -- 只需导入模块，无需关心实例
import Component2

-- 初始化注册表
$(initCssRegistry)

-- 收集所有注册的CSS
allCss :: [(String, Css)]
allCss = $(collectCss)

优点： #

• 无需定义冗余的空类型，代码更简洁直观；
• 只要模块被导入（确保编译时被处理），CSS片段就会被注册，无需手动管理实例导入；
• 编译时收集，无运行时开销。

注意： #

• 必须确保initCssRegistry在所有defineCss调用之前执行（放在收集模块最顶层）；
• ghcjs和ghc都支持这套TH逻辑，兼容性没问题。

方案2：运行时IORef注册表（无TH，适合简单场景） #

如果不想用TH，可以用IORef在运行时收集CSS片段，通过unsafePerformIO完成注册（需谨慎使用）。

实现代码： #

{-# LANGUAGE OverloadedStrings #-}
module CssRuntimeRegistry where

import Clay
import Data.IORef
import System.IO.Unsafe
import qualified Data.Map as Map

-- 全局IORef存储CSS注册表
cssRegistry :: IORef (Map.Map String Css)
cssRegistry = unsafePerformIO $ newIORef Map.empty
{-# NOINLINE cssRegistry #-}

-- 注册CSS片段的函数
registerCss :: String -> Css -> IO ()
registerCss name css = atomicModifyIORef' cssRegistry $ \m -> (Map.insert name css m, ())

-- 收集所有注册的CSS
collectCss :: IO [(String, Css)]
collectCss = Map.toList <$> readIORef cssRegistry

业务模块中使用：

{-# LANGUAGE OverloadedStrings #-}
module Component1 where

import Clay
import CssRuntimeRegistry

-- 模块加载时自动注册CSS
_ = unsafePerformIO $ registerCss "c1" (byClass "c1" & flexDirection row)
{-# NOINLINE _ #-}

收集时调用：

main :: IO ()
main = do
  cssList <- collectCss
  mapM_ (print . over _2 (renderWith compact [])) cssList

优点： #

• 完全不用TH，代码最简单；
• 模块中只需调用注册函数，无需额外类型或实例。

缺点： #

• 依赖unsafePerformIO，需注意初始化顺序（确保模块被加载时注册执行）；
• ghc/ghcjs的死代码消除（DCE）可能会移除未被引用的模块，导致CSS未注册，需通过-fno-full-laziness或显式引用模块来避免；
• 运行时收集，有轻微的运行时开销。

方案3：类型级列表收集（纯类型系统，无TH） #

如果偏好纯类型解决方案，可以用DataKinds和类型级列表来组织CSS片段，通过类型类将类型级定义转换为值级CSS。

实现代码： #

首先定义类型级结构：

{-# LANGUAGE DataKinds, TypeOperators, TypeApplications, FlexibleInstances, FlexibleContexts #-}
module CssTypeRegistry where

import Clay
import Data.Proxy
import GHC.TypeLits

-- 类型级表示CSS规则（简化版，可扩展）
data CssRule = ClassRule Symbol [CssProp]
data CssProp = FlexDirection PropValue
data PropValue = Row | Column

-- 值级转换函数
cssPropToValue :: PropValue -> Value
cssPropToValue Row = row
cssPropToValue Column = column

ruleToCss :: CssRule -> Css
ruleToCss (ClassRule cls props) = byClass (symbolVal cls) $ mapM_ applyProp props
  where
    applyProp (FlexDirection v) = flexDirection (cssPropToValue v)

-- 类型类：将类型级列表转换为值级Css列表
class CollectCss (rules :: [CssRule]) where
  collectCss :: Proxy rules -> [(String, Css)]

instance CollectCss '[] where
  collectCss _ = []

instance (CollectCss rest, KnownSymbol cls) => CollectCss (ClassRule cls '[FlexDirection Row] ': rest) where
  collectCss _ = 
    let cls = symbolVal (Proxy @cls)
        css = ruleToCss (ClassRule (Proxy @cls) [FlexDirection Row])
    in (cls, css) : collectCss (Proxy @rest)

instance (CollectCss rest, KnownSymbol cls) => CollectCss (ClassRule cls '[FlexDirection Column] ': rest) where
  collectCss _ = 
    let cls = symbolVal (Proxy @cls)
        css = ruleToCss (ClassRule (Proxy @cls) [FlexDirection Column])
    in (cls, css) : collectCss (Proxy @rest)

业务模块中导出类型级规则：

{-# LANGUAGE DataKinds #-}
module Component1 where

import CssTypeRegistry

-- 类型级定义CSS规则
type Component1Css = '[ClassRule "c1" '[FlexDirection Row]]

收集时组合类型列表：

{-# LANGUAGE DataKinds, TypeApplications #-}
module CssCollector where

import CssTypeRegistry
import Component1
import Component2

-- 组合所有模块的类型级规则
type AllCss = Component1Css ++ Component2Css

allCss :: [(String, Css)]
allCss = collectCss (Proxy @AllCss)

优点： #

• 纯类型系统实现，无TH或IO副作用；
• 类型安全，编译时就能检查CSS规则的合法性。

缺点： #

• 需要手动将CSS结构映射到类型级，复杂CSS（如嵌套规则、媒体查询）的类型级表示会非常繁琐；
• 扩展性差，新增CSS属性需要修改类型定义和转换逻辑。

内容的提问来源于stack exchange，提问作者David Fox