1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE DeriveLift #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE TemplateHaskell #-} 6{-# LANGUAGE FlexibleInstances #-} 7module Text.Hamlet.Parse 8 ( Result (..) 9 , Content (..) 10 , Doc (..) 11 , parseDoc 12 , HamletSettings (..) 13 , defaultHamletSettings 14 , xhtmlHamletSettings 15 , CloseStyle (..) 16 , Binding (..) 17 , NewlineStyle (..) 18 , specialOrIdent 19 , DataConstr (..) 20 , Module (..) 21 ) 22 where 23 24import Text.Shakespeare.Base 25import Control.Applicative ((<$>), Applicative (..)) 26import Control.Monad 27import Control.Arrow 28import Data.Char (GeneralCategory(..), generalCategory, isUpper) 29import Data.Data 30import Text.ParserCombinators.Parsec hiding (Line) 31import Data.Set (Set) 32import qualified Data.Set as Set 33import Data.Maybe (mapMaybe, fromMaybe, isNothing) 34import Language.Haskell.TH.Syntax hiding (Module) 35 36data Result v = Error String | Ok v 37 deriving (Show, Eq, Read, Data, Typeable) 38instance Monad Result where 39 return = Ok 40 Error s >>= _ = Error s 41 Ok v >>= f = f v 42#if MIN_VERSION_base(4,13,0) 43instance MonadFail Result where 44 fail = Error 45#endif 46instance Functor Result where 47 fmap = liftM 48instance Applicative Result where 49 pure = return 50 (<*>) = ap 51 52data Content = ContentRaw String 53 | ContentVar Deref 54 | ContentUrl Bool Deref -- ^ bool: does it include params? 55 | ContentEmbed Deref 56 | ContentMsg Deref 57 | ContentAttrs Deref 58 deriving (Show, Eq, Read, Data, Typeable) 59 60data Line = LineForall Deref Binding 61 | LineIf Deref 62 | LineElseIf Deref 63 | LineElse 64 | LineWith [(Deref, Binding)] 65 | LineMaybe Deref Binding 66 | LineNothing 67 | LineCase Deref 68 | LineOf Binding 69 | LineTag 70 { _lineTagName :: String 71 , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] 72 , _lineContent :: [Content] 73 , _lineClasses :: [(Maybe Deref, [Content])] 74 , _lineAttrs :: [Deref] 75 , _lineNoNewline :: Bool 76 } 77 | LineContent [Content] Bool -- ^ True == avoid newlines 78 deriving (Eq, Show, Read) 79 80parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) 81parseLines set s = 82 case parse parser s s of 83 Left e -> Error $ show e 84 Right x -> Ok x 85 where 86 parser = do 87 mnewline <- parseNewline 88 let set' = 89 case mnewline of 90 Nothing -> 91 case hamletNewlines set of 92 DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } 93 _ -> set 94 Just n -> set { hamletNewlines = n } 95 res <- many (parseLine set') 96 return (mnewline, set', res) 97 98 parseNewline = 99 (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> 100 return Nothing 101 parseNewline' = 102 (try (string "always") >> return (Just AlwaysNewlines)) <|> 103 (try (string "never") >> return (Just NoNewlines)) <|> 104 (try (string "text") >> return (Just NewlinesText)) 105 106 eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) 107 108parseLine :: HamletSettings -> Parser (Int, Line) 109parseLine set = do 110 ss <- fmap sum $ many ((char ' ' >> return 1) <|> 111 (char '\t' >> fail "Tabs are not allowed in Hamlet indentation")) 112 x <- doctype <|> 113 doctypeDollar <|> 114 comment <|> 115 ssiInclude <|> 116 htmlComment <|> 117 doctypeRaw <|> 118 backslash <|> 119 controlIf <|> 120 controlElseIf <|> 121 (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> 122 controlMaybe <|> 123 (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> 124 controlForall <|> 125 controlWith <|> 126 controlCase <|> 127 controlOf <|> 128 angle <|> 129 invalidDollar <|> 130 (eol' >> return (LineContent [] True)) <|> 131 (do 132 (cs, avoidNewLines) <- content InContent 133 isEof <- (eof >> return True) <|> return False 134 if null cs && ss == 0 && isEof 135 then fail "End of Hamlet template" 136 else return $ LineContent cs avoidNewLines) 137 return (ss, x) 138 where 139 eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) 140 eol = eof <|> eol' 141 doctype = do 142 try $ string "!!!" >> eol 143 return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True 144 doctypeDollar = do 145 _ <- try $ string "$doctype " 146 name <- many $ noneOf "\r\n" 147 eol 148 case lookup name $ hamletDoctypeNames set of 149 Nothing -> fail $ "Unknown doctype name: " ++ name 150 Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True 151 152 doctypeRaw = do 153 x <- try $ string "<!" 154 y <- many $ noneOf "\r\n" 155 eol 156 return $ LineContent [ContentRaw $ concat [x, y, "\n"]] True 157 158 invalidDollar = do 159 _ <- char '$' 160 fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash." 161 comment = do 162 _ <- try $ string "$#" 163 _ <- many $ noneOf "\r\n" 164 eol 165 return $ LineContent [] True 166 ssiInclude = do 167 x <- try $ string "<!--#" 168 y <- many $ noneOf "\r\n" 169 eol 170 return $ LineContent [ContentRaw $ x ++ y] False 171 htmlComment = do 172 _ <- try $ string "<!--" 173 _ <- manyTill anyChar $ try $ string "-->" 174 x <- many nonComments 175 eol 176 return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables? 177 nonComments = (many1 $ noneOf "\r\n<") <|> (do 178 _ <- char '<' 179 (do 180 _ <- try $ string "!--" 181 _ <- manyTill anyChar $ try $ string "-->" 182 return "") <|> return "<") 183 backslash = do 184 _ <- char '\\' 185 (eol >> return (LineContent [ContentRaw "\n"] True)) 186 <|> (uncurry LineContent <$> content InContent) 187 controlIf = do 188 _ <- try $ string "$if" 189 spaces 190 x <- parseDeref 191 _ <- spaceTabs 192 eol 193 return $ LineIf x 194 controlElseIf = do 195 _ <- try $ string "$elseif" 196 spaces 197 x <- parseDeref 198 _ <- spaceTabs 199 eol 200 return $ LineElseIf x 201 binding = do 202 y <- identPattern 203 spaces 204 _ <- string "<-" 205 spaces 206 x <- parseDeref 207 _ <- spaceTabs 208 return (x,y) 209 bindingSep = char ',' >> spaceTabs 210 controlMaybe = do 211 _ <- try $ string "$maybe" 212 spaces 213 (x,y) <- binding 214 eol 215 return $ LineMaybe x y 216 controlForall = do 217 _ <- try $ string "$forall" 218 spaces 219 (x,y) <- binding 220 eol 221 return $ LineForall x y 222 controlWith = do 223 _ <- try $ string "$with" 224 spaces 225 bindings <- (binding `sepBy` bindingSep) `endBy` eol 226 return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] 227 controlCase = do 228 _ <- try $ string "$case" 229 spaces 230 x <- parseDeref 231 _ <- spaceTabs 232 eol 233 return $ LineCase x 234 controlOf = do 235 _ <- try $ string "$of" 236 spaces 237 x <- identPattern 238 _ <- spaceTabs 239 eol 240 return $ LineOf x 241 content cr = do 242 x <- many $ content' cr 243 case cr of 244 InQuotes -> void $ char '"' 245 NotInQuotes -> return () 246 NotInQuotesAttr -> return () 247 InContent -> eol 248 return (cc $ map fst x, any snd x) 249 where 250 cc [] = [] 251 cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c 252 cc (a:b) = a : cc b 253 254 content' cr = contentHash cr 255 <|> contentAt 256 <|> contentCaret 257 <|> contentUnder 258 <|> contentReg' cr 259 contentHash cr = do 260 x <- parseHash 261 case x of 262 Left "#" -> case cr of 263 NotInQuotes -> fail "Expected hash at end of line, got Id" 264 _ -> return (ContentRaw "#", False) 265 Left str -> return (ContentRaw str, null str) 266 Right deref -> return (ContentVar deref, False) 267 contentAt = do 268 x <- parseAt 269 return $ case x of 270 Left str -> (ContentRaw str, null str) 271 Right (s, y) -> (ContentUrl y s, False) 272 contentCaret = do 273 x <- parseCaret 274 case x of 275 Left str -> return (ContentRaw str, null str) 276 Right deref -> return (ContentEmbed deref, False) 277 contentUnder = do 278 x <- parseUnder 279 case x of 280 Left str -> return (ContentRaw str, null str) 281 Right deref -> return (ContentMsg deref, False) 282 contentReg' x = (flip (,) False) <$> contentReg x 283 contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" 284 contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" 285 contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" 286 contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r" 287 tagAttribValue notInQuotes = do 288 cr <- (char '"' >> return InQuotes) <|> return notInQuotes 289 fst <$> content cr 290 tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes 291 tagCond = do 292 d <- between (char ':') (char ':') parseDeref 293 tagClass (Just d) <|> tagAttrib (Just d) 294 tagClass x = char '.' >> (TagClass . ((,)x)) <$> tagAttribValue NotInQuotes 295 tagAttrib cond = do 296 s <- many1 $ noneOf " \t=\r\n><" 297 v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing 298 return $ TagAttrib (cond, s, v) 299 300 tagAttrs = do 301 _ <- char '*' 302 d <- between (char '{') (char '}') parseDeref 303 return $ TagAttribs d 304 305 tag' = foldr tag'' ("div", [], [], []) 306 tag'' (TagName s) (_, y, z, as) = (s, y, z, as) 307 tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) 308 tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) 309 tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) 310 tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) 311 312 ident :: Parser Ident 313 ident = do 314 i <- many1 (alphaNum <|> char '_' <|> char '\'') <|> 315 (char '(' *> many1 (satisfy (\c -> generalCategory c == OtherPunctuation)) <* char ')') 316 white 317 return (Ident i) 318 <?> "identifier" 319 320 parens = between (char '(' >> white) (char ')' >> white) 321 322 brackets = between (char '[' >> white) (char ']' >> white) 323 324 braces = between (char '{' >> white) (char '}' >> white) 325 326 comma = char ',' >> white 327 328 atsign = char '@' >> white 329 330 equals = char '=' >> white 331 332 white = skipMany $ char ' ' 333 334 wildDots = string ".." >> white 335 336 isVariable (Ident (x:_)) = not (isUpper x) 337 isVariable (Ident []) = error "isVariable: bad identifier" 338 339 isConstructor (Ident (x:_)) = isUpper x || generalCategory x == OtherPunctuation 340 isConstructor (Ident []) = error "isConstructor: bad identifier" 341 342 identPattern :: Parser Binding 343 identPattern = gcon True <|> apat 344 where 345 apat = choice 346 [ varpat 347 , gcon False 348 , parens tuplepat 349 , brackets listpat 350 ] 351 352 varpat = do 353 v <- try $ do v <- ident 354 guard (isVariable v) 355 return v 356 option (BindVar v) $ do 357 atsign 358 b <- apat 359 return (BindAs v b) 360 <?> "variable" 361 362 gcon :: Bool -> Parser Binding 363 gcon allowArgs = do 364 c <- try $ do c <- dataConstr 365 return c 366 choice 367 [ record c 368 , fmap (BindConstr c) (guard allowArgs >> many apat) 369 , return (BindConstr c []) 370 ] 371 <?> "constructor" 372 373 dataConstr = do 374 p <- dcPiece 375 ps <- many dcPieces 376 return $ toDataConstr p ps 377 378 dcPiece = do 379 x@(Ident y) <- ident 380 guard $ isConstructor x 381 return y 382 383 dcPieces = do 384 _ <- char '.' 385 dcPiece 386 387 toDataConstr x [] = DCUnqualified $ Ident x 388 toDataConstr x (y:ys) = 389 go (x:) y ys 390 where 391 go front next [] = DCQualified (Module $ front []) (Ident next) 392 go front next (rest:rests) = go (front . (next:)) rest rests 393 394 record c = braces $ do 395 (fields, wild) <- option ([], False) $ go 396 return (BindRecord c fields wild) 397 where 398 go = (wildDots >> return ([], True)) 399 <|> (do x <- recordField 400 (xs,wild) <- option ([],False) (comma >> go) 401 return (x:xs,wild)) 402 403 recordField = do 404 field <- ident 405 p <- option (BindVar field) -- support punning 406 (equals >> identPattern) 407 return (field,p) 408 409 tuplepat = do 410 xs <- identPattern `sepBy` comma 411 return $ case xs of 412 [x] -> x 413 _ -> BindTuple xs 414 415 listpat = BindList <$> identPattern `sepBy` comma 416 417 angle = do 418 _ <- char '<' 419 name' <- many $ noneOf " \t.#\r\n!>" 420 let name = if null name' then "div" else name' 421 xs <- many $ try ((many $ oneOf " \t\r\n") >> 422 (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) 423 _ <- many $ oneOf " \t\r\n" 424 _ <- char '>' 425 (c, avoidNewLines) <- content InContent 426 let (tn, attr, classes, attrsd) = tag' $ TagName name : xs 427 if '/' `elem` tn 428 then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." 429 else return $ LineTag tn attr c classes attrsd avoidNewLines 430 431data TagPiece = TagName String 432 | TagIdent [Content] 433 | TagClass (Maybe Deref, [Content]) 434 | TagAttrib (Maybe Deref, String, Maybe [Content]) 435 | TagAttribs Deref 436 deriving Show 437 438data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent 439 440data Nest = Nest Line [Nest] 441 442nestLines :: [(Int, Line)] -> [Nest] 443nestLines [] = [] 444nestLines ((i, l):rest) = 445 let (deeper, rest') = span (\(i', _) -> i' > i) rest 446 in Nest l (nestLines deeper) : nestLines rest' 447 448data Doc = DocForall Deref Binding [Doc] 449 | DocWith [(Deref, Binding)] [Doc] 450 | DocCond [(Deref, [Doc])] (Maybe [Doc]) 451 | DocMaybe Deref Binding [Doc] (Maybe [Doc]) 452 | DocCase Deref [(Binding, [Doc])] 453 | DocContent Content 454 deriving (Show, Eq, Read, Data, Typeable) 455 456nestToDoc :: HamletSettings -> [Nest] -> Result [Doc] 457nestToDoc _set [] = Ok [] 458nestToDoc set (Nest (LineForall d i) inside:rest) = do 459 inside' <- nestToDoc set inside 460 rest' <- nestToDoc set rest 461 Ok $ DocForall d i inside' : rest' 462nestToDoc set (Nest (LineWith dis) inside:rest) = do 463 inside' <- nestToDoc set inside 464 rest' <- nestToDoc set rest 465 Ok $ DocWith dis inside' : rest' 466nestToDoc set (Nest (LineIf d) inside:rest) = do 467 inside' <- nestToDoc set inside 468 (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest 469 rest'' <- nestToDoc set rest' 470 Ok $ DocCond ifs el : rest'' 471nestToDoc set (Nest (LineMaybe d i) inside:rest) = do 472 inside' <- nestToDoc set inside 473 (nothing, rest') <- 474 case rest of 475 Nest LineNothing ninside:x -> do 476 ninside' <- nestToDoc set ninside 477 return (Just ninside', x) 478 _ -> return (Nothing, rest) 479 rest'' <- nestToDoc set rest' 480 Ok $ DocMaybe d i inside' nothing : rest'' 481nestToDoc set (Nest (LineCase d) inside:rest) = do 482 let getOf (Nest (LineOf x) insideC) = do 483 insideC' <- nestToDoc set insideC 484 Ok (x, insideC') 485 getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard." 486 cases <- mapM getOf inside 487 rest' <- nestToDoc set rest 488 Ok $ DocCase d cases : rest' 489nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do 490 let attrFix (x, y, z) = (x, y, [(Nothing, z)]) 491 let takeClass (a, "class", b) = Just (a, fromMaybe [] b) 492 takeClass _ = Nothing 493 let clazzes = classes ++ mapMaybe takeClass attrs 494 let notClass (_, x, _) = x /= "class" 495 let noclass = filter notClass attrs 496 let attrs' = 497 case clazzes of 498 [] -> map attrFix noclass 499 _ -> (testIncludeClazzes clazzes, "class", map (second Just) clazzes) 500 : map attrFix noclass 501 let closeStyle = 502 if not (null content) || not (null inside) 503 then CloseSeparate 504 else hamletCloseStyle set tn 505 let end = case closeStyle of 506 CloseSeparate -> 507 DocContent $ ContentRaw $ "</" ++ tn ++ ">" 508 _ -> DocContent $ ContentRaw "" 509 seal = case closeStyle of 510 CloseInside -> DocContent $ ContentRaw "/>" 511 _ -> DocContent $ ContentRaw ">" 512 start = DocContent $ ContentRaw $ "<" ++ tn 513 attrs'' = concatMap attrToContent attrs' 514 newline' = DocContent $ ContentRaw 515 $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } 516 inside' <- nestToDoc set inside 517 rest' <- nestToDoc set rest 518 Ok $ start 519 : attrs'' 520 ++ map (DocContent . ContentAttrs) attrsD 521 ++ seal 522 : map DocContent content 523 ++ inside' 524 ++ end 525 : newline' 526 : rest' 527nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do 528 inside' <- nestToDoc set inside 529 rest' <- nestToDoc set rest 530 let newline' = DocContent $ ContentRaw 531 $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } 532 nextIsContent = 533 case (inside, rest) of 534 ([], Nest LineContent{} _:_) -> True 535 ([], Nest LineTag{} _:_) -> True 536 _ -> False 537 Ok $ map DocContent content ++ newline':inside' ++ rest' 538nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" 539nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" 540nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing" 541nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)" 542 543compressDoc :: [Doc] -> [Doc] 544compressDoc [] = [] 545compressDoc (DocForall d i doc:rest) = 546 DocForall d i (compressDoc doc) : compressDoc rest 547compressDoc (DocWith dis doc:rest) = 548 DocWith dis (compressDoc doc) : compressDoc rest 549compressDoc (DocMaybe d i doc mnothing:rest) = 550 DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) 551 : compressDoc rest 552compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest) 553 | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest 554compressDoc (DocCond x y:rest) = 555 DocCond (map (second compressDoc) x) (compressDoc `fmap` y) 556 : compressDoc rest 557compressDoc (DocCase d cs:rest) = 558 DocCase d (map (second compressDoc) cs) : compressDoc rest 559compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest 560compressDoc ( DocContent (ContentRaw x) 561 : DocContent (ContentRaw y) 562 : rest 563 ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest 564compressDoc (DocContent x:rest) = DocContent x : compressDoc rest 565 566parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc]) 567parseDoc set s = do 568 (mnl, set', ls) <- parseLines set s 569 let notEmpty (_, LineContent [] _) = False 570 notEmpty _ = True 571 let ns = nestLines $ filter notEmpty ls 572 ds <- nestToDoc set' ns 573 return (mnl, compressDoc ds) 574 575attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] 576attrToContent (Just cond, k, v) = 577 [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] 578attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] 579attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] 580attrToContent (Nothing, k, [(Nothing, Just v)]) = 581 DocContent (ContentRaw (' ' : k ++ "=\"")) 582 : map DocContent v 583 ++ [DocContent $ ContentRaw "\""] 584attrToContent (Nothing, k, v) = -- only for class 585 DocContent (ContentRaw (' ' : k ++ "=\"")) 586 : concatMap go (init v) 587 ++ go' (last v) 588 ++ [DocContent $ ContentRaw "\""] 589 where 590 go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] 591 go (Just b, x) = 592 [ DocCond 593 [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] 594 Nothing 595 ] 596 go' (Nothing, x) = maybe [] (map DocContent) x 597 go' (Just b, x) = 598 [ DocCond 599 [(b, maybe [] (map DocContent) x)] 600 Nothing 601 ] 602 603-- | Settings for parsing of a hamlet document. 604data HamletSettings = HamletSettings 605 { 606 -- | The value to replace a \"!!!\" with. Do not include the trailing 607 -- newline. 608 hamletDoctype :: String 609 -- | Should we add newlines to the output, making it more human-readable? 610 -- Useful for client-side debugging but may alter browser page layout. 611 , hamletNewlines :: NewlineStyle 612 -- | How a tag should be closed. Use this to switch between HTML, XHTML 613 -- or even XML output. 614 , hamletCloseStyle :: String -> CloseStyle 615 -- | Mapping from short names in \"$doctype\" statements to full doctype. 616 , hamletDoctypeNames :: [(String, String)] 617 } 618 deriving Lift 619 620data NewlineStyle = NoNewlines -- ^ never add newlines 621 | NewlinesText -- ^ add newlines between consecutive text lines 622 | AlwaysNewlines -- ^ add newlines everywhere 623 | DefaultNewlineStyle 624 deriving (Show, Lift) 625 626instance Lift (String -> CloseStyle) where 627 lift _ = [|\s -> htmlCloseStyle s|] 628#if MIN_VERSION_template_haskell(2,16,0) 629 liftTyped = unsafeTExpCoerce . lift 630#endif 631 632 633-- See the html specification for a list of all void elements: 634-- https://www.w3.org/TR/html/syntax.html#void-elements 635htmlEmptyTags :: Set String 636htmlEmptyTags = Set.fromAscList 637 [ "area" 638 , "base" 639 , "basefont" -- not html 5 640 , "br" 641 , "col" 642 , "embed" 643 , "frame" -- not html 5 644 , "hr" 645 , "img" 646 , "input" 647 , "isindex" -- not html 5 648 , "keygen" 649 , "link" 650 , "meta" 651 , "param" 652 , "source" 653 , "track" 654 , "wbr" 655 ] 656 657-- | Defaults settings: HTML5 doctype and HTML-style empty tags. 658defaultHamletSettings :: HamletSettings 659defaultHamletSettings = HamletSettings "<!DOCTYPE html>" DefaultNewlineStyle htmlCloseStyle doctypeNames 660 661xhtmlHamletSettings :: HamletSettings 662xhtmlHamletSettings = 663 HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames 664 where 665 doctype = 666 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++ 667 "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" 668 669htmlCloseStyle :: String -> CloseStyle 670htmlCloseStyle s = 671 if Set.member s htmlEmptyTags 672 then NoClose 673 else CloseSeparate 674 675xhtmlCloseStyle :: String -> CloseStyle 676xhtmlCloseStyle s = 677 if Set.member s htmlEmptyTags 678 then CloseInside 679 else CloseSeparate 680 681data CloseStyle = NoClose | CloseInside | CloseSeparate 682 683parseConds :: HamletSettings 684 -> ([(Deref, [Doc])] -> [(Deref, [Doc])]) 685 -> [Nest] 686 -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest]) 687parseConds set front (Nest LineElse inside:rest) = do 688 inside' <- nestToDoc set inside 689 Ok (front [], Just inside', rest) 690parseConds set front (Nest (LineElseIf d) inside:rest) = do 691 inside' <- nestToDoc set inside 692 parseConds set (front . (:) (d, inside')) rest 693parseConds _ front rest = Ok (front [], Nothing, rest) 694 695doctypeNames :: [(String, String)] 696doctypeNames = 697 [ ("5", "<!DOCTYPE html>") 698 , ("html", "<!DOCTYPE html>") 699 , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">") 700 , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") 701 ] 702 703data Binding = BindVar Ident 704 | BindAs Ident Binding 705 | BindConstr DataConstr [Binding] 706 | BindTuple [Binding] 707 | BindList [Binding] 708 | BindRecord DataConstr [(Ident, Binding)] Bool 709 deriving (Eq, Show, Read, Data, Typeable) 710 711data DataConstr = DCQualified Module Ident 712 | DCUnqualified Ident 713 deriving (Eq, Show, Read, Data, Typeable) 714 715newtype Module = Module [String] 716 deriving (Eq, Show, Read, Data, Typeable) 717 718spaceTabs :: Parser String 719spaceTabs = many $ oneOf " \t" 720 721-- | When using conditional classes, it will often be a single class, e.g.: 722-- 723-- > <div :isHome:.homepage> 724-- 725-- If isHome is False, we do not want any class attribute to be present. 726-- However, due to combining multiple classes together, the most obvious 727-- implementation would produce a class="". The purpose of this function is to 728-- work around that. It does so by checking if all the classes on this tag are 729-- optional. If so, it will only include the class attribute if at least one 730-- conditional is true. 731testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref 732testIncludeClazzes cs 733 | any (isNothing . fst) cs = Nothing 734 | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs 735 736-- | This funny hack is to allow us to refer to the 'or' function without 737-- requiring the user to have it in scope. See how this function is used in 738-- Text.Hamlet. 739specialOrIdent :: Ident 740specialOrIdent = Ident "__or__hamlet__special" 741