hamlet 0.7.2.1 → 0.7.3
raw patch · 13 files changed
+301/−749 lines, 13 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Text.Lucius: instance Eq Content
+ Text.Lucius: instance Show Content
+ Text.Lucius: lucius :: QuasiQuoter
+ Text.Lucius: renderLucius :: (url -> [(String, String)] -> String) -> Cassius url -> Text
+ Text.Lucius: type Lucius a = Cassius a
Files
- Old/Cassius.hs +0/−138
- Old/Hamlet.hs +0/−308
- Old/Julius.hs +0/−70
- Old/Utf8.hs +0/−29
- Text/Cassius.hs +4/−14
- Text/Css.hs +11/−0
- Text/Hamlet/Parse.hs +43/−21
- Text/Julius.hs +0/−6
- Text/Lucius.hs +160/−0
- Text/Shakespeare.hs +0/−23
- hamlet.cabal +5/−19
- hamlet6to7.hs +0/−117
- runtests.hs +78/−4
− Old/Cassius.hs
@@ -1,138 +0,0 @@-module Old.Cassius- ( parse- , render'- ) where--import qualified Text.ParserCombinators.Parsec as P-import Text.ParserCombinators.Parsec hiding (Line, parse)-import Data.List (intercalate)-import Data.Char (isUpper, isDigit)-import Language.Haskell.TH.Quote (QuasiQuoter (..))-import Language.Haskell.TH.Syntax-import Data.Maybe (catMaybes)-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import Data.Word (Word8)-import Data.Bits-import System.IO.Unsafe (unsafePerformIO)-import Old.Utf8-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import Text.Shakespeare (Deref (..), Ident (..))-import Text.Cassius (Content (..))--parse s = either (error . show) id $ P.parse parseBlocks s s-render' = concatMap renderBlock--renderBlock (sel, attrs) = concat- [ renderConts sel- , "\n"- , concatMap renderPair attrs- ]--renderPair (x, y) = concat- [ " "- , renderConts x- , ": "- , renderConts y- , "\n"- ]--renderConts = concatMap render--render (ContentRaw s) = s-render (ContentVar deref) = concat [ "#{", renderDeref deref, "}" ]-render (ContentUrl deref) = concat [ "@{", renderDeref deref, "}" ]-render (ContentUrlParam deref) = concat [ "@?{", renderDeref deref, "}" ]--type Contents = [Content]-type ContentPair = (Contents, Contents)-type Block = (Contents, [ContentPair])--parseBlocks :: Parser [Block]-parseBlocks = catMaybes `fmap` many parseBlock--parseEmptyLine :: Parser ()-parseEmptyLine = do- try $ skipMany $ oneOf " \t"- parseComment <|> eol--parseComment :: Parser ()-parseComment = do- skipMany $ oneOf " \t"- _ <- string "$#"- _ <- manyTill anyChar $ eol <|> eof- return ()--parseIndent :: Parser Int-parseIndent =- sum `fmap` many ((char ' ' >> return 1) <|> (char '\t' >> return 4))--parseBlock :: Parser (Maybe Block)-parseBlock = do- indent <- parseIndent- (emptyBlock >> return Nothing)- <|> (eof >> if indent > 0 then return Nothing else fail "")- <|> realBlock indent- where- emptyBlock = parseEmptyLine- realBlock indent = do- name <- many1 $ parseContent True- eol- pairs <- fmap catMaybes $ many $ parsePair' indent- case pairs of- [] -> return Nothing- _ -> return $ Just (name, pairs)- parsePair' indent = try (parseEmptyLine >> return Nothing)- <|> try (Just `fmap` parsePair indent)--parsePair :: Int -> Parser (Contents, Contents)-parsePair minIndent = do- indent <- parseIndent- if indent <= minIndent then fail "not indented" else return ()- key <- manyTill (parseContent False) $ char ':'- spaces- value <- manyTill (parseContent True) $ eol <|> eof- return (key, value)--eol :: Parser ()-eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ())--parseContent :: Bool -> Parser Content-parseContent allowColon = do- (char '$' >> (parseComment <|> parseDollar <|> parseVar)) <|>- (char '@' >> (parseAt <|> parseUrl)) <|> safeColon <|> do- s <- many1 $ noneOf $ (if allowColon then id else (:) ':') "\r\n$@"- return $ ContentRaw s- where- safeColon = try $ do- _ <- char ':'- notFollowedBy $ oneOf " \t"- return $ ContentRaw ":"- parseAt = char '@' >> return (ContentRaw "@")- parseUrl = do- c <- (char '?' >> return ContentUrlParam) <|> return ContentUrl- d <- parseDeref- _ <- char '@'- return $ c d- parseDollar = char '$' >> return (ContentRaw "$")- parseVar = do- d <- parseDeref- _ <- char '$'- return $ ContentVar d- parseComment = char '#' >> skipMany (noneOf "\r\n")- >> return (ContentRaw "")--parseDeref :: Parser Deref-parseDeref =- deref- where- derefParens = between (char '(') (char ')') deref- derefSingle = derefParens <|> fmap (DerefIdent . Ident) ident- deref = do- let delim = (char '.' <|> (many1 (char ' ') >> return ' '))- x <- derefSingle- xs <- many $ delim >> derefSingle- return $ foldr1 DerefBranch $ x : xs- ident = many1 (alphaNum <|> char '_' <|> char '\'')
− Old/Hamlet.hs
@@ -1,308 +0,0 @@-module Old.Hamlet- ( parse'- , render'- ) where--import Control.Applicative ((<$>), Applicative (..))-import Control.Monad-import Control.Arrow-import Data.Data-import Data.List (intercalate)-import Text.ParserCombinators.Parsec hiding (Line)-import Text.Shakespeare (Deref (..), Ident (..))-import Text.Hamlet.Parse (Line (..), Content (..))-import Old.Utf8 (renderDeref)--renderAttr (mderef, name, val) = concat- [ " "- , case mderef of- Nothing -> ""- Just deref -> concat- [ ":"- , renderDeref deref- , ":"- ]- , name- , "=\""- , concatMap renderContent val- , "\""- ]--renderClass c = ' ': '.' : concatMap renderContent c--renderContent (ContentRaw s) = s-renderContent (ContentVar d) = concat ["#{", renderDeref d, "}"]-renderContent (ContentUrl False d) = concat ["@{", renderDeref d, "}"]-renderContent (ContentUrl True d) = concat ["@?{", renderDeref d, "}"]-renderContent (ContentEmbed d) = concat ["^{", renderDeref d, "}"]--renderLine' (indent, x) = concat [replicate indent ' ', renderLine x, "\n"]--renderLine (LineForall deref (Ident i)) = concat- [ "$forall "- , i- , " <- "- , renderDeref deref- ]-renderLine (LineIf deref) = concat- [ "$if "- , renderDeref deref- ]-renderLine (LineElseIf deref) = concat- [ "$elseif "- , renderDeref deref- ]-renderLine LineElse = "$else"-renderLine (LineMaybe deref (Ident i)) = concat- [ "$maybe "- , i- , " <- "- , renderDeref deref- ]-renderLine LineNothing = "$nothing"-renderLine (LineTag tn attrs content classes) = concat- [ "<"- , tn- , concatMap renderAttr attrs- , concatMap renderClass classes- , ">"- , concatMap renderContent content- ]-renderLine (LineContent c) = '\\' : concatMap renderContent c--data Result v = Error String | Ok v-instance Monad Result where- return = Ok- Error s >>= _ = Error s- Ok v >>= f = f v- fail = Error-instance Functor Result where- fmap = liftM-instance Applicative Result where- pure = return- (<*>) = ap--parseLines :: HamletSettings -> String -> Result [(Int, Line)]-parseLines set s =- case parse (many $ parseLine set) s s of- Left e -> Error $ show e- Right x -> Ok x--parseLine :: HamletSettings -> Parser (Int, Line)-parseLine set = do- ss <- fmap sum $ many ((char ' ' >> return 1) <|>- (char '\t' >> return 4))- x <- doctype <|>- comment <|>- backslash <|>- controlIf <|>- controlElseIf <|>- (try (string "$else") >> many (oneOf " \t") >> eol >> return LineElse) <|>- controlMaybe <|>- (try (string "$nothing") >> many (oneOf " \t") >> eol >> return LineNothing) <|>- controlForall <|>- tag <|>- (eol' >> return (LineContent [])) <|>- (do- cs <- content InContent- isEof <- (eof >> return True) <|> return False- if null cs && ss == 0 && isEof- then fail "End of Hamlet template"- else return $ LineContent cs)- 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"]- comment = do- _ <- try $ string "$#"- _ <- many $ noneOf "\r\n"- eol- return $ LineContent []- backslash = do- _ <- char '\\'- (eol >> return (LineContent [ContentRaw "\n"]))- <|> (LineContent <$> content InContent)- controlIf = do- _ <- try $ string "$if"- spaces- x <- deref False- _ <- many $ oneOf " \t"- eol- return $ LineIf x- controlElseIf = do- _ <- try $ string "$elseif"- spaces- x <- deref False- _ <- many $ oneOf " \t"- eol- return $ LineElseIf x- controlMaybe = do- _ <- try $ string "$maybe"- spaces- x <- deref False- spaces- y <- ident- _ <- many $ oneOf " \t"- eol- return $ LineMaybe x y- controlForall = do- _ <- try $ string "$forall"- spaces- x <- deref False- spaces- y <- ident- _ <- many $ oneOf " \t"- eol- return $ LineForall x y- tag = do- x <- tagName <|> tagIdent <|> tagClass <|> tagAttrib- xs <- many $ tagIdent <|> tagClass <|> tagAttrib- c <- (eol >> return []) <|> (do- _ <- many1 $ oneOf " \t"- content InContent)- let (tn, attr, classes) = tag' $ x : xs- return $ LineTag tn attr c classes- content cr = do- x <- many $ content' cr- case cr of- InQuotes -> char '"' >> return ()- NotInQuotes -> return ()- InContent -> (char '$' >> eol) <|> eol- return x- content' cr = try contentDollar <|> contentAt <|> contentCarrot- <|> contentReg cr- contentDollar = do- _ <- char '$'- (char '$' >> return (ContentRaw "$")) <|> (do- s <- deref True- _ <- char '$'- return $ ContentVar s)- contentAt = do- _ <- char '@'- (char '@' >> return (ContentRaw "@")) <|> (do- x <- (char '?' >> return True) <|> return False- s <- deref True- _ <- char '@'- return $ ContentUrl x s)- contentCarrot = do- _ <- char '^'- (char '^' >> return (ContentRaw "^")) <|> (do- s <- deref True- _ <- char '^'- return $ ContentEmbed s)- contentReg InContent = ContentRaw <$> many1 (noneOf "$@^\r\n")- contentReg NotInQuotes = ContentRaw <$> many1 (noneOf "$@^#.! \t\n\r")- contentReg InQuotes =- (do- _ <- char '\\'- ContentRaw . return <$> anyChar- ) <|> (ContentRaw <$> many1 (noneOf "$@^\\\"\n\r"))- tagName = do- _ <- char '%'- s <- many1 $ noneOf " \t.#!\r\n"- return $ TagName s- tagAttribValue = do- cr <- (char '"' >> return InQuotes) <|> return NotInQuotes- content cr- tagIdent = char '#' >> TagIdent <$> tagAttribValue- tagClass = char '.' >> TagClass <$> tagAttribValue- tagAttrib = do- _ <- char '!'- cond <- (Just <$> tagAttribCond) <|> return Nothing- s <- many1 $ noneOf " \t.!=\r\n"- v <- (do- _ <- char '='- s' <- tagAttribValue- return s') <|> return []- return $ TagAttrib (cond, s, v)- tagAttribCond = do- _ <- char ':'- d <- deref True- _ <- char ':'- return d- tag' = foldr tag'' ("div", [], [])- tag'' (TagName s) (_, y, z) = (s, y, z)- tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z)- tag'' (TagClass s) (x, y, z) = (x, y, s : z)- tag'' (TagAttrib s) (x, y, z) = (x, s : y, z)- derefParens = between (char '(') (char ')') $ deref True- derefSingle = derefParens <|> fmap DerefIdent ident- deref spaceAllowed = do- let delim = if spaceAllowed- then (char '.' <|> (many1 (char ' ') >> return ' '))- else char '.'- x <- derefSingle- xs <- many $ delim >> derefSingle- return $ foldr1 DerefBranch $ x : xs- ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'')--data TagPiece = TagName String- | TagIdent [Content]- | TagClass [Content]- | TagAttrib (Maybe Deref, String, [Content])--data ContentRule = InQuotes | NotInQuotes | 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'---- | Settings for parsing of a hamlet document.-data HamletSettings = HamletSettings- {- -- | The value to replace a \"!!!\" with. Do not include the trailing- -- newline.- hamletDoctype :: String- -- | 'True' means to close empty tags (eg, img) with a trailing slash, ie- -- XML-style empty tags. 'False' uses HTML-style.- , hamletCloseEmpties :: Bool- -- | Should we put a newline after closing a tag?- , hamletCloseNewline :: Bool- }---- | Defaults settings: HTML5 doctype and HTML-style empty tags.-defaultHamletSettings :: HamletSettings-defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False False--xhtmlHamletSettings :: HamletSettings-xhtmlHamletSettings =- HamletSettings doctype True False- where- doctype =- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++- "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"--debugHamletSettings :: HamletSettings-debugHamletSettings = HamletSettings "<!DOCTYPE html>" False True--data CloseStyle = NoClose | CloseInside | CloseSeparate---- FIXME A breaking change, but move closeTag to be a record in the--- HamletSettings datatype. Would allow more precise XML encodings.-closeTag :: HamletSettings -> String -> CloseStyle-closeTag h s =- if canBeEmpty s- then CloseSeparate- else (if hamletCloseEmpties h then CloseInside else NoClose)- where- canBeEmpty "img" = False- canBeEmpty "link" = False- canBeEmpty "meta" = False- canBeEmpty "br" = False- canBeEmpty "hr" = False- canBeEmpty "input" = False- canBeEmpty _ = True--parse' set s =- case parseLines defaultHamletSettings s of- Error e -> error e- Ok x -> x--render' = concatMap renderLine'
− Old/Julius.hs
@@ -1,70 +0,0 @@-module Old.Julius- ( render- , parse- ) where--import qualified Text.ParserCombinators.Parsec as P-import Text.ParserCombinators.Parsec hiding (Line, parse)-import Data.Char (isUpper, isDigit)-import Language.Haskell.TH.Quote (QuasiQuoter (..))-import Language.Haskell.TH.Syntax-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import System.IO.Unsafe (unsafePerformIO)-import Old.Utf8-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import Text.Shakespeare (Deref (..), Ident (..))-import Text.Julius (Content (..), Contents)--parse s = either (error . show) id $ P.parse parseContents s s--render = concatMap render'--render' (ContentRaw s) = s-render' (ContentVar deref) = concat [ "#{", renderDeref deref, "}" ]-render' (ContentUrl deref) = concat [ "@{", renderDeref deref, "}" ]-render' (ContentUrlParam deref) = concat [ "@?{", renderDeref deref, "}" ]-render' (ContentMix deref) = concat [ "^{", renderDeref deref, "}" ]--parseContents :: Parser Contents-parseContents = many1 parseContent--parseContent :: Parser Content-parseContent = do- (char '%' >> (parsePercent <|> parseVar)) <|>- (char '@' >> (parseAt <|> parseUrl)) <|> do- (char '^' >> (parseCaret <|> parseMix)) <|> do- s <- many1 $ noneOf "%@^"- return $ ContentRaw s- where- parseCaret = char '^' >> return (ContentRaw "^")- parseMix = do- d <- parseDeref- _ <- char '^'- return $ ContentMix d- parseAt = char '@' >> return (ContentRaw "@")- parseUrl = do- c <- (char '?' >> return ContentUrlParam) <|> return ContentUrl- d <- parseDeref- _ <- char '@'- return $ c d- parsePercent = char '%' >> return (ContentRaw "%")- parseVar = do- d <- parseDeref- _ <- char '%'- return $ ContentVar d--parseDeref :: Parser Deref-parseDeref =- deref- where- derefParens = between (char '(') (char ')') deref- derefSingle = derefParens <|> fmap (DerefIdent . Ident) ident- deref = do- let delim = (char '.' <|> (many1 (char ' ') >> return ' '))- x <- derefSingle- xs <- many $ delim >> derefSingle- return $ foldr1 DerefBranch $ x : xs- ident = many1 (alphaNum <|> char '_' <|> char '\'')
− Old/Utf8.hs
@@ -1,29 +0,0 @@-module Old.Utf8- ( charsToOctets- , bsToChars- , lbsToChars- , renderDeref- ) where--import Text.Shakespeare-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy.Char8 as L--import qualified Data.Text as T-import qualified Data.Text.Encoding as T--import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Encoding as LT--charsToOctets :: String -> String-charsToOctets = L.unpack . LT.encodeUtf8 . LT.pack--bsToChars :: S.ByteString -> String-bsToChars = T.unpack . T.decodeUtf8--lbsToChars :: L.ByteString -> String-lbsToChars = LT.unpack . LT.decodeUtf8--renderDeref (DerefIdent (Ident s)) = s-renderDeref (DerefBranch x (DerefIdent (Ident y))) = concat [renderDeref x, " ", y]-renderDeref (DerefBranch x y) = concat [renderDeref x, " (", renderDeref y, ")"]
Text/Cassius.hs view
@@ -30,13 +30,9 @@ , PercentageSize (..) , percentageSize , PixelSize (..)-#if HAMLET6TO7- , parseBlocks- , Content (..)- , compressBlock-#endif ) where +import Text.Css import Text.MkSizeType import Text.Shakespeare import Text.ParserCombinators.Parsec hiding (Line)@@ -53,8 +49,6 @@ import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Hamlet.Quasi (readUtf8File)-import Data.Map (Map)-import qualified Data.Map as Map import Data.List (intersperse) data Color = Color Word8 Word8 Word8@@ -92,7 +86,7 @@ go (Css' x y) = mconcat [ x , singleton '{'- , mconcat $ intersperse (singleton ';') $ map go' $ Map.toList y+ , mconcat $ intersperse (singleton ';') $ map go' y , singleton '}' ] go' (k, v) = mconcat@@ -105,10 +99,6 @@ renderCassius r s = renderCss $ s r type Css = [Css']-data Css' = Css'- { _cssSelectors :: Builder- , _cssAttributes :: Map TL.Text Builder- } type Cassius url = (url -> [(String, String)] -> String) -> Css @@ -222,7 +212,7 @@ blockToCss r (sel, props) = do css' <- [|Css'|] let sel' = contentsToBuilder r sel- props' <- [|Map.fromList|] `appE` listE (map go props)+ props' <- listE (map go props) return css' `appE` sel' `appE` return props' where go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y]@@ -290,7 +280,7 @@ return $ map go a where go :: (Contents, [ContentPair]) -> Css'- go (x, y) = Css' (mconcat $ map go' x) $ Map.fromList $ map go'' y+ go (x, y) = Css' (mconcat $ map go' x) $ map go'' y go' :: Content -> Builder go' (ContentRaw s) = fromText $ TS.pack s go' (ContentVar d) =
+ Text/Css.hs view
@@ -0,0 +1,11 @@+module Text.Css+ ( Css' (..)+ ) where++import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy as TL++data Css' = Css'+ { _cssSelectors :: Builder+ , _cssAttributes :: [(TL.Text, Builder)]+ }
Text/Hamlet/Parse.hs view
@@ -10,10 +10,6 @@ , xhtmlHamletSettings , debugHamletSettings , CloseStyle (..)-#if HAMLET6TO7- , parseLines- , Line (..)-#endif ) where @@ -26,6 +22,7 @@ import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set+import Data.Maybe (mapMaybe) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable)@@ -56,7 +53,7 @@ { _lineTagName :: String , _lineAttr :: [(Maybe Deref, String, [Content])] , _lineContent :: [Content]- , _lineClasses :: [[Content]]+ , _lineClasses :: [(Maybe Deref, [Content])] } | LineContent [Content] deriving (Eq, Show, Read)@@ -183,20 +180,19 @@ cr <- (char '"' >> return InQuotes) <|> return notInQuotes content cr tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes- tagClass = char '.' >> TagClass <$> tagAttribValue NotInQuotes- tagAttrib = do- cond <- (Just <$> tagAttribCond) <|> return Nothing+ tagCond = do+ _ <- char ':'+ d <- parseDeref+ _ <- char ':'+ tagClass (Just d) <|> tagAttrib (Just d)+ tagClass x = char '.' >> (TagClass . (,) x) <$> tagAttribValue NotInQuotes+ tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n>" v <- (do _ <- char '=' s' <- tagAttribValue NotInQuotesAttr return s') <|> return [] return $ TagAttrib (cond, s, v)- tagAttribCond = do- _ <- char ':'- d <- parseDeref- _ <- char ':'- return d tag' = foldr tag'' ("div", [], []) tag'' (TagName s) (_, y, z) = (s, y, z) tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z)@@ -207,7 +203,8 @@ _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" let name = if null name' then "div" else name'- xs <- many $ try ((many $ oneOf " \t") >> (tagIdent <|> tagClass <|> tagAttrib))+ xs <- many $ try ((many $ oneOf " \t") >>+ (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrib Nothing)) _ <- many $ oneOf " \t" c <- (eol >> return []) <|> (do _ <- char '>'@@ -218,7 +215,7 @@ data TagPiece = TagName String | TagIdent [Content]- | TagClass [Content]+ | TagClass (Maybe Deref, [Content]) | TagAttrib (Maybe Deref, String, [Content]) deriving Show @@ -260,11 +257,17 @@ rest'' <- nestToDoc set rest' Ok $ DocMaybe d i inside' nothing : rest'' nestToDoc set (Nest (LineTag tn attrs content classes) inside:rest) = do+ let attrFix (x, y, z) = (x, y, [(Nothing, z)])+ let takeClass (a, "class", b) = Just (a, b)+ takeClass _ = Nothing+ let clazzes = classes ++ mapMaybe takeClass attrs+ let notClass (_, x, _) = x /= "class"+ let noclass = filter notClass attrs let attrs' =- case classes of- [] -> attrs- _ -> (Nothing, "class", intercalate [ContentRaw " "] classes)- : attrs+ case clazzes of+ [] -> map attrFix noclass+ _ -> (Nothing, "class", clazzes)+ : map attrFix noclass let closeStyle = if not (null content) || not (null inside) then CloseSeparate@@ -326,14 +329,33 @@ ds <- nestToDoc set ns return $ compressDoc ds -attrToContent :: (Maybe Deref, String, [Content]) -> [Doc]+attrToContent :: (Maybe Deref, String, [(Maybe Deref, [Content])]) -> [Doc] attrToContent (Just cond, k, v) = [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, v) =+attrToContent (Nothing, k, [(Nothing, [])]) = [DocContent $ ContentRaw $ ' ' : k]+attrToContent (Nothing, k, [(Nothing, v)]) = DocContent (ContentRaw (' ' : k ++ "=\"")) : map DocContent v ++ [DocContent $ ContentRaw "\""]+attrToContent (Nothing, k, v) = -- only for class+ DocContent (ContentRaw (' ' : k ++ "=\""))+ : concat (map go $ init v)+ ++ go' (last v)+ ++ [DocContent $ ContentRaw "\""]+ where+ go (Nothing, x) = map DocContent x ++ [DocContent $ ContentRaw " "]+ go (Just b, x) =+ [ DocCond+ [(b, map DocContent x ++ [DocContent $ ContentRaw " "])]+ Nothing+ ]+ go' (Nothing, x) = map DocContent x+ go' (Just b, x) =+ [ DocCond+ [(b, map DocContent x)]+ Nothing+ ] -- | Settings for parsing of a hamlet document. data HamletSettings = HamletSettings
Text/Julius.hs view
@@ -10,12 +10,6 @@ , julius , juliusFile , juliusFileDebug-#if HAMLET6TO7- , parseContents- , Content (..)- , Contents- , compressContents-#endif ) where import Text.ParserCombinators.Parsec hiding (Line)
+ Text/Lucius.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.Lucius+ ( -- * Datatypes+ Lucius+ -- * Rendering+ , renderLucius+ -- * Parsing+ , lucius+ -- * Re-export cassius+ , module Text.Cassius+ ) where++import Text.Cassius hiding (Cassius, renderCassius, cassius, cassiusFile, cassiusFileDebug)+import Text.Shakespeare+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Language.Haskell.TH+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton)+import Data.Maybe (catMaybes)+import Data.Monoid+import Data.Word (Word8)+import Data.Bits+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Text.Hamlet.Quasi (readUtf8File)+import Data.List (intersperse)+import qualified Text.Cassius as C+import Text.ParserCombinators.Parsec hiding (Line)+import Text.Css+import Text.Shakespeare+import Data.Char (isSpace)++type Lucius a = C.Cassius a++renderLucius = C.renderCassius++lucius :: QuasiQuoter+lucius = QuasiQuoter { quoteExp = luciusFromString }++luciusFromString :: String -> Q Exp+luciusFromString s =+ blocksToLucius+ $ either (error . show) id $ parse (parseBlocks id) s s++type Block = (Selector, Pairs)++type Pairs = [Pair]++type Pair = (Contents, Contents)++type Selector = Contents++blocksToLucius :: [Block] -> Q Exp+blocksToLucius blocks = do+ r <- newName "_render"+ lamE [varP r] $ listE $ map (blockToCss r) blocks++blockToCss :: Name -> Block -> Q Exp+blockToCss r (sel, pairs) = do+ css' <- [|Css'|]+ let sel' = contentsToBuilder r sel+ props' <- listE (map go pairs)+ return css' `appE` sel' `appE` return props'+ where+ go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y]+ tlt = appE [|toLazyText|]++data Content = ContentRaw String+ | ContentVar Deref+ | ContentUrl Deref+ | ContentUrlParam Deref+ deriving (Show, Eq)+type Contents = [Content]++contentsToBuilder :: Name -> [Content] -> Q Exp+contentsToBuilder r contents =+ appE [|mconcat|] $ listE $ map (contentToBuilder r) contents++contentToBuilder :: Name -> Content -> Q Exp+contentToBuilder _ (ContentRaw x) =+ [|fromText . TS.pack|] `appE` litE (StringL x)+contentToBuilder _ (ContentVar d) =+ [|fromLazyText . toCss|] `appE` return (derefToExp [] d)+contentToBuilder r (ContentUrl u) =+ [|fromText . TS.pack|] `appE`+ (varE r `appE` return (derefToExp [] u) `appE` listE [])+contentToBuilder r (ContentUrlParam u) =+ [|fromText . TS.pack|] `appE`+ ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))++parseBlocks :: ([Block] -> [Block]) -> Parser [Block]+parseBlocks front = do+ whiteSpace+ (parseBlock >>= (\b -> parseBlocks (front . (:) b))) <|> (return $ map compressBlock $ front [])++compressBlock = id -- FIXME++whiteSpace = many (oneOf " \t\n\r" >> return ()) >> return () -- FIXME comments, don't use many++parseBlock :: Parser Block+parseBlock = do+ sel <- parseSelector+ _ <- char '{'+ whiteSpace+ pairs <- parsePairs id+ whiteSpace+ return (sel, pairs)++parseSelector :: Parser Selector+parseSelector = fmap trim $ parseContents "{"++trim :: Contents -> Contents+trim =+ reverse . trim' False . reverse . trim' True+ where+ trim' _ [] = []+ trim' b (ContentRaw s:rest) =+ let s' = trimS b s+ in if null s' then trim' b rest else ContentRaw s' : rest+ trim' _ x = x+ trimS True = dropWhile isSpace+ trimS False = reverse . dropWhile isSpace . reverse++parsePairs :: ([Pair] -> [Pair]) -> Parser [Pair]+parsePairs front = (char '}' >> return (front [])) <|> (do+ x <- parsePair+ parsePairs $ front . (:) x)++parsePair :: Parser Pair+parsePair = do+ key <- parseContents ":"+ _ <- char ':'+ whiteSpace+ val <- parseContents ";}"+ (char ';' >> return ()) <|> return ()+ whiteSpace+ return (key, val)++parseContents :: String -> Parser Contents+parseContents = many1 . parseContent++parseContent :: String -> Parser Content+parseContent restricted =+ parseHash' <|> parseAt' <|> parseComment <|> parseChar+ where+ parseHash' = either ContentRaw ContentVar `fmap` parseHash+ parseAt' =+ either ContentRaw go `fmap` parseAt+ where+ go (d, False) = ContentUrl d+ go (d, True) = ContentUrlParam d+ parseChar = (ContentRaw . return) `fmap` noneOf restricted+ parseComment = do+ _ <- try $ string "/*"+ _ <- manyTill anyChar $ try $ string "*/"+ return $ ContentRaw ""
Text/Shakespeare.hs view
@@ -4,11 +4,7 @@ {-# LANGUAGE CPP #-} -- | General parsers, functions and datatypes for all three languages. module Text.Shakespeare-#if HAMLET6TO7- ( Deref (..)-#else ( Deref-#endif , Ident (..) , Scope , parseDeref@@ -39,22 +35,7 @@ | DerefRational Rational | DerefString String | DerefBranch Deref Deref-#if HAMLET6TO7- deriving (Show, Read, Data, Typeable)--instance Eq Deref where- x == y = True -- FIXME--simp :: Deref -> Deref-simp (DerefBranch x (DerefBranch y z)) = DerefBranch (DerefBranch (simp x) (simp y)) (simp z)-simp (DerefBranch x y) = DerefBranch (simp x) (simp y)-simp (DerefRational _) = error "Old Hamlet did not support rationals"-simp (DerefModulesIdent _ _) = error "Old Hamlet did not support modules"-simp (DerefIntegral i) = DerefIdent $ Ident $ show i-simp (DerefIdent i) = DerefIdent i-#else deriving (Show, Eq, Read, Data, Typeable)-#endif instance Lift Ident where lift (Ident s) = [|Ident|] `appE` lift s@@ -88,11 +69,7 @@ x <- derefSingle res <- deref' $ (:) x skipMany $ oneOf " \t"-#if HAMLET6TO7- return $ simp res-#else return res-#endif where delim = (many1 (char ' ') >> return()) <|> lookAhead (char '(' >> return ())
hamlet.cabal view
@@ -1,5 +1,5 @@ name: hamlet-version: 0.7.2.1+version: 0.7.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,26 +8,19 @@ description: Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at <http://docs.yesodweb.com/book/hamlet/> for more details. .- As a quick overview, here is a sample Hamlet template (note that, due to some issues with Haddock, I have replaced braces ({ and }) with double-square-brackets ([[ and ]])):+ Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see http://docs.yesodweb.com/book/templates for a thorough description . > !!! > <html > <head > <title>Hamlet Demo > <body- > <h1>Information on #[[name person]]- > <p>#[[name person]] is #[[age person]] years old.+ > <h1>Information on John Doe > <h2 > $if isMarried person > Married > $else > Not married- > <ul- > $forall child <- children person- > <li>#[[child]]- > <p- > <a href=@[[page person]]>See the page.- > ^[[footer]] category: Web, Yesod stability: Stable cabal-version: >= 1.6@@ -53,12 +46,14 @@ exposed-modules: Text.Hamlet Text.Hamlet.RT Text.Cassius+ Text.Lucius Text.Julius other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi Text.Hamlet.Debug Text.MkSizeType Text.Shakespeare+ Text.Css ghc-options: -Wall executable runtests@@ -72,15 +67,6 @@ else Buildable: False main-is: runtests.hs--executable hamlet6to7- cpp-options: -DHAMLET6TO7- build-depends: QuickCheck >= 2 && < 3- main-is: hamlet6to7.hs- Other-Modules: Old.Utf8- Old.Cassius- Old.Hamlet- Old.Julius source-repository head type: git
− hamlet6to7.hs
@@ -1,117 +0,0 @@-import qualified Old.Julius as J-import qualified Old.Cassius as C-import qualified Old.Hamlet as H-import System.Environment (getArgs)--import Text.ParserCombinators.Parsec-import qualified Text.Julius as JN-import qualified Text.Cassius as CN-import qualified Text.Hamlet.Parse as HN--import Data.Char (toUpper)--main = getArgs >>= mapM_ go--go fp = do- putStrLn $ "Checking " ++ fp- case reverse $ takeWhile (/= '.') $ reverse fp of- "julius" -> readFile fp >>= jelper >>= writeFile fp7- "cassius" -> readFile fp >>= celper >>= writeFile fp7- "hamlet" -> readFile fp >>= helper HN.defaultHamletSettings >>= writeFile fp7- "hs" -> readFile fp >>= hsHelper fp7- _ -> return ()- where- fp7 = fp -- ++ ".7"- write = writeFile fp7- check checker = do- x <- checker `fmap` readFile fp7- if x then return () else putStrLn $ "### Error parsing: " ++ fp7--hsHelper fp s = do- let contents = either (error . show) id $ parse parseHs s s- contents' <- concat `fmap` mapM renderContent contents- writeFile fp contents'--renderContent (ContentRaw s) = return s-renderContent (ContentHamlet False s) = helper HN.defaultHamletSettings s-renderContent (ContentHamlet True s) = helper HN.xhtmlHamletSettings s-renderContent (ContentCassius s) = celper s-renderContent (ContentJulius s) = jelper s--data Content = ContentRaw String- | ContentHamlet Bool String- | ContentCassius String- | ContentJulius String-parseHs =- concat `fmap` many1 parseContent- where- parseContent = parseHamlet- <|> parseXhamlet- <|> parseCassius- <|> parseJulius- <|> (return . ContentRaw . return) `fmap` anyChar- parseHamlet = do- start <- startP "hamlet"- inside <- manyTill anyChar $ try $ string "|]"- return [ContentRaw start, ContentHamlet False inside, ContentRaw "|]"]- parseXhamlet = do- start <- try $ string "[$xhamlet|" <|> string "[xhamlet|"- inside <- manyTill anyChar $ try $ string "|]"- return [ContentRaw start, ContentHamlet True inside, ContentRaw "|]"]- parseCassius = do- start <- try $ string "[$cassius|" <|> string "[cassius|"- inside <- manyTill anyChar $ try $ string "|]"- return [ContentRaw start, ContentCassius inside, ContentRaw "|]"]- parseJulius = do- start <- try $ string "[$julius|" <|> string "[julius|"- inside <- manyTill anyChar $ try $ string "|]"- return [ContentRaw start, ContentJulius inside, ContentRaw "|]"]- startP n = try (string $ concat ["[$", n, "|"])- <|> try (string $ concat ["[", n, "|"])- <|> try (string $ concat ["[", map toUpper n, "|"])- <|> try (do- a <- string "\n#if "- b <- many1 $ noneOf "\r\n"- c <- string "\r\n" <|> string "\n"- d <- many $ char ' '- e <- string $ concat ["[", n, "|"]- f <- string "\r\n" <|> string "\n"- g <- string "#else"- h <- string "\r\n" <|> string "\n"- i <- many $ char ' '- j <- string $ concat ["[$", n, "|"]- k <- string "\r\n" <|> string "\n"- l <- string "#endif"- m <- string "\r\n" <|> string "\n"- return $ concat [a, b, c, d, e, f, g, h, i, j, k, l, m]- )--jelper s = do- let x = J.parse s- let y = J.render x- case parse JN.parseContents y y of- Right z- | JN.compressContents x == JN.compressContents z -> return ()- | otherwise -> putStrLn "### Mismatch in Julius"- _ -> putStrLn "Could not parse Julius"- return y--celper s = do- let x = C.parse s- let y = C.render' x- case parse CN.parseBlocks y y of- Right z- | x == z -> return ()- | otherwise -> putStrLn "### Mismatch in Cassius"- _ -> putStrLn "Could not parse Cassius"- return y--helper set s = do- let x = H.parse' set s- let y = H.render' x- case HN.parseLines set y of- HN.Ok z- | x == z -> return ()- | otherwise -> putStrLn "### Mismatch in Hamlet"- _ -> putStrLn "Could not parse Hamlet"- return y
runtests.hs view
@@ -7,6 +7,7 @@ import Prelude hiding (reverse) import Text.Hamlet import Text.Cassius +import Text.Lucius import Text.Julius import Data.List (intercalate) import qualified Data.Text.Lazy as T @@ -99,6 +100,10 @@ , testCase "embed json" caseEmbedJson , testCase "interpolated operators" caseOperators , testCase "HTML comments" caseHtmlComments + , testCase "multi cassius" caseMultiCassius + , testCase "nested maybes" caseNestedMaybes + , testCase "lucius" caseLucius + , testCase "conditional class" caseCondClass ] data Url = Home | Sub SubUrl @@ -611,15 +616,15 @@ let urlp = (Home, [("p", "q")]) flip celper [$cassius| foo - color: #{colorRed} background: #{colorBlack} bar: baz + color: #{colorRed} bin - color: #{(((Color 127) 100) 5)} + background-image: url(@{Home}) bar: bar - unicode-test: שלום + color: #{(((Color 127) 100) 5)} f#{var}x: someval - background-image: url(@{Home}) + unicode-test: שלום urlp: url(@?{urlp}) |] $ concat [ "foo{background:#000;bar:baz;color:#F00}" @@ -913,4 +918,73 @@ <!-- ignored comment --> <p 2 +|] + +caseMultiCassius :: Assertion +caseMultiCassius = do + celper "foo{bar:baz;bar:bin}" [$cassius| +foo + bar: baz + bar: bin +|] + +caseNestedMaybes :: Assertion +caseNestedMaybes = do + let muser = Just "User" :: Maybe String + mprof = Nothing :: Maybe Int + m3 = Nothing :: Maybe String + helper "justnothing" [$hamlet| +$maybe user <- muser + $maybe profile <- mprof + First two are Just + $maybe desc <- m3 + \ and left us a description: + <p>#{desc} + $nothing + and has left us no description. + $nothing + justnothing +$nothing + <h1>No such Person exists. + |] + + +caseLucius :: Assertion +caseLucius = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip celper [$lucius| +foo { + background: #{colorBlack}; + bar: baz; + color: #{colorRed}; +} +bin { + background-image: url(@{Home}); + bar: bar; + color: #{(((Color 127) 100) 5)}; + f#{var}x: someval; + unicode-test: שלום; + urlp: url(@?{urlp}); +} +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCondClass :: Assertion +caseCondClass = do + helper "<p class=\"current\"></p>" [$hamlet| +<p :False:.ignored :True:.current +|] + + helper "<p class=\"1 3 2 4\"></p>" [$hamlet| +<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4 +|] + + helper "<p class=\"foo bar baz\"></p>" [$hamlet| +<p class=foo class=bar class=baz |]