@@ -1,297 +1,203 @@
1−--------------------------------------------------------------------------------
2−-- | Module containing the template data structure
31{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
43module Hakyll.Web.Template.Internal
5− ( TemplateKey (..)
6− , TemplateExpr (..)
7− , TemplateElement (..)
8− , templateElems
9− , readTemplateElems
10− , readTemplateElemsFile
4+ ( Template (..)
5+ , template
6+ , templateBodyCompiler
7+ , templateCompiler
8+ , applyTemplate
9+ , applyTemplate'
10+ , loadAndApplyTemplate
11+ , applyAsTemplate
12+ , readTemplate
13+ , unsafeReadTemplateFile
14+
15+ , module Hakyll.Web.Template.Internal.Element
16+ , module Hakyll.Web.Template.Internal.Trim
1117 ) where
1218
1319
1420--------------------------------------------------------------------------------
15−import Control.Applicative ((<|>))
16−import Control.Monad (void)
17−import Data.Binary (Binary, get, getWord8, put, putWord8)
18−import Data.List (intercalate)
19−import Data.Maybe (isJust)
20−import Data.Typeable (Typeable)
21−import GHC.Exts (IsString (..))
22−import qualified Text.Parsec as P
23−import qualified Text.Parsec.String as P
24−
25−
26−--------------------------------------------------------------------------------
27−import Hakyll.Core.Util.Parser
21+import Control.Monad.Except (MonadError (..))
22+import Data.Binary (Binary)
23+import Data.List (intercalate)
24+import Data.Typeable (Typeable)
25+import GHC.Exts (IsString (..))
26+import Prelude hiding (id)
2827
2928
3029--------------------------------------------------------------------------------
31−newtype TemplateKey = TemplateKey String
32− deriving (Binary, Show, Eq, Typeable)
30+import Hakyll.Core.Compiler
31+import Hakyll.Core.Identifier
32+import Hakyll.Core.Item
33+import Hakyll.Core.Writable
34+import Hakyll.Web.Template.Context
35+import Hakyll.Web.Template.Internal.Element
36+import Hakyll.Web.Template.Internal.Trim
3337
3438
3539--------------------------------------------------------------------------------
36−instance IsString TemplateKey where
37− fromString = TemplateKey
40+-- | Datatype used for template substitutions.
41+newtype Template = Template
42+ { unTemplate :: [TemplateElement]
43+ } deriving (Show, Eq, Binary, Typeable)
3844
3945
4046--------------------------------------------------------------------------------
41−-- | Elements of a template.
42−data TemplateElement
43− = Chunk String
44− | Expr TemplateExpr
45− | Escaped
46− -- expr, then, else
47− | If TemplateExpr [TemplateElement] (Maybe [TemplateElement])
48− -- expr, body, separator
49− | For TemplateExpr [TemplateElement] (Maybe [TemplateElement])
50− -- filename
51− | Partial TemplateExpr
52− | TrimL
53− | TrimR
54− deriving (Show, Eq, Typeable)
47+instance Writable Template where
48+ -- Writing a template is impossible
49+ write _ _ = return ()
5550
5651
5752--------------------------------------------------------------------------------
58−instance Binary TemplateElement where
59− put (Chunk string) = putWord8 0 >> put string
60− put (Expr e) = putWord8 1 >> put e
61− put Escaped = putWord8 2
62− put (If e t f) = putWord8 3 >> put e >> put t >> put f
63− put (For e b s) = putWord8 4 >> put e >> put b >> put s
64− put (Partial e) = putWord8 5 >> put e
65− put TrimL = putWord8 6
66− put TrimR = putWord8 7
67−
68− get = getWord8 >>= \tag -> case tag of
69− 0 -> Chunk <$> get
70− 1 -> Expr <$> get
71− 2 -> pure Escaped
72− 3 -> If <$> get <*> get <*> get
73− 4 -> For <$> get <*> get <*> get
74− 5 -> Partial <$> get
75− 6 -> pure TrimL
76− 7 -> pure TrimR
77− _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
53+instance IsString Template where
54+ fromString = readTemplate
7855
7956
8057--------------------------------------------------------------------------------
81−-- | Expression in a template
82−data TemplateExpr
83− = Ident TemplateKey
84− | Call TemplateKey [TemplateExpr]
85− | StringLiteral String
86− deriving (Eq, Typeable)
87−
88−
89−--------------------------------------------------------------------------------
90−instance Show TemplateExpr where
91− show (Ident (TemplateKey k)) = k
92− show (Call (TemplateKey k) as) =
93− k ++ "(" ++ intercalate ", " (map show as) ++ ")"
94− show (StringLiteral s) = show s
95−
96−
97−--------------------------------------------------------------------------------
98−instance Binary TemplateExpr where
99− put (Ident k) = putWord8 0 >> put k
100− put (Call k as) = putWord8 1 >> put k >> put as
101− put (StringLiteral s) = putWord8 2 >> put s
102−
103− get = getWord8 >>= \tag -> case tag of
104− 0 -> Ident <$> get
105− 1 -> Call <$> get <*> get
106− 2 -> StringLiteral <$> get
107− _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
58+-- | Wrap the constructor to ensure trim is called.
59+template :: [TemplateElement] -> Template
60+template = Template . trim
10861
10962
11063--------------------------------------------------------------------------------
111−readTemplateElems :: String -> [TemplateElement]
112−readTemplateElems = readTemplateElemsFile "{literal}"
113−
64+readTemplate :: String -> Template
65+readTemplate = Template . trim . readTemplateElems
11466
11567--------------------------------------------------------------------------------
116−readTemplateElemsFile :: FilePath -> String -> [TemplateElement]
117−readTemplateElemsFile file input = case P.parse templateElems file input of
118− Left err -> error $ "Cannot parse template: " ++ show err
119− Right t -> t
120−
68+-- | Read a template, without metadata header
69+templateBodyCompiler :: Compiler (Item Template)
70+templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do
71+ item <- getResourceBody
72+ file <- getResourceFilePath
73+ return $ fmap (template . readTemplateElemsFile file) item
12174
12275--------------------------------------------------------------------------------
123−templateElems :: P.Parser [TemplateElement]
124−templateElems = mconcat <$> P.many (P.choice [ lift chunk
125− , lift escaped
126− , conditional
127− , for
128− , partial
129− , expr
130− ])
131− where lift = fmap (:[])
76+-- | Read complete file contents as a template
77+templateCompiler :: Compiler (Item Template)
78+templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do
79+ item <- getResourceString
80+ file <- getResourceFilePath
81+ return $ fmap (template . readTemplateElemsFile file) item
13282
13383
13484--------------------------------------------------------------------------------
135−chunk :: P.Parser TemplateElement
136−chunk = Chunk <$> P.many1 (P.noneOf "$")
85+applyTemplate :: Template -- ^ Template
86+ -> Context a -- ^ Context
87+ -> Item a -- ^ Page
88+ -> Compiler (Item String) -- ^ Resulting item
89+applyTemplate tpl context item = do
90+ body <- applyTemplate' (unTemplate tpl) context item
91+ return $ itemSetBody body item
13792
13893
13994--------------------------------------------------------------------------------
140−expr :: P.Parser [TemplateElement]
141−expr = P.try $ do
142− trimLExpr <- trimOpen
143− e <- expr'
144− trimRExpr <- trimClose
145− return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]
95+applyTemplate'
96+ :: forall a.
97+ [TemplateElement] -- ^ Unwrapped Template
98+ -> Context a -- ^ Context
99+ -> Item a -- ^ Page
100+ -> Compiler String -- ^ Resulting item
101+applyTemplate' tes context x = go tes
102+ where
103+ context' :: String -> [String] -> Item a -> Compiler ContextField
104+ context' = unContext (context `mappend` missingField)
146105
106+ go = fmap concat . mapM applyElem
147107
148−--------------------------------------------------------------------------------
149−expr' :: P.Parser TemplateExpr
150−expr' = stringLiteral <|> call <|> ident
108+ trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++
109+ "fully trimmed."
151110
111+ ---------------------------------------------------------------------------
152112
153−--------------------------------------------------------------------------------
154−escaped :: P.Parser TemplateElement
155−escaped = Escaped <$ P.try (P.string "$$")
113+ applyElem :: TemplateElement -> Compiler String
156114
115+ applyElem TrimL = trimError
157116
158−--------------------------------------------------------------------------------
159−trimOpen :: P.Parser Bool
160−trimOpen = do
161− void $ P.char '$'
162− trimLIf <- P.optionMaybe $ P.try (P.char '-')
163− pure $ isJust trimLIf
117+ applyElem TrimR = trimError
164118
119+ applyElem (Chunk c) = return c
165120
166−--------------------------------------------------------------------------------
167−trimClose :: P.Parser Bool
168−trimClose = do
169− trimIfR <- P.optionMaybe $ P.try (P.char '-')
170− void $ P.char '$'
171− pure $ isJust trimIfR
121+ applyElem (Expr e) = applyExpr e >>= getString e
172122
123+ applyElem Escaped = return "$"
173124
174−--------------------------------------------------------------------------------
175−conditional :: P.Parser [TemplateElement]
176−conditional = P.try $ do
177− -- if
178− trimLIf <- trimOpen
179− void $ P.string "if("
180− e <- expr'
181− void $ P.char ')'
182− trimRIf <- trimClose
183− -- then
184− thenBranch <- templateElems
185− -- else
186− elseParse <- opt "else"
187− -- endif
188− trimLEnd <- trimOpen
189− void $ P.string "endif"
190− trimREnd <- trimClose
191−
192− -- As else is optional we need to sort out where any Trim_s need to go.
193− let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse
194− where thenNoElse =
195− [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]
196−
197− thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)
198− where thenB = [TrimR | trimRIf]
199− ++ thenBranch
200− ++ [TrimL | trimLElse]
201−
202− elseB = Just $ [TrimR | trimRElse]
203− ++ elseBranch
204− ++ [TrimL | trimLEnd]
205−
206− pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]
125+ applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
126+ where
127+ handler _ = case mf of
128+ Nothing -> return ""
129+ Just f -> go f
207130
131+ applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
132+ StringField _ -> fail $
133+ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
134+ "got StringField for expr " ++ show e
135+ ListField c xs -> do
136+ sep <- maybe (return "") go s
137+ bs <- mapM (applyTemplate' b c) xs
138+ return $ intercalate sep bs
208139
209−--------------------------------------------------------------------------------
210−for :: P.Parser [TemplateElement]
211−for = P.try $ do
212− -- for
213− trimLFor <- trimOpen
214− void $ P.string "for("
215− e <- expr'
216− void $ P.char ')'
217− trimRFor <- trimClose
218− -- body
219− bodyBranch <- templateElems
220− -- sep
221− sepParse <- opt "sep"
222− -- endfor
223− trimLEnd <- trimOpen
224− void $ P.string "endfor"
225− trimREnd <- trimClose
226−
227− -- As sep is optional we need to sort out where any Trim_s need to go.
228− let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse
229− where forNoSep =
230− [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]
231−
232− forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)
233− where forB = [TrimR | trimRFor]
234− ++ bodyBranch
235− ++ [TrimL | trimLSep]
236−
237− sepB = Just $ [TrimR | trimRSep]
238− ++ sepBranch
239− ++ [TrimL | trimLEnd]
240−
241− pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]
140+ applyElem (Partial e) = do
141+ p <- applyExpr e >>= getString e
142+ tpl' <- loadBody (fromFilePath p)
143+ applyTemplate' tpl' context x
242144
145+ ---------------------------------------------------------------------------
243146
244−--------------------------------------------------------------------------------
245−partial :: P.Parser [TemplateElement]
246−partial = P.try $ do
247− trimLPart <- trimOpen
248− void $ P.string "partial("
249− e <- expr'
250− void $ P.char ')'
251− trimRPart <- trimClose
147+ applyExpr :: TemplateExpr -> Compiler ContextField
252148
253− pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]
149+ applyExpr (Ident (TemplateKey k)) = context' k [] x
254150
151+ applyExpr (Call (TemplateKey k) args) = do
152+ args' <- mapM (\e -> applyExpr e >>= getString e) args
153+ context' k args' x
255154
256−--------------------------------------------------------------------------------
257−ident :: P.Parser TemplateExpr
258−ident = P.try $ Ident <$> key
155+ applyExpr (StringLiteral s) = return (StringField s)
259156
157+ ----------------------------------------------------------------------------
260158
261−--------------------------------------------------------------------------------
262−call :: P.Parser TemplateExpr
263−call = P.try $ do
264− f <- key
265− void $ P.char '('
266− P.spaces
267− as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)
268− P.spaces
269− void $ P.char ')'
270− return $ Call f as
159+ getString _ (StringField s) = return s
160+ getString e (ListField _ _) = fail $
161+ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
162+ "got ListField for expr " ++ show e
271163
272164
273165--------------------------------------------------------------------------------
274−stringLiteral :: P.Parser TemplateExpr
275−stringLiteral = do
276− void $ P.char '\"'
277− str <- P.many $ do
278− x <- P.noneOf "\""
279− if x == '\\' then P.anyChar else return x
280− void $ P.char '\"'
281− return $ StringLiteral str
166+-- | The following pattern is so common:
167+--
168+-- > tpl <- loadBody "templates/foo.html"
169+-- > someCompiler
170+-- > >>= applyTemplate tpl context
171+--
172+-- That we have a single function which does this:
173+--
174+-- > someCompiler
175+-- > >>= loadAndApplyTemplate "templates/foo.html" context
176+loadAndApplyTemplate :: Identifier -- ^ Template identifier
177+ -> Context a -- ^ Context
178+ -> Item a -- ^ Page
179+ -> Compiler (Item String) -- ^ Resulting item
180+loadAndApplyTemplate identifier context item = do
181+ tpl <- loadBody identifier
182+ applyTemplate tpl context item
282183
283184
284185--------------------------------------------------------------------------------
285−key :: P.Parser TemplateKey
286−key = TemplateKey <$> metadataKey
186+-- | It is also possible that you want to substitute @$key$@s within the body of
187+-- an item. This function does that by interpreting the item body as a template,
188+-- and then applying it to itself.
189+applyAsTemplate :: Context String -- ^ Context
190+ -> Item String -- ^ Item and template
191+ -> Compiler (Item String) -- ^ Resulting item
192+applyAsTemplate context item =
193+ let tpl = template $ readTemplateElemsFile file (itemBody item)
194+ file = toFilePath $ itemIdentifier item
195+ in applyTemplate tpl context item
287196
288197
289198--------------------------------------------------------------------------------
290−opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))
291−opt clause = P.optionMaybe $ P.try $ do
292− trimL <- trimOpen
293− void $ P.string clause
294− trimR <- trimClose
295− branch <- templateElems
296− pure (trimL, branch, trimR)
199+unsafeReadTemplateFile :: FilePath -> Compiler Template
200+unsafeReadTemplateFile file = do
201+ tpl <- unsafeCompiler $ readFile file
202+ pure $ template $ readTemplateElemsFile file tpl
297203