问题描述
我试图在编译时解析一些 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 源存储为 Text 并在运行时呈现它,但我想知道是否有替代方法。
解决方法
您可以尝试按照以下概念验证定义手动实例。但是,我建议先做一些客观的基准测试,然后再假设这种“预编译”标记的性能比仅在运行时进行渲染要好。
定义一个通用的 Lift (String -> String)
实例会“具有挑战性”,但我们可以像这样提升一个 StaticString
,通过获取它的字符串值,然后使用 IsString
实例来构造一个重新:
instance Lift StaticString where
lift ss = let ss' = getString ss "" in [| fromString ss' :: StaticString |]
一旦定义,除了 ChoiceString
之外,ByteString
实例是乏味但简单的。您可以考虑使用 Lift ByteString
中的 th-lift-instances
实例,或者也许有一个我不知道的更好的实例。
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 ()
。 Append
的 MarkupM
构造函数带来了一个问题,因为它引入了一个新的 MarkupM b
类型,该类型对任何 b
进行了量化。这意味着一个实例:
instance Lift a => Lift (MarkupM a)
不起作用,因为我们永远无法保证 Lift b
所需的 Append
。我们可以通过编写一个仅适用于 Lift
的非法 MarkupM ()
实例来作弊。请注意,构造函数中 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)