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.

Did you try ```deriving instance Lift Html => Lift MyBadType``` — David Fox, Jan 04 '21 at 05:20
@DavidFox Thank you for your comment. Unfortunately this did not change the error I am getting (after enabling a few more extensions). By the way, I have the same problem if I use lucid HTML. Would be really nice to understand why this happens. — patrick, Jan 04 '21 at 10:31
My intuition say this is going to be very difficult and maybe not the right thing. I got stuck trying to write ```instance Lift (String -> String)``` which I don't think makes sense. The type may not be suitable for encoding data this way. — David Fox, Jan 04 '21 at 17:16
@DavidFox From the documentation, I suspect the `String -> String` field of `StaticString` is intended to be a difference list, so probably the `Lift` instance for `String` is Good Enough there. (In particular, don't lift `f :: String -> String`; instead lift `f "" :: String` and partially apply `(++)`.) — Daniel Wagner, Jan 05 '21 at 16:13

score 0 · Answer 1 · answered Jan 04 '21 at 21:25

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)

Thank you for this! I try to work with it when I get back to this issue and let you know. You are right, the performance impact of interpreting the markdown at runtime is likely low. The main reason I want to do this is to do some further processing and checks at compile time to make sure the markdown produces sane HTML (are the links formatted correctly? for example). If I could do this at compile time it will make the app less error prone (I hope). — patrick, Jan 05 '21 at 08:14
Ah. You could also consider rendering at compile time to check for errors but just throwing the result away and then re-rendering at runtime. — K. A. Buhr, Jan 05 '21 at 18:21
The type variable in the first field of `Append` is existentially quantified, so no observer can ever do anything interesting with it. This means you should be able to write an actually valid `Lift a => Lift (MarkupM a)` instance by writing `lift (Append a b) = [| Append (void a) b |]` or so (with `void :: Functor f => f a -> f ()`) without actually losing any useful information. — Daniel Wagner, Jan 05 '21 at 19:47

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

1 Answers1