1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{- |
4   Module      : Text.DocTemplates.Parser
5   Copyright   : Copyright (C) 2009-2019 John MacFarlane
6   License     : BSD3
7
8   Maintainer  : John MacFarlane <jgm@berkeley.edu>
9   Stability   : alpha
10   Portability : portable
11-}
12
13module Text.DocTemplates.Parser
14    ( compileTemplate ) where
15
16import Data.Char (isAlphaNum)
17import Control.Monad (guard, when)
18import Control.Monad.Trans (lift)
19import qualified Text.Parsec as P
20import qualified Text.Parsec.Pos as P
21import Control.Applicative
22import Data.String (IsString(..))
23import Data.Text (Text)
24import qualified Data.Text as T
25import qualified Data.Text.Read as T
26import System.FilePath
27import Text.DocTemplates.Internal
28import qualified Text.DocLayout as DL
29#if MIN_VERSION_base(4,11,0)
30#else
31import Data.Semigroup ((<>), Semigroup)
32#endif
33
34-- | Compile a template.  The FilePath parameter is used
35-- to determine a default path and extension for partials
36-- and may be left empty if partials are not used.
37compileTemplate :: (TemplateMonad m, TemplateTarget a)
38                => FilePath -> Text -> m (Either String (Template a))
39compileTemplate templPath template = do
40  res <- P.runParserT (pTemplate <* P.eof)
41           PState{ templatePath    = templPath
42                 , partialNesting  = 1
43                 , breakingSpaces  = False
44                 , firstNonspace   = P.initialPos templPath
45                 , nestedCol       = Nothing
46                 , insideDirective = False
47                 } templPath template
48  case res of
49       Left e   -> return $ Left $ show e
50       Right x  -> return $ Right x
51
52
53data PState =
54  PState { templatePath    :: FilePath
55         , partialNesting  :: !Int
56         , breakingSpaces  :: !Bool
57         , firstNonspace   :: P.SourcePos
58         , nestedCol       :: Maybe Int
59         , insideDirective :: Bool
60         }
61
62type Parser = P.ParsecT Text PState
63
64pTemplate :: (TemplateMonad m, TemplateTarget a) => Parser m (Template a)
65pTemplate = do
66  P.skipMany pComment
67  mconcat <$> many
68    ((pLit <|> pNewline <|> pDirective <|>
69      pEscape) <* P.skipMany pComment)
70
71pEndline :: Monad m => Parser m String
72pEndline = P.try $ do
73  nls <- pLineEnding
74  mbNested <- nestedCol <$> P.getState
75  inside <- insideDirective <$> P.getState
76  case mbNested of
77    Just col -> do
78      P.skipMany $ do
79        P.getPosition >>= guard . (< col) . P.sourceColumn
80        P.char ' ' <|> P.char '\t'
81      curcol <- P.sourceColumn <$> P.getPosition
82      guard $ inside || curcol >= col
83    Nothing  ->  return ()
84  return nls
85
86pBlankLine :: (TemplateTarget a, Monad m) => Parser m (Template a)
87pBlankLine =
88  P.try $ Literal . fromString <$> pLineEnding <* P.lookAhead pNewlineOrEof
89
90pNewline :: (TemplateTarget a, Monad m) => Parser m (Template a)
91pNewline = P.try $ do
92  nls <- pEndline
93  sps <- P.many (P.char ' ' <|> P.char '\t')
94  breakspaces <- breakingSpaces <$> P.getState
95  pos <- P.getPosition
96  P.updateState $ \st -> st{ firstNonspace = pos }
97  return $ Literal $
98    if breakspaces
99       then DL.BreakingSpace
100       else fromString $ nls <> sps
101
102pLit :: (TemplateTarget a, Monad m) => Parser m (Template a)
103pLit = do
104  cs <- P.many1 (P.satisfy (\c -> c /= '$' && c /= '\n' && c /= '\r'))
105  when (all (\c -> c == ' ' || c == '\t') cs) $ do
106     pos <- P.getPosition
107     when (P.sourceLine pos == 1) $
108       P.updateState $ \st -> st{ firstNonspace = pos }
109  breakspaces <- breakingSpaces <$> P.getState
110  if breakspaces
111     then return $ toBreakable cs
112     else return $ Literal $ fromString cs
113
114toBreakable :: TemplateTarget a => String -> Template a
115toBreakable [] = Empty
116toBreakable xs =
117  case break isSpacy xs of
118    ([], []) -> Empty
119    ([], zs) -> Literal DL.BreakingSpace <>
120                   toBreakable (dropWhile isSpacy zs)
121    (ys, []) -> Literal (fromString ys)
122    (ys, zs) -> Literal (fromString ys) <> toBreakable zs
123
124isSpacy :: Char -> Bool
125isSpacy ' '  = True
126isSpacy '\n' = True
127isSpacy '\r' = True
128isSpacy '\t' = True
129isSpacy _    = False
130
131backupSourcePos :: Monad m => Int -> Parser m ()
132backupSourcePos n = do
133  pos <- P.getPosition
134  P.setPosition $ P.incSourceColumn pos (- n)
135
136pEscape :: (TemplateTarget a, Monad m) => Parser m (Template a)
137pEscape = Literal "$" <$ P.try (P.string "$$" <* backupSourcePos 1)
138
139pDirective :: (TemplateTarget a, TemplateMonad m)
140           => Parser m (Template a)
141pDirective =
142  pConditional <|> pForLoop <|> pReflowToggle <|> pNested <|>
143  pInterpolate <|> pBarePartial
144
145pEnclosed :: Monad m => Parser m a -> Parser m a
146pEnclosed parser = P.try $ do
147  closer <- pOpen
148  P.skipMany pSpaceOrTab
149  result <- parser
150  P.skipMany pSpaceOrTab
151  closer
152  return result
153
154pParens :: Monad m => Parser m a -> Parser m a
155pParens parser = do
156  P.char '('
157  result <- parser
158  P.char ')'
159  return result
160
161pInside :: Monad m
162        => Parser m (Template a)
163        -> Parser m (Template a)
164pInside parser = do
165  oldInside <- insideDirective <$> P.getState
166  P.updateState $ \st -> st{ insideDirective = True }
167  res <- parser
168  P.updateState $ \st -> st{ insideDirective = oldInside }
169  return res
170
171pConditional :: (TemplateTarget a, TemplateMonad m)
172             => Parser m (Template a)
173pConditional = do
174  v <- pEnclosed $ P.try $ P.string "if" *> pParens pVar
175  pInside $ do
176    multiline <- P.option False (True <$ skipEndline)
177    -- if newline after the "if", then a newline after "endif" will be swallowed
178    ifContents <- pTemplate
179    elseContents <- P.option mempty (pElse multiline <|> pElseIf)
180    pEnclosed (P.string "endif")
181    when multiline $ P.option () skipEndline
182    return $ Conditional v ifContents elseContents
183
184pElse :: (TemplateTarget a, TemplateMonad m)
185      => Bool -> Parser m (Template a)
186pElse multiline = do
187  pEnclosed (P.string "else")
188  when multiline $ P.option () skipEndline
189  pTemplate
190
191pElseIf :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
192pElseIf = do
193  v <- pEnclosed $ P.try $ P.string "elseif" *> pParens pVar
194  multiline <- P.option False (True <$ skipEndline)
195  ifContents <- pTemplate
196  elseContents <- P.option mempty (pElse multiline <|> pElseIf)
197  return $ Conditional v ifContents elseContents
198
199skipEndline :: Monad m => Parser m ()
200skipEndline = do
201  pEndline
202  pos <- P.lookAhead $ do
203           P.skipMany (P.char ' ' <|> P.char '\t')
204           P.getPosition
205  P.updateState $ \st -> st{ firstNonspace = pos }
206
207pReflowToggle :: (Monoid a, Semigroup a, TemplateMonad m)
208              => Parser m (Template a)
209pReflowToggle = do
210  pEnclosed $ P.char '~'
211  P.modifyState $ \st -> st{ breakingSpaces = not (breakingSpaces st) }
212  return mempty
213
214pNested :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
215pNested = do
216  col <- P.sourceColumn <$> P.getPosition
217  pEnclosed $ P.char '^'
218  oldNested <- nestedCol <$> P.getState
219  P.updateState $ \st -> st{ nestedCol = Just col }
220  x <- pTemplate
221  xs <- P.many $ P.try $ do
222          y <- mconcat <$> P.many1 pBlankLine
223          z <- pTemplate
224          return (y <> z)
225  let contents = x <> mconcat xs
226  P.updateState $ \st -> st{ nestedCol = oldNested }
227  return $ Nested contents
228
229pForLoop :: (TemplateTarget a, TemplateMonad m) => Parser m (Template a)
230pForLoop = do
231  v <- pEnclosed $ P.try $ P.string "for" *> pParens pVar
232  -- if newline after the "for", then a newline after "endfor" will be swallowed
233  pInside $ do
234    multiline <- P.option False $ skipEndline >> return True
235    contents <- pTemplate
236    sep <- P.option mempty $
237             do pEnclosed (P.string "sep")
238                when multiline $ P.option () skipEndline
239                pTemplate
240    pEnclosed (P.string "endfor")
241    when multiline $ P.option () skipEndline
242    return $ Iterate v contents sep
243
244pInterpolate :: (TemplateTarget a, TemplateMonad m)
245             => Parser m (Template a)
246pInterpolate = do
247  pos <- P.getPosition
248  -- we don't used pEnclosed here, to get better error messages:
249  (closer, var) <- P.try $ do
250    cl <- pOpen
251    P.skipMany pSpaceOrTab
252    v <- pVar
253    P.notFollowedBy (P.char '(') -- bare partial
254    return (cl, v)
255  res <- (P.char ':' *> (pPartialName >>= pPartial (Just var)))
256      <|> Iterate var (Interpolate (Variable ["it"] [])) <$> pSep
257      <|> return (Interpolate var)
258  P.skipMany pSpaceOrTab
259  closer
260  handleNesting False pos res
261
262pLineEnding :: Monad m => Parser m String
263pLineEnding = P.string "\n" <|> P.try (P.string "\r\n") <|> P.string "\r"
264
265pNewlineOrEof :: Monad m => Parser m ()
266pNewlineOrEof = () <$ pLineEnding <|> P.eof
267
268handleNesting :: TemplateMonad m
269              => Bool -> P.SourcePos -> Template a -> Parser m (Template a)
270handleNesting eatEndline pos templ = do
271  firstNonspacePos <- firstNonspace <$> P.getState
272  let beginline = firstNonspacePos == pos
273  endofline <- (True <$ P.lookAhead pNewlineOrEof) <|> pure False
274  when (eatEndline && beginline) $ P.optional skipEndline
275  mbNested <- nestedCol <$> P.getState
276  let toNested t@(Nested{}) = t
277      toNested t = case P.sourceColumn pos of
278                     1 -> t
279                     n | Just n == mbNested -> t
280                       | otherwise          -> Nested t
281  return $ if beginline && endofline
282              then toNested templ
283              else templ
284
285pBarePartial :: (TemplateTarget a, TemplateMonad m)
286             => Parser m (Template a)
287pBarePartial = do
288  pos <- P.getPosition
289  (closer, fp) <- P.try $ do
290    closer <- pOpen
291    P.skipMany pSpaceOrTab
292    fp <- pPartialName
293    return (closer, fp)
294  res <- pPartial Nothing fp
295  P.skipMany pSpaceOrTab
296  closer
297  handleNesting True pos res
298
299pPartialName :: TemplateMonad m
300             => Parser m FilePath
301pPartialName = P.try $ do
302  fp <- P.many1 (P.alphaNum <|> P.oneOf ['_','-','.','/','\\'])
303  P.string "()"
304  return fp
305
306pPartial :: (TemplateTarget a, TemplateMonad m)
307         => Maybe Variable -> FilePath -> Parser m (Template a)
308pPartial mbvar fp = do
309  oldst <- P.getState
310  separ <- P.option mempty pSep
311  tp <- templatePath <$> P.getState
312  let fp' = case takeExtension fp of
313               "" -> replaceBaseName tp fp
314               _  -> replaceFileName tp fp
315  partial <- lift $ removeFinalNewline <$> getPartial fp'
316  nesting <- partialNesting <$> P.getState
317  t <- if nesting > 50
318          then return $ Literal "(loop)"
319          else do
320            oldInput <- P.getInput
321            oldPos <- P.getPosition
322            P.setPosition $ P.initialPos fp'
323            P.setInput partial
324            P.updateState $ \st -> st{ partialNesting = nesting + 1 }
325            P.updateState $ \st -> st{ nestedCol = Nothing }
326            res' <- pTemplate <* P.eof
327            P.updateState $ \st -> st{ partialNesting = nesting }
328            P.setInput oldInput
329            P.setPosition oldPos
330            return res'
331  P.putState oldst
332  fs <- many pPipe
333  case mbvar of
334    Just var -> return $ Iterate var (Partial fs t) separ
335    Nothing  -> return $ Partial fs t
336
337removeFinalNewline :: Text -> Text
338removeFinalNewline t =
339  case T.unsnoc t of
340    Just (t', '\n') -> t'
341    _ -> t
342
343pSep :: (TemplateTarget a, Monad m) => Parser m (Template a)
344pSep = do
345    P.char '['
346    xs <- P.many (P.satisfy (/= ']'))
347    P.char ']'
348    return $ Literal (fromString xs)
349
350pSpaceOrTab :: Monad m => Parser m Char
351pSpaceOrTab = P.satisfy (\c -> c == ' ' || c == '\t')
352
353pComment :: Monad m => Parser m ()
354pComment = do
355  pos <- P.getPosition
356  P.try (P.string "$--")
357  P.skipMany (P.satisfy (/='\n'))
358  -- If the comment begins in the first column, the line ending
359  -- will be consumed; otherwise not.
360  when (P.sourceColumn pos == 1) $ () <$ pNewlineOrEof
361
362pOpenDollar :: Monad m => Parser m (Parser m ())
363pOpenDollar =
364  pCloseDollar <$ P.try (P.char '$' <*
365                   P.notFollowedBy (P.char '$' <|> P.char '{'))
366  where
367   pCloseDollar = () <$ P.char '$'
368
369pOpenBraces :: Monad m => Parser m (Parser m ())
370pOpenBraces =
371  pCloseBraces <$ P.try (P.string "${" <* P.notFollowedBy (P.char '}'))
372  where
373   pCloseBraces = () <$ P.try (P.char '}')
374
375pOpen :: Monad m => Parser m (Parser m ())
376pOpen = pOpenDollar <|> pOpenBraces
377
378pVar :: Monad m => Parser m Variable
379pVar = do
380  first <- pIdentPart <|> pIt
381  rest <- P.many (P.char '.' *> pIdentPart)
382  pipes <- P.many pPipe
383  return $ Variable (first:rest) pipes
384
385pPipe :: Monad m => Parser m Pipe
386pPipe = do
387  P.char '/'
388  pipeName <- P.many1 P.letter
389  P.notFollowedBy P.letter
390  case pipeName of
391    "uppercase"  -> return ToUppercase
392    "lowercase"  -> return ToLowercase
393    "pairs"      -> return ToPairs
394    "length"     -> return ToLength
395    "alpha"      -> return ToAlpha
396    "roman"      -> return ToRoman
397    "reverse"    -> return Reverse
398    "first"      -> return FirstItem
399    "rest"       -> return Rest
400    "last"       -> return LastItem
401    "allbutlast" -> return AllButLast
402    "chomp"      -> return Chomp
403    "nowrap"     -> return NoWrap
404    "left"       -> Block LeftAligned <$> pBlockWidth <*> pBlockBorders
405    "right"      -> Block RightAligned <$> pBlockWidth <*> pBlockBorders
406    "center"     -> Block Centered <$> pBlockWidth <*> pBlockBorders
407    _            -> fail $ "Unknown pipe " ++ pipeName
408
409pBlockWidth :: Monad m => Parser m Int
410pBlockWidth = P.try (do
411  _ <- P.many1 P.space
412  ds <- P.many1 P.digit
413  case T.decimal (T.pack ds) of
414        Right (n,"") -> return n
415        _            -> fail "Expected integer parameter for pipe") P.<?>
416          "integer parameter for pipe"
417
418pBlockBorders :: Monad m => Parser m Border
419pBlockBorders = do
420  P.skipMany P.space
421  let pBorder = do
422        P.char '"'
423        cs <- P.many $ (P.noneOf ['"','\\']) <|> (P.char '\\' >> P.anyChar)
424        P.char '"'
425        P.skipMany P.space
426        return $ T.pack cs
427  Border <$> P.option mempty pBorder <*> P.option mempty pBorder
428
429pIt :: Monad m => Parser m Text
430pIt = fromString <$> P.try (P.string "it")
431
432pIdentPart :: Monad m => Parser m Text
433pIdentPart = P.try $ do
434  first <- P.letter
435  rest <- P.many (P.satisfy (\c -> isAlphaNum c || c == '_' || c == '-'))
436  let part = first : rest
437  guard $ part `notElem` reservedWords
438  return $ fromString part
439
440reservedWords :: [String]
441reservedWords = ["if","else","endif","elseif","for","endfor","sep","it"]
442