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,17,0)
629    liftTyped = unsafeCodeCoerce . lift
630#elif MIN_VERSION_template_haskell(2,16,0)
631    liftTyped = unsafeTExpCoerce . lift
632#endif
633
634
635-- See the html specification for a list of all void elements:
636-- https://www.w3.org/TR/html/syntax.html#void-elements
637htmlEmptyTags :: Set String
638htmlEmptyTags = Set.fromAscList
639    [ "area"
640    , "base"
641    , "basefont" -- not html 5
642    , "br"
643    , "col"
644    , "embed"
645    , "frame"    -- not html 5
646    , "hr"
647    , "img"
648    , "input"
649    , "isindex"  -- not html 5
650    , "keygen"
651    , "link"
652    , "meta"
653    , "param"
654    , "source"
655    , "track"
656    , "wbr"
657    ]
658
659-- | Defaults settings: HTML5 doctype and HTML-style empty tags.
660defaultHamletSettings :: HamletSettings
661defaultHamletSettings = HamletSettings "<!DOCTYPE html>" DefaultNewlineStyle htmlCloseStyle doctypeNames
662
663xhtmlHamletSettings :: HamletSettings
664xhtmlHamletSettings =
665    HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames
666  where
667    doctype =
668      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++
669      "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
670
671htmlCloseStyle :: String -> CloseStyle
672htmlCloseStyle s =
673    if Set.member s htmlEmptyTags
674        then NoClose
675        else CloseSeparate
676
677xhtmlCloseStyle :: String -> CloseStyle
678xhtmlCloseStyle s =
679    if Set.member s htmlEmptyTags
680        then CloseInside
681        else CloseSeparate
682
683data CloseStyle = NoClose | CloseInside | CloseSeparate
684
685parseConds :: HamletSettings
686           -> ([(Deref, [Doc])] -> [(Deref, [Doc])])
687           -> [Nest]
688           -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])
689parseConds set front (Nest LineElse inside:rest) = do
690    inside' <- nestToDoc set inside
691    Ok (front [], Just inside', rest)
692parseConds set front (Nest (LineElseIf d) inside:rest) = do
693    inside' <- nestToDoc set inside
694    parseConds set (front . (:) (d, inside')) rest
695parseConds _ front rest = Ok (front [], Nothing, rest)
696
697doctypeNames :: [(String, String)]
698doctypeNames =
699    [ ("5", "<!DOCTYPE html>")
700    , ("html", "<!DOCTYPE html>")
701    , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")
702    , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
703    ]
704
705data Binding = BindVar Ident
706             | BindAs Ident Binding
707             | BindConstr DataConstr [Binding]
708             | BindTuple [Binding]
709             | BindList [Binding]
710             | BindRecord DataConstr [(Ident, Binding)] Bool
711    deriving (Eq, Show, Read, Data, Typeable)
712
713data DataConstr = DCQualified Module Ident
714                | DCUnqualified Ident
715    deriving (Eq, Show, Read, Data, Typeable)
716
717newtype Module = Module [String]
718    deriving (Eq, Show, Read, Data, Typeable)
719
720spaceTabs :: Parser String
721spaceTabs = many $ oneOf " \t"
722
723-- | When using conditional classes, it will often be a single class, e.g.:
724--
725-- > <div :isHome:.homepage>
726--
727-- If isHome is False, we do not want any class attribute to be present.
728-- However, due to combining multiple classes together, the most obvious
729-- implementation would produce a class="". The purpose of this function is to
730-- work around that. It does so by checking if all the classes on this tag are
731-- optional. If so, it will only include the class attribute if at least one
732-- conditional is true.
733testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref
734testIncludeClazzes cs
735    | any (isNothing . fst) cs = Nothing
736    | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs
737
738-- | This funny hack is to allow us to refer to the 'or' function without
739-- requiring the user to have it in scope. See how this function is used in
740-- Text.Hamlet.
741specialOrIdent :: Ident
742specialOrIdent = Ident "__or__hamlet__special"
743