------------------------------------------------------------------------------
-- |
-- Module      : QueueSheet.Template
-- Description : queue sheet template functions
-- Copyright   : Copyright (c) 2020-2025 Travis Cardwell
-- License     : MIT
------------------------------------------------------------------------------

{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module QueueSheet.Template
  ( -- * API
    loadTemplate
  , renderTemplate
  ) where

-- https://hackage.haskell.org/package/base
import Data.Bifunctor (first)
import Data.Either (fromRight)
#if !MIN_VERSION_base (4,11,0)
import Data.Monoid ((<>))
#endif
import qualified System.IO as IO

-- https://hackage.haskell.org/package/ginger
import qualified Text.Ginger as Ginger
import Text.Ginger ((~>))

-- https://hackage.haskell.org/package/text
import Data.Text (Text)
import qualified Data.Text.IO as TIO

-- https://hackage.haskell.org/package/transformers
import Control.Monad.Trans.Writer (Writer)

-- (queue-sheet)
import QueueSheet.Types
  ( Date, Item, Name
  , Queue
      ( Queue, queueDate, queueItems, queueName, queueSection, queueTags
      , queueUrl
      )
  , QueueSheet(QueueSheet, qsQueues, qsSections), Section, Tag(Tag), Url
  )

------------------------------------------------------------------------------
-- $QueueCtx

-- | Queue context
data QueueCtx
  = QueueCtx
    { QueueCtx -> Name
name      :: !Name
    , QueueCtx -> Maybe Url
url       :: !(Maybe Url)
    , QueueCtx -> Maybe Date
date      :: !(Maybe Date)
    , QueueCtx -> [Tag]
tags      :: ![Tag]
    , QueueCtx -> Maybe Item
prevItem  :: !(Maybe Item)
    , QueueCtx -> [Item]
nextItems :: ![Item]
    }

instance Ginger.ToGVal m QueueCtx where
  toGVal :: QueueCtx -> GVal m
toGVal QueueCtx{[Item]
[Tag]
Maybe Item
Maybe Date
Maybe Url
Name
name :: QueueCtx -> Name
url :: QueueCtx -> Maybe Url
date :: QueueCtx -> Maybe Date
tags :: QueueCtx -> [Tag]
prevItem :: QueueCtx -> Maybe Item
nextItems :: QueueCtx -> [Item]
name :: Name
url :: Maybe Url
date :: Maybe Date
tags :: [Tag]
prevItem :: Maybe Item
nextItems :: [Item]
..} = [Pair m] -> GVal m
forall (m :: * -> *). [Pair m] -> GVal m
Ginger.dict ([Pair m] -> GVal m) -> [Pair m] -> GVal m
forall a b. (a -> b) -> a -> b
$
    [ VarName
"name"       VarName -> Name -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Name
name
    , VarName
"url"        VarName -> Maybe Url -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Maybe Url
url
    , VarName
"date"       VarName -> Maybe Date -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Maybe Date
date
    , VarName
"prev_item"  VarName -> Maybe Item -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Maybe Item
prevItem
    , VarName
"next_items" VarName -> [Item] -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> [Item]
nextItems
    ] [Pair m] -> [Pair m] -> [Pair m]
forall a. [a] -> [a] -> [a]
++ [(VarName
"tag_" VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
tag) VarName -> Bool -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Bool
True | Tag VarName
tag <- [Tag]
tags]

-- | Construct a queue context
queueCtx :: Queue -> QueueCtx
queueCtx :: Queue -> QueueCtx
queueCtx Queue{[Tag]
Maybe (Either Item [Item])
Maybe Date
Maybe Url
Section
Name
queueDate :: Queue -> Maybe Date
queueItems :: Queue -> Maybe (Either Item [Item])
queueName :: Queue -> Name
queueSection :: Queue -> Section
queueTags :: Queue -> [Tag]
queueUrl :: Queue -> Maybe Url
queueName :: Name
queueUrl :: Maybe Url
queueDate :: Maybe Date
queueSection :: Section
queueTags :: [Tag]
queueItems :: Maybe (Either Item [Item])
..} = QueueCtx
    { name :: Name
name      = Name
queueName
    , url :: Maybe Url
url       = Maybe Url
queueUrl
    , date :: Maybe Date
date      = Maybe Date
queueDate
    , tags :: [Tag]
tags      = [Tag]
queueTags
    , prevItem :: Maybe Item
prevItem  = (Item -> Maybe Item)
-> ([Item] -> Maybe Item) -> Either Item [Item] -> Maybe Item
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Item -> Maybe Item
forall a. a -> Maybe a
Just (Maybe Item -> [Item] -> Maybe Item
forall a b. a -> b -> a
const Maybe Item
forall a. Maybe a
Nothing) (Either Item [Item] -> Maybe Item)
-> Maybe (Either Item [Item]) -> Maybe Item
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Either Item [Item])
queueItems
    , nextItems :: [Item]
nextItems = [Item]
-> (Either Item [Item] -> [Item])
-> Maybe (Either Item [Item])
-> [Item]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Item] -> Either Item [Item] -> [Item]
forall b a. b -> Either a b -> b
fromRight []) Maybe (Either Item [Item])
queueItems
    }

