Is it possible to derive a `Lift` (or `Data`) instance for Blazes `Html`?

Question

I am trying to parse some markdown at compile time and hold on to the Html instance it generates. Normally I would do something like this using a derived Language.Haskell.TH.Lift.Lift instance:

-- 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 |]                                                                                    

However, when I try this pattern with a type that contains a Blaze.Html field: ( I am using the extensions TemplateHaskell DeriveLift DeriveGeneric, and the packages template-haskell th-lift and blaze-html)

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

I get this error:

    • 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)

Now, it is pretty clear from this error what GHC wants me to do. But I would really avoid having to instantiate Lift (or Data) myself for the Html type.

Is there a way I can avoid it? Or a different approach I am missing here? Or is implementing the instances trivial by some trick I am not aware of?

I am aware that I could just store the markdown source as a Text during compile time and render it at runtime, but I would like to know if there is an alternative.

Answer 1

You can try defining manual instances as in the following proof-of-concept. However, I'd suggest doing some objective benchmarking before assuming that this "pre-compiled" markup will perform better than just doing the rendering at runtime.

A general Lift (String -> String) instance would be "challenging" to define, but we can lift a StaticString like so, by getting its string value and then using the IsString instance to construct one afresh:

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

Once that's defined, a ChoiceString instance is tedious but straightforward, except for the ByteString. You could consider using the Lift ByteString instance from th-lift-instances instead, or maybe there's an even better one that I don't know about.

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 |]

That leaves HTML = MarkupM (). The Append constructor for MarkupM poses a problem, since it introduces a new MarkupM b type quantified over any b. This means that an instance:

instance Lift a => Lift (MarkupM a)

won't work, because we'll never be able to guarantee the needed Lift b for Append. We can cheat by writing an illegal Lift instance that only works for MarkupM (). Note here that any values of type a in constructors are ignored and assumed to be () :: ().

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 () |]

This appears to work for the following example:

-- 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)