是否可以为Blazes `Html`派生一个`Lift` (或`Data`)实例？

Question

我试图在编译时解析一些markdown，并保留它生成的Html实例。通常，我会使用派生的Language.Haskell.TH.Lift.Lift实例执行以下操作：

-- Lib.hs                                                                                                                                                           
module Lib where                                                                                                                                                                              
import Language.Haskell.TH                                                                                                                                                                    
import Language.Haskell.TH.Lift                                                                                                                                                               
                                                                                                                                                                                              
data MyNiceType = MyNiceType { f0 :: Int } deriving (Lift, Show)                                                                                                                              
                                                                                                                                                                                              
preloadNiceType :: Q Exp                                                                                                                                                                      
preloadNiceType = do
  -- do some important work at compile time                                                                                                                                                                          
  let x = MyNiceType 0                                                                                                                                                                       
  [| x |]                                                                                    

但是，当我使用包含Blaze.Html字段的类型尝试此模式时：(我使用的是TemplateHaskell DeriveLift DeriveGeneric扩展，以及template-haskell th-lift和blaze-html包)

data MyBadType = MyBadType { f1 :: Html  } deriving (Lift)

我得到了这个错误：

    • No instance for (Lift Html)
        arising from the first field of ‘MyBadType’ (type ‘Html’)
      Possible fix:
        use a standalone 'deriving instance' declaration,
          so you can specify the instance context yourself
    • When deriving the instance for (Lift MyBadType)

现在，从这个错误中可以很清楚地看出GHC想要我做什么。但我真的可以避免自己为Html类型实例化Lift (或Data)。

有没有什么办法可以避免呢？还是我在这里缺少的一种不同的方法？或者是通过一些我不知道的技巧来实现这些实例？

我知道我可以在编译时将markdown源代码存储为文本，然后在运行时呈现它，但我想知道是否有替代方案。

Answer 1

您可以尝试定义手动实例，如以下概念验证中所示。但是，我建议先做一些客观的基准测试，然后再假设这个“预编译”的标记会比仅仅在运行时渲染执行得更好。

定义一个通用的Lift (String -> String)实例将是“具有挑战性的”，但是我们可以像这样提升一个StaticString，方法是获取它的字符串值，然后使用IsString实例重新构造一个：

instance Lift StaticString where
  lift ss = let ss' = getString ss "" in [| fromString ss' :: StaticString |]

定义完成后，除了ByteString之外，ChoiceString实例将变得乏味而简单。您可以考虑使用th-lift-instances中的Lift ByteString实例，或者可能还有一个我不知道的更好的实例。

instance Lift ChoiceString where
  lift (Static a) = [| Static a |]
  lift (String a) = [| String a |]
  lift (Text a) = [| Text a |]
  lift (ByteString bs) = let ws = BS.unpack bs in [| BS.pack ws |]
  lift (PreEscaped a) = [| PreEscaped a |]
  lift (External a) = [| External a |]
  lift (AppendChoiceString a b) = [| AppendChoiceString a b |]
  lift EmptyChoiceString = [| EmptyChoiceString |]

那就只剩下HTML = MarkupM ()了。MarkupM的Append构造函数带来了一个问题，因为它引入了在任何b上量化的新MarkupM b类型。这意味着一个实例：

instance Lift a => Lift (MarkupM a)

不会起作用，因为我们永远不能保证Append所需的Lift b。我们可以通过编写一个只为MarkupM ()工作的非法Lift实例来作弊。请注意，构造函数中任何a类型的值都将被忽略，并被假定为() :: ()。

instance Lift (MarkupM a) where
  lift (Parent a b c d)   = [| Parent a b c d |]
  lift (CustomParent a b) = [| CustomParent a b |]
  lift (Leaf a b c _)     = [| Leaf a b c () |]
  lift (CustomLeaf a b _) = [| CustomLeaf a b () |]
  lift (Content a _)      = [| Content a () |]
  lift (Comment a _)      = [| Comment a () |]
  lift (Append a b)       = [| Append a b |]
  lift (AddAttribute a b c d) = [| AddAttribute a b c d |]
  lift (AddCustomAttribute a b c) = [| AddCustomAttribute a b c |]
  lift (Empty _) = [| Append Empty () |]

这似乎适用于以下示例：

-- LiftBlaze.hs
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -Wno-orphans #-}

module LiftBlaze where

import Data.String
import qualified Data.ByteString as BS
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import Text.Blaze.Internal
import Text.Blaze.Html5 hiding (a, b, head)
import qualified Text.Blaze.Html5 as H

instance Lift (MarkupM a) where
  lift (Parent a b c d)   = [| Parent a b c d |]
  lift (CustomParent a b) = [| CustomParent a b |]
  lift (Leaf a b c _)     = [| Leaf a b c () |]
  lift (CustomLeaf a b _) = [| CustomLeaf a b () |]
  lift (Content a _)      = [| Content a () |]
  lift (Comment a _)      = [| Comment a () |]
  lift (Append a b)       = [| Append a b |]
  lift (AddAttribute a b c d) = [| AddAttribute a b c d |]
  lift (AddCustomAttribute a b c) = [| AddCustomAttribute a b c |]
  lift (Empty _) = [| Append Empty () |]
instance Lift StaticString where
  lift ss = let ss' = getString ss "" in [| fromString ss' :: StaticString |]
instance Lift ChoiceString where
  lift (Static a) = [| Static a |]
  lift (String a) = [| String a |]
  lift (Text a) = [| Text a |]
  lift (ByteString bs) = let ws = BS.unpack bs in [| BS.pack ws |]
  lift (PreEscaped a) = [| PreEscaped a |]
  lift (External a) = [| External a |]
  lift (AppendChoiceString a b) = [| AppendChoiceString a b |]
  lift EmptyChoiceString = [| EmptyChoiceString |]

data MyHTMLType = MyHTMLType { f0 :: Html } deriving (Lift)

preloadNiceType :: Q [Dec]
preloadNiceType = do
  -- do some important work at compile time
  let x = MyHTMLType $ docTypeHtml $ do
        H.head $ do
          H.title "Compiled HTML"
        body $ do
          stringComment "not sure this is a good idea"
          p "I can't believe we're doing this!"
  [d| thing = x |]

-- Main.hs
{-# LANGUAGE TemplateHaskell #-}

import LiftBlaze
import Text.Blaze.Html.Renderer.Pretty

-- preload "thing"
preloadNiceType

main = do
  putStrLn $ renderHtml (f0 thing)