------------------------------------------------------------------------------
-- $SectionCtx

-- | Section context
newtype SectionCtx = SectionCtx (Section, [QueueCtx])

instance Ginger.ToGVal m SectionCtx where
  toGVal :: SectionCtx -> GVal m
toGVal (SectionCtx (Section
section, [QueueCtx]
queues)) = [Pair m] -> GVal m
forall (m :: * -> *). [Pair m] -> GVal m
Ginger.dict
    [ VarName
"name"   VarName -> Section -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Section
section
    , VarName
"queues" VarName -> [QueueCtx] -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> [QueueCtx]
queues
    ]

-- | Check if a section context has any queues
sectionCtxHasQueues :: SectionCtx -> Bool
sectionCtxHasQueues :: SectionCtx -> Bool
sectionCtxHasQueues (SectionCtx (Section
_, [])) = Bool
False
sectionCtxHasQueues SectionCtx
_                    = Bool
True

------------------------------------------------------------------------------
-- $Context

-- | Template context
newtype Context = Context [SectionCtx]
  deriving newtype (Ginger.ToGVal m)

-- | Template context constructor
context :: [Section] -> [Queue] -> Context
context :: [Section] -> [Queue] -> Context
context [Section]
sections [Queue]
queues = [SectionCtx] -> Context
Context ([SectionCtx] -> Context) -> [SectionCtx] -> Context
forall a b. (a -> b) -> a -> b
$ (SectionCtx -> Bool) -> [SectionCtx] -> [SectionCtx]
forall a. (a -> Bool) -> [a] -> [a]
filter SectionCtx -> Bool
sectionCtxHasQueues
    [ (Section, [QueueCtx]) -> SectionCtx
SectionCtx
        ( Section
section
        , [ Queue -> QueueCtx
queueCtx Queue
queue
          | Queue
queue <- [Queue]
queues, Queue -> Section
queueSection Queue
queue Section -> Section -> Bool
forall a. Eq a => a -> a -> Bool
== Section
section
          ]
        )
    | Section
section <- [Section]
sections
    ]

-- | Create a Ginger context from a template context
gingerContext
  :: Context
  -> Ginger.GingerContext Ginger.SourcePos (Writer Text) Text
gingerContext :: Context -> GingerContext SourcePos (Writer VarName) VarName
gingerContext Context
ctx = (VarName -> GVal (Run SourcePos (Writer VarName) VarName))
-> GingerContext SourcePos (Writer VarName) VarName
forall p.
(VarName -> GVal (Run p (Writer VarName) VarName))
-> GingerContext p (Writer VarName) VarName
Ginger.makeContextText ((VarName -> GVal (Run SourcePos (Writer VarName) VarName))
 -> GingerContext SourcePos (Writer VarName) VarName)
-> (VarName -> GVal (Run SourcePos (Writer VarName) VarName))
-> GingerContext SourcePos (Writer VarName) VarName
forall a b. (a -> b) -> a -> b
$ \case
    VarName
"sections" -> Context -> GVal (Run SourcePos (Writer VarName) VarName)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
Ginger.toGVal Context
ctx
    VarName
_          -> Maybe VarName -> GVal (Run SourcePos (Writer VarName) VarName)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
Ginger.toGVal (Maybe VarName
forall a. Maybe a
Nothing :: Maybe Text)

------------------------------------------------------------------------------
-- $API

-- | Load a Ginger template
--
-- @since 0.3.0.0
loadTemplate
  :: FilePath
  -> IO (Either String (Ginger.Template Ginger.SourcePos))
