gallery/make-pages/BuilderQQ.hs

{-# LANGUAGE PatternSynonyms, TemplateHaskell #-}
module BuilderQQ
  (b, Builder, toStrictText, toLazyText, fromText, fromString,
   ifJust, escId, escAttr, CanBuild (..))
where

import Data.Char (isSpace, isAlphaNum)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.List (dropWhileEnd)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Text.Lazy.Builder
  (Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy (toStrict)
import Data.List.NonEmpty (NonEmpty, toList)

data Chunk = Lit String | Var String

parseB :: String -> ExpQ
parseB = toExpQ . reverse . go "" [] . trim where
  trim = dropWhileEnd isSpace . dropWhile (== '\n')
  go acc cs []             = addLit acc cs
  go acc cs ('$':'&':rest) = go acc cs rest         -- $&: expands to nothing
  go acc cs ('$':'$':rest) = go ('$' : acc) cs rest -- $$: expands to one $
  go acc cs ('$':rest)     = go "" (Var var : addLit acc cs) rest' -- $var
    where (var, rest') = span isIdChar rest
  go acc cs (c:rest) = go (c : acc) cs rest

  addLit l cs = if null l then cs else Lit (reverse l) : cs
  isIdChar c  = isAlphaNum c || c `elem` ("_'" :: String)

  toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|]
  chunk1 (Lit lit)  = Just $ stringE lit
  chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|]


toStrictText :: Builder -> Strict.Text
toStrictText = toStrict . toLazyText

b :: QuasiQuoter
b = QuasiQuoter parseB undefined undefined undefined


ifJust :: Monoid b => Maybe a -> (a -> b) -> b
ifJust x f = maybe mempty f x


escId :: Strict.Text -> Builder
escId = foldMap esc1 . Strict.unpack where
  esc1 c | isSpace c       = ""
         | latin1Special c = "_"
         | otherwise       = singleton c
  latin1Special c =
    c <= 'ÿ' && not (isAlphaNum c) && c /= '-'

escAttr :: Strict.Text -> Builder
escAttr = foldMap esc1 . Strict.unpack where
  esc1 c = fromMaybe (singleton c) $ lookup c
    [('<', "&lt;"), ('>', "&gt;"), ('"', "&quot;"), ('\'', "&apos;")]


class CanBuild a where build :: a -> Builder

instance CanBuild Builder     where build = id
instance CanBuild Strict.Text where build = fromText
instance CanBuild Lazy.Text   where build = fromLazyText
instance CanBuild Char        where build = singleton
instance CanBuild String      where build = fromString

newtype ShowBuild a = ShowBuild a deriving newtype Show
instance Show a => CanBuild (ShowBuild a) where build = build . show

deriving via ShowBuild Int     instance CanBuild Int
deriving via ShowBuild Integer instance CanBuild Integer

instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where
  build = foldMap \x -> build x <> "\n"

instance CanBuild a => CanBuild (NonEmpty a) where build = build . toList