Template.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}

{- | Reads a document template when the package is compiled.

The template is the Flat ODF text of the manual, with holes written
@{{name}}@. 'embedTemplate' splits it into literal text and holes, and each
hole @{{legal-name}}@ becomes the function @holeLegalName@, which must be in
scope where the splice is used. A hole with no such function fails to
compile.
-}
module ReOC.Render.Template (
  embedTemplate,
  templateHoles,
  holeFunctionName,
) where

import qualified Data.ByteString as ByteString
import Data.Char (toUpper)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import Language.Haskell.TH (Exp, Q, listE, litE, lookupValueName, runIO, stringL, varE)
import Language.Haskell.TH.Syntax (addDependentFile)

{- $setup
>>> :set -XOverloadedStrings
-}

{- | The literal text and holes of a template.

>>> templateHoles "a {{legal-name}} b {{version}}"
[Left "a ",Right "legal-name",Left " b ",Right "version",Left ""]
-}
templateHoles :: Text -> [Either Text Text]
templateHoles t =
  case Text.splitOn (Text.pack "{{") t of
    [] -> []
    first : rest -> Left first : concatMap hole rest
 where
  hole chunk =
    let (name, after) = Text.breakOn (Text.pack "}}") chunk
     in [Right name, Left (Text.drop 2 after)]

{- | The name of the function that fills a hole.

>>> holeFunctionName "repl-training-overview"
"holeReplTrainingOverview"
-}
holeFunctionName :: Text -> String
holeFunctionName name =
  "hole" <> concatMap (capitalise . Text.unpack) (Text.splitOn (Text.pack "-") name)
 where
  capitalise w =
    case w of
      c : cs -> toUpper c : cs
      [] -> []

{- | The template at a path, relative to the package, as an expression of type
@[Either Text (ReOC -> Text)]@.
-}
embedTemplate :: FilePath -> Q Exp
embedTemplate path = do
  addDependentFile path
  t <- runIO (decodeUtf8 <$> ByteString.readFile path)
  listE (map segment (templateHoles t))
 where
  segment (Left literal) =
    [|Left (Text.pack $(litE (stringL (Text.unpack literal))))|]
  segment (Right name) = do
    found <- lookupValueName (holeFunctionName name)
    case found of
      Just n -> [|Right $(varE n)|]
      Nothing -> fail ("the operations manual template has the hole {{" <> Text.unpack name <> "}}, but " <> holeFunctionName name <> " is not in scope")