{-# 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
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 =>
FilePath ->
FilePath ->
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
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 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
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
clearError :: TemplateName -> TemplateErrors -> TemplateErrors
clearError :: TemplateName -> TemplateErrors -> TemplateErrors
clearError =
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete