hamlet 0.6.1.2 → 0.7.0
raw patch · 16 files changed
+1480/−594 lines, 16 filesdep +blaze-htmldep +containersdep −blaze-builderdep ~failurenew-component:exe:hamlet6to7PVP ok
version bump matches the API change (PVP)
Dependencies added: blaze-html, containers
Dependencies removed: blaze-builder
Dependency ranges changed: failure
API changes (from Hackage documentation)
- Text.Cassius: Css :: Builder -> Css
- Text.Cassius: instance Eq Deref
- Text.Cassius: instance Lift Deref
- Text.Cassius: instance Monoid Css
- Text.Cassius: instance Show Deref
- Text.Cassius: newtype Css
- Text.Hamlet: Html :: Builder -> Html
- Text.Hamlet: class ToHtml a
- Text.Hamlet: hamletCloseEmpties :: HamletSettings -> Bool
- Text.Hamlet: newtype Html
- Text.Hamlet: toHtml :: ToHtml a => a -> Html
- Text.Julius: instance Eq Deref
- Text.Julius: instance Lift Deref
- Text.Julius: instance Show Deref
+ Text.Cassius: instance Eq Content
+ Text.Cassius: renderCss :: Css -> Text
+ Text.Cassius: type Css = [Css']
+ Text.Hamlet: hamletCloseStyle :: HamletSettings -> String -> CloseStyle
+ Text.Hamlet: type Html = HtmlM ()
+ Text.Julius: instance Eq Content
- Text.Cassius: renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> ByteString
+ Text.Cassius: renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> Text
- Text.Hamlet: HamletSettings :: String -> Bool -> Bool -> HamletSettings
+ Text.Hamlet: HamletSettings :: String -> Bool -> (String -> CloseStyle) -> HamletSettings
- Text.Julius: renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> ByteString
+ Text.Julius: renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> Text
- Text.Julius: toJavascript :: ToJavascript a => a -> String
+ Text.Julius: toJavascript :: ToJavascript a => a -> Builder
Files
- Old/Cassius.hs +138/−0
- Old/Hamlet.hs +308/−0
- Old/Julius.hs +70/−0
- Old/Utf8.hs +29/−0
- Text/Cassius.hs +124/−140
- Text/Hamlet.hs +7/−21
- Text/Hamlet/Debug.hs +4/−4
- Text/Hamlet/Parse.hs +98/−92
- Text/Hamlet/Quasi.hs +21/−51
- Text/Hamlet/RT.hs +18/−16
- Text/Julius.hs +51/−98
- Text/Shakespeare.hs +211/−0
- Text/Utf8.hs +0/−23
- hamlet.cabal +17/−7
- hamlet6to7.hs +117/−0
- runtests.hs +267/−142
+ Old/Cassius.hs view
@@ -0,0 +1,138 @@+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 view
@@ -0,0 +1,308 @@+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 view
@@ -0,0 +1,70 @@+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 view
@@ -0,0 +1,29 @@+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
@@ -1,35 +1,42 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} module Text.Cassius ( Cassius- , Css (..)+ , Css , renderCassius+ , renderCss , cassius , Color (..) , colorRed , colorBlack , cassiusFile , cassiusFileDebug+#if HAMLET6TO7+ , parseBlocks+ , Content (..)+ , compressBlock+#endif ) where +import Text.Shakespeare import Text.ParserCombinators.Parsec hiding (Line)-import Data.List (intercalate)-import Data.Char (isUpper, isDigit) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax-import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromString)+import Language.Haskell.TH+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton) 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 Text.Utf8 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 deriving Show@@ -38,7 +45,7 @@ let (r1, r2) = toHex r (g1, g2) = toHex g (b1, b2) = toHex b- in '#' :+ in TL.pack $ '#' : if r1 == r2 && g1 == g2 && b1 == b2 then [r1, g1, b1] else [r1, r2, g1, g2, b1, b2]@@ -59,51 +66,60 @@ colorBlack :: Color colorBlack = Color 0 0 0 -renderCss :: Css -> L.ByteString-renderCss (Css b) = toLazyByteString b+renderCss :: Css -> TL.Text+renderCss =+ toLazyText . mconcat . map go+ where+ go (Css' x y) = mconcat+ [ x+ , singleton '{'+ , mconcat $ intersperse (singleton ';') $ map go' $ Map.toList y+ , singleton '}'+ ]+ go' (k, v) = mconcat+ [ fromLazyText k+ , singleton ':'+ , v+ ] -renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> L.ByteString+renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> TL.Text renderCassius r s = renderCss $ s r -newtype Css = Css Builder- deriving Monoid-type Cassius url = (url -> [(String, String)] -> String) -> Css--class ToCss a where -- FIXME use Text instead of String for efficiency? or a builder directly?- toCss :: a -> String-instance ToCss [Char] where toCss = id-instance ToCss TS.Text where toCss = TS.unpack-instance ToCss TL.Text where toCss = TL.unpack--contentPairToContents :: ContentPair -> Contents-contentPairToContents (x, y) = concat [x, ContentRaw ":" : y]+type Css = [Css']+data Css' = Css'+ { _cssSelectors :: Builder+ , _cssAttributes :: Map TL.Text Builder+ } -data Deref = DerefLeaf String- | DerefBranch Deref Deref- deriving (Show, Eq)+type Cassius url = (url -> [(String, String)] -> String) -> Css -instance Lift Deref where- lift (DerefLeaf s) = do- dl <- [|DerefLeaf|]- return $ dl `AppE` (LitE $ StringL s)- lift (DerefBranch x y) = do- x' <- lift x- y' <- lift y- db <- [|DerefBranch|]- return $ db `AppE` x' `AppE` y'+class ToCss a where+ toCss :: a -> TL.Text+instance ToCss [Char] where toCss = TL.pack+instance ToCss TS.Text where toCss = TL.fromChunks . return+instance ToCss TL.Text where toCss = id data Content = ContentRaw String | ContentVar Deref | ContentUrl Deref | ContentUrlParam Deref- deriving Show+ deriving (Show, Eq) type Contents = [Content] type ContentPair = (Contents, Contents) type Block = (Contents, [ContentPair]) parseBlocks :: Parser [Block]-parseBlocks = catMaybes `fmap` many parseBlock+parseBlocks = (map compressBlock . catMaybes) `fmap` many parseBlock +compressBlock :: Block -> Block+compressBlock (x, y) =+ (cc x, map go y)+ where+ go (k, v) = (cc k, cc v)+ cc [] = []+ cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c+ cc (a:b) = a : cc b+ parseEmptyLine :: Parser () parseEmptyLine = do try $ skipMany $ oneOf " \t"@@ -111,9 +127,11 @@ parseComment :: Parser () parseComment = do+ _ <- try (skipMany (oneOf " \t") >> string "/*")+ _ <- manyTill anyChar $ try $ string "*/"+ -- FIXME This requires that any line beginning with a comment is entirely a comment skipMany $ oneOf " \t"- _ <- string "$#"- _ <- manyTill anyChar $ eol <|> eof+ _ <- eol <|> eof return () parseIndent :: Parser Int@@ -151,105 +169,65 @@ 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+parseContent allowColon =+ parseHash' <|> parseAt' <|> parseComment <|> parseChar where- derefParens = between (char '(') (char ')') deref- derefSingle = derefParens <|> fmap DerefLeaf 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 '\'')--render :: Block -> Contents-render (n, pairs) =- let inner = intercalate [ContentRaw ";"]- $ map contentPairToContents pairs- in concat [n, [ContentRaw "{"], inner, [ContentRaw "}"]]--compressContents :: Contents -> Contents-compressContents [] = []-compressContents (ContentRaw x:ContentRaw y:z) =- compressContents $ ContentRaw (x ++ y) : z-compressContents (x:y) = x : compressContents y+ 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+ restricted = (if allowColon then id else (:) ':') "\r\n"+ parseComment = do+ _ <- try $ string "/*"+ _ <- manyTill anyChar $ try $ string "*/"+ return $ ContentRaw "" -contentsToCassius :: [Content] -> Q Exp-contentsToCassius a = do+blocksToCassius :: [(Contents, [ContentPair])] -> Q Exp+blocksToCassius a = do r <- newName "_render"- c <- mapM (contentToCss r) $ compressContents a- d <- case c of- [] -> [|mempty|]- [x] -> return x- _ -> do- mc <- [|mconcat|]- return $ mc `AppE` ListE c- return $ LamE [VarP r] d+ lamE [varP r] $ listE $ map (blockToCss r) a cassius :: QuasiQuoter cassius = QuasiQuoter { quoteExp = cassiusFromString } cassiusFromString :: String -> Q Exp cassiusFromString s =- contentsToCassius- $ concatMap render $ either (error . show) id $ parse parseBlocks s s+ blocksToCassius+ $ either (error . show) id $ parse parseBlocks s s -contentToCss :: Name -> Content -> Q Exp-contentToCss _ (ContentRaw s') = do- let d = charsToOctets s'- ts <- [|Css . fromByteString . S8.pack|]- return $ ts `AppE` LitE (StringL d)-contentToCss _ (ContentVar d) = do- ts <- [|Css . fromString . toCss|]- return $ ts `AppE` derefToExp d-contentToCss r (ContentUrl d) = do- ts <- [|Css . fromString|]- return $ ts `AppE` (VarE r `AppE` derefToExp d `AppE` ListE [])-contentToCss r (ContentUrlParam d) = do- ts <- [|Css . fromString|]- up <- [|\r' (u, p) -> r' u p|]- return $ ts `AppE` (up `AppE` VarE r `AppE` derefToExp d) -derefToExp :: Deref -> Exp-derefToExp (DerefBranch x y) =- let x' = derefToExp x- y' = derefToExp y- in x' `AppE` y'-derefToExp (DerefLeaf "") = error "Illegal empty ident"-derefToExp (DerefLeaf v@(s:_))- | all isDigit v = LitE $ IntegerL $ read v- | isUpper s = ConE $ mkName v- | otherwise = VarE $ mkName v+blockToCss :: Name -> (Contents, [ContentPair]) -> Q Exp+blockToCss r (sel, props) = do+ css' <- [|Css'|]+ let sel' = contentsToBuilder r sel+ props' <- [|Map.fromList|] `appE` listE (map go props)+ return css' `appE` sel' `appE` return props'+ where+ go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y]+ tlt = appE [|toLazyText|] +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))+ cassiusFile :: FilePath -> Q Exp cassiusFile fp = do- contents <- fmap bsToChars $ qRunIO $ S8.readFile fp+ contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp cassiusFromString contents data VarType = VTPlain | VTUrl | VTUrlParam@@ -260,7 +238,7 @@ getVars (ContentUrl d) = [(d, VTUrl)] getVars (ContentUrlParam d) = [(d, VTUrlParam)] -data CDData url = CDPlain String+data CDData url = CDPlain TL.Text | CDUrl url | CDUrlParam (url, [(String, String)]) @@ -268,7 +246,7 @@ vtToExp (d, vt) = do d' <- lift d c' <- c vt- return $ TupE [d', c' `AppE` derefToExp d]+ return $ TupE [d', c' `AppE` derefToExp [] d] where c VTPlain = [|CDPlain . toCss|] c VTUrl = [|CDUrl|]@@ -276,30 +254,36 @@ cassiusFileDebug :: FilePath -> Q Exp cassiusFileDebug fp = do- s <- fmap bsToChars $ qRunIO $ S8.readFile fp- let a = concatMap render $ either (error . show) id $ parse parseBlocks s s- c <- mapM vtToExp $ concatMap getVars a+ s <- fmap TL.unpack $ qRunIO $ readUtf8File fp+ let a = either (error . show) id $ parse parseBlocks s s+ c <- mapM vtToExp $ concatMap getVars $ concatMap go a cr <- [|cassiusRuntime|] return $ cr `AppE` (LitE $ StringL fp) `AppE` ListE c+ where+ go (x, y) = x ++ concatMap go' y+ go' (k, v) = k ++ v cassiusRuntime :: FilePath -> [(Deref, CDData url)] -> Cassius url cassiusRuntime fp cd render' = unsafePerformIO $ do- s <- fmap bsToChars $ qRunIO $ S8.readFile fp+ s <- fmap TL.unpack $ qRunIO $ readUtf8File fp let a = either (error . show) id $ parse parseBlocks s s- return $ mconcat $ map go $ concatMap render a+ return $ map go a where- go :: Content -> Css- go (ContentRaw s) = Css $ fromString s- go (ContentVar d) =+ go :: (Contents, [ContentPair]) -> Css'+ go (x, y) = Css' (mconcat $ map go' x) $ Map.fromList $ map go'' y+ go' :: Content -> Builder+ go' (ContentRaw s) = fromText $ TS.pack s+ go' (ContentVar d) = case lookup d cd of- Just (CDPlain s) -> Css $ fromString s+ Just (CDPlain s) -> fromLazyText s _ -> error $ show d ++ ": expected CDPlain"- go (ContentUrl d) =+ go' (ContentUrl d) = case lookup d cd of- Just (CDUrl u) -> Css $ fromString $ render' u []+ Just (CDUrl u) -> fromText $ TS.pack $ render' u [] _ -> error $ show d ++ ": expected CDUrl"- go (ContentUrlParam d) =+ go' (ContentUrlParam d) = case lookup d cd of Just (CDUrlParam (u, p)) ->- Css $ fromString $ render' u p+ fromText $ TS.pack $ render' u p _ -> error $ show d ++ ": expected CDUrlParam"+ go'' (k, v) = (toLazyText $ mconcat $ map go' k, mconcat $ map go' v)
Text/Hamlet.hs view
@@ -15,10 +15,9 @@ , defaultHamletSettings , xhtmlHamletSettings -- * Datatypes- , Html (..)+ , Html , Hamlet -- * Typeclass- , ToHtml (..) , HamletValue (..) -- * Construction , preEscapedString@@ -44,15 +43,14 @@ import Text.Hamlet.Quasi import Text.Hamlet.RT import Text.Hamlet.Debug-import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Monoid (mappend)-import Blaze.ByteString.Builder (toLazyByteString, fromByteString)-import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedString)-import Blaze.ByteString.Builder.Char.Utf8 (fromString) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import qualified Data.Text.Encoding.Error as T+import Text.Blaze.Renderer.Utf8 (renderHtml)+import qualified Text.Blaze.Renderer.Text as BT+import Text.Blaze (preEscapedText, preEscapedString, string, unsafeByteString) -- | Converts a 'Hamlet' to lazy bytestring. renderHamlet :: (url -> [(String, String)] -> String) -> Hamlet url -> L.ByteString@@ -63,26 +61,14 @@ renderHamletText render h = T.decodeUtf8With T.lenientDecode $ renderHtml $ h render -renderHtml :: Html -> L.ByteString-renderHtml (Html h) = toLazyByteString h- renderHtmlText :: Html -> T.Text-renderHtmlText (Html h) = T.decodeUtf8With T.lenientDecode $ toLazyByteString h+renderHtmlText = BT.renderHtml -- | Wrap an 'Html' for embedding in an XML file. cdata :: Html -> Html cdata h =- Html (fromByteString "<![CDATA[")+ preEscapedText "<![CDATA[" `mappend` h `mappend`- Html (fromByteString "]]>")--preEscapedString :: String -> Html-preEscapedString = Html . fromString--string :: String -> Html-string = Html . fromHtmlEscapedString--unsafeByteString :: S.ByteString -> Html-unsafeByteString = Html . fromByteString+ preEscapedText "]]>"
Text/Hamlet/Debug.hs view
@@ -7,23 +7,23 @@ import Text.Hamlet.Quasi import Text.Hamlet.RT import Language.Haskell.TH.Syntax-import qualified Data.ByteString.Char8 as S8 import System.IO.Unsafe (unsafePerformIO) import Control.Arrow import Data.Either import Control.Monad (forM)-import Text.Utf8+import qualified Data.Text.Lazy as T+import Text.Blaze (toHtml) unsafeRenderTemplate :: FilePath -> HamletMap url -> (url -> [(String, String)] -> String) -> Html unsafeRenderTemplate fp hd render = unsafePerformIO $ do- contents <- fmap bsToChars $ S8.readFile fp+ contents <- fmap T.unpack $ readUtf8File fp temp <- parseHamletRT defaultHamletSettings contents renderHamletRT' True temp hd render hamletFileDebug :: FilePath -> Q Exp hamletFileDebug fp = do- contents <- fmap bsToChars $ qRunIO $ S8.readFile fp+ contents <- fmap T.unpack $ qRunIO $ readUtf8File fp HamletRT docs <- qRunIO $ parseHamletRT defaultHamletSettings contents urt <- [|unsafeRenderTemplate|] render <- newName "render"
Text/Hamlet/Parse.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} module Text.Hamlet.Parse ( Result (..)- , Deref (..)- , Ident (..) , Content (..) , Doc (..) , parseDoc@@ -10,15 +9,23 @@ , defaultHamletSettings , xhtmlHamletSettings , debugHamletSettings+ , CloseStyle (..)+#if HAMLET6TO7+ , parseLines+ , Line (..)+#endif ) where +import Text.Shakespeare import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow import Data.Data import Data.List (intercalate) import Text.ParserCombinators.Parsec hiding (Line)+import Data.Set (Set)+import qualified Data.Set as Set data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable)@@ -33,12 +40,6 @@ pure = return (<*>) = ap -data Deref = DerefLeaf Ident- | DerefBranch Deref Deref- deriving (Show, Eq, Read, Data, Typeable)-newtype Ident = Ident String- deriving (Show, Eq, Read, Data, Typeable)- data Content = ContentRaw String | ContentVar Deref | ContentUrl Bool Deref -- ^ bool: does it include params?@@ -79,7 +80,7 @@ controlMaybe <|> (try (string "$nothing") >> many (oneOf " \t") >> eol >> return LineNothing) <|> controlForall <|>- tag <|>+ angle <|> (eol' >> return (LineContent [])) <|> (do cs <- content InContent@@ -106,91 +107,78 @@ controlIf = do _ <- try $ string "$if" spaces- x <- deref False+ x <- parseDeref _ <- many $ oneOf " \t" eol return $ LineIf x controlElseIf = do _ <- try $ string "$elseif" spaces- x <- deref False+ x <- parseDeref _ <- many $ oneOf " \t" eol return $ LineElseIf x controlMaybe = do _ <- try $ string "$maybe" spaces- x <- deref False- spaces y <- ident+ spaces+ _ <- string "<-"+ spaces+ x <- parseDeref _ <- many $ oneOf " \t" eol return $ LineMaybe x y controlForall = do _ <- try $ string "$forall" spaces- x <- deref False- spaces y <- ident+ spaces+ _ <- string "<-"+ spaces+ x <- parseDeref _ <- 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)+ InContent -> eol+ return $ cc 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+ <|> contentReg cr+ contentHash = do+ x <- parseHash+ case x of+ Left str -> return $ ContentRaw str+ Right deref -> return $ ContentVar deref 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+ x <- parseAt+ return $ case x of+ Left str -> ContentRaw str+ Right (s, y) -> ContentUrl y s+ contentCaret = do+ x <- parseCaret+ case x of+ Left str -> return $ ContentRaw str+ Right deref -> return $ ContentEmbed deref+ contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"+ contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"+ contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r>" 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"+ s <- many1 $ noneOf " \t.!=\r\n>" v <- (do _ <- char '=' s' <- tagAttribValue@@ -198,7 +186,7 @@ return $ TagAttrib (cond, s, v) tagAttribCond = do _ <- char ':'- d <- deref True+ d <- parseDeref _ <- char ':' return d tag' = foldr tag'' ("div", [], [])@@ -206,21 +194,25 @@ 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 DerefLeaf 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 '\'')+ angle = do+ _ <- 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))+ _ <- many $ oneOf " \t"+ c <- (eol >> return []) <|> (do+ _ <- char '>'+ c <- content InContent+ return c)+ let (tn, attr, classes) = tag' $ TagName name : xs+ return $ LineTag tn attr c classes data TagPiece = TagName String | TagIdent [Content] | TagClass [Content] | TagAttrib (Maybe Deref, String, [Content])+ deriving Show data ContentRule = InQuotes | NotInQuotes | InContent @@ -268,7 +260,7 @@ let closeStyle = if not (null content) || not (null inside) then CloseSeparate- else closeTag set tn+ else hamletCloseStyle set tn let end = case closeStyle of CloseSeparate -> DocContent $ ContentRaw $ "</" ++ tn ++ ">"@@ -341,45 +333,59 @@ -- | 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?+ -- | Should we put a newline after closing a tag? Mostly useful for debug+ -- output. , hamletCloseNewline :: Bool+ -- | How a tag should be closed. Use this to switch between HTML, XHTML+ -- or even XML output.+ , hamletCloseStyle :: String -> CloseStyle } +htmlEmptyTags :: Set String+htmlEmptyTags = Set.fromAscList+ [ "area"+ , "base"+ , "basefont"+ , "br"+ , "col"+ , "frame"+ , "hr"+ , "img"+ , "input"+ , "isindex"+ , "link"+ , "meta"+ , "param"+ ]+ -- | Defaults settings: HTML5 doctype and HTML-style empty tags. defaultHamletSettings :: HamletSettings-defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False False+defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False htmlCloseStyle xhtmlHamletSettings :: HamletSettings xhtmlHamletSettings =- HamletSettings doctype True False+ HamletSettings doctype False xhtmlCloseStyle 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+debugHamletSettings = HamletSettings "<!DOCTYPE html>" True htmlCloseStyle -data CloseStyle = NoClose | CloseInside | CloseSeparate+htmlCloseStyle :: String -> CloseStyle+htmlCloseStyle s =+ if Set.member s htmlEmptyTags+ then NoClose+ else 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+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])])
Text/Hamlet/Quasi.hs view
@@ -14,43 +14,30 @@ , hamletFile , xhamletFile , hamletFileWithSettings- , ToHtml (..) , HamletValue (..) , varName- , Html (..)+ , Html , Hamlet+ , readUtf8File ) where +import Text.Shakespeare import Text.Hamlet.Parse import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote import Data.Char (isUpper, isDigit)-import qualified Data.ByteString.Char8 as S8 import Data.Monoid (Monoid (..))-import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)-import Blaze.ByteString.Builder.Html.Utf8- (fromHtmlEscapedString, fromHtmlEscapedText, fromHtmlEscapedLazyText) import Data.Maybe (fromMaybe)-import Data.String-import Text.Utf8-import qualified Data.Text as TS import qualified Data.Text.Lazy as TL--instance IsString Html where- fromString = Html . fromHtmlEscapedString--class ToHtml a where- toHtml :: a -> Html-instance ToHtml String where- toHtml = Html . fromHtmlEscapedString-instance ToHtml Html where- toHtml = id-instance ToHtml TS.Text where- toHtml = Html . fromHtmlEscapedText-instance ToHtml TL.Text where- toHtml = Html . fromHtmlEscapedLazyText+import qualified Data.Text.Lazy.IO as TIO+import qualified System.IO as SIO+import Text.Blaze (Html, preEscapedString, string, toHtml) -type Scope = [(Ident, Exp)]+readUtf8File :: FilePath -> IO TL.Text+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ TIO.hGetContents h docsToExp :: Scope -> [Doc] -> Q Exp docsToExp scope docs = do@@ -62,7 +49,7 @@ docToExp :: Scope -> Doc -> Q Exp docToExp scope (DocForall list ident@(Ident name) inside) = do- let list' = deref scope list+ let list' = derefToExp scope list name' <- newName name let scope' = (ident, VarE name') : scope mh <- [|mapM_|]@@ -70,7 +57,7 @@ let lam = LamE [VarP name'] inside' return $ mh `AppE` lam `AppE` list' docToExp scope (DocMaybe val ident@(Ident name) inside mno) = do- let val' = deref scope val+ let val' = derefToExp scope val name' <- newName name let scope' = (ident, VarE name') : scope inside' <- docsToExp scope' inside@@ -96,27 +83,27 @@ where go :: (Deref, [Doc]) -> Q Exp go (d, docs) = do- let d' = deref scope d+ let d' = derefToExp scope d docs' <- docsToExp scope docs return $ TupE [d', docs'] docToExp v (DocContent c) = contentToExp v c contentToExp :: Scope -> Content -> Q Exp contentToExp _ (ContentRaw s) = do- os <- [|htmlToHamletMonad . Html . fromByteString . S8.pack|]- let s' = LitE $ StringL $ charsToOctets s+ os <- [|htmlToHamletMonad . preEscapedString|]+ let s' = LitE $ StringL s return $ os `AppE` s' contentToExp scope (ContentVar d) = do str <- [|htmlToHamletMonad . toHtml|]- return $ str `AppE` deref scope d+ return $ str `AppE` derefToExp scope d contentToExp scope (ContentUrl hasParams d) = do ou <- if hasParams then [|\(u, p) -> urlToHamletMonad u p|] else [|\u -> urlToHamletMonad u []|]- let d' = deref scope d+ let d' = derefToExp scope d return $ ou `AppE` d' contentToExp scope (ContentEmbed d) = do- let d' = deref scope d+ let d' = derefToExp scope d fhv <- [|fromHamletValue|] return $ fhv `AppE` d' @@ -166,7 +153,7 @@ hamletFileWithSettings :: HamletSettings -> FilePath -> Q Exp hamletFileWithSettings set fp = do- contents <- fmap bsToChars $ qRunIO $ S8.readFile fp+ contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp hamletFromString set contents -- | Calls 'hamletFileWithSettings' with 'defaultHamletSettings'.@@ -177,16 +164,6 @@ xhamletFile :: FilePath -> Q Exp xhamletFile = hamletFileWithSettings xhtmlHamletSettings -deref :: Scope -> Deref -> Exp-deref scope (DerefBranch x y) =- let x' = deref scope x- y' = deref scope y- in x' `AppE` y'-deref scope (DerefLeaf d@(Ident dName)) =- case lookup d scope of- Nothing -> varName scope dName- Just exp' -> exp'- varName :: Scope -> String -> Exp varName _ "" = error "Illegal empty varName" varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope@@ -215,13 +192,6 @@ maybeH Nothing _ (Just x) = x maybeH (Just v) f _ = f v -newtype Html = Html Builder- deriving Monoid-instance Show Html where- show (Html b) = show $ lbsToChars $ toLazyByteString b-instance Eq Html where- (Html a) == (Html b) = toLazyByteString a == toLazyByteString b- -- | An function generating an 'Html' given a URL-rendering function. type Hamlet url = (url -> [(String, String)] -> String) -> Html @@ -241,7 +211,7 @@ toHamletValue = fmap fst . runHMonad htmlToHamletMonad x = HMonad $ const (x, ()) urlToHamletMonad url pairs = HMonad $ \r ->- (Html $ fromHtmlEscapedString $ r url pairs, ())+ (string $ r url pairs, ()) fromHamletValue f = HMonad $ \r -> (f r, ()) instance Monad (HamletMonad (Hamlet url)) where return x = HMonad $ const (mempty, x)
Text/Hamlet/RT.hs view
@@ -14,15 +14,16 @@ , SimpleDoc (..) ) where +import Text.Shakespeare import Data.Monoid (mconcat) import Control.Monad (liftM, forM) import Control.Exception (Exception) import Data.Typeable (Typeable) import Control.Failure import Text.Hamlet.Parse-import Text.Hamlet.Quasi (Html (..))+import Text.Hamlet.Quasi (Html) import Data.List (intercalate)-import Blaze.ByteString.Builder.Char.Utf8 (fromString)+import Text.Blaze (preEscapedString) type HamletMap url = [([String], HamletData url)] @@ -59,23 +60,23 @@ Ok x -> liftM HamletRT $ mapM convert x where convert x@(DocForall deref (Ident ident) docs) = do- deref' <- flattenDeref x deref+ deref' <- flattenDeref' x deref docs' <- mapM convert docs return $ SDForall deref' ident docs' convert x@(DocMaybe deref (Ident ident) jdocs ndocs) = do- deref' <- flattenDeref x deref+ deref' <- flattenDeref' x deref jdocs' <- mapM convert jdocs ndocs' <- maybe (return []) (mapM convert) ndocs return $ SDMaybe deref' ident jdocs' ndocs' convert (DocContent (ContentRaw s')) = return $ SDRaw s' convert x@(DocContent (ContentVar deref)) = do- y <- flattenDeref x deref+ y <- flattenDeref' x deref return $ SDVar y convert x@(DocContent (ContentUrl p deref)) = do- y <- flattenDeref x deref+ y <- flattenDeref' x deref return $ SDUrl p y convert x@(DocContent (ContentEmbed deref)) = do- y <- flattenDeref x deref+ y <- flattenDeref' x deref return $ SDTemplate y convert x@(DocCond conds els) = do conds' <- mapM go conds@@ -83,14 +84,9 @@ return $ SDCond conds' els' where go (deref, docs') = do- deref' <- flattenDeref x deref+ deref' <- flattenDeref' x deref docs'' <- mapM convert docs' return (deref', docs'')- flattenDeref _ (DerefLeaf (Ident x)) = return [x]- flattenDeref orig (DerefBranch (DerefLeaf (Ident x)) y) = do- y' <- flattenDeref orig y- return $ y' ++ [x]- flattenDeref orig _ = failure $ HamletUnsupportedDocException orig renderHamletRT :: Failure HamletException m => HamletRT@@ -108,7 +104,7 @@ renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = liftM mconcat $ mapM (go scope0) docs where- go _ (SDRaw s) = return $ Html $ fromString s+ go _ (SDRaw s) = return $ preEscapedString s go scope (SDVar n) = do v <- lookup' n n scope case v of@@ -117,9 +113,9 @@ go scope (SDUrl p n) = do v <- lookup' n n scope case (p, v) of- (False, HDUrl u) -> return $ Html $ fromString $ renderUrl u []+ (False, HDUrl u) -> return $ preEscapedString $ renderUrl u [] (True, HDUrlParams u q) ->- return $ Html $ fromString $ renderUrl u q+ return $ preEscapedString $ renderUrl u q (False, _) -> fa $ showName n ++ ": expected HDUrl" (True, _) -> fa $ showName n ++ ": expected HDUrlParams" go scope (SDTemplate n) = do@@ -168,3 +164,9 @@ showName :: [String] -> String showName = intercalate "." . reverse++flattenDeref' :: Failure HamletException f => Doc -> Deref -> f [String]+flattenDeref' orig deref =+ case flattenDeref deref of+ Nothing -> failure $ HamletUnsupportedDocException orig+ Just x -> return x
Text/Julius.hs view
@@ -1,108 +1,73 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} module Text.Julius ( Julius , Javascript (..)+ , ToJavascript (..) , renderJulius , julius , juliusFile , juliusFileDebug- , ToJavascript (..)+#if HAMLET6TO7+ , parseContents+ , Content (..)+ , Contents+ , compressContents+#endif ) where import Text.ParserCombinators.Parsec hiding (Line)-import Data.Char (isUpper, isDigit) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax-import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromString)-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText) import Data.Monoid import System.IO.Unsafe (unsafePerformIO)-import Text.Utf8 import qualified Data.Text as TS import qualified Data.Text.Lazy as TL+import Text.Hamlet.Quasi (readUtf8File)+import Text.Shakespeare -renderJavascript :: Javascript -> L.ByteString-renderJavascript (Javascript b) = toLazyByteString b+renderJavascript :: Javascript -> TL.Text+renderJavascript (Javascript b) = toLazyText b -renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> L.ByteString+renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> TL.Text renderJulius r s = renderJavascript $ s r newtype Javascript = Javascript Builder deriving Monoid type Julius url = (url -> [(String, String)] -> String) -> Javascript -class ToJavascript a where -- FIXME use Text instead of String for efficiency? or a builder directly?- toJavascript :: a -> String-instance ToJavascript [Char] where toJavascript = id-instance ToJavascript TS.Text where toJavascript = TS.unpack-instance ToJavascript TL.Text where toJavascript = TL.unpack--data Deref = DerefLeaf String- | DerefBranch Deref Deref- deriving (Show, Eq)--instance Lift Deref where- lift (DerefLeaf s) = do- dl <- [|DerefLeaf|]- return $ dl `AppE` (LitE $ StringL s)- lift (DerefBranch x y) = do- x' <- lift x- y' <- lift y- db <- [|DerefBranch|]- return $ db `AppE` x' `AppE` y'+class ToJavascript a where+ toJavascript :: a -> Builder+instance ToJavascript [Char] where toJavascript = fromLazyText . TL.pack+instance ToJavascript TS.Text where toJavascript = fromText+instance ToJavascript TL.Text where toJavascript = fromLazyText data Content = ContentRaw String | ContentVar Deref | ContentUrl Deref | ContentUrlParam Deref | ContentMix Deref- deriving Show+ deriving (Show, Eq) type Contents = [Content] 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+parseContent =+ parseHash' <|> parseAt' <|> parseCaret' <|> parseChar where- derefParens = between (char '(') (char ')') deref- derefSingle = derefParens <|> fmap DerefLeaf 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 '\'')+ parseHash' = either ContentRaw ContentVar `fmap` parseHash+ parseAt' =+ either ContentRaw go `fmap` parseAt+ where+ go (d, False) = ContentUrl d+ go (d, True) = ContentUrlParam d+ parseCaret' = either ContentRaw ContentMix `fmap` parseCaret+ parseChar = (ContentRaw . return) `fmap` anyChar compressContents :: Contents -> Contents compressContents [] = []@@ -113,7 +78,7 @@ contentsToJulius :: [Content] -> Q Exp contentsToJulius a = do r <- newName "_render"- c <- mapM (contentToJavascript r) $ compressContents a+ c <- mapM (contentToJavascript r) a d <- case c of [] -> [|mempty|] [x] -> return x@@ -128,41 +93,29 @@ juliusFromString :: String -> Q Exp juliusFromString s = do let a = either (error . show) id $ parse parseContents s s- contentsToJulius a+ contentsToJulius $ compressContents a contentToJavascript :: Name -> Content -> Q Exp contentToJavascript _ (ContentRaw s') = do- let d = charsToOctets s'- ts <- [|Javascript . fromByteString . S8.pack|]- return $ ts `AppE` LitE (StringL d)+ ts <- [|Javascript . fromText . TS.pack|]+ return $ ts `AppE` LitE (StringL s') contentToJavascript _ (ContentVar d) = do- ts <- [|Javascript . fromString . toJavascript|]- return $ ts `AppE` derefToExp d+ ts <- [|Javascript . toJavascript|]+ return $ ts `AppE` derefToExp [] d contentToJavascript r (ContentUrl d) = do- ts <- [|Javascript . fromString|]- return $ ts `AppE` (VarE r `AppE` derefToExp d `AppE` ListE [])+ ts <- [|Javascript . fromText . TS.pack|]+ return $ ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []) contentToJavascript r (ContentUrlParam d) = do- ts <- [|Javascript . fromString|]+ ts <- [|Javascript . fromText . TS.pack|] up <- [|\r' (u, p) -> r' u p|]- return $ ts `AppE` (up `AppE` VarE r `AppE` derefToExp d)+ return $ ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d) contentToJavascript r (ContentMix d) = do- return $ derefToExp d `AppE` VarE r--derefToExp :: Deref -> Exp-derefToExp (DerefBranch x y) =- let x' = derefToExp x- y' = derefToExp y- in x' `AppE` y'-derefToExp (DerefLeaf "") = error "Illegal empty ident"-derefToExp (DerefLeaf v@(s:_))- | all isDigit v = LitE $ IntegerL $ read v- | isUpper s = ConE $ mkName v- | otherwise = VarE $ mkName v+ return $ derefToExp [] d `AppE` VarE r juliusFile :: FilePath -> Q Exp juliusFile fp = do- contents <- fmap bsToChars $ qRunIO $ S8.readFile fp- juliusFromString contents+ contents <- qRunIO $ readUtf8File fp+ juliusFromString $ TL.unpack contents data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin @@ -173,7 +126,7 @@ getVars (ContentUrlParam d) = [(d, VTUrlParam)] getVars (ContentMix d) = [(d, VTMixin)] -data JDData url = JDPlain String+data JDData url = JDPlain Builder | JDUrl url | JDUrlParam (url, [(String, String)]) | JDMixin (Julius url)@@ -182,7 +135,7 @@ vtToExp (d, vt) = do d' <- lift d c' <- c vt- return $ TupE [d', c' `AppE` derefToExp d]+ return $ TupE [d', c' `AppE` derefToExp [] d] where c VTPlain = [|JDPlain . toJavascript|] c VTUrl = [|JDUrl|]@@ -191,7 +144,7 @@ juliusFileDebug :: FilePath -> Q Exp juliusFileDebug fp = do- s <- fmap bsToChars $ qRunIO $ S8.readFile fp+ s <- qRunIO $ fmap TL.unpack $ readUtf8File fp let a = either (error . show) id $ parse parseContents s s b = concatMap getVars a c <- mapM vtToExp b@@ -200,24 +153,24 @@ juliusRuntime :: FilePath -> [(Deref, JDData url)] -> Julius url juliusRuntime fp cd render' = unsafePerformIO $ do- s <- fmap bsToChars $ qRunIO $ S8.readFile fp+ s <- fmap TL.unpack $ readUtf8File fp let a = either (error . show) id $ parse parseContents s s return $ mconcat $ map go a where go :: Content -> Javascript- go (ContentRaw s) = Javascript $ fromString s+ go (ContentRaw s) = Javascript $ fromText $ TS.pack s go (ContentVar d) = case lookup d cd of- Just (JDPlain s) -> Javascript $ fromString s+ Just (JDPlain s) -> Javascript s _ -> error $ show d ++ ": expected JDPlain" go (ContentUrl d) = case lookup d cd of- Just (JDUrl u) -> Javascript $ fromString $ render' u []+ Just (JDUrl u) -> Javascript $ fromText $ TS.pack $ render' u [] _ -> error $ show d ++ ": expected JDUrl" go (ContentUrlParam d) = case lookup d cd of Just (JDUrlParam (u, p)) ->- Javascript $ fromString $ render' u p+ Javascript $ fromText $ TS.pack $ render' u p _ -> error $ show d ++ ": expected JDUrlParam" go (ContentMix d) = case lookup d cd of
+ Text/Shakespeare.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+-- | General parsers, functions and datatypes for all three languages.+module Text.Shakespeare+#if HAMLET6TO7+ ( Deref (..)+#else+ ( Deref+#endif+ , Ident (..)+ , Scope+ , parseDeref+ , parseHash+ , parseAt+ , parseCaret+ , derefToExp+ , flattenDeref+ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH (appE)+import Data.Char (isUpper)+import Text.ParserCombinators.Parsec+import Data.List (intercalate)+import Data.Ratio (numerator, denominator, (%))+import Data.Data (Data)+import Data.Typeable (Typeable)++newtype Ident = Ident String+ deriving (Show, Eq, Read, Data, Typeable)++type Scope = [(Ident, Exp)]++data Deref = DerefModulesIdent [String] Ident+ | DerefIdent Ident+ | DerefIntegral Integer+ | 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+instance Lift Deref where+ lift (DerefModulesIdent v s) = do+ dl <- [|DerefModulesIdent|]+ v' <- lift v+ s' <- lift s+ return $ dl `AppE` v' `AppE` s'+ lift (DerefIdent s) = do+ dl <- [|DerefIdent|]+ s' <- lift s+ return $ dl `AppE` s'+ lift (DerefBranch x y) = do+ x' <- lift x+ y' <- lift y+ db <- [|DerefBranch|]+ return $ db `AppE` x' `AppE` y'+ lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i+ lift (DerefRational r) = do+ n <- lift $ numerator r+ d <- lift $ denominator r+ per <- [|(%)|]+ dr <- [|DerefRational|]+ return $ dr `AppE` (InfixE (Just n) per (Just d))+ lift (DerefString s) = [|DerefString|] `appE` lift s++parseDeref :: Parser Deref+parseDeref = do+ skipMany $ oneOf " \t"+ 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 ())+ derefParens = between (char '(') (char ')') parseDeref+ derefSingle = derefParens <|> numeric <|> strLit<|> ident+ deref' lhs =+ dollar <|> derefSingle'+ <|> return (foldl1 DerefBranch $ lhs [])+ where+ dollar = do+ _ <- try $ delim >> char '$'+ rhs <- parseDeref+ let lhs' = foldl1 DerefBranch $ lhs []+ return $ DerefBranch lhs' rhs+ derefSingle' = do+ x <- try $ delim >> derefSingle+ deref' $ lhs . (:) x+ numeric = do+ n <- (char '-' >> return "-") <|> return ""+ x <- many1 digit+ y <- (char '.' >> fmap Just (many1 digit)) <|> return Nothing+ return $ case y of+ Nothing -> DerefIntegral $ read' "Integral" $ n ++ x+ Just z -> DerefRational $ toRational+ (read' "Rational" $ n ++ x ++ '.' : z :: Double)+ strLit = do+ _ <- char '"'+ chars <- many quotedChar+ _ <- char '"'+ return $ DerefString chars+ quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""+ escapedChar =+ (char 'n' >> return '\n') <|>+ (char 'r' >> return '\r') <|>+ (char 'b' >> return '\b') <|>+ (char 't' >> return '\t') <|>+ (char '\\' >> return '\\') <|>+ (char '"' >> return '"') <|>+ (char '\'' >> return '\'')+ ident = do+ mods <- many modul+ func <- many1 (alphaNum <|> char '_' <|> char '\'')+ let func' = Ident func+ return $+ if null mods+ then DerefIdent func'+ else DerefModulesIdent mods func'+ modul = try $ do+ c <- upper+ cs <- many (alphaNum <|> char '_')+ _ <- char '.'+ return $ c : cs++read' :: Read a => String -> String -> a+read' t s =+ case reads s of+ (x, _):_ -> x+ [] -> error $ t ++ " read failed: " ++ s++expType :: Ident -> Name -> Exp+expType (Ident (c:_)) = if isUpper c then ConE else VarE+expType (Ident "") = error "Bad Ident"++derefToExp :: Scope -> Deref -> Exp+derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y+derefToExp _ (DerefModulesIdent mods i@(Ident s)) =+ expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods)+derefToExp scope (DerefIdent i@(Ident s)) =+ case lookup i scope of+ Just e -> e+ Nothing -> expType i $ mkName s+derefToExp _ (DerefIntegral i) = LitE $ IntegerL i+derefToExp _ (DerefRational r) = LitE $ RationalL r+derefToExp _ (DerefString s) = LitE $ StringL s++-- FIXME shouldn't we use something besides a list here?+flattenDeref :: Deref -> Maybe [String]+flattenDeref (DerefIdent (Ident x)) = Just [x]+flattenDeref (DerefBranch (DerefIdent (Ident x)) y) = do+ y' <- flattenDeref y+ Just $ y' ++ [x]+flattenDeref _ = Nothing++parseHash :: Parser (Either String Deref)+parseHash = do+ _ <- char '#'+ (char '\\' >> return (Left "#")) <|> (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right deref) <|> (do+ -- Check for hash just before newline+ _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof+ return $ Left ""+ ) <|> return (Left "#")++parseAt :: Parser (Either String (Deref, Bool))+parseAt = do+ _ <- char '@'+ (char '\\' >> return (Left "@")) <|> (do+ x <- (char '?' >> return True) <|> return False+ (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right (deref, x))+ <|> return (Left $ if x then "@?" else "@"))++parseCaret :: Parser (Either String Deref)+parseCaret = do+ _ <- char '^'+ (char '\\' >> return (Left "^")) <|> (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right deref) <|> return (Left "^")
− Text/Utf8.hs
@@ -1,23 +0,0 @@-module Text.Utf8- ( charsToOctets- , bsToChars- , lbsToChars- ) where--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
hamlet.cabal view
@@ -1,5 +1,5 @@ name: hamlet-version: 0.6.1.2+version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -29,12 +29,12 @@ > %a!href=@page.person@ See the page. > ^footer^ category: Web, Yesod-stability: unstable+stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/ -flag buildtests+flag test description: Build the executable to run unit tests default: False @@ -42,10 +42,11 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , template-haskell- , blaze-builder >= 0.2 && < 0.3+ , blaze-html >= 0.4 && < 0.5 , parsec >= 2 && < 4- , failure >= 0.1.0 && < 0.2+ , failure >= 0.1 && < 0.2 , text >= 0.7 && < 0.12+ , containers >= 0.2 && < 0.5 exposed-modules: Text.Hamlet Text.Hamlet.RT Text.Cassius@@ -53,11 +54,11 @@ other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi Text.Hamlet.Debug- Text.Utf8+ Text.Shakespeare ghc-options: -Wall executable runtests- if flag(buildtests)+ if flag(test) Buildable: True cpp-options: -DTEST build-depends: QuickCheck >= 2 && < 3,@@ -67,6 +68,15 @@ 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 view
@@ -0,0 +1,117 @@+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
@@ -4,11 +4,14 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) +import Prelude hiding (reverse) import Text.Hamlet import Text.Cassius import Text.Julius import Data.List (intercalate) -import Text.Utf8 +import qualified Data.Text.Lazy as T +import qualified Data.List +import qualified Data.List as L main :: IO () main = defaultMain [testSuite] @@ -59,7 +62,7 @@ , testCase "currency symbols" caseCurrency , testCase "external" caseExternal , testCase "parens" caseParens - , testCase "hamlet literals"caseHamletLiterals + , testCase "hamlet literals" caseHamletLiterals , testCase "hamlet' and xhamlet'" caseHamlet' , testCase "hamletDebug" caseHamletDebug , testCase "hamlet runtime" caseHamletRT @@ -76,12 +79,21 @@ , testCase "comments" caseComments , testCase "hamletFileDebug double foralls" caseDoubleForalls , testCase "cassius pseudo-class" casePseudo - , testCase "different binding names" caseDiffBindNames + -- FIXME test is disabled , testCase "different binding names" caseDiffBindNames , testCase "blank line" caseBlankLine , testCase "leading spaces" caseLeadingSpaces , testCase "cassius all spaces" caseCassiusAllSpaces , testCase "cassius whitespace and colons" caseCassiusWhitespaceColons , testCase "cassius trailing comments" caseCassiusTrailingComments + , testCase "hamlet angle bracket syntax" caseHamletAngleBrackets + , testCase "hamlet module names" caseHamletModuleNames + , testCase "cassius module names" caseCassiusModuleNames + , testCase "julius module names" caseJuliusModuleNames + , testCase "single dollar at and caret" caseSingleDollarAtCaret + , testCase "dollar operator" caseDollarOperator + , testCase "in a row" caseInARow + , testCase "embedded slash" caseEmbeddedSlash + , testCase "string literals" caseStringLiterals ] data Url = Home | Sub SubUrl @@ -150,8 +162,8 @@ helper :: String -> Hamlet Url -> Assertion helper res h = do - let x = renderHamlet render h - res @=? lbsToChars x + let x = renderHamletText render h + T.pack res @=? x caseEmpty :: Assertion caseEmpty = helper "" [$hamlet||] @@ -161,50 +173,51 @@ caseTag :: Assertion caseTag = helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [$hamlet| -%p.foo - #bar baz|] +<p .foo + <#bar>baz +|] caseVar :: Assertion caseVar = do - helper "<var>" [$hamlet|$var.theArg$|] + helper "<var>" [$hamlet|#{var theArg}|] caseVarChain :: Assertion caseVarChain = do - helper "<var>" [$hamlet|$var.getArg.getArg.getArg.theArg$|] + helper "<var>" [$hamlet|#{var (getArg (getArg (getArg theArg)))}|] caseUrl :: Assertion caseUrl = do - helper (render Home []) [$hamlet|@url.theArg@|] + helper (render Home []) [$hamlet|@{url theArg}|] caseUrlChain :: Assertion caseUrlChain = do - helper (render Home []) [$hamlet|@url.getArg.getArg.getArg.theArg@|] + helper (render Home []) [$hamlet|@{url (getArg (getArg (getArg theArg)))}|] caseEmbed :: Assertion caseEmbed = do - helper "embed" [$hamlet|^embed.theArg^|] + helper "embed" [$hamlet|^{embed theArg}|] caseEmbedChain :: Assertion caseEmbedChain = do - helper "embed" [$hamlet|^embed.getArg.getArg.getArg.theArg^|] + helper "embed" [$hamlet|^{embed (getArg (getArg (getArg theArg)))}|] caseIf :: Assertion caseIf = do helper "if" [$hamlet| -$if true.theArg +$if true theArg if |] caseIfChain :: Assertion caseIfChain = do helper "if" [$hamlet| -$if true.getArg.getArg.getArg.theArg +$if true (getArg (getArg (getArg theArg))) if |] caseElse :: Assertion caseElse = helper "else" [$hamlet| -$if false.theArg +$if false theArg if $else else @@ -212,7 +225,7 @@ caseElseChain :: Assertion caseElseChain = helper "else" [$hamlet| -$if false.getArg.getArg.getArg.theArg +$if false (getArg (getArg (getArg theArg))) if $else else @@ -220,9 +233,9 @@ caseElseIf :: Assertion caseElseIf = helper "elseif" [$hamlet| -$if false.theArg +$if false theArg if -$elseif true.theArg +$elseif true theArg elseif $else else @@ -230,9 +243,9 @@ caseElseIfChain :: Assertion caseElseIfChain = helper "elseif" [$hamlet| -$if false.getArg.getArg.getArg.theArg +$if false(getArg(getArg(getArg theArg))) if -$elseif true.getArg.getArg.getArg.theArg +$elseif true(getArg(getArg(getArg theArg))) elseif $else else @@ -241,45 +254,52 @@ caseList :: Assertion caseList = do helper "xxx" [$hamlet| -$forall list.theArg _x +$forall _x <- (list theArg) x |] caseListChain :: Assertion caseListChain = do helper "urlurlurl" [$hamlet| -$forall list.getArg.getArg.getArg.getArg.getArg.theArg x - @url.x@ +$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) + @{url x} |] caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "<script></script>" [$hamlet|%script|] +caseScriptNotEmpty = helper "<script></script>" [$hamlet|<script|] caseMetaEmpty :: Assertion caseMetaEmpty = do - helper "<meta>" [$hamlet|%meta|] - helper "<meta/>" [$xhamlet|%meta|] + helper "<meta>" [$hamlet|<meta|] + helper "<meta/>" [$xhamlet|<meta|] + helper "<meta>" [$hamlet|<meta>|] + helper "<meta/>" [$xhamlet|<meta>|] caseInputEmpty :: Assertion caseInputEmpty = do - helper "<input>" [$hamlet|%input|] - helper "<input/>" [$xhamlet|%input|] + helper "<input>" [$hamlet|<input|] + helper "<input/>" [$xhamlet|<input|] + helper "<input>" [$hamlet|<input>|] + helper "<input/>" [$xhamlet|<input>|] caseMultiClass :: Assertion caseMultiClass = do - helper "<div class=\"foo bar\"></div>" [$hamlet|.foo.bar|] + helper "<div class=\"foo bar\"></div>" [$hamlet|<.foo.bar|] + helper "<div class=\"foo bar\"></div>" [$hamlet|<.foo.bar>|] caseAttribOrder :: Assertion -caseAttribOrder = helper "<meta 1 2 3>" [$hamlet|%meta!1!2!3|] +caseAttribOrder = do + helper "<meta 1 2 3>" [$hamlet|<meta 1 2 3|] + helper "<meta 1 2 3>" [$hamlet|<meta 1 2 3>|] caseNothing :: Assertion caseNothing = do helper "" [$hamlet| -$maybe nothing.theArg _n +$maybe _n <- nothing theArg nothing |] helper "nothing" [$hamlet| -$maybe nothing.theArg _n +$maybe _n <- nothing theArg something $nothing nothing @@ -287,32 +307,32 @@ caseNothingChain :: Assertion caseNothingChain = helper "" [$hamlet| -$maybe nothing.getArg.getArg.getArg.theArg n - nothing $n$ +$maybe n <- nothing(getArg(getArg(getArg theArg))) + nothing #{n} |] caseJust :: Assertion caseJust = helper "it's just" [$hamlet| -$maybe just.theArg n - it's $n$ +$maybe n <- just theArg + it's #{n} |] caseJustChain :: Assertion caseJustChain = helper "it's just" [$hamlet| -$maybe just.getArg.getArg.getArg.theArg n - it's $n$ +$maybe n <- just(getArg(getArg(getArg theArg))) + it's #{n} |] caseConstructor :: Assertion caseConstructor = do - helper "url" [$hamlet|@Home@|] - helper "suburl" [$hamlet|@Sub.SubUrl@|] + helper "url" [$hamlet|@{Home}|] + helper "suburl" [$hamlet|@{Sub SubUrl}|] let text = "<raw text>" - helper "<raw text>" [$hamlet|$preEscapedString.text$|] + helper "<raw text>" [$hamlet|#{preEscapedString text}|] caseUrlParams :: Assertion caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [$hamlet|@?urlParams.theArg@|] + helper "url?foo=bar&foo1=bar1" [$hamlet|@?{urlParams theArg}|] caseEscape :: Assertion caseEscape = do @@ -321,23 +341,29 @@ \ \ |] - helper "$@^" [$hamlet|$$@@^^|] + helper "$@^" [$hamlet|$@^|] caseEmptyStatementList :: Assertion caseEmptyStatementList = do helper "" [$hamlet|$if True|] - helper "" [$hamlet|$maybe Nothing _x|] + helper "" [$hamlet|$maybe _x <- Nothing|] let emptyList = [] - helper "" [$hamlet|$forall emptyList _x|] + helper "" [$hamlet|$forall _x <- emptyList|] caseAttribCond :: Assertion caseAttribCond = do - helper "<select></select>" [$hamlet|%select!:False:selected|] - helper "<select selected></select>" [$hamlet|%select!:True:selected|] - helper "<meta var=\"foo:bar\">" [$hamlet|%meta!var=foo:bar|] + helper "<select></select>" [$hamlet|<select :False:selected|] + helper "<select selected></select>" [$hamlet|<select :True:selected|] + helper "<meta var=\"foo:bar\">" [$hamlet|<meta var=foo:bar|] helper "<select selected></select>" - [$hamlet|%select!:true.theArg:selected|] + [$hamlet|<select :true theArg:selected|] + helper "<select></select>" [$hamlet|<select :False:selected>|] + helper "<select selected></select>" [$hamlet|<select :True:selected>|] + helper "<meta var=\"foo:bar\">" [$hamlet|<meta var=foo:bar>|] + helper "<select selected></select>" + [$hamlet|<select :true theArg:selected>|] + caseNonAscii :: Assertion caseNonAscii = do helper "עִבְרִי" [$hamlet|עִבְרִי|] @@ -345,55 +371,60 @@ caseMaybeFunction :: Assertion caseMaybeFunction = do helper "url?foo=bar&foo1=bar1" [$hamlet| -$maybe Just.urlParams x - @?x.theArg@ +$maybe x <- Just urlParams + @?{x theArg} |] caseTrailingDollarSign :: Assertion caseTrailingDollarSign = - helper "trailing space \ndollar sign $" [$hamlet|trailing space $ + helper "trailing space \ndollar sign #" [$hamlet|trailing space # \ -dollar sign $$|] +dollar sign #\ +|] caseNonLeadingPercent :: Assertion caseNonLeadingPercent = helper "<span style=\"height:100%\">foo</span>" [$hamlet| -%span!style=height:100% foo +<span style=height:100%>foo |] caseQuotedAttribs :: Assertion caseQuotedAttribs = helper "<input type=\"submit\" value=\"Submit response\">" [$hamlet| -%input!type=submit!value="Submit response" +<input type=submit value="Submit response" |] caseSpacedDerefs :: Assertion caseSpacedDerefs = do - helper "<var>" [$hamlet|$var theArg$|] - helper "<div class=\"<var>\"></div>" [$hamlet|.$var theArg$|] + helper "<var>" [$hamlet|#{var theArg}|] + helper "<div class=\"<var>\"></div>" [$hamlet|<.#{var theArg}|] caseAttribVars :: Assertion caseAttribVars = do - helper "<div id=\"<var>\"></div>" [$hamlet|#$var.theArg$|] - helper "<div class=\"<var>\"></div>" [$hamlet|.$var.theArg$|] - helper "<div f=\"<var>\"></div>" [$hamlet|!f=$var.theArg$|] + helper "<div id=\"<var>\"></div>" [$hamlet|<##{var theArg}|] + helper "<div class=\"<var>\"></div>" [$hamlet|<.#{var theArg}|] + helper "<div f=\"<var>\"></div>" [$hamlet|< f=#{var theArg}|] + helper "<div id=\"<var>\"></div>" [$hamlet|<##{var theArg}>|] + helper "<div class=\"<var>\"></div>" [$hamlet|<.#{var theArg}>|] + helper "<div f=\"<var>\"></div>" [$hamlet|< f=#{var theArg}>|] + caseStringsAndHtml :: Assertion caseStringsAndHtml = do let str = "<string>" let html = preEscapedString "<html>" - helper "<string> <html>" [$hamlet|$str$ $html$|] + helper "<string> <html>" [$hamlet|#{str} #{html}|] caseNesting :: Assertion caseNesting = do helper "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>" [$hamlet| -%table - %tbody - $forall users user - %tr - %td $user$ +<table + <tbody + $forall user <- users + <tr + <td>#{user} |] helper (concat @@ -403,10 +434,10 @@ , "</select>" ]) [$hamlet| -%select#$name$!name=$name$ - %option!:isBoolBlank.val:selected - %option!value=true!:isBoolTrue.val:selected Yes - %option!value=false!:isBoolFalse.val:selected No +<select #"#{name}" name=#{name} + <option :isBoolBlank val:selected + <option value=true :isBoolTrue val:selected>Yes + <option value=false :isBoolFalse val:selected>No |] where users = ["1", "2"] @@ -422,14 +453,14 @@ caseCurrency :: Assertion caseCurrency = - helper foo [$hamlet|$foo$|] + helper foo [$hamlet|#{foo}|] where foo = "eg: 5, $6, €7.01, £75" caseExternal :: Assertion caseExternal = do - helper "foo<br>" $ $(hamletFile "external.hamlet") - helper "foo<br/>" $ $(xhamletFile "external.hamlet") + helper "foo<br>" $(hamletFile "external.hamlet") + helper "foo<br/>" $(xhamletFile "external.hamlet") where foo = "foo" @@ -438,58 +469,59 @@ let plus = (++) x = "x" y = "y" - helper "xy" [$hamlet|$(plus x) y$|] - helper "xy" [$hamlet|$(plus.x).y$|] - helper "xxy" [$hamlet|$(plus (plus x).x).y$|] + helper "xy" [$hamlet|#{(plus x) y}|] + helper "xxy" [$hamlet|#{plus (plus x x) y}|] let alist = ["1", "2", "3"] helper "123" [$hamlet| -$forall (id id.id id.alist) x - $x$ +$forall x <- (id id id id alist) + #{x} |] caseHamletLiterals :: Assertion -caseHamletLiterals = helper "123" [$hamlet|$show.123$|] +caseHamletLiterals = do + helper "123" [$hamlet|#{show 123}|] + helper "123.456" [$hamlet|#{show 123.456}|] + helper "-123" [$hamlet|#{show -123}|] + helper "-123.456" [$hamlet|#{show -123.456}|] helper' :: String -> Html -> Assertion -helper' res h = do - let x = renderHtml h - res @=? lbsToChars x +helper' res h = T.pack res @=? renderHtmlText h caseHamlet' :: Assertion caseHamlet' = do helper' "foo" [$hamlet|foo|] helper' "foo" [$xhamlet|foo|] - helper "<br>" $ const $ [$hamlet|%br|] - helper "<br/>" $ const $ [$xhamlet|%br|] + helper "<br>" $ const $ [$hamlet|<br|] + helper "<br/>" $ const $ [$xhamlet|<br|] -- new with generalized stuff helper' "foo" [$hamlet|foo|] helper' "foo" [$xhamlet|foo|] - helper "<br>" $ const $ [$hamlet|%br|] - helper "<br/>" $ const $ [$xhamlet|%br|] + helper "<br>" $ const $ [$hamlet|<br|] + helper "<br/>" $ const $ [$xhamlet|<br|] caseHamletDebug :: Assertion caseHamletDebug = do helper "<p>foo</p>\n<p>bar</p>\n" [$hamletDebug| -%p foo -%p bar +<p>foo +<p>bar |] caseHamletRT :: Assertion caseHamletRT = do - temp <- parseHamletRT defaultHamletSettings "$var$" + temp <- parseHamletRT defaultHamletSettings "#{var}" rt <- parseHamletRT defaultHamletSettings $ unlines - [ "$baz.bar.foo$ bin $" - , "$forall list l" - , " $l$" - , "$maybe just j" - , " $j$" - , "$maybe nothing n" + [ "#{baz(bar foo)} bin #" + , "$forall l <- list" + , " #{l}" + , "$maybe j <- just" + , " #{j}" + , "$maybe n <- nothing" , "$nothing" , " nothing" - , "^template^" - , "@url@" + , "^{template}" + , "@{url}" , "$if false" , "$elseif false" , "$elseif true" @@ -497,7 +529,7 @@ , "$if false" , "$else" , " b" - , "@?urlp@" + , "@?{urlp}" ] let scope = [ (["foo", "bar", "baz"], HDHtml $ preEscapedString "foo<bar>baz") @@ -518,17 +550,17 @@ , (["false"], HDBool False) ] rend <- renderHamletRT rt scope render - lbsToChars (renderHtml rend) @?= - "foo<bar>baz bin 123justnothingvarurlaburl?foo=bar" + renderHtmlText rend @?= + T.pack "foo<bar>baz bin 123justnothingvarurlaburl?foo=bar" caseHamletFileDebugChange :: Assertion caseHamletFileDebugChange = do let foo = "foo" - writeFile "external-debug.hamlet" "$foo$ 1" + writeFile "external-debug.hamlet" "#{foo} 1" helper "foo 1" $ $(hamletFileDebug "external-debug.hamlet") - writeFile "external-debug.hamlet" "$foo$ 2" + writeFile "external-debug.hamlet" "#{foo} 2" helper "foo 2" $ $(hamletFileDebug "external-debug.hamlet") - writeFile "external-debug.hamlet" "$foo$ 1" + writeFile "external-debug.hamlet" "#{foo} 1" caseHamletFileDebugFeatures :: Assertion caseHamletFileDebugFeatures = do @@ -561,7 +593,7 @@ celper :: String -> Cassius Url -> Assertion celper res h = do let x = renderCassius render h - res @=? lbsToChars x + T.pack res @=? x caseCassius :: Assertion caseCassius = do @@ -569,20 +601,22 @@ let urlp = (Home, [("p", "q")]) flip celper [$cassius| foo - color: $colorRed$ - background: $colorBlack$ + color: #{colorRed} + background: #{colorBlack} bar: baz bin - color: $(((Color 127) 100) 5)$ + color: #{(((Color 127) 100) 5)} bar: bar unicode-test: שלום - f$var$x: someval - background-image: url(@Home@) - urlp: url(@?urlp@) + f#{var}x: someval + background-image: url(@{Home}) + urlp: url(@?{urlp}) |] $ concat - [ "foo{color:#F00;background:#000;bar:baz}" - , "bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" - , "background-image:url(url);urlp:url(url?p=q)}" + [ "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)}" ] caseCassiusFile :: Assertion @@ -590,9 +624,11 @@ let var = "var" let urlp = (Home, [("p", "q")]) flip celper $(cassiusFile "external1.cassius") $ concat - [ "foo{color:#F00;background:#000;bar:baz}" - , "bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" - , "background-image:url(url);urlp:url(url?p=q)}" + [ "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)}" ] caseCassiusFileDebug :: Assertion @@ -600,36 +636,36 @@ let var = "var" let urlp = (Home, [("p", "q")]) flip celper $(cassiusFileDebug "external1.cassius") $ concat - [ "foo{color:#F00;background:#000;bar:baz}" - , "bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" - , "background-image:url(url);urlp:url(url?p=q)}" + [ "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)}" ] caseCassiusFileDebugChange :: Assertion caseCassiusFileDebugChange = do let var = "var" - writeFile "external2.cassius" "foo\n $var$: 1" + writeFile "external2.cassius" "foo\n #{var}: 1" celper "foo{var:1}" $(cassiusFileDebug "external2.cassius") - writeFile "external2.cassius" "foo\n $var$: 2" + writeFile "external2.cassius" "foo\n #{var}: 2" celper "foo{var:2}" $(cassiusFileDebug "external2.cassius") - writeFile "external2.cassius" "foo\n $var$: 1" + writeFile "external2.cassius" "foo\n #{var}: 1" jmixin = [$julius|var x;|] jelper :: String -> Julius Url -> Assertion -jelper res h = do - let x = renderJulius render h - res @=? lbsToChars x +jelper res h = T.pack res @=? renderJulius render h caseJulius :: Assertion caseJulius = do let var = "var" let urlp = (Home, [("p", "q")]) flip jelper [$julius|שלום -%var% -@Home@ -@?urlp@ -^jmixin^ +#{var} +@{Home} +@?{urlp} +^{jmixin} |] $ intercalate "\r\n" [ "שלום" , var @@ -665,20 +701,21 @@ caseJuliusFileDebugChange :: Assertion caseJuliusFileDebugChange = do let var = "somevar" - writeFile "external2.julius" "var %var% = 1;" + writeFile "external2.julius" "var #{var} = 1;" jelper "var somevar = 1;" $(juliusFileDebug "external2.julius") - writeFile "external2.julius" "var %var% = 2;" + writeFile "external2.julius" "var #{var} = 2;" jelper "var somevar = 2;" $(juliusFileDebug "external2.julius") - writeFile "external2.julius" "var %var% = 1;" + writeFile "external2.julius" "var #{var} = 1;" caseComments :: Assertion caseComments = do + -- FIXME reconsider Hamlet comment syntax? helper "" [$hamlet|$# this is a comment $# another comment $#a third one|] - celper "" [$cassius|$# this is a comment -$# another comment -$#a third one|] + celper "" [$cassius|/* this is a comment */ +/* another comment */ +/*a third one*/|] caseDoubleForalls :: Assertion caseDoubleForalls = do @@ -703,7 +740,7 @@ caseBlankLine :: Assertion caseBlankLine = do helper "<p>foo</p>" [$hamlet| -%p +<p foo @@ -727,9 +764,9 @@ $if True $elseif False $else -$maybe Nothing x +$maybe x <- Nothing $nothing -$forall empty x +$forall x <- empty |] where empty = [] @@ -752,8 +789,96 @@ caseCassiusTrailingComments :: Assertion caseCassiusTrailingComments = do celper "h1:hover {color:green ;font-family:sans-serif}" [$cassius| - h1:hover $# Please ignore this - color: green $# This is a comment. - $# Obviously this is ignored too. + h1:hover /* Please ignore this */ + color: green /* This is a comment. */ + /* Obviously this is ignored too. */ font-family:sans-serif |] + +caseHamletAngleBrackets :: Assertion +caseHamletAngleBrackets = + helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" + [$hamlet| +<p.foo height="100" + <span #bar width=50>HELLO +|] + +caseHamletModuleNames :: Assertion +caseHamletModuleNames = + helper "oof oof 3.14 -5" + [$hamlet|#{Data.List.reverse foo} # +#{L.reverse foo} # +#{show 3.14} #{show -5}|] + where + foo = "foo" + +caseCassiusModuleNames :: Assertion +caseCassiusModuleNames = + celper "sel{bar:oof oof 3.14 -5}" + [$cassius| +sel + bar: #{Data.List.reverse foo} #{L.reverse foo} #{show 3.14} #{show -5} +|] + where + foo = "foo" + +caseJuliusModuleNames :: Assertion +caseJuliusModuleNames = + jelper "oof oof 3.14 -5" + [$julius|#{Data.List.reverse foo} #{L.reverse foo} #{show 3.14} #{show -5}|] + where + foo = "foo" + +caseSingleDollarAtCaret :: Assertion +caseSingleDollarAtCaret = do + helper "$@^" [$hamlet|$@^|] + celper "sel{att:$@^}" [$cassius| +sel + att: $@^ +|] + jelper "$@^" [$julius|$@^|] + + helper "#{@{^{" [$hamlet|#\{@\{^\{|] + celper "sel{att:#{@{^{}" [$cassius| +sel + att: #\{@\{^{ +|] + jelper "#{@{^{" [$julius|#\{@\{^\{|] + +caseDollarOperator :: Assertion +caseDollarOperator = do + let val = (1, (2, 3)) + helper "2" [$hamlet|#{ show $ fst $ snd val }|] + helper "2" [$hamlet|#{ show $ fst $ snd $ val}|] + + celper "sel{att:2}" [$cassius| +sel + att: #{ show $ fst $ snd val } +|] + celper "sel{att:2}" [$cassius| +sel + att: #{ show $ fst $ snd $ val} +|] + + jelper "2" [$julius|#{ show $ fst $ snd val }|] + jelper "2" [$julius|#{ show $ fst $ snd $ val}|] + +caseInARow :: Assertion +caseInARow = do + helper "1" [$hamlet|#{ show $ const 1 2 }|] + +caseEmbeddedSlash :: Assertion +caseEmbeddedSlash = do + helper "///" [$hamlet|///|] + celper "sel{att:///}" [$cassius| +sel + att: /// +|] + +caseStringLiterals :: Assertion +caseStringLiterals = do + helper "string" [$hamlet|#{"string"}|] + helper "string" [$hamlet|#{id "string"}|] + helper "gnirts" [$hamlet|#{L.reverse $ id "string"}|] + helper "str"ing" [$hamlet|#{"str\"ing"}|] + helper "str<ing" [$hamlet|#{"str<ing"}|]