summaryrefslogtreecommitdiff
path: root/src/Hakyll/Web/Template
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll/Web/Template')
-rw-r--r--src/Hakyll/Web/Template/Context.hs379
-rw-r--r--src/Hakyll/Web/Template/Internal.hs203
-rw-r--r--src/Hakyll/Web/Template/Internal/Element.hs298
-rw-r--r--src/Hakyll/Web/Template/Internal/Trim.hs95
-rw-r--r--src/Hakyll/Web/Template/List.hs91
5 files changed, 0 insertions, 1066 deletions
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
deleted file mode 100644
index b6c7994..0000000
--- a/src/Hakyll/Web/Template/Context.hs
+++ /dev/null
@@ -1,379 +0,0 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
-module Hakyll.Web.Template.Context
- ( ContextField (..)
- , Context (..)
- , field
- , boolField
- , constField
- , listField
- , listFieldWith
- , functionField
- , mapContext
-
- , defaultContext
- , bodyField
- , metadataField
- , urlField
- , pathField
- , titleField
- , snippetField
- , dateField
- , dateFieldWith
- , getItemUTC
- , getItemModificationTime
- , modificationTimeField
- , modificationTimeFieldWith
- , teaserField
- , teaserFieldWithSeparator
- , missingField
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Applicative (Alternative (..))
-import Control.Monad (msum)
-import Data.List (intercalate)
-import Data.Time.Clock (UTCTime (..))
-import Data.Time.Format (formatTime)
-import qualified Data.Time.Format as TF
-import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
-import Hakyll.Core.Compiler
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-import Hakyll.Core.Metadata
-import Hakyll.Core.Provider
-import Hakyll.Core.Util.String (needlePrefix, splitAll)
-import Hakyll.Web.Html
-import System.FilePath (splitDirectories, takeBaseName)
-
-
---------------------------------------------------------------------------------
--- | Mostly for internal usage
-data ContextField
- = StringField String
- | forall a. ListField (Context a) [Item a]
-
-
---------------------------------------------------------------------------------
--- | The 'Context' monoid. Please note that the order in which you
--- compose the items is important. For example in
---
--- > field "A" f1 <> field "A" f2
---
--- the first context will overwrite the second. This is especially
--- important when something is being composed with
--- 'metadataField' (or 'defaultContext'). If you want your context to be
--- overwritten by the metadata fields, compose it from the right:
---
--- @
--- 'metadataField' \<\> field \"date\" fDate
--- @
---
-newtype Context a = Context
- { unContext :: String -> [String] -> Item a -> Compiler ContextField
- }
-
-
---------------------------------------------------------------------------------
-instance Monoid (Context a) where
- mempty = missingField
- mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
-
-
---------------------------------------------------------------------------------
-field' :: String -> (Item a -> Compiler ContextField) -> Context a
-field' key value = Context $ \k _ i -> if k == key then value i else empty
-
-
---------------------------------------------------------------------------------
--- | Constructs a new field in the 'Context.'
-field
- :: String -- ^ Key
- -> (Item a -> Compiler String) -- ^ Function that constructs a value based
- -- on the item
- -> Context a
-field key value = field' key (fmap StringField . value)
-
-
---------------------------------------------------------------------------------
--- | Creates a 'field' to use with the @$if()$@ template macro.
-boolField
- :: String
- -> (Item a -> Bool)
- -> Context a
-boolField name f = field name (\i -> if f i
- then pure (error $ unwords ["no string value for bool field:",name])
- else empty)
-
-
---------------------------------------------------------------------------------
--- | Creates a 'field' that does not depend on the 'Item'
-constField :: String -> String -> Context a
-constField key = field key . const . return
-
-
---------------------------------------------------------------------------------
-listField :: String -> Context a -> Compiler [Item a] -> Context b
-listField key c xs = listFieldWith key c (const xs)
-
-
---------------------------------------------------------------------------------
-listFieldWith
- :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
-listFieldWith key c f = field' key $ fmap (ListField c) . f
-
-
---------------------------------------------------------------------------------
-functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
-functionField name value = Context $ \k args i ->
- if k == name
- then StringField <$> value args i
- else empty
-
-
---------------------------------------------------------------------------------
-mapContext :: (String -> String) -> Context a -> Context a
-mapContext f (Context c) = Context $ \k a i -> do
- fld <- c k a i
- case fld of
- StringField str -> return $ StringField (f str)
- ListField _ _ -> fail $
- "Hakyll.Web.Template.Context.mapContext: " ++
- "can't map over a ListField!"
-
---------------------------------------------------------------------------------
--- | A context that allows snippet inclusion. In processed file, use as:
---
--- > ...
--- > $snippet("path/to/snippet/")$
--- > ...
---
--- The contents of the included file will not be interpolated.
---
-snippetField :: Context String
-snippetField = functionField "snippet" f
- where
- f [contentsPath] _ = loadBody (fromFilePath contentsPath)
- f _ i = error $
- "Too many arguments to function 'snippet()' in item " ++
- show (itemIdentifier i)
-
---------------------------------------------------------------------------------
--- | A context that contains (in that order)
---
--- 1. A @$body$@ field
---
--- 2. Metadata fields
---
--- 3. A @$url$@ 'urlField'
---
--- 4. A @$path$@ 'pathField'
---
--- 5. A @$title$@ 'titleField'
-defaultContext :: Context String
-defaultContext =
- bodyField "body" `mappend`
- metadataField `mappend`
- urlField "url" `mappend`
- pathField "path" `mappend`
- titleField "title" `mappend`
- missingField
-
-
---------------------------------------------------------------------------------
-teaserSeparator :: String
-teaserSeparator = "<!--more-->"
-
-
---------------------------------------------------------------------------------
--- | Constructs a 'field' that contains the body of the item.
-bodyField :: String -> Context String
-bodyField key = field key $ return . itemBody
-
-
---------------------------------------------------------------------------------
--- | Map any field to its metadata value, if present
-metadataField :: Context a
-metadataField = Context $ \k _ i -> do
- value <- getMetadataField (itemIdentifier i) k
- maybe empty (return . StringField) value
-
-
---------------------------------------------------------------------------------
--- | Absolute url to the resulting item
-urlField :: String -> Context a
-urlField key = field key $
- fmap (maybe empty toUrl) . getRoute . itemIdentifier
-
-
---------------------------------------------------------------------------------
--- | Filepath of the underlying file of the item
-pathField :: String -> Context a
-pathField key = field key $ return . toFilePath . itemIdentifier
-
-
---------------------------------------------------------------------------------
--- | This title 'field' takes the basename of the underlying file by default
-titleField :: String -> Context a
-titleField = mapContext takeBaseName . pathField
-
-
---------------------------------------------------------------------------------
--- | When the metadata has a field called @published@ in one of the
--- following formats then this function can render the date.
---
--- * @Mon, 06 Sep 2010 00:01:00 +0000@
---
--- * @Mon, 06 Sep 2010 00:01:00 UTC@
---
--- * @Mon, 06 Sep 2010 00:01:00@
---
--- * @2010-09-06T00:01:00+0000@
---
--- * @2010-09-06T00:01:00Z@
---
--- * @2010-09-06T00:01:00@
---
--- * @2010-09-06 00:01:00+0000@
---
--- * @2010-09-06 00:01:00@
---
--- * @September 06, 2010 00:01 AM@
---
--- Following date-only formats are supported too (@00:00:00@ for time is
--- assumed)
---
--- * @2010-09-06@
---
--- * @September 06, 2010@
---
--- Alternatively, when the metadata has a field called @path@ in a
--- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
--- and no @published@ metadata field set, this function can render
--- the date. This pattern matches the file name or directory names
--- that begins with @yyyy-mm-dd@ . For example:
--- @folder//yyyy-mm-dd-title//dist//main.extension@ .
--- In case of multiple matches, the rightmost one is used.
-
-dateField :: String -- ^ Key in which the rendered date should be placed
- -> String -- ^ Format to use on the date
- -> Context a -- ^ Resulting context
-dateField = dateFieldWith defaultTimeLocale
-
-
---------------------------------------------------------------------------------
--- | This is an extended version of 'dateField' that allows you to
--- specify a time locale that is used for outputting the date. For more
--- details, see 'dateField'.
-dateFieldWith :: TimeLocale -- ^ Output time locale
- -> String -- ^ Destination key
- -> String -- ^ Format to use on the date
- -> Context a -- ^ Resulting context
-dateFieldWith locale key format = field key $ \i -> do
- time <- getItemUTC locale $ itemIdentifier i
- return $ formatTime locale format time
-
-
---------------------------------------------------------------------------------
--- | Parser to try to extract and parse the time from the @published@
--- field or from the filename. See 'dateField' for more information.
--- Exported for user convenience.
-getItemUTC :: MonadMetadata m
- => TimeLocale -- ^ Output time locale
- -> Identifier -- ^ Input page
- -> m UTCTime -- ^ Parsed UTCTime
-getItemUTC locale id' = do
- metadata <- getMetadata id'
- let tryField k fmt = lookupString k metadata >>= parseTime' fmt
- paths = splitDirectories $ toFilePath id'
-
- maybe empty' return $ msum $
- [tryField "published" fmt | fmt <- formats] ++
- [tryField "date" fmt | fmt <- formats] ++
- [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]
- where
- empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
- "could not parse time for " ++ show id'
- parseTime' = parseTimeM True locale
- formats =
- [ "%a, %d %b %Y %H:%M:%S %Z"
- , "%Y-%m-%dT%H:%M:%S%Z"
- , "%Y-%m-%d %H:%M:%S%Z"
- , "%Y-%m-%d"
- , "%B %e, %Y %l:%M %p"
- , "%B %e, %Y"
- , "%b %d, %Y"
- ]
-
-
---------------------------------------------------------------------------------
--- | Get the time on which the actual file was last modified. This only works if
--- there actually is an underlying file, of couse.
-getItemModificationTime
- :: Identifier
- -> Compiler UTCTime
-getItemModificationTime identifier = do
- provider <- compilerProvider <$> compilerAsk
- return $ resourceModificationTime provider identifier
-
-
---------------------------------------------------------------------------------
-modificationTimeField :: String -- ^ Key
- -> String -- ^ Format
- -> Context a -- ^ Resuting context
-modificationTimeField = modificationTimeFieldWith defaultTimeLocale
-
-
---------------------------------------------------------------------------------
-modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
- -> String -- ^ Key
- -> String -- ^ Format
- -> Context a -- ^ Resulting context
-modificationTimeFieldWith locale key fmt = field key $ \i -> do
- mtime <- getItemModificationTime $ itemIdentifier i
- return $ formatTime locale fmt mtime
-
-
---------------------------------------------------------------------------------
--- | A context with "teaser" key which contain a teaser of the item.
--- The item is loaded from the given snapshot (which should be saved
--- in the user code before any templates are applied).
-teaserField :: String -- ^ Key to use
- -> Snapshot -- ^ Snapshot to load
- -> Context String -- ^ Resulting context
-teaserField = teaserFieldWithSeparator teaserSeparator
-
-
---------------------------------------------------------------------------------
--- | A context with "teaser" key which contain a teaser of the item, defined as
--- the snapshot content before the teaser separator. The item is loaded from the
--- given snapshot (which should be saved in the user code before any templates
--- are applied).
-teaserFieldWithSeparator :: String -- ^ Separator to use
- -> String -- ^ Key to use
- -> Snapshot -- ^ Snapshot to load
- -> Context String -- ^ Resulting context
-teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
- body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
- case needlePrefix separator body of
- Nothing -> fail $
- "Hakyll.Web.Template.Context: no teaser defined for " ++
- show (itemIdentifier item)
- Just t -> return t
-
-
---------------------------------------------------------------------------------
-missingField :: Context a
-missingField = Context $ \k _ i -> fail $
- "Missing field $" ++ k ++ "$ in context for item " ++
- show (itemIdentifier i)
-
-parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
-#if MIN_VERSION_time(1,5,0)
-parseTimeM = TF.parseTimeM
-#else
-parseTimeM _ = TF.parseTime
-#endif
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
deleted file mode 100644
index d0e4d47..0000000
--- a/src/Hakyll/Web/Template/Internal.hs
+++ /dev/null
@@ -1,203 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Hakyll.Web.Template.Internal
- ( Template (..)
- , template
- , templateBodyCompiler
- , templateCompiler
- , applyTemplate
- , applyTemplate'
- , loadAndApplyTemplate
- , applyAsTemplate
- , readTemplate
- , unsafeReadTemplateFile
-
- , module Hakyll.Web.Template.Internal.Element
- , module Hakyll.Web.Template.Internal.Trim
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Monad.Except (MonadError (..))
-import Data.Binary (Binary)
-import Data.List (intercalate)
-import Data.Typeable (Typeable)
-import GHC.Exts (IsString (..))
-import Prelude hiding (id)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-import Hakyll.Core.Writable
-import Hakyll.Web.Template.Context
-import Hakyll.Web.Template.Internal.Element
-import Hakyll.Web.Template.Internal.Trim
-
-
---------------------------------------------------------------------------------
--- | Datatype used for template substitutions.
-newtype Template = Template
- { unTemplate :: [TemplateElement]
- } deriving (Show, Eq, Binary, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Writable Template where
- -- Writing a template is impossible
- write _ _ = return ()
-
-
---------------------------------------------------------------------------------
-instance IsString Template where
- fromString = readTemplate
-
-
---------------------------------------------------------------------------------
--- | Wrap the constructor to ensure trim is called.
-template :: [TemplateElement] -> Template
-template = Template . trim
-
-
---------------------------------------------------------------------------------
-readTemplate :: String -> Template
-readTemplate = Template . trim . readTemplateElems
-
---------------------------------------------------------------------------------
--- | Read a template, without metadata header
-templateBodyCompiler :: Compiler (Item Template)
-templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do
- item <- getResourceBody
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
-
---------------------------------------------------------------------------------
--- | Read complete file contents as a template
-templateCompiler :: Compiler (Item Template)
-templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do
- item <- getResourceString
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
-
-
---------------------------------------------------------------------------------
-applyTemplate :: Template -- ^ Template
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler (Item String) -- ^ Resulting item
-applyTemplate tpl context item = do
- body <- applyTemplate' (unTemplate tpl) context item
- return $ itemSetBody body item
-
-
---------------------------------------------------------------------------------
-applyTemplate'
- :: forall a.
- [TemplateElement] -- ^ Unwrapped Template
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler String -- ^ Resulting item
-applyTemplate' tes context x = go tes
- where
- context' :: String -> [String] -> Item a -> Compiler ContextField
- context' = unContext (context `mappend` missingField)
-
- go = fmap concat . mapM applyElem
-
- trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++
- "fully trimmed."
-
- ---------------------------------------------------------------------------
-
- applyElem :: TemplateElement -> Compiler String
-
- applyElem TrimL = trimError
-
- applyElem TrimR = trimError
-
- applyElem (Chunk c) = return c
-
- applyElem (Expr e) = applyExpr e >>= getString e
-
- applyElem Escaped = return "$"
-
- applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
- where
- handler _ = case mf of
- Nothing -> return ""
- Just f -> go f
-
- applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
- StringField _ -> fail $
- "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
- "got StringField for expr " ++ show e
- ListField c xs -> do
- sep <- maybe (return "") go s
- bs <- mapM (applyTemplate' b c) xs
- return $ intercalate sep bs
-
- applyElem (Partial e) = do
- p <- applyExpr e >>= getString e
- Template tpl' <- loadBody (fromFilePath p)
- applyTemplate' tpl' context x
-
- ---------------------------------------------------------------------------
-
- applyExpr :: TemplateExpr -> Compiler ContextField
-
- applyExpr (Ident (TemplateKey k)) = context' k [] x
-
- applyExpr (Call (TemplateKey k) args) = do
- args' <- mapM (\e -> applyExpr e >>= getString e) args
- context' k args' x
-
- applyExpr (StringLiteral s) = return (StringField s)
-
- ----------------------------------------------------------------------------
-
- getString _ (StringField s) = return s
- getString e (ListField _ _) = fail $
- "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
- "got ListField for expr " ++ show e
-
-
---------------------------------------------------------------------------------
--- | The following pattern is so common:
---
--- > tpl <- loadBody "templates/foo.html"
--- > someCompiler
--- > >>= applyTemplate tpl context
---
--- That we have a single function which does this:
---
--- > someCompiler
--- > >>= loadAndApplyTemplate "templates/foo.html" context
-loadAndApplyTemplate :: Identifier -- ^ Template identifier
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler (Item String) -- ^ Resulting item
-loadAndApplyTemplate identifier context item = do
- tpl <- loadBody identifier
- applyTemplate tpl context item
-
-
---------------------------------------------------------------------------------
--- | It is also possible that you want to substitute @$key$@s within the body of
--- an item. This function does that by interpreting the item body as a template,
--- and then applying it to itself.
-applyAsTemplate :: Context String -- ^ Context
- -> Item String -- ^ Item and template
- -> Compiler (Item String) -- ^ Resulting item
-applyAsTemplate context item =
- let tpl = template $ readTemplateElemsFile file (itemBody item)
- file = toFilePath $ itemIdentifier item
- in applyTemplate tpl context item
-
-
---------------------------------------------------------------------------------
-unsafeReadTemplateFile :: FilePath -> Compiler Template
-unsafeReadTemplateFile file = do
- tpl <- unsafeCompiler $ readFile file
- pure $ template $ readTemplateElemsFile file tpl
-
diff --git a/src/Hakyll/Web/Template/Internal/Element.hs b/src/Hakyll/Web/Template/Internal/Element.hs
deleted file mode 100644
index f564355..0000000
--- a/src/Hakyll/Web/Template/Internal/Element.hs
+++ /dev/null
@@ -1,298 +0,0 @@
---------------------------------------------------------------------------------
--- | Module containing the elements used in a template. A template is generally
--- just a list of these elements.
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Hakyll.Web.Template.Internal.Element
- ( TemplateKey (..)
- , TemplateExpr (..)
- , TemplateElement (..)
- , templateElems
- , readTemplateElems
- , readTemplateElemsFile
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Applicative ((<|>))
-import Control.Monad (void)
-import Data.Binary (Binary, get, getWord8, put, putWord8)
-import Data.List (intercalate)
-import Data.Maybe (isJust)
-import Data.Typeable (Typeable)
-import GHC.Exts (IsString (..))
-import qualified Text.Parsec as P
-import qualified Text.Parsec.String as P
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Util.Parser
-
-
---------------------------------------------------------------------------------
-newtype TemplateKey = TemplateKey String
- deriving (Binary, Show, Eq, Typeable)
-
-
---------------------------------------------------------------------------------
-instance IsString TemplateKey where
- fromString = TemplateKey
-
-
---------------------------------------------------------------------------------
--- | Elements of a template.
-data TemplateElement
- = Chunk String
- | Expr TemplateExpr
- | Escaped
- -- expr, then, else
- | If TemplateExpr [TemplateElement] (Maybe [TemplateElement])
- -- expr, body, separator
- | For TemplateExpr [TemplateElement] (Maybe [TemplateElement])
- -- filename
- | Partial TemplateExpr
- | TrimL
- | TrimR
- deriving (Show, Eq, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Binary TemplateElement where
- put (Chunk string) = putWord8 0 >> put string
- put (Expr e) = putWord8 1 >> put e
- put Escaped = putWord8 2
- put (If e t f) = putWord8 3 >> put e >> put t >> put f
- put (For e b s) = putWord8 4 >> put e >> put b >> put s
- put (Partial e) = putWord8 5 >> put e
- put TrimL = putWord8 6
- put TrimR = putWord8 7
-
- get = getWord8 >>= \tag -> case tag of
- 0 -> Chunk <$> get
- 1 -> Expr <$> get
- 2 -> pure Escaped
- 3 -> If <$> get <*> get <*> get
- 4 -> For <$> get <*> get <*> get
- 5 -> Partial <$> get
- 6 -> pure TrimL
- 7 -> pure TrimR
- _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
-
-
---------------------------------------------------------------------------------
--- | Expression in a template
-data TemplateExpr
- = Ident TemplateKey
- | Call TemplateKey [TemplateExpr]
- | StringLiteral String
- deriving (Eq, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Show TemplateExpr where
- show (Ident (TemplateKey k)) = k
- show (Call (TemplateKey k) as) =
- k ++ "(" ++ intercalate ", " (map show as) ++ ")"
- show (StringLiteral s) = show s
-
-
---------------------------------------------------------------------------------
-instance Binary TemplateExpr where
- put (Ident k) = putWord8 0 >> put k
- put (Call k as) = putWord8 1 >> put k >> put as
- put (StringLiteral s) = putWord8 2 >> put s
-
- get = getWord8 >>= \tag -> case tag of
- 0 -> Ident <$> get
- 1 -> Call <$> get <*> get
- 2 -> StringLiteral <$> get
- _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
-
-
---------------------------------------------------------------------------------
-readTemplateElems :: String -> [TemplateElement]
-readTemplateElems = readTemplateElemsFile "{literal}"
-
-
---------------------------------------------------------------------------------
-readTemplateElemsFile :: FilePath -> String -> [TemplateElement]
-readTemplateElemsFile file input = case P.parse templateElems file input of
- Left err -> error $ "Cannot parse template: " ++ show err
- Right t -> t
-
-
---------------------------------------------------------------------------------
-templateElems :: P.Parser [TemplateElement]
-templateElems = mconcat <$> P.many (P.choice [ lift chunk
- , lift escaped
- , conditional
- , for
- , partial
- , expr
- ])
- where lift = fmap (:[])
-
-
---------------------------------------------------------------------------------
-chunk :: P.Parser TemplateElement
-chunk = Chunk <$> P.many1 (P.noneOf "$")
-
-
---------------------------------------------------------------------------------
-expr :: P.Parser [TemplateElement]
-expr = P.try $ do
- trimLExpr <- trimOpen
- e <- expr'
- trimRExpr <- trimClose
- return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]
-
-
---------------------------------------------------------------------------------
-expr' :: P.Parser TemplateExpr
-expr' = stringLiteral <|> call <|> ident
-
-
---------------------------------------------------------------------------------
-escaped :: P.Parser TemplateElement
-escaped = Escaped <$ P.try (P.string "$$")
-
-
---------------------------------------------------------------------------------
-trimOpen :: P.Parser Bool
-trimOpen = do
- void $ P.char '$'
- trimLIf <- P.optionMaybe $ P.try (P.char '-')
- pure $ isJust trimLIf
-
-
---------------------------------------------------------------------------------
-trimClose :: P.Parser Bool
-trimClose = do
- trimIfR <- P.optionMaybe $ P.try (P.char '-')
- void $ P.char '$'
- pure $ isJust trimIfR
-
-
---------------------------------------------------------------------------------
-conditional :: P.Parser [TemplateElement]
-conditional = P.try $ do
- -- if
- trimLIf <- trimOpen
- void $ P.string "if("
- e <- expr'
- void $ P.char ')'
- trimRIf <- trimClose
- -- then
- thenBranch <- templateElems
- -- else
- elseParse <- opt "else"
- -- endif
- trimLEnd <- trimOpen
- void $ P.string "endif"
- trimREnd <- trimClose
-
- -- As else is optional we need to sort out where any Trim_s need to go.
- let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse
- where thenNoElse =
- [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]
-
- thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)
- where thenB = [TrimR | trimRIf]
- ++ thenBranch
- ++ [TrimL | trimLElse]
-
- elseB = Just $ [TrimR | trimRElse]
- ++ elseBranch
- ++ [TrimL | trimLEnd]
-
- pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]
-
-
---------------------------------------------------------------------------------
-for :: P.Parser [TemplateElement]
-for = P.try $ do
- -- for
- trimLFor <- trimOpen
- void $ P.string "for("
- e <- expr'
- void $ P.char ')'
- trimRFor <- trimClose
- -- body
- bodyBranch <- templateElems
- -- sep
- sepParse <- opt "sep"
- -- endfor
- trimLEnd <- trimOpen
- void $ P.string "endfor"
- trimREnd <- trimClose
-
- -- As sep is optional we need to sort out where any Trim_s need to go.
- let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse
- where forNoSep =
- [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]
-
- forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)
- where forB = [TrimR | trimRFor]
- ++ bodyBranch
- ++ [TrimL | trimLSep]
-
- sepB = Just $ [TrimR | trimRSep]
- ++ sepBranch
- ++ [TrimL | trimLEnd]
-
- pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]
-
-
---------------------------------------------------------------------------------
-partial :: P.Parser [TemplateElement]
-partial = P.try $ do
- trimLPart <- trimOpen
- void $ P.string "partial("
- e <- expr'
- void $ P.char ')'
- trimRPart <- trimClose
-
- pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]
-
-
---------------------------------------------------------------------------------
-ident :: P.Parser TemplateExpr
-ident = P.try $ Ident <$> key
-
-
---------------------------------------------------------------------------------
-call :: P.Parser TemplateExpr
-call = P.try $ do
- f <- key
- void $ P.char '('
- P.spaces
- as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)
- P.spaces
- void $ P.char ')'
- return $ Call f as
-
-
---------------------------------------------------------------------------------
-stringLiteral :: P.Parser TemplateExpr
-stringLiteral = do
- void $ P.char '\"'
- str <- P.many $ do
- x <- P.noneOf "\""
- if x == '\\' then P.anyChar else return x
- void $ P.char '\"'
- return $ StringLiteral str
-
-
---------------------------------------------------------------------------------
-key :: P.Parser TemplateKey
-key = TemplateKey <$> metadataKey
-
-
---------------------------------------------------------------------------------
-opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))
-opt clause = P.optionMaybe $ P.try $ do
- trimL <- trimOpen
- void $ P.string clause
- trimR <- trimClose
- branch <- templateElems
- pure (trimL, branch, trimR)
-
diff --git a/src/Hakyll/Web/Template/Internal/Trim.hs b/src/Hakyll/Web/Template/Internal/Trim.hs
deleted file mode 100644
index e416ff2..0000000
--- a/src/Hakyll/Web/Template/Internal/Trim.hs
+++ /dev/null
@@ -1,95 +0,0 @@
---------------------------------------------------------------------------------
--- | Module for trimming whitespace from tempaltes.
-module Hakyll.Web.Template.Internal.Trim
- ( trim
- ) where
-
-
---------------------------------------------------------------------------------
-import Data.Char (isSpace)
-import Data.List (dropWhileEnd)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Web.Template.Internal.Element
-
-
---------------------------------------------------------------------------------
-trim :: [TemplateElement] -> [TemplateElement]
-trim = cleanse . canonicalize
-
-
---------------------------------------------------------------------------------
--- | Apply the Trim nodes to the Chunks.
-cleanse :: [TemplateElement] -> [TemplateElement]
-cleanse = recurse cleanse . process
- where process [] = []
- process (TrimR:Chunk str:ts) = let str' = dropWhile isSpace str
- in if null str'
- then process ts
- -- Might need to TrimL.
- else process $ Chunk str':ts
-
- process (Chunk str:TrimL:ts) = let str' = dropWhileEnd isSpace str
- in if null str'
- then process ts
- else Chunk str':process ts
-
- process (t:ts) = t:process ts
-
---------------------------------------------------------------------------------
--- | Enforce the invariant that:
---
--- * Every 'TrimL' has a 'Chunk' to its left.
--- * Every 'TrimR' has a 'Chunk' to its right.
---
-canonicalize :: [TemplateElement] -> [TemplateElement]
-canonicalize = go
- where go t = let t' = redundant . swap $ dedupe t
- in if t == t' then t else go t'
-
-
---------------------------------------------------------------------------------
--- | Remove the 'TrimR' and 'TrimL's that are no-ops.
-redundant :: [TemplateElement] -> [TemplateElement]
-redundant = recurse redundant . process
- where -- Remove the leading 'TrimL's.
- process (TrimL:ts) = process ts
- -- Remove trailing 'TrimR's.
- process ts = foldr trailing [] ts
- where trailing TrimR [] = []
- trailing x xs = x:xs
-
-
---------------------------------------------------------------------------------
--- >>> swap $ [TrimR, TrimL]
--- [TrimL, TrimR]
-swap :: [TemplateElement] -> [TemplateElement]
-swap = recurse swap . process
- where process [] = []
- process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts)
- process (t:ts) = t:process ts
-
-
---------------------------------------------------------------------------------
--- | Remove 'TrimR' and 'TrimL' duplication.
-dedupe :: [TemplateElement] -> [TemplateElement]
-dedupe = recurse dedupe . process
- where process [] = []
- process (TrimR:TrimR:ts) = process (TrimR:ts)
- process (TrimL:TrimL:ts) = process (TrimL:ts)
- process (t:ts) = t:process ts
-
-
---------------------------------------------------------------------------------
--- | @'recurse' f t@ applies f to every '[TemplateElement]' in t.
-recurse :: ([TemplateElement] -> [TemplateElement])
- -> [TemplateElement]
- -> [TemplateElement]
-recurse _ [] = []
-recurse f (x:xs) = process x:recurse f xs
- where process y = case y of
- If e tb eb -> If e (f tb) (f <$> eb)
- For e t s -> For e (f t) (f <$> s)
- _ -> y
-
diff --git a/src/Hakyll/Web/Template/List.hs b/src/Hakyll/Web/Template/List.hs
deleted file mode 100644
index 4d769fc..0000000
--- a/src/Hakyll/Web/Template/List.hs
+++ /dev/null
@@ -1,91 +0,0 @@
---------------------------------------------------------------------------------
--- | Provides an easy way to combine several items in a list. The applications
--- are obvious:
---
--- * A post list on a blog
---
--- * An image list in a gallery
---
--- * A sitemap
-{-# LANGUAGE TupleSections #-}
-module Hakyll.Web.Template.List
- ( applyTemplateList
- , applyJoinTemplateList
- , chronological
- , recentFirst
- , sortChronological
- , sortRecentFirst
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Monad (liftM)
-import Data.List (intersperse, sortBy)
-import Data.Ord (comparing)
-import Data.Time.Locale.Compat (defaultTimeLocale)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-import Hakyll.Core.Metadata
-import Hakyll.Web.Template
-import Hakyll.Web.Template.Context
-
-
---------------------------------------------------------------------------------
--- | Generate a string of a listing of pages, after applying a template to each
--- page.
-applyTemplateList :: Template
- -> Context a
- -> [Item a]
- -> Compiler String
-applyTemplateList = applyJoinTemplateList ""
-
-
---------------------------------------------------------------------------------
--- | Join a listing of pages with a string in between, after applying a template
--- to each page.
-applyJoinTemplateList :: String
- -> Template
- -> Context a
- -> [Item a]
- -> Compiler String
-applyJoinTemplateList delimiter tpl context items = do
- items' <- mapM (applyTemplate tpl context) items
- return $ concat $ intersperse delimiter $ map itemBody items'
-
-
---------------------------------------------------------------------------------
--- | Sort pages chronologically. Uses the same method as 'dateField' for
--- extracting the date.
-chronological :: MonadMetadata m => [Item a] -> m [Item a]
-chronological =
- sortByM $ getItemUTC defaultTimeLocale . itemIdentifier
- where
- sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]
- sortByM f xs = liftM (map fst . sortBy (comparing snd)) $
- mapM (\x -> liftM (x,) (f x)) xs
-
-
---------------------------------------------------------------------------------
--- | The reverse of 'chronological'
-recentFirst :: MonadMetadata m => [Item a] -> m [Item a]
-recentFirst = liftM reverse . chronological
-
-
---------------------------------------------------------------------------------
--- | Version of 'chronological' which doesn't need the actual items.
-sortChronological
- :: MonadMetadata m => [Identifier] -> m [Identifier]
-sortChronological ids =
- liftM (map itemIdentifier) $ chronological [Item i () | i <- ids]
-
-
---------------------------------------------------------------------------------
--- | Version of 'recentFirst' which doesn't need the actual items.
-sortRecentFirst
- :: MonadMetadata m => [Identifier] -> m [Identifier]
-sortRecentFirst ids =
- liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 05:02:34 +0000