{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module QueueSheet.Template
(
loadTemplate
, renderTemplate
) where
import Data.Bifunctor (first)
#if !MIN_VERSION_base (4,11,0)
import Data.Monoid ((<>))
#endif
import qualified System.IO as IO
import qualified Text.Ginger as Ginger
import Text.Ginger ((~>))
import Data.Text (Text)
import qualified Data.Text.IO as TIO
import Control.Monad.Trans.Writer (Writer)
import QueueSheet.Types
( Date, Item, Name
, Queue
( Queue, queueDate, queueItems, queueName, queueSection, queueTags
, queueUrl
)
, QueueSheet(QueueSheet, qsQueues, qsSections), Section, Tag(Tag), Url
)
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
nextItems :: [Item]
prevItem :: Maybe Item
tags :: [Tag]
date :: Maybe Date
url :: Maybe Url
name :: Name
nextItems :: QueueCtx -> [Item]
prevItem :: QueueCtx -> Maybe Item
tags :: QueueCtx -> [Tag]
date :: QueueCtx -> Maybe Date
url :: QueueCtx -> Maybe Url
name :: QueueCtx -> Name
..} = [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
$
[ Text
"name" Text -> Name -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Name
name
, Text
"url" Text -> Maybe Url -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Maybe Url
url
, Text
"date" Text -> Maybe Date -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Maybe Date
date
, Text
"prev_item" Text -> Maybe Item -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Maybe Item
prevItem
, Text
"next_items" Text -> [Item] -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> [Item]
nextItems
] [Pair m] -> [Pair m] -> [Pair m]
forall a. [a] -> [a] -> [a]
++ [(Text
"tag_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag) Text -> Bool -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Bool
True | Tag Text
tag <- [Tag]
tags]
queueCtx :: Queue -> QueueCtx
queueCtx :: Queue -> QueueCtx
queueCtx Queue{[Tag]
Maybe (Either Item [Item])
Maybe Date
Maybe Url
Section
Name
queueItems :: Maybe (Either Item [Item])
queueTags :: [Tag]
queueSection :: Section
queueDate :: Maybe Date
queueUrl :: Maybe Url
queueName :: Name
queueUrl :: Queue -> Maybe Url
queueTags :: Queue -> [Tag]
queueSection :: Queue -> Section
queueName :: Queue -> Name
queueItems :: Queue -> Maybe (Either Item [Item])
queueDate :: Queue -> Maybe Date
..} = QueueCtx :: Name
-> Maybe Url
-> Maybe Date
-> [Tag]
-> Maybe Item
-> [Item]
-> QueueCtx
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 -> [Item])
-> ([Item] -> [Item]) -> Either Item [Item] -> [Item]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Item] -> Item -> [Item]
forall a b. a -> b -> a
const []) [Item] -> [Item]
forall a. a -> a
id) Maybe (Either Item [Item])
queueItems
}
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
[ Text
"name" Text -> Section -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Section
section
, Text
"queues" Text -> [QueueCtx] -> Pair m
forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> [QueueCtx]
queues
]
sectionCtxHasQueues :: SectionCtx -> Bool
sectionCtxHasQueues :: SectionCtx -> Bool
sectionCtxHasQueues (SectionCtx (Section
_, [])) = Bool
False
sectionCtxHasQueues SectionCtx
_ = Bool
True
newtype Context = Context [SectionCtx]
deriving newtype (Ginger.ToGVal m)
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
]
gingerContext
:: Context
-> Ginger.GingerContext Ginger.SourcePos (Writer Text) Text
gingerContext :: Context -> GingerContext SourcePos (Writer Text) Text
gingerContext Context
ctx = (Text -> GVal (Run SourcePos (Writer Text) Text))
-> GingerContext SourcePos (Writer Text) Text
forall p.
(Text -> GVal (Run p (Writer Text) Text))
-> GingerContext p (Writer Text) Text
Ginger.makeContextText ((Text -> GVal (Run SourcePos (Writer Text) Text))
-> GingerContext SourcePos (Writer Text) Text)
-> (Text -> GVal (Run SourcePos (Writer Text) Text))
-> GingerContext SourcePos (Writer Text) Text
forall a b. (a -> b) -> a -> b
$ \case
Text
"sections" -> Context -> GVal (Run SourcePos (Writer Text) Text)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
Ginger.toGVal Context
ctx
Text
_ -> Maybe Text -> GVal (Run SourcePos (Writer Text) Text)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
Ginger.toGVal (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)
loadTemplate
:: FilePath
-> IO (Either String (Ginger.Template Ginger.SourcePos))
loadTemplate :: FilePath -> IO (Either FilePath (Template SourcePos))
loadTemplate FilePath
path = (ParserError -> FilePath)
-> Either ParserError (Template SourcePos)
-> Either FilePath (Template SourcePos)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParserError -> FilePath
formatError (Either ParserError (Template SourcePos)
-> Either FilePath (Template SourcePos))
-> IO (Either ParserError (Template SourcePos))
-> IO (Either FilePath (Template SourcePos))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserOptions IO
-> FilePath -> IO (Either ParserError (Template SourcePos))
forall (m :: * -> *).
Monad m =>
ParserOptions m
-> FilePath -> m (Either ParserError (Template SourcePos))
Ginger.parseGingerFile' ParserOptions IO
options FilePath
path
where
options :: Ginger.ParserOptions IO
options :: ParserOptions IO
options = ParserOptions :: forall (m :: * -> *).
IncludeResolver m
-> Maybe FilePath
-> Bool
-> Bool
-> Bool
-> Delimiters
-> ParserOptions m
Ginger.ParserOptions
{ poIncludeResolver :: IncludeResolver IO
poIncludeResolver = (FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (IO FilePath -> IO (Maybe FilePath))
-> (FilePath -> IO FilePath) -> IncludeResolver IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
IO.readFile
, poSourceName :: Maybe FilePath
poSourceName = Maybe FilePath
forall a. Maybe a
Nothing
, poKeepTrailingNewline :: Bool
poKeepTrailingNewline = Bool
False
, poLStripBlocks :: Bool
poLStripBlocks = Bool
False
, poTrimBlocks :: Bool
poTrimBlocks = Bool
False
, poDelimiters :: Delimiters
poDelimiters = Delimiters :: FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Delimiters
Ginger.Delimiters
{ delimOpenInterpolation :: FilePath
delimOpenInterpolation = FilePath
"<<"
, delimCloseInterpolation :: FilePath
delimCloseInterpolation = FilePath
">>"
, delimOpenTag :: FilePath
delimOpenTag = FilePath
"<!"
, delimCloseTag :: FilePath
delimCloseTag = FilePath
"!>"
, delimOpenComment :: FilePath
delimOpenComment = FilePath
"<#"
, delimCloseComment :: FilePath
delimCloseComment = FilePath
"#>"
}
}
formatError :: Ginger.ParserError -> String
formatError :: ParserError -> FilePath
formatError ParserError
err = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
"error loading template: "
, FilePath -> (SourcePos -> FilePath) -> Maybe SourcePos -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
path SourcePos -> FilePath
forall a. Show a => a -> FilePath
show (Maybe SourcePos -> FilePath) -> Maybe SourcePos -> FilePath
forall a b. (a -> b) -> a -> b
$ ParserError -> Maybe SourcePos
Ginger.peSourcePosition ParserError
err
, FilePath
": "
, ParserError -> FilePath
Ginger.peErrorMessage ParserError
err
]
renderTemplate
:: FilePath
-> Ginger.Template Ginger.SourcePos
-> QueueSheet
-> IO ()
renderTemplate :: FilePath -> Template SourcePos -> QueueSheet -> IO ()
renderTemplate FilePath
path Template SourcePos
template QueueSheet{[Queue]
[Section]
qsQueues :: [Queue]
qsSections :: [Section]
qsSections :: QueueSheet -> [Section]
qsQueues :: QueueSheet -> [Queue]
..} =
let ctx :: GingerContext SourcePos (Writer Text) Text
ctx = Context -> GingerContext SourcePos (Writer Text) Text
gingerContext (Context -> GingerContext SourcePos (Writer Text) Text)
-> Context -> GingerContext SourcePos (Writer Text) Text
forall a b. (a -> b) -> a -> b
$ [Section] -> [Queue] -> Context
context [Section]
qsSections [Queue]
qsQueues
in FilePath -> Text -> IO ()
TIO.writeFile FilePath
path (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ GingerContext SourcePos (Writer Text) Text
-> Template SourcePos -> Text
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 Text) Text
ctx Template SourcePos
template