loadTemplate :: [Char] -> IO (Either [Char] (Template SourcePos))
loadTemplate [Char]
path = (ParserError -> [Char])
-> Either ParserError (Template SourcePos)
-> Either [Char] (Template SourcePos)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParserError -> [Char]
formatError (Either ParserError (Template SourcePos)
 -> Either [Char] (Template SourcePos))
-> IO (Either ParserError (Template SourcePos))
-> IO (Either [Char] (Template SourcePos))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserOptions IO
-> [Char] -> IO (Either ParserError (Template SourcePos))
forall (m :: * -> *).
Monad m =>
ParserOptions m
-> [Char] -> m (Either ParserError (Template SourcePos))
Ginger.parseGingerFile' ParserOptions IO
options [Char]
path
  where
    options :: Ginger.ParserOptions IO
    options :: ParserOptions IO
options = Ginger.ParserOptions
      { poIncludeResolver :: IncludeResolver IO
poIncludeResolver     = ([Char] -> Maybe [Char]) -> IO [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (IO [Char] -> IO (Maybe [Char]))
-> ([Char] -> IO [Char]) -> IncludeResolver IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [Char]
IO.readFile
      , poSourceName :: Maybe [Char]
poSourceName          = Maybe [Char]
forall a. Maybe a
Nothing
      , poKeepTrailingNewline :: Bool
poKeepTrailingNewline = Bool
False
      , poLStripBlocks :: Bool
poLStripBlocks        = Bool
False
      , poTrimBlocks :: Bool
poTrimBlocks          = Bool
False
      , poDelimiters :: Delimiters
poDelimiters          = Ginger.Delimiters
          { delimOpenInterpolation :: [Char]
delimOpenInterpolation  = [Char]
"<<"
          , delimCloseInterpolation :: [Char]
delimCloseInterpolation = [Char]
">>"
          , delimOpenTag :: [Char]
delimOpenTag            = [Char]
"<!"
          , delimCloseTag :: [Char]
delimCloseTag           = [Char]
"!>"
          , delimOpenComment :: [Char]
delimOpenComment        = [Char]
"<#"
          , delimCloseComment :: [Char]
delimCloseComment       = [Char]
"#>"
          }
      }

    formatError :: Ginger.ParserError -> String
    formatError :: ParserError -> [Char]
formatError ParserError
err = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Char]
"error loading template: "
      , [Char] -> (SourcePos -> [Char]) -> Maybe SourcePos -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
path SourcePos -> [Char]
forall a. Show a => a -> [Char]
show (Maybe SourcePos -> [Char]) -> Maybe SourcePos -> [Char]
forall a b. (a -> b) -> a -> b
$ ParserError -> Maybe SourcePos
Ginger.peSourcePosition ParserError
err
      , [Char]
": "
      , ParserError -> [Char]
Ginger.peErrorMessage ParserError
err
      ]

-- | Render a template using the given context
--
-- @since 0.3.0.0
renderTemplate
  :: FilePath
  -> Ginger.Template Ginger.SourcePos
  -> QueueSheet
  -> IO ()
renderTemplate :: [Char] -> Template SourcePos -> QueueSheet -> IO ()
renderTemplate [Char]
path Template SourcePos
template QueueSheet{[Queue]
[Section]
qsQueues :: QueueSheet -> [Queue]
qsSections :: QueueSheet -> [Section]
qsSections :: [Section]
qsQueues :: [Queue]
..} =
    let ctx :: GingerContext SourcePos (Writer VarName) VarName
ctx = Context -> GingerContext SourcePos (Writer VarName) VarName
gingerContext (Context -> GingerContext SourcePos (Writer VarName) VarName)
-> Context -> GingerContext SourcePos (Writer VarName) VarName
forall a b. (a -> b) -> a -> b
$ [Section] -> [Queue] -> Context
context [Section]
qsSections [Queue]
qsQueues
    in  [Char] -> VarName -> IO ()
TIO.writeFile [Char]
path (VarName -> IO ()) -> VarName -> IO ()
forall a b. (a -> b) -> a -> b
$ GingerContext SourcePos (Writer VarName) VarName
-> Template SourcePos -> VarName
forall p h.
(ToGVal (Run p (Writer h) h) h, ToGVal (Run p (Writer h) h) p,
 Monoid h) =>
GingerContext p (Writer h) h -> Template p -> h
Ginger.runGinger GingerContext SourcePos (Writer VarName) VarName
ctx Template SourcePos
template