diff --git a/heterocephalus.cabal b/heterocephalus.cabal --- a/heterocephalus.cabal +++ b/heterocephalus.cabal @@ -1,5 +1,5 @@ name: heterocephalus -version: 0.1.0.0 +version: 1.0.0 synopsis: A flexible and type safe template engine for Haskell. description: Please see README.md homepage: https://github.com/arowM/heterocephalus#readme diff --git a/src/Text/Hamlet/Parse.hs b/src/Text/Hamlet/Parse.hs --- a/src/Text/Hamlet/Parse.hs +++ b/src/Text/Hamlet/Parse.hs @@ -5,15 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Parse ( Result (..) - , Content (..) - , Doc (..) - , parseDoc - , HamletSettings (..) - , defaultHamletSettings - , xhtmlHamletSettings - , CloseStyle (..) , Binding (..) - , NewlineStyle (..) , specialOrIdent , DataConstr (..) , Module (..) @@ -21,16 +13,9 @@ where import Text.Shakespeare.Base -import Control.Applicative ((<$>), Applicative (..)) +import Control.Applicative (Applicative (..)) import Control.Monad -import Control.Arrow -import Data.Char (isUpper) import Data.Data -import Text.ParserCombinators.Parsec hiding (Line) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Maybe (mapMaybe, fromMaybe, isNothing) -import Language.Haskell.TH.Syntax (Lift (..)) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable) @@ -45,661 +30,6 @@ pure = return (<*>) = ap -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Bool Deref -- ^ bool: does it include params? - | ContentEmbed Deref - | ContentMsg Deref - | ContentAttrs Deref - deriving (Show, Eq, Read, Data, Typeable) - -data Line = LineForall Deref Binding - | LineIf Deref - | LineElseIf Deref - | LineElse - | LineWith [(Deref, Binding)] - | LineMaybe Deref Binding - | LineNothing - | LineCase Deref - | LineOf Binding - | LineTag - { _lineTagName :: String - , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] - , _lineContent :: [Content] - , _lineClasses :: [(Maybe Deref, [Content])] - , _lineAttrs :: [Deref] - , _lineNoNewline :: Bool - } - | LineContent [Content] Bool -- ^ True == avoid newlines - deriving (Eq, Show, Read) - -parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) -parseLines set s = - case parse parser s s of - Left e -> Error $ show e - Right x -> Ok x - where - parser = do - mnewline <- parseNewline - let set' = - case mnewline of - Nothing -> - case hamletNewlines set of - DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } - _ -> set - Just n -> set { hamletNewlines = n } - res <- many (parseLine set') - return (mnewline, set', res) - - parseNewline = - (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> - return Nothing - parseNewline' = - (try (string "always") >> return (Just AlwaysNewlines)) <|> - (try (string "never") >> return (Just NoNewlines)) <|> - (try (string "text") >> return (Just NewlinesText)) - - eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) - -parseLine :: HamletSettings -> Parser (Int, Line) -parseLine set = do - ss <- fmap sum $ many ((char ' ' >> return 1) <|> - (char '\t' >> fail "Tabs are not allowed in Hamlet indentation")) - x <- doctype <|> - doctypeDollar <|> - comment <|> - ssiInclude <|> - htmlComment <|> - doctypeRaw <|> - backslash <|> - controlIf <|> - controlElseIf <|> - (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> - controlMaybe <|> - (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> - controlForall <|> - controlWith <|> - controlCase <|> - controlOf <|> - angle <|> - invalidDollar <|> - (eol' >> return (LineContent [] True)) <|> - (do - (cs, avoidNewLines) <- content InContent - isEof <- (eof >> return True) <|> return False - if null cs && ss == 0 && isEof - then fail "End of Hamlet template" - else return $ LineContent cs avoidNewLines) - return (ss, x) - where - eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) - eol = eof <|> eol' - doctype = do - try $ string "!!!" >> eol - return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True - doctypeDollar = do - _ <- try $ string "$doctype " - name <- many $ noneOf "\r\n" - eol - case lookup name $ hamletDoctypeNames set of - Nothing -> fail $ "Unknown doctype name: " ++ name - Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True - - doctypeRaw = do - x <- try $ string "" - x <- many nonComments - eol - return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables? - nonComments = (many1 $ noneOf "\r\n<") <|> (do - _ <- char '<' - (do - _ <- try $ string "!--" - _ <- manyTill anyChar $ try $ string "-->" - return "") <|> return "<") - backslash = do - _ <- char '\\' - (eol >> return (LineContent [ContentRaw "\n"] True)) - <|> (uncurry LineContent <$> content InContent) - controlIf = do - _ <- try $ string "$if" - spaces - x <- parseDeref - _ <- spaceTabs - eol - return $ LineIf x - controlElseIf = do - _ <- try $ string "$elseif" - spaces - x <- parseDeref - _ <- spaceTabs - eol - return $ LineElseIf x - binding = do - y <- identPattern - spaces - _ <- string "<-" - spaces - x <- parseDeref - _ <- spaceTabs - return (x,y) - bindingSep = char ',' >> spaceTabs - controlMaybe = do - _ <- try $ string "$maybe" - spaces - (x,y) <- binding - eol - return $ LineMaybe x y - controlForall = do - _ <- try $ string "$forall" - spaces - (x,y) <- binding - eol - return $ LineForall x y - controlWith = do - _ <- try $ string "$with" - spaces - bindings <- (binding `sepBy` bindingSep) `endBy` eol - return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] - controlCase = do - _ <- try $ string "$case" - spaces - x <- parseDeref - _ <- spaceTabs - eol - return $ LineCase x - controlOf = do - _ <- try $ string "$of" - spaces - x <- identPattern - _ <- spaceTabs - eol - return $ LineOf x - content cr = do - x <- many $ content' cr - case cr of - InQuotes -> void $ char '"' - NotInQuotes -> return () - NotInQuotesAttr -> return () - InContent -> eol - return (cc $ map fst x, any snd x) - where - cc [] = [] - cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c - cc (a:b) = a : cc b - content' cr = contentHash <|> contentAt <|> contentCaret - <|> contentUnder - <|> contentReg' cr - contentHash = do - x <- parseHash - case x of - Left str -> return (ContentRaw str, null str) - Right deref -> return (ContentVar deref, False) - contentAt = do - x <- parseAt - return $ case x of - Left str -> (ContentRaw str, null str) - Right (s, y) -> (ContentUrl y s, False) - contentCaret = do - x <- parseCaret - case x of - Left str -> return (ContentRaw str, null str) - Right deref -> return (ContentEmbed deref, False) - contentUnder = do - x <- parseUnder - case x of - Left str -> return (ContentRaw str, null str) - Right deref -> return (ContentMsg deref, False) - contentReg' x = (flip (,) False) <$> contentReg x - contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" - contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" - contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" - contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r" - tagAttribValue notInQuotes = do - cr <- (char '"' >> return InQuotes) <|> return notInQuotes - fst <$> content cr - tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes - tagCond = do - d <- between (char ':') (char ':') parseDeref - tagClass (Just d) <|> tagAttrib (Just d) - tagClass x = do - clazz <- char '.' >> tagAttribValue NotInQuotes - let hasHash (ContentRaw s) = any (== '#') s - hasHash _ = False - if any hasHash clazz - then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?" - else return (TagClass (x, clazz)) - tagAttrib cond = do - s <- many1 $ noneOf " \t=\r\n><" - v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing - return $ TagAttrib (cond, s, v) - - tagAttrs = do - _ <- char '*' - d <- between (char '{') (char '}') parseDeref - return $ TagAttribs d - - tag' = foldr tag'' ("div", [], [], []) - tag'' (TagName s) (_, y, z, as) = (s, y, z, as) - tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) - tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) - tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) - tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) - - ident :: Parser Ident - ident = do - i <- many1 (alphaNum <|> char '_' <|> char '\'') - white - return (Ident i) - "identifier" - - parens = between (char '(' >> white) (char ')' >> white) - - brackets = between (char '[' >> white) (char ']' >> white) - - braces = between (char '{' >> white) (char '}' >> white) - - comma = char ',' >> white - - atsign = char '@' >> white - - equals = char '=' >> white - - white = skipMany $ char ' ' - - wildDots = string ".." >> white - - isVariable (Ident (x:_)) = not (isUpper x) - isVariable (Ident []) = error "isVariable: bad identifier" - - isConstructor (Ident (x:_)) = isUpper x - isConstructor (Ident []) = error "isConstructor: bad identifier" - - identPattern :: Parser Binding - identPattern = gcon True <|> apat - where - apat = choice - [ varpat - , gcon False - , parens tuplepat - , brackets listpat - ] - - varpat = do - v <- try $ do v <- ident - guard (isVariable v) - return v - option (BindVar v) $ do - atsign - b <- apat - return (BindAs v b) - "variable" - - gcon :: Bool -> Parser Binding - gcon allowArgs = do - c <- try $ do c <- dataConstr - return c - choice - [ record c - , fmap (BindConstr c) (guard allowArgs >> many apat) - , return (BindConstr c []) - ] - "constructor" - - dataConstr = do - p <- dcPiece - ps <- many dcPieces - return $ toDataConstr p ps - - dcPiece = do - x@(Ident y) <- ident - guard $ isConstructor x - return y - - dcPieces = do - _ <- char '.' - dcPiece - - toDataConstr x [] = DCUnqualified $ Ident x - toDataConstr x (y:ys) = - go (x:) y ys - where - go front next [] = DCQualified (Module $ front []) (Ident next) - go front next (rest:rests) = go (front . (next:)) rest rests - - record c = braces $ do - (fields, wild) <- option ([], False) $ go - return (BindRecord c fields wild) - where - go = (wildDots >> return ([], True)) - <|> (do x <- recordField - (xs,wild) <- option ([],False) (comma >> go) - return (x:xs,wild)) - - recordField = do - field <- ident - p <- option (BindVar field) -- support punning - (equals >> identPattern) - return (field,p) - - tuplepat = do - xs <- identPattern `sepBy` comma - return $ case xs of - [x] -> x - _ -> BindTuple xs - - listpat = BindList <$> identPattern `sepBy` comma - - angle = do - _ <- char '<' - name' <- many $ noneOf " \t.#\r\n!>" - let name = if null name' then "div" else name' - xs <- many $ try ((many $ oneOf " \t\r\n") >> - (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) - _ <- many $ oneOf " \t\r\n" - _ <- char '>' - (c, avoidNewLines) <- content InContent - let (tn, attr, classes, attrsd) = tag' $ TagName name : xs - if '/' `elem` tn - then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." - else return $ LineTag tn attr c classes attrsd avoidNewLines - -data TagPiece = TagName String - | TagIdent [Content] - | TagClass (Maybe Deref, [Content]) - | TagAttrib (Maybe Deref, String, Maybe [Content]) - | TagAttribs Deref - deriving Show - -data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent - -data Nest = Nest Line [Nest] - -nestLines :: [(Int, Line)] -> [Nest] -nestLines [] = [] -nestLines ((i, l):rest) = - let (deeper, rest') = span (\(i', _) -> i' > i) rest - in Nest l (nestLines deeper) : nestLines rest' - -data Doc = DocForall Deref Binding [Doc] - | DocWith [(Deref, Binding)] [Doc] - | DocCond [(Deref, [Doc])] (Maybe [Doc]) - | DocMaybe Deref Binding [Doc] (Maybe [Doc]) - | DocCase Deref [(Binding, [Doc])] - | DocContent Content - deriving (Show, Eq, Read, Data, Typeable) - -nestToDoc :: HamletSettings -> [Nest] -> Result [Doc] -nestToDoc _set [] = Ok [] -nestToDoc set (Nest (LineForall d i) inside:rest) = do - inside' <- nestToDoc set inside - rest' <- nestToDoc set rest - Ok $ DocForall d i inside' : rest' -nestToDoc set (Nest (LineWith dis) inside:rest) = do - inside' <- nestToDoc set inside - rest' <- nestToDoc set rest - Ok $ DocWith dis inside' : rest' -nestToDoc set (Nest (LineIf d) inside:rest) = do - inside' <- nestToDoc set inside - (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest - rest'' <- nestToDoc set rest' - Ok $ DocCond ifs el : rest'' -nestToDoc set (Nest (LineMaybe d i) inside:rest) = do - inside' <- nestToDoc set inside - (nothing, rest') <- - case rest of - Nest LineNothing ninside:x -> do - ninside' <- nestToDoc set ninside - return (Just ninside', x) - _ -> return (Nothing, rest) - rest'' <- nestToDoc set rest' - Ok $ DocMaybe d i inside' nothing : rest'' -nestToDoc set (Nest (LineCase d) inside:rest) = do - let getOf (Nest (LineOf x) insideC) = do - insideC' <- nestToDoc set insideC - Ok (x, insideC') - getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard." - cases <- mapM getOf inside - rest' <- nestToDoc set rest - Ok $ DocCase d cases : rest' -nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do - let attrFix (x, y, z) = (x, y, [(Nothing, z)]) - let takeClass (a, "class", b) = Just (a, fromMaybe [] b) - takeClass _ = Nothing - let clazzes = classes ++ mapMaybe takeClass attrs - let notClass (_, x, _) = x /= "class" - let noclass = filter notClass attrs - let attrs' = - case clazzes of - [] -> map attrFix noclass - _ -> (testIncludeClazzes clazzes, "class", map (second Just) clazzes) - : map attrFix noclass - let closeStyle = - if not (null content) || not (null inside) - then CloseSeparate - else hamletCloseStyle set tn - let end = case closeStyle of - CloseSeparate -> - DocContent $ ContentRaw $ "" - _ -> DocContent $ ContentRaw "" - seal = case closeStyle of - CloseInside -> DocContent $ ContentRaw "/>" - _ -> DocContent $ ContentRaw ">" - start = DocContent $ ContentRaw $ "<" ++ tn - attrs'' = concatMap attrToContent attrs' - newline' = DocContent $ ContentRaw - $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } - inside' <- nestToDoc set inside - rest' <- nestToDoc set rest - Ok $ start - : attrs'' - ++ map (DocContent . ContentAttrs) attrsD - ++ seal - : map DocContent content - ++ inside' - ++ end - : newline' - : rest' -nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do - inside' <- nestToDoc set inside - rest' <- nestToDoc set rest - let newline' = DocContent $ ContentRaw - $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } - nextIsContent = - case (inside, rest) of - ([], Nest LineContent{} _:_) -> True - ([], Nest LineTag{} _:_) -> True - _ -> False - Ok $ map DocContent content ++ newline':inside' ++ rest' -nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" -nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" -nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing" -nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)" - -compressDoc :: [Doc] -> [Doc] -compressDoc [] = [] -compressDoc (DocForall d i doc:rest) = - DocForall d i (compressDoc doc) : compressDoc rest -compressDoc (DocWith dis doc:rest) = - DocWith dis (compressDoc doc) : compressDoc rest -compressDoc (DocMaybe d i doc mnothing:rest) = - DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) - : compressDoc rest -compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest) - | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest -compressDoc (DocCond x y:rest) = - DocCond (map (second compressDoc) x) (compressDoc `fmap` y) - : compressDoc rest -compressDoc (DocCase d cs:rest) = - DocCase d (map (second compressDoc) cs) : compressDoc rest -compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest -compressDoc ( DocContent (ContentRaw x) - : DocContent (ContentRaw y) - : rest - ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest -compressDoc (DocContent x:rest) = DocContent x : compressDoc rest - -parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc]) -parseDoc set s = do - (mnl, set', ls) <- parseLines set s - let notEmpty (_, LineContent [] _) = False - notEmpty _ = True - let ns = nestLines $ filter notEmpty ls - ds <- nestToDoc set' ns - return (mnl, compressDoc ds) - -attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] -attrToContent (Just cond, k, v) = - [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] -attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] -attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] -attrToContent (Nothing, k, [(Nothing, Just v)]) = - DocContent (ContentRaw (' ' : k ++ "=\"")) - : map DocContent v - ++ [DocContent $ ContentRaw "\""] -attrToContent (Nothing, k, v) = -- only for class - DocContent (ContentRaw (' ' : k ++ "=\"")) - : concatMap go (init v) - ++ go' (last v) - ++ [DocContent $ ContentRaw "\""] - where - go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] - go (Just b, x) = - [ DocCond - [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] - Nothing - ] - go' (Nothing, x) = maybe [] (map DocContent) x - go' (Just b, x) = - [ DocCond - [(b, maybe [] (map DocContent) x)] - Nothing - ] - --- | Settings for parsing of a hamlet document. -data HamletSettings = HamletSettings - { - -- | The value to replace a \"!!!\" with. Do not include the trailing - -- newline. - hamletDoctype :: String - -- | Should we add newlines to the output, making it more human-readable? - -- Useful for client-side debugging but may alter browser page layout. - , hamletNewlines :: NewlineStyle - -- | How a tag should be closed. Use this to switch between HTML, XHTML - -- or even XML output. - , hamletCloseStyle :: String -> CloseStyle - -- | Mapping from short names in \"$doctype\" statements to full doctype. - , hamletDoctypeNames :: [(String, String)] - } - -data NewlineStyle = NoNewlines -- ^ never add newlines - | NewlinesText -- ^ add newlines between consecutive text lines - | AlwaysNewlines -- ^ add newlines everywhere - | DefaultNewlineStyle - deriving Show - -instance Lift NewlineStyle where - lift NoNewlines = [|NoNewlines|] - lift NewlinesText = [|NewlinesText|] - lift AlwaysNewlines = [|AlwaysNewlines|] - lift DefaultNewlineStyle = [|DefaultNewlineStyle|] - -instance Lift (String -> CloseStyle) where - lift _ = [|\s -> htmlCloseStyle s|] - -instance Lift HamletSettings where - lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|] - - --- See the html specification for a list of all void elements: --- https://www.w3.org/TR/html/syntax.html#void-elements -htmlEmptyTags :: Set String -htmlEmptyTags = Set.fromAscList - [ "area" - , "base" - , "basefont" -- not html 5 - , "br" - , "col" - , "embed" - , "frame" -- not html 5 - , "hr" - , "img" - , "input" - , "isindex" -- not html 5 - , "keygen" - , "link" - , "meta" - , "param" - , "source" - , "track" - , "wbr" - ] - --- | Defaults settings: HTML5 doctype and HTML-style empty tags. -defaultHamletSettings :: HamletSettings -defaultHamletSettings = HamletSettings "" DefaultNewlineStyle htmlCloseStyle doctypeNames - -xhtmlHamletSettings :: HamletSettings -xhtmlHamletSettings = - HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames - where - doctype = - "" - -htmlCloseStyle :: String -> CloseStyle -htmlCloseStyle s = - if Set.member s htmlEmptyTags - then NoClose - else CloseSeparate - -xhtmlCloseStyle :: String -> CloseStyle -xhtmlCloseStyle s = - if Set.member s htmlEmptyTags - then CloseInside - else CloseSeparate - -data CloseStyle = NoClose | CloseInside | CloseSeparate - -parseConds :: HamletSettings - -> ([(Deref, [Doc])] -> [(Deref, [Doc])]) - -> [Nest] - -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest]) -parseConds set front (Nest LineElse inside:rest) = do - inside' <- nestToDoc set inside - Ok (front [], Just inside', rest) -parseConds set front (Nest (LineElseIf d) inside:rest) = do - inside' <- nestToDoc set inside - parseConds set (front . (:) (d, inside')) rest -parseConds _ front rest = Ok (front [], Nothing, rest) - -doctypeNames :: [(String, String)] -doctypeNames = - [ ("5", "") - , ("html", "") - , ("1.1", "") - , ("strict", "") - ] - data Binding = BindVar Ident | BindAs Ident Binding | BindConstr DataConstr [Binding] @@ -714,24 +44,6 @@ newtype Module = Module [String] deriving (Eq, Show, Read, Data, Typeable) - -spaceTabs :: Parser String -spaceTabs = many $ oneOf " \t" - --- | When using conditional classes, it will often be a single class, e.g.: --- --- >
--- --- If isHome is False, we do not want any class attribute to be present. --- However, due to combining multiple classes together, the most obvious --- implementation would produce a class="". The purpose of this function is to --- work around that. It does so by checking if all the classes on this tag are --- optional. If so, it will only include the class attribute if at least one --- conditional is true. -testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref -testIncludeClazzes cs - | any (isNothing . fst) cs = Nothing - | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs -- | This funny hack is to allow us to refer to the 'or' function without -- requiring the user to have it in scope. See how this function is used in diff --git a/src/Text/Heterocephalus.hs b/src/Text/Heterocephalus.hs --- a/src/Text/Heterocephalus.hs +++ b/src/Text/Heterocephalus.hs @@ -3,10 +3,15 @@ module Text.Heterocephalus ( -- * Core functions - compile - , compileFile + compileText + , compileTextFile + , compileHtml + , compileHtmlFile -- * low-level + , HeterocephalusSetting(escapeExp) + , compile + , compileFile , compileFromString ) where @@ -17,75 +22,163 @@ import qualified Data.Text.Lazy as TL import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax hiding (Module) +import Text.Blaze (preEscapedToMarkup) import Text.Blaze.Html (toHtml) import Text.Blaze.Internal (preEscapedText) import Text.Hamlet import Text.Hamlet.Parse - hiding (defaultHamletSettings, parseDoc, HamletSettings) import Text.Shakespeare.Base -import Text.Heterocephalus.Parse (parseDoc) +import Text.Heterocephalus.Parse (Doc(..), Content(..), parseDoc) {- $setup >>> :set -XTemplateHaskell -XQuasiQuotes - >>> import Text.Blaze.Html.Renderer.String + >>> import Text.Blaze.Renderer.String -} {-| Heterocephalus quasi-quoter. + This function DOES NOT escape template variables. + To render the compiled file, use @Text.Blaze.Renderer.*.renderMarkup@. - >>> renderHtml (let as = ["a", "b"] in [compile|sample %{ forall a <- as }key: #{a}, %{ endforall }|] "") - "sample key: a, key: b, " + >>> renderMarkup (let as = ["", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|]) + "sample key: , key: b, " - >>> renderHtml (let num=2 in [compile|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|] "") + >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|]) "2 is even number." -} -compile :: QuasiQuoter -compile = compileWithSettings hamletRules defaultHamletSettings +compileText :: QuasiQuoter +compileText = compile textSetting -{-| Compile a template file. --} -compileFile :: FilePath -> Q Exp -compileFile = compileFileWithSettings hamletRules defaultHamletSettings +{-| Heterocephalus quasi-quoter for Html. + Same as 'compileText' but this function do escape template variables for Html. -compileWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter -compileWithSettings hr set = + >>> renderMarkup (let as = ["", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|]) + "sample key: <a>, key: b, " + -} +compileHtml :: QuasiQuoter +compileHtml = compile htmlSetting + +{-| Heterocephalus quasi-quoter. + Same as 'compileText' but this function read template literal from an external file. + + >>> putStr $ renderMarkup (let as = ["", "b"] in $(compileTextFile "templates/sample.txt")) + sample + key: , + key: b, + -} +compileTextFile :: FilePath -> Q Exp +compileTextFile = compileFile textSetting + +{-| Heterocephalus quasi-quoter. + Same as 'compileTextFile' but escapes template variables for Html. + + >>> putStr $ renderMarkup (let as = ["", "b"] in $(compileHtmlFile "templates/sample.txt")) + sample + key: <a>, + key: b, + -} +compileHtmlFile :: FilePath -> Q Exp +compileHtmlFile = compileFile htmlSetting + +compile :: HeterocephalusSetting -> QuasiQuoter +compile set = QuasiQuoter - { quoteExp = compileFromString hr set + { quoteExp = compileFromString set , quotePat = error "not used" , quoteType = error "not used" , quoteDec = error "not used" } -compileFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp -compileFileWithSettings qhr set fp = do +{-| Compile a template file. +-} +compileFile :: HeterocephalusSetting -> FilePath -> Q Exp +compileFile set fp = do qAddDependentFile fp contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp - compileFromString qhr set contents + compileFromString set contents -compileFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp -compileFromString qhr set s = do - hr <- qhr - hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s +compileFromString :: HeterocephalusSetting -> String -> Q Exp +compileFromString set s = + docsToExp set [] $ docFromString s -docFromString :: HamletSettings -> String -> [Doc] -docFromString _ s = +docFromString :: String -> [Doc] +docFromString s = case parseDoc s of Error s' -> error s' Ok d -> d +data HeterocephalusSetting = HeterocephalusSetting + { escapeExp :: Q Exp + } +{-| A setting that escapes template variables for Html + -} +htmlSetting :: HeterocephalusSetting +htmlSetting = HeterocephalusSetting + { escapeExp = [|toHtml|] + } + +{-| A setting that DOES NOT escape template variables + -} +textSetting :: HeterocephalusSetting +textSetting = HeterocephalusSetting + { escapeExp = [|preEscapedToMarkup|] + } + -- ============================================== --- Codes from Text.Hamlet that is not exposed +-- Helper functions -- ============================================== -docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp -docsToExp env hr scope docs = do - exps <- mapM (docToExp env hr scope) docs +docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp +docsToExp set scope docs = do + exps <- mapM (docToExp set scope) docs case exps of [] -> [|return ()|] [x] -> return x _ -> return $ DoE $ map NoBindS exps +-- TODO What's scope? +docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp +docToExp set scope (DocForall list idents inside) = do + let list' = derefToExp scope list + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope + mh <- [|F.mapM_|] + inside' <- docsToExp set scope' inside + let lam = LamE [pat] inside' + return $ mh `AppE` lam `AppE` list' +docToExp set scope (DocCond conds final) = do + conds' <- mapM go conds + final' <- + case final of + Nothing -> [|Nothing|] + Just f -> do + f' <- docsToExp set scope f + j <- [|Just|] + return $ j `AppE` f' + ch <- [|condH|] + return $ ch `AppE` ListE conds' `AppE` final' + where + go :: (Deref, [Doc]) -> Q Exp + go (d, docs) = do + let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d + docs' <- docsToExp set scope docs + return $ TupE [d', docs'] +docToExp set v (DocContent c) = contentToExp set v c + +contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp +contentToExp _ _ (ContentRaw s) = do + os <- [|preEscapedText . pack|] + let s' = LitE $ StringL s + return $ os `AppE` s' +contentToExp set scope (ContentVar d) = do + str <- escapeExp set + return $ str `AppE` derefToExp scope d + +-- ============================================== +-- Codes from Text.Hamlet that is not exposed +-- ============================================== + unIdent :: Ident -> String unIdent (Ident s) = s @@ -159,103 +252,6 @@ TyConI (DataD _ _ _ _ cons _) <- reify typeName [fields] <- return [fields | RecC name fields <- cons, name == conName] return [fieldName | (fieldName, _, _) <- fields] - -docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp -docToExp env hr scope (DocForall list idents inside) = do - let list' = derefToExp scope list - (pat, extraScope) <- bindingPattern idents - let scope' = extraScope ++ scope - mh <- [|F.mapM_|] - inside' <- docsToExp env hr scope' inside - let lam = LamE [pat] inside' - return $ mh `AppE` lam `AppE` list' -docToExp env hr scope (DocWith [] inside) = do - inside' <- docsToExp env hr scope inside - return $ inside' -docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do - let deref' = derefToExp scope deref - (pat, extraScope) <- bindingPattern idents - let scope' = extraScope ++ scope - inside' <- docToExp env hr scope' (DocWith dis inside) - let lam = LamE [pat] inside' - return $ lam `AppE` deref' -docToExp env hr scope (DocMaybe val idents inside mno) = do - let val' = derefToExp scope val - (pat, extraScope) <- bindingPattern idents - let scope' = extraScope ++ scope - inside' <- docsToExp env hr scope' inside - let inside'' = LamE [pat] inside' - ninside' <- - case mno of - Nothing -> [|Nothing|] - Just no -> do - no' <- docsToExp env hr scope no - j <- [|Just|] - return $ j `AppE` no' - mh <- [|maybeH|] - return $ mh `AppE` val' `AppE` inside'' `AppE` ninside' -docToExp env hr scope (DocCond conds final) = do - conds' <- mapM go conds - final' <- - case final of - Nothing -> [|Nothing|] - Just f -> do - f' <- docsToExp env hr scope f - j <- [|Just|] - return $ j `AppE` f' - ch <- [|condH|] - return $ ch `AppE` ListE conds' `AppE` final' - where - go :: (Deref, [Doc]) -> Q Exp - go (d, docs) = do - let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d - docs' <- docsToExp env hr scope docs - return $ TupE [d', docs'] -docToExp env hr scope (DocCase deref cases) = do - let exp_ = derefToExp scope deref - matches <- mapM toMatch cases - return $ CaseE exp_ matches - where - toMatch :: (Binding, [Doc]) -> Q Match - toMatch (idents, inside) = do - (pat, extraScope) <- bindingPattern idents - let scope' = extraScope ++ scope - insideExp <- docsToExp env hr scope' inside - return $ Match pat (NormalB insideExp) [] -docToExp env hr v (DocContent c) = contentToExp env hr v c - -contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp -contentToExp _ hr _ (ContentRaw s) = do - os <- [|preEscapedText . pack|] - let s' = LitE $ StringL s - return $ hrFromHtml hr `AppE` (os `AppE` s') -contentToExp _ hr scope (ContentVar d) = do - str <- [|toHtml|] - return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d) -contentToExp env hr scope (ContentUrl hasParams d) = - case urlRender env of - Nothing -> error "URL interpolation used, but no URL renderer provided" - Just wrender -> - wrender $ \render -> do - let render' = return render - ou <- - if hasParams - then [|\(u, p) -> $(render') u p|] - else [|\u -> $(render') u []|] - let d' = derefToExp scope d - pet <- [|toHtml|] - return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d')) -contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d -contentToExp env hr scope (ContentMsg d) = - case msgRender env of - Nothing -> - error "Message interpolation used, but no message renderer provided" - Just wrender -> - wrender $ \render -> - return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d) -contentToExp _ hr scope (ContentAttrs d) = do - html <- [|attrsToHtml . toAttributes|] - return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d) type QueryParameters = [(Text, Text)] diff --git a/src/Text/Heterocephalus/Parse.hs b/src/Text/Heterocephalus/Parse.hs --- a/src/Text/Heterocephalus/Parse.hs +++ b/src/Text/Heterocephalus/Parse.hs @@ -13,7 +13,7 @@ import Text.ParserCombinators.Parsec hiding (Line) import Text.Shakespeare.Base -import Text.Hamlet.Parse hiding (parseDoc) +import Text.Hamlet.Parse data Control = ControlForall Deref Binding @@ -25,6 +25,15 @@ | NoControl Content deriving (Show, Eq, Read, Data, Typeable) +data Doc = DocForall Deref Binding [Doc] + | DocCond [(Deref, [Doc])] (Maybe [Doc]) + | DocContent Content + deriving (Show, Eq, Read, Data, Typeable) + +data Content = ContentRaw String + | ContentVar Deref + deriving (Show, Eq, Read, Data, Typeable) + type UserParser a = Parsec String a docFromString :: String -> [Doc] @@ -35,7 +44,7 @@ parseDoc :: String -> Result [Doc] parseDoc s = do - controls <- concat <$> mapM parseLineControl (lines s) + controls <- parseLineControl s return $ controlsToDocs controls controlsToDocs :: [Control] -> [Doc] @@ -111,7 +120,7 @@ lineControl = manyTill control $ try eof >> return () control :: UserParser () Control -control = controlHash <|> controlCaret <|> controlPercent <|> controlReg +control = controlHash <|> controlPercent <|> controlReg where controlPercent = do x <- parsePercent @@ -124,16 +133,15 @@ case x of Left str -> ContentRaw str Right deref -> ContentVar deref - controlCaret = do - x <- parseCaret - return . NoControl $ - case x of - Left str -> ContentRaw str - Right deref -> ContentEmbed deref - controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%^\r\n") + controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%") parsePercent :: UserParser () (Either String Control) -parsePercent = parseControl '%' +parsePercent = do + a <- parseControl '%' + optional eol + return a + where + eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) parseControl :: Char -> UserParser () (Either String Control) parseControl c = do