{-# LANGUAGE RecordWildCards #-}

module Heist.Extra.TemplateState (
  TemplateState,
  TemplateName,
  emptyTemplateState,
  addTemplateFile,
  removeTemplateFile,
  renderHeistTemplate,
) where

import Control.Monad.Except (MonadError (throwError), runExcept)
import Data.ByteString.Builder (toLazyByteString)
import Data.Default (Default (..))
import Data.HashMap.Strict qualified as HM
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import GHC.IO.Unsafe (unsafePerformIO)
import Heist qualified as H
import Heist.Internal.Types qualified as HT
import Heist.Interpreted qualified as HI
import System.FilePath (splitExtension)
import Text.XmlHtml qualified as XmlHtml

type TemplateName = ByteString

-- | Holds a set of Heist template files that are importing one another.
data TemplateState = TemplateState (H.HeistState Identity) TemplateErrors

instance Default TemplateState where
  def :: TemplateState
def = forall a. IO a -> a
unsafePerformIO forall (m :: Type -> Type). MonadIO m => m TemplateState
emptyTemplateState

emptyTemplateState :: MonadIO m => m TemplateState
emptyTemplateState :: forall (m :: Type -> Type). MonadIO m => m TemplateState
emptyTemplateState = do
  let HeistConfig Identity
heistCfg :: H.HeistConfig Identity =
        forall (m :: Type -> Type). HeistConfig m
H.emptyHeistConfig
          forall a b. a -> (a -> b) -> b
& forall (f :: Type -> Type) (m :: Type -> Type).
Functor f =>
(Text -> f Text) -> HeistConfig m -> f (HeistConfig m)
H.hcNamespace (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity Text
"")
          forall a b. a -> (a -> b) -> b
& forall a. Identity a -> a
runIdentity
  Either [String] (HeistState Identity)
eSt <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (n :: Type -> Type).
Monad n =>
HeistConfig n -> IO (Either [String] (HeistState n))
H.initHeist HeistConfig Identity
heistCfg
  let st :: HeistState Identity
st = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a t. (HasCallStack, IsText t) => t -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToText a => a -> Text
toText) forall a. a -> a
id Either [String] (HeistState Identity)
eSt
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HeistState Identity -> TemplateErrors -> TemplateState
TemplateState HeistState Identity
st forall a. Monoid a => a
mempty

getTemplateState :: MonadError Text m => TemplateState -> m (HT.HeistState Identity)
getTemplateState :: forall (m :: Type -> Type).
MonadError Text m =>
TemplateState -> m (HeistState Identity)
getTemplateState (TemplateState HeistState Identity
st TemplateErrors
errs) =
  if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null TemplateErrors
errs
    then forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ TemplateErrors -> Text
showErrors TemplateErrors
errs
    else forall (f :: Type -> Type) a. Applicative f => a -> f a
pure HeistState Identity
st

addTemplate :: TemplateName -> FilePath -> TemplateState -> Either Text HT.Template -> TemplateState
addTemplate :: TemplateName
-> String -> TemplateState -> Either Text Template -> TemplateState
addTemplate TemplateName
name String
fp (TemplateState HeistState Identity
st TemplateErrors
errs) = \case
  Left Text
err ->
    HeistState Identity -> TemplateErrors -> TemplateState
TemplateState HeistState Identity
st (TemplateName -> Text -> TemplateErrors -> TemplateErrors
assignError TemplateName
name Text
err TemplateErrors
errs)
  Right Template
doc ->
    let newSt :: HeistState Identity
newSt = forall (n :: Type -> Type).
TemplateName
-> Template -> Maybe String -> HeistState n -> HeistState n
HI.addTemplate TemplateName
name Template
doc (forall a. a -> Maybe a
Just String
fp) HeistState Identity
st
     in HeistState Identity -> TemplateErrors -> TemplateState
TemplateState HeistState Identity
newSt (TemplateName -> TemplateErrors -> TemplateErrors
clearError TemplateName
name TemplateErrors
errs)

addTemplateFile ::
  HasCallStack =>
  -- | Absolute path
  FilePath ->
  -- | Relative path (to template base)
  FilePath ->
  -- | Contents of the .tmpl file
  ByteString ->
  TemplateState ->
  TemplateState
addTemplateFile :: HasCallStack =>
String -> String -> TemplateName -> TemplateState -> TemplateState
addTemplateFile String
fp (HasCallStack => String -> TemplateName
tmplName -> TemplateName
name) TemplateName
s TemplateState
tmplSt =
  TemplateName
-> String -> TemplateState -> Either Text Template -> TemplateState
addTemplate TemplateName
name String
fp TemplateState
tmplSt forall a b. (a -> b) -> a -> b
$
    String -> TemplateName -> Either String Document
XmlHtml.parseHTML String
fp TemplateName
s forall a b. a -> (a -> b) -> b
& \case
      Left (forall a. ToText a => a -> Text
toText -> Text
err) ->
        forall a b. a -> Either a b
Left Text
err
      Right XmlHtml.XmlDocument {} ->
        forall a b. a -> Either a b
Left Text
"Xml unsupported"
      Right XmlHtml.HtmlDocument {Template
Maybe DocType
Encoding
docEncoding :: Document -> Encoding
docType :: Document -> Maybe DocType
docContent :: Document -> Template
docContent :: Template
docType :: Maybe DocType
docEncoding :: Encoding
..} ->
        forall a b. b -> Either a b
