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