Right Template
docContent

removeTemplate :: HasCallStack => TemplateName -> TemplateState -> TemplateState
removeTemplate :: HasCallStack => TemplateName -> TemplateState -> TemplateState
removeTemplate TemplateName
name (TemplateState HeistState Identity
st TemplateErrors
errs) =
  let tpath :: TPath
tpath = TemplateName -> TPath
H.splitTemplatePath TemplateName
name
      newSt :: HeistState Identity
newSt = HeistState Identity
st {_templateMap :: HashMap TPath DocumentFile
HT._templateMap = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete TPath
tpath (forall (m :: Type -> Type).
HeistState m -> HashMap TPath DocumentFile
HT._templateMap HeistState Identity
st)}
   in HeistState Identity -> TemplateErrors -> TemplateState
TemplateState HeistState Identity
newSt (TemplateName -> TemplateErrors -> TemplateErrors
clearError TemplateName
name TemplateErrors
errs)

removeTemplateFile :: HasCallStack => FilePath -> TemplateState -> TemplateState
removeTemplateFile :: HasCallStack => String -> TemplateState -> TemplateState
removeTemplateFile (HasCallStack => String -> TemplateName
tmplName -> TemplateName
name) = HasCallStack => TemplateName -> TemplateState -> TemplateState
removeTemplate TemplateName
name

tmplName :: HasCallStack => String -> TemplateName
tmplName :: HasCallStack => String -> TemplateName
tmplName String
fp = forall a. a -> Maybe a -> a
fromMaybe (forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Not a .tpl file") forall a b. (a -> b) -> a -> b
$ do
  let (String
base, String
ext) = String -> (String, String)
splitExtension String
fp
  forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String
ext forall a. Eq a => a -> a -> Bool
== String
".tpl"
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 String
base

renderHeistTemplate ::
  HasCallStack =>
  TemplateName ->
  H.Splices (HI.Splice Identity) ->
  TemplateState ->
  Either Text LByteString
renderHeistTemplate :: HasCallStack =>
TemplateName
-> Splices (Splice Identity)
-> TemplateState
-> Either Text LByteString
renderHeistTemplate TemplateName
name Splices (Splice Identity)
splices TemplateState
tmplSt =
  forall e a. Except e a -> Either e a
runExcept forall a b. (a -> b) -> a -> b
$ do
    HeistState Identity
st <- forall (m :: Type -> Type).
MonadError Text m =>
TemplateState -> m (HeistState Identity)
getTemplateState TemplateState
tmplSt
    (Builder
builder, TemplateName
_mimeType) <-
      forall (m :: Type -> Type) e a.
Monad m =>
e -> Maybe a -> ExceptT e m a
tryJust (Text
"Unable to render template '" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 TemplateName
name forall a. Semigroup a => a -> a -> a
<> Text
"'") forall a b. (a -> b) -> a -> b
$
        forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$
          forall (n :: Type -> Type).
Monad n =>
HeistState n -> TemplateName -> n (Maybe (Builder, TemplateName))
HI.renderTemplate (forall (n :: Type -> Type).
Splices (Splice n) -> HeistState n -> HeistState n
HI.bindSplices Splices (Splice Identity)
splices HeistState Identity
st) TemplateName
name
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Builder -> LByteString
toLazyByteString Builder
builder
  where
    -- A 'fromJust' that fails in the 'ExceptT' monad
    tryJust :: Monad m => e -> Maybe a -> ExceptT e m a
    tryJust :: forall (m :: Type -> Type) e a.
Monad m =>
e -> Maybe a -> ExceptT e m a
tryJust e
e = forall (m :: Type -> Type) e a.
Applicative m =>
Either e a -> ExceptT e m a
hoistEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l r. l -> Maybe r -> Either l r
maybeToRight e
e

-- | Type to track errors on a per template basis
type TemplateErrors = Map TemplateName Text

showErrors :: TemplateErrors -> Text
showErrors :: TemplateErrors -> Text
showErrors TemplateErrors
m =
  Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$
    forall k a. Map k a -> [(k, a)]
Map.toList TemplateErrors
m forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \(TemplateName
k, Text
v) ->
      forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 TemplateName
k forall a. Semigroup a => a -> a -> a
<> Text
":\n" forall a. Semigroup a => a -> a -> a
<> forall t. IsText t "unlines" => [t] -> t
unlines (Text -> Text
indent forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. IsText t "lines" => t -> [t]
lines Text
v)
  where
    indent :: Text -> Text
    indent :: Text -> Text
indent Text
s = Text
"\t" forall a. Semigroup a => a -> a -> a
<> Text
s

-- | Assign a new error for the given template
assignError :: TemplateName -> Text -> TemplateErrors -> TemplateErrors
assignError :: TemplateName -> Text -> TemplateErrors -> TemplateErrors
assignError =
  forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert

-- | Indicate that the given template has no errors
clearError :: TemplateName -> TemplateErrors -> TemplateErrors
clearError :: TemplateName -> TemplateErrors -> TemplateErrors
clearError =
  forall k a. Ord k => k -> Map k a -> Map k a
Map.delete