diff --git a/Text/Cassius.hs b/Text/Cassius.hs new file mode 100644 --- /dev/null +++ b/Text/Cassius.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +module Text.Cassius + ( Cassius + , Css (..) + , renderCassius + , CassiusMixin + , cassiusMixin + , cassius + , Color (..) + , colorRed + , colorBlack + , cassiusFile + , cassiusFileDebug + ) where + +import Text.ParserCombinators.Parsec hiding (Line) +import Data.Neither (AEither (..), either) +import Data.Traversable (sequenceA) +import Control.Applicative ((<$>)) +import Data.List (intercalate) +import Data.Char (isUpper, isDigit) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Text.Blaze.Builder.Core (Builder, fromByteString, toLazyByteString) +import Text.Blaze.Builder.Utf8 (fromString) +import Data.Maybe (catMaybes) +import Prelude hiding (either) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Data.Word (Word8) +import Data.Bits +import System.IO.Unsafe (unsafePerformIO) + +data Color = Color Word8 Word8 Word8 + deriving Show +instance ToCss Color where + toCss (Color r g b) = + let (r1, r2) = toHex r + (g1, g2) = toHex g + (b1, b2) = toHex b + in '#' : + if r1 == r2 && g1 == g2 && b1 == b2 + then [r1, g1, b1] + else [r1, r2, g1, g2, b1, b2] + where + toHex :: Word8 -> (Char, Char) + toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15) + toChar :: Word8 -> Char + toChar c + | c < 10 = mkChar c 0 '0' + | otherwise = mkChar c 10 'A' + mkChar :: Word8 -> Word8 -> Char -> Char + mkChar a b' c = + toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c) + +colorRed :: Color +colorRed = Color 255 0 0 + +colorBlack :: Color +colorBlack = Color 0 0 0 + +renderCss :: Css -> L.ByteString +renderCss (Css b) = toLazyByteString b + +renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> L.ByteString +renderCassius r s = renderCss $ s r + +newtype Css = Css Builder + deriving Monoid +type Cassius url = (url -> [(String, String)] -> String) -> Css + +class ToCss a where + toCss :: a -> String +instance ToCss [Char] where toCss = id + +data ContentPair = CPSimple Contents Contents + | CPMixin Deref + deriving Show +contentPairToContents :: ContentPair -> Contents +contentPairToContents (CPSimple x y) = concat [x, ContentRaw ":" : y] +contentPairToContents (CPMixin deref) = [ContentMix deref] + +data FlatDec = FlatDec Contents [ContentPair] + deriving Show + +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' + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Deref + | ContentUrlParam Deref + | ContentMix Deref + deriving Show +type Contents = [Content] + +data DecS = Attrib Contents Contents + | Block Contents [DecS] + | MixinDec Deref + deriving Show + +data Line = LinePair Contents Contents + | LineSingle Contents + | LineMix Deref + deriving Show + +data Nest = Nest Line [Nest] + deriving Show + +parseLines :: Parser [(Int, Line)] +parseLines = fmap (catMaybes) + $ many (parseEmptyLine <|> try parseComment <|> parseLine) + +eol :: Parser () +eol = + (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + +parseEmptyLine :: Parser (Maybe (Int, Line)) +parseEmptyLine = eol >> return Nothing + +parseComment :: Parser (Maybe (Int, Line)) +parseComment = do + _ <- many $ oneOf " \t" + _ <- string "$#" + _ <- many $ noneOf "\r\n" + eol <|> return () + return Nothing + +parseLine :: Parser (Maybe (Int, Line)) +parseLine = do + ss <- fmap sum $ many ((char ' ' >> return 1) <|> + (char '\t' >> return 4)) + x <- parseLineMix <|> do + key' <- many1 $ parseContent False + let key = trim key' + parsePair key <|> return (LineSingle key) + eol <|> eof + return $ Just (ss, x) + where + parseLineMix = do + _ <- char '^' + d <- parseDeref + _ <- char '^' + return $ LineMix d + parsePair key = do + _ <- try $ string ": " + _ <- spaces + val <- many1 $ parseContent True + return $ LinePair key $ trim val + --trim = reverse . dropWhile isSpace . reverse + trim = id -- FIXME + +parseContent :: Bool -> Parser Content +parseContent allowColon = do + (char '$' >> (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 + +parseDeref :: Parser Deref +parseDeref = + deref + 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 '\'') + +nestLines :: [(Int, Line)] -> [Nest] +nestLines [] = [] +nestLines ((i, l):rest) = + let (deeper, rest') = span (\(i', _) -> i' > i) rest + in Nest l (nestLines deeper) : nestLines rest' + +nestToDec :: Bool -> Nest -> AEither [String] DecS +nestToDec _ (Nest LineMix{} (_:_)) = + ALeft ["Mixins may not have nested content"] +nestToDec True (Nest LineMix{} []) = + ALeft ["Cannot have LineMix at top level"] +nestToDec False (Nest (LineMix deref) []) = + ARight $ MixinDec deref +nestToDec _ (Nest LinePair{} (_:_)) = + ALeft ["Only LineSingle may have nested content"] +nestToDec _ (Nest LineSingle{} []) = + ALeft ["A LineSingle must have nested content"] +nestToDec True (Nest LinePair{} _) = + ALeft ["Cannot have a LinePair at top level"] +nestToDec _ (Nest (LineSingle name) nests) = + Block name <$> sequenceA (map (nestToDec False) nests) +nestToDec _ (Nest (LinePair key val) []) = ARight $ Attrib key val + +flatDec :: DecS -> [FlatDec] +flatDec Attrib{} = error "flatDec Attrib" +flatDec MixinDec{} = error "flatDec MixinDec" +flatDec (Block name decs) = + let as = concatMap getAttrib decs + bs = concatMap getBlock decs + a = case as of + [] -> id + _ -> (:) (FlatDec name as) + b = concatMap flatDec bs + in a b + where + getAttrib (Attrib x y) = [CPSimple x y] + getAttrib (MixinDec d) = [CPMixin d] + getAttrib Block{} = [] + getBlock (Block n d) = [Block (concat [name, ContentRaw " " : n]) d] + getBlock _ = [] + +render :: FlatDec -> Contents +render (FlatDec 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 + +contentsToCassius :: [Content] -> Q Exp +contentsToCassius 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 + +cassiusMixin :: QuasiQuoter +cassiusMixin = + QuasiQuoter e p + where + p = error "cassiusMixin quasi-quoter for patterns does not exist" + e s = do + let a = either (error . show) id + $ parse parseLines s s + let b = flip map a $ \(_, l) -> + case l of + LinePair x y -> CPSimple x y + LineMix deref -> CPMixin deref + LineSingle _ -> error "Mixins cannot contain singles" + d <- contentsToCassius + $ intercalate [ContentRaw ";"] + $ map contentPairToContents b + sm <- [|CassiusMixin|] + return $ sm `AppE` d + +newtype CassiusMixin url = CassiusMixin { unCassiusMixin :: Cassius url } + +cassius :: QuasiQuoter +cassius = + QuasiQuoter cassiusFromString p + where + p = error "cassius quasi-quoter for patterns does not exist" + +cassiusFromString :: String -> Q Exp +cassiusFromString s = do + let a = either (error . show) id $ parse parseLines s s + let b = either (error . unlines) id + $ sequenceA $ map (nestToDec True) $ nestLines a + contentsToCassius $ concatMap render $ concatMap flatDec b + +contentToCss :: Name -> Content -> Q Exp +contentToCss _ (ContentRaw s') = do + let d = S8.unpack $ BSU.fromString 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) +contentToCss r (ContentMix d) = do + un <- [|unCassiusMixin|] + return $ un `AppE` 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 + +cassiusFile :: FilePath -> Q Exp +cassiusFile fp = do + contents <- fmap BSU.toString $ qRunIO $ S8.readFile fp + cassiusFromString contents + +data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin + +getVars :: Line -> [(Deref, VarType)] +getVars (LinePair x y) = concatMap getVars' $ x ++ y +getVars (LineSingle x) = concatMap getVars' x +getVars (LineMix x) = [(x, VTMixin)] + +getVars' :: Content -> [(Deref, VarType)] +getVars' ContentRaw{} = [] +getVars' (ContentVar d) = [(d, VTPlain)] +getVars' (ContentUrl d) = [(d, VTUrl)] +getVars' (ContentUrlParam d) = [(d, VTUrlParam)] +getVars' (ContentMix d) = [(d, VTMixin)] + +data CDData url = CDPlain String + | CDUrl url + | CDUrlParam (url, [(String, String)]) + | CDMixin (CassiusMixin url) + +vtToExp :: (Deref, VarType) -> Q Exp +vtToExp (d, vt) = do + d' <- lift d + c' <- c vt + return $ TupE [d', c' `AppE` derefToExp d] + where + c VTPlain = [|CDPlain . toCss|] + c VTUrl = [|CDUrl|] + c VTUrlParam = [|CDUrlParam|] + c VTMixin = [|CDMixin|] + +cassiusFileDebug :: FilePath -> Q Exp +cassiusFileDebug fp = do + s <- fmap BSU.toString $ qRunIO $ S8.readFile fp + let a = either (error . show) id $ parse parseLines s s + b = concatMap (getVars . snd) a + c <- mapM vtToExp b + cr <- [|cassiusRuntime|] + return $ cr `AppE` (LitE $ StringL fp) `AppE` ListE c + +cassiusRuntime :: FilePath -> [(Deref, CDData url)] -> Cassius url +cassiusRuntime fp cd render' = unsafePerformIO $ do + s <- fmap BSU.toString $ qRunIO $ S8.readFile fp + let a = either (error . show) id $ parse parseLines s s + let b = either (error . unlines) id + $ sequenceA $ map (nestToDec True) $ nestLines a + return $ mconcat $ map go $ concatMap render $ concatMap flatDec b + where + go :: Content -> Css + go (ContentRaw s) = Css $ fromString s + go (ContentVar d) = + case lookup d cd of + Just (CDPlain s) -> Css $ fromString s + _ -> error $ show d ++ ": expected CDPlain" + go (ContentUrl d) = + case lookup d cd of + Just (CDUrl u) -> Css $ fromString $ render' u [] + _ -> error $ show d ++ ": expected CDUrl" + go (ContentUrlParam d) = + case lookup d cd of + Just (CDUrlParam (u, p)) -> + Css $ fromString $ render' u p + _ -> error $ show d ++ ": expected CDUrlParam" + go (ContentMix d) = + case lookup d cd of + Just (CDMixin (CassiusMixin m)) -> m render' + _ -> error $ show d ++ ": expected CDMixin" diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Text.Hamlet ( -- * Basic quasiquoters hamlet @@ -8,6 +9,7 @@ -- * Load from external file , hamletFile , xhamletFile + , hamletFileDebug -- * Customized settings , hamletWithSettings , hamletFileWithSettings @@ -15,8 +17,10 @@ , defaultHamletSettings , xhtmlHamletSettings -- * Datatypes - , Html + , Html (..) , Hamlet + -- * Typeclass + , ToHtml (..) -- * Construction/rendering , renderHamlet , renderHtml @@ -35,22 +39,35 @@ import Text.Hamlet.Parse import Text.Hamlet.Quasi import Text.Hamlet.RT -import Text.Blaze +import Text.Hamlet.Debug +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Monoid (mappend) - --- | An function generating an 'Html' given a URL-rendering function. -type Hamlet url = (url -> String) -> Html () +import Text.Blaze.Builder.Core (toLazyByteString, fromByteString) +import Text.Blaze.Builder.Html (fromHtmlEscapedString) +import Text.Blaze.Builder.Utf8 (fromString) -- | Converts a 'Hamlet' to lazy bytestring. -renderHamlet :: (url -> String) -> Hamlet url -> L.ByteString +renderHamlet :: (url -> [(String, String)] -> String) -> Hamlet url -> L.ByteString renderHamlet render h = renderHtml $ h render +renderHtml :: Html -> L.ByteString +renderHtml (Html h) = toLazyByteString h + -- | Wrap an 'Html' for embedding in an XML file. -cdata :: Html () -> Html () +cdata :: Html -> Html cdata h = - preEscapedString "" + Html (fromByteString "]]>") + +preEscapedString :: String -> Html +preEscapedString = Html . fromString + +string :: String -> Html +string = Html . fromHtmlEscapedString + +unsafeByteString :: S.ByteString -> Html +unsafeByteString = Html . fromByteString diff --git a/Text/Hamlet/Debug.hs b/Text/Hamlet/Debug.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/Debug.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TemplateHaskell #-} +module Text.Hamlet.Debug + ( hamletFileDebug + ) where + +import Text.Hamlet.Parse +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 qualified Data.ByteString.UTF8 as BSU +import Control.Arrow +import Data.Either +import Control.Monad (forM) + +unsafeRenderTemplate :: FilePath -> HamletMap url + -> (url -> [(String, String)] -> String) -> Html +unsafeRenderTemplate fp hd render = unsafePerformIO $ do + contents <- fmap BSU.toString $ S8.readFile fp + temp <- parseHamletRT defaultHamletSettings contents + renderHamletRT' True temp hd render + +hamletFileDebug :: FilePath -> Q Exp +hamletFileDebug fp = do + contents <- fmap BSU.toString $ qRunIO $ S8.readFile fp + HamletRT docs <- qRunIO $ parseHamletRT defaultHamletSettings contents + urt <- [|unsafeRenderTemplate|] + render <- newName "render" + let hd = combineDVals $ concatMap getHD docs + hd' <- liftDVals (VarE render) hd + let h = urt `AppE` LitE (StringL fp) `AppE` hd' `AppE` VarE render + return $ LamE [VarP render] h + +derefToExp :: [Exp] -> Exp +derefToExp = foldr1 AppE . reverse + +type DVal = ([Exp], DVal') +data DVal' = DHtml + | DUrl + | DUrlParam + | DTemplate + | DBool + | DMaybe [([String], DVal)] + | DList [([String], DVal)] + deriving (Show, Eq) + +liftDVals :: Exp -> [([String], DVal)] -> Q Exp +liftDVals render pairs = do + pairs' <- forM pairs $ \(k, d) -> do + let k' = ListE $ map (LitE . StringL) k + d' <- liftDVal render d + return $ TupE [k', d'] + return $ ListE pairs' + +liftDVal :: Exp -> DVal -> Q Exp +liftDVal _ (x, DHtml) = do + f <- [|HDHtml . toHtml|] + return $ f `AppE` derefToExp x +liftDVal _ (x, DUrl) = do + f <- [|HDUrl|] + return $ f `AppE` derefToExp x +liftDVal _ (x, DUrlParam) = do + f <- [|uncurry HDUrlParams|] + return $ f `AppE` derefToExp x +liftDVal render (x, DTemplate) = do + f <- [|HDHtml|] + return $ f `AppE` (derefToExp x `AppE` render) +liftDVal _ (x, DBool) = do + f <- [|HDBool|] + return $ f `AppE` derefToExp x +liftDVal render (x, DMaybe each) = do + var <- newName "_var" + each' <- liftDVals render $ map (second $ replaceFirst $ VarE var) each + let each'' = LamE [VarP var] each' + hdlist <- [|HDMaybe|] + map' <- [|fmap|] + return $ hdlist `AppE` (map' `AppE` each'' `AppE` derefToExp x) +liftDVal render (x, DList each) = do + var <- newName "_var" + each' <- liftDVals render $ map (second $ replaceFirst $ VarE var) each + let each'' = LamE [VarP var] each' + hdlist <- [|HDList|] + map' <- [|map|] + return $ hdlist `AppE` (map' `AppE` each'' `AppE` derefToExp x) + +combineDVals :: [([String], DVal)] -> [([String], DVal)] +combineDVals [] = [] +combineDVals ((x1, y1):rest) = + case matches of + [] -> (x1, y1) : combineDVals rest + ys -> (x1, foldr combine' y1 ys) : combineDVals nomatch + where + matches = map snd $ filter (\(x, _) -> x == x1) rest + nomatch = filter (\(x, _) -> x /= x1) rest + combine' (a, x) (b, y) + | a == b = (a, combine x y) + | otherwise = error $ "Bad parameters to combine': " ++ show ((a, x), (b, y)) + combine (DList x) (DList y) = DList $ combineDVals $ x ++ y + combine (DMaybe x) (DMaybe y) = DMaybe $ combineDVals $ x ++ y + combine x y + | x == y = x + combine x y = error $ "Bad parameters to combine: " ++ show (x, y) + +varNames :: [String] -> [Exp] +varNames = map $ varName [] +getHD :: SimpleDoc -> [([String], DVal)] +getHD SDRaw{} = [] +getHD (SDVar x) = [(x, (varNames x, DHtml))] +getHD (SDUrl hasParams x) = + [(x, (varNames x, if hasParams then DUrlParam else DUrl))] +getHD (SDTemplate x) = [(x, (varNames x, DTemplate))] +getHD (SDCond xs edocs) = + let hd = concatMap getHD $ edocs ++ concatMap snd xs + bools = map (\(x, _) -> (x, (varNames x, DBool))) xs + in hd ++ bools +getHD (SDMaybe x y docs ndocs) = + (x, (varNames x, DMaybe subs)) : tops ++ ntops + where + hd = concatMap getHD docs + (tops, subs) = partitionEithers $ map go hd + ntops = concatMap getHD ndocs + go (a@(y':rest), e) + | y == y' = Right (rest, e) + | otherwise = Left (a, e) + go ([], _) = error "getHD of SDMaybe" +getHD (SDForall x y docs) = + (x, (varNames x, DList subs)) : tops + where + hd = concatMap getHD docs + (tops, subs) = partitionEithers $ map go hd + go (a@(y':rest), e) + | y == y' = Right (rest, e) + | otherwise = Left (a, e) + go ([], _) = error "getHD of SDForall" + +replaceFirst :: Exp -> DVal -> DVal +replaceFirst x (_:y, z) = (x:y, z) +replaceFirst _ _ = error "replaceFirst on something empty" diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -71,6 +71,7 @@ ss <- fmap sum $ many ((char ' ' >> return 1) <|> (char '\t' >> return 4)) x <- doctype <|> + comment <|> backslash <|> try controlIf <|> try controlElseIf <|> @@ -90,8 +91,13 @@ eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol' doctype = do - string "!!!" >> eol + 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"])) @@ -125,7 +131,7 @@ eol return $ LineForall x y tag = do - x <- tagName <|> tagIdent <|> tagClass + x <- tagName <|> tagIdent <|> tagClass <|> tagAttrib xs <- many $ tagIdent <|> tagClass <|> tagAttrib c <- (eol >> return []) <|> (do _ <- many1 $ oneOf " \t" diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs --- a/Text/Hamlet/Quasi.hs +++ b/Text/Hamlet/Quasi.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Hamlet.Quasi ( hamlet , xhamlet @@ -12,25 +13,34 @@ , hamletFile , xhamletFile , hamletFileWithSettings - , showParams + , ToHtml (..) + , varName + , Html (..) + , Hamlet ) where import Text.Hamlet.Parse import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote -import Data.Char (isUpper) +import Data.Char (isUpper, isDigit) import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 -import Data.Monoid (mconcat, mappend, mempty) -import Text.Blaze (unsafeByteString, Html, string) -import Data.List (intercalate) +import Data.Monoid (Monoid (..)) +import Text.Blaze.Builder.Core (Builder, fromByteString, toLazyByteString) +import Text.Blaze.Builder.Html (fromHtmlEscapedString) +import Data.Maybe (fromMaybe) +import Data.String +instance IsString Html where + fromString = Html . fromHtmlEscapedString + class ToHtml a where - toHtml :: a -> Html () + toHtml :: a -> Html instance ToHtml String where - toHtml = string -instance ToHtml (Html a) where - toHtml x = x >> return () + toHtml = Html . fromHtmlEscapedString +instance ToHtml Html where + toHtml = id type Scope = [(Ident, Exp)] @@ -38,16 +48,13 @@ docsToExp render scope docs = do exps <- mapM (docToExp render scope) docs me <- [|mempty|] + ma <- [|mappend|] + let ma' x y = InfixE (Just x) ma $ Just y return $ case exps of [] -> me [x] -> x - _ -> - let x = init exps - y = last exps - x' = map (BindS WildP) x - y' = NoBindS y - in DoE $ x' ++ [y'] + _ -> foldr1 ma' exps docToExp :: Exp -> Scope -> Doc -> Q Exp docToExp render scope (DocForall list ident@(Ident name) inside) = do @@ -92,14 +99,16 @@ contentToExp :: Exp -> Scope -> Content -> Q Exp contentToExp _ _ (ContentRaw s) = do - os <- [|unsafeByteString . S8.pack|] + os <- [|Html . fromByteString . S8.pack|] let s' = LitE $ StringL $ S8.unpack $ BSU.fromString s return $ os `AppE` s' contentToExp _ scope (ContentVar d) = do str <- [|toHtml|] return $ str `AppE` deref scope d contentToExp render scope (ContentUrl hasParams d) = do - ou <- if hasParams then [|outputUrlParams|] else [|outputUrl|] + ou <- if hasParams + then [|\r (u, p) -> Html $ fromHtmlEscapedString $ r u p|] + else [|\r u -> Html $ fromHtmlEscapedString $ r u []|] let d' = deref scope d return $ ou `AppE` render `AppE` d' contentToExp render scope (ContentEmbed d) = do @@ -176,23 +185,25 @@ in x' `AppE` y' deref scope (DerefLeaf d@(Ident dName)) = case lookup d scope of - Nothing -> varName dName + Nothing -> varName scope dName Just exp' -> exp' - where - varName "" = error "Illegal empty varName" - varName v@(s:_) = - case lookup (Ident v) scope of - Just e -> e - Nothing -> - if isUpper s - then ConE $ mkName v - else VarE $ mkName v +varName :: Scope -> String -> Exp +varName _ "" = error "Illegal empty varName" +varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope + +strToExp :: String -> Exp +strToExp s@(c:_) + | all isDigit s = LitE $ IntegerL $ read s + | isUpper c = ConE $ mkName s + | otherwise = VarE $ mkName s +strToExp "" = error "strToExp on empty string" + -- | Checks for truth in the left value in each pair in the first argument. If -- a true exists, then the corresponding right action is performed. Only the -- first is performed. In there are no true values, then the second argument is -- performed, if supplied. -condH :: [(Bool, Html ())] -> Maybe (Html ()) -> Html () +condH :: [(Bool, Html)] -> Maybe Html -> Html condH [] Nothing = mempty condH [] (Just x) = x condH ((True, y):_) _ = y @@ -200,50 +211,17 @@ -- | Runs the second argument with the value in the first, if available. -- Otherwise, runs the third argument, if available. -maybeH :: Maybe v -> (v -> Html ()) -> Maybe (Html ()) -> Html () +maybeH :: Maybe v -> (v -> Html) -> Maybe Html -> Html maybeH Nothing _ Nothing = mempty maybeH Nothing _ (Just x) = x maybeH (Just v) f _ = f v --- | Uses the URL rendering function to convert the given URL to a 'String' and --- then calls 'outputString'. -outputUrl :: (url -> String) -> url -> Html () -outputUrl render u = string $ render u - --- | Same as 'outputUrl', but appends a query-string with given keys and --- values. -outputUrlParams :: (url -> String) -> (url, [(String, String)]) -> Html () -outputUrlParams render (u, []) = outputUrl render u -outputUrlParams render (u, params) = mappend - (outputUrl render u) - (string $ showParams params) - -showParams :: [(String, String)] -> String -showParams z = - '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar +newtype Html = Html Builder + deriving Monoid +instance Show Html where + show (Html b) = show $ BSLU.toString $ toLazyByteString b +instance Eq Html where + (Html a) == (Html b) = toLazyByteString a == toLazyByteString b --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] +-- | An function generating an 'Html' given a URL-rendering function. +type Hamlet url = (url -> [(String, String)] -> String) -> Html diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -6,9 +6,11 @@ ( -- * Public API HamletRT (..) , HamletData (..) + , HamletMap , HamletException (..) , parseHamletRT , renderHamletRT + , renderHamletRT' , SimpleDoc (..) ) where @@ -17,20 +19,22 @@ import Control.Exception (Exception) import Data.Typeable (Typeable) import Control.Failure -import Text.Blaze import Text.Hamlet.Parse -import Text.Hamlet.Quasi (showParams) +import Text.Hamlet.Quasi (Html (..)) import Data.List (intercalate) +import Text.Blaze.Builder.Utf8 (fromString) -data HamletData url = HDHtml (Html ()) - | HDUrl url - | HDUrlParams url [(String, String)] - | HDTemplate HamletRT - | HDBool Bool - | HDMaybe (Maybe (HamletData url)) - | HDList [HamletData url] - | HDMap [(String, HamletData url)] +type HamletMap url = [([String], HamletData url)] +data HamletData url + = HDHtml Html + | HDUrl url + | HDUrlParams url [(String, String)] + | HDTemplate HamletRT + | HDBool Bool + | HDMaybe (Maybe (HamletMap url)) + | HDList [HamletMap url] + data SimpleDoc = SDRaw String | SDVar [String] | SDUrl Bool [String] @@ -85,67 +89,82 @@ flattenDeref _ (DerefLeaf (Ident x)) = return [x] flattenDeref orig (DerefBranch (DerefLeaf (Ident x)) y) = do y' <- flattenDeref orig y - return $ x : y' + return $ y' ++ [x] flattenDeref orig _ = failure $ HamletUnsupportedDocException orig renderHamletRT :: Failure HamletException m => HamletRT - -> HamletData url - -> (url -> String) - -> m (Html ()) -renderHamletRT (HamletRT docs) (HDMap scope0) renderUrl = + -> HamletMap url + -> (url -> [(String, String)] -> String) + -> m Html +renderHamletRT = renderHamletRT' False + +renderHamletRT' :: Failure HamletException m + => Bool + -> HamletRT + -> HamletMap url + -> (url -> [(String, String)] -> String) + -> m Html +renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = liftM mconcat $ mapM (go scope0) docs where - go _ (SDRaw s) = return $ preEscapedString s + go _ (SDRaw s) = return $ Html $ fromString s go scope (SDVar n) = do - v <- lookup' n n $ HDMap scope + v <- lookup' n n scope case v of HDHtml h -> return h - _ -> fa $ intercalate "." n ++ ": expected HDHtml" + _ -> fa $ showName n ++ ": expected HDHtml" go scope (SDUrl p n) = do - v <- lookup' n n $ HDMap scope + v <- lookup' n n scope case (p, v) of - (False, HDUrl u) -> return $ preEscapedString $ renderUrl u + (False, HDUrl u) -> return $ Html $ fromString $ renderUrl u [] (True, HDUrlParams u q) -> - return $ preEscapedString $ renderUrl u ++ showParams q - (False, _) -> fa $ intercalate "." n ++ ": expected HDUrl" - (True, _) -> fa $ intercalate "." n ++ ": expected HDUrlParams" + return $ Html $ fromString $ renderUrl u q + (False, _) -> fa $ showName n ++ ": expected HDUrl" + (True, _) -> fa $ showName n ++ ": expected HDUrlParams" go scope (SDTemplate n) = do - v <- lookup' n n $ HDMap scope - case v of - HDTemplate h -> renderHamletRT h (HDMap scope) renderUrl - _ -> fa $ intercalate "." n ++ ": expected HDTemplate" + v <- lookup' n n scope + case (tempAsHtml, v) of + (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl + (False, _) -> fa $ showName n ++ ": expected HDTemplate" + (True, HDHtml h) -> return h + (True, _) -> fa $ showName n ++ ": expected HDHtml" go scope (SDForall n ident docs') = do - v <- lookup' n n $ HDMap scope + v <- lookup' n n scope case v of - HDList os -> do + HDList os -> liftM mconcat $ forM os $ \o -> do - let scope' = HDMap $ (ident, o) : scope - renderHamletRT (HamletRT docs') scope' renderUrl - _ -> fa $ intercalate "." n ++ ": expected HDList" + let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope + renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl + _ -> fa $ showName n ++ ": expected HDList" go scope (SDMaybe n ident jdocs ndocs) = do - v <- lookup' n n $ HDMap scope + v <- lookup' n n scope (scope', docs') <- case v of HDMaybe Nothing -> return (scope, ndocs) - HDMaybe (Just o) -> return ((ident, o) : scope, jdocs) - _ -> fa $ intercalate "." n ++ ": expected HDMaybe" - renderHamletRT (HamletRT docs') (HDMap scope') renderUrl + HDMaybe (Just o) -> do + let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope + return (scope', jdocs) + _ -> fa $ showName n ++ ": expected HDMaybe" + renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl go scope (SDCond [] docs') = - renderHamletRT (HamletRT docs') (HDMap scope) renderUrl + renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl go scope (SDCond ((b, docs'):cs) els) = do - v <- lookup' b b $ HDMap scope + v <- lookup' b b scope case v of HDBool True -> - renderHamletRT (HamletRT docs') (HDMap scope) renderUrl + renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl HDBool False -> go scope (SDCond cs els) - _ -> fa $ intercalate "." b ++ ": expected HDBool" - lookup' _ [] x = return x - lookup' orig (n:ns) (HDMap m) = - case lookup n m of - Nothing -> fa $ intercalate "." orig ++ " not found" - Just o -> lookup' orig ns o - lookup' orig _ _ = fa $ intercalate "." orig ++ ": unexpected type" - fa = failure . HamletRenderException -renderHamletRT _ _ _ = - failure $ HamletRenderException "renderHamletRT must be given a HDMap" + _ -> fa $ showName b ++ ": expected HDBool" + lookup' :: Failure HamletException m + => [String] -> [String] -> HamletMap url -> m (HamletData url) + lookup' orig k m = + case lookup k m of + Nothing -> fa $ showName orig ++ ": not found" + Just x -> return x + +fa :: Failure HamletException m => String -> m a +fa = failure . HamletRenderException + +showName :: [String] -> String +showName = intercalate "." . reverse diff --git a/Text/Julius.hs b/Text/Julius.hs new file mode 100644 --- /dev/null +++ b/Text/Julius.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +module Text.Julius + ( Julius + , Javascript (..) + , renderJulius + , julius + , juliusFile + , juliusFileDebug + ) where + +import Text.ParserCombinators.Parsec hiding (Line) +import Data.Char (isUpper, isDigit) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Text.Blaze.Builder.Core (Builder, fromByteString, toLazyByteString) +import Text.Blaze.Builder.Utf8 (fromString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import System.IO.Unsafe (unsafePerformIO) + +renderJavascript :: Javascript -> L.ByteString +renderJavascript (Javascript b) = toLazyByteString b + +renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> L.ByteString +renderJulius r s = renderJavascript $ s r + +newtype Javascript = Javascript Builder + deriving Monoid +type Julius url = (url -> [(String, String)] -> String) -> Javascript + +class ToJavascript a where + toJavascript :: a -> String +instance ToJavascript [Char] where toJavascript = id + +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' + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Deref + | ContentUrlParam Deref + | ContentMix Deref + deriving Show +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 + 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 '\'') + +compressContents :: Contents -> Contents +compressContents [] = [] +compressContents (ContentRaw x:ContentRaw y:z) = + compressContents $ ContentRaw (x ++ y) : z +compressContents (x:y) = x : compressContents y + +contentsToJulius :: [Content] -> Q Exp +contentsToJulius a = do + r <- newName "_render" + c <- mapM (contentToJavascript r) $ compressContents a + d <- case c of + [] -> [|mempty|] + [x] -> return x + _ -> do + mc <- [|mconcat|] + return $ mc `AppE` ListE c + return $ LamE [VarP r] d + +julius :: QuasiQuoter +julius = + QuasiQuoter juliusFromString p + where + p = error "julius quasi-quoter for patterns does not exist" + +juliusFromString :: String -> Q Exp +juliusFromString s = do + let a = either (error . show) id $ parse parseContents s s + contentsToJulius a + +contentToJavascript :: Name -> Content -> Q Exp +contentToJavascript _ (ContentRaw s') = do + let d = S8.unpack $ BSU.fromString s' + ts <- [|Javascript . fromByteString . S8.pack|] + return $ ts `AppE` LitE (StringL d) +contentToJavascript _ (ContentVar d) = do + ts <- [|Javascript . fromString . toJavascript|] + return $ ts `AppE` derefToExp d +contentToJavascript r (ContentUrl d) = do + ts <- [|Javascript . fromString|] + return $ ts `AppE` (VarE r `AppE` derefToExp d `AppE` ListE []) +contentToJavascript r (ContentUrlParam d) = do + ts <- [|Javascript . fromString|] + up <- [|\r' (u, p) -> r' u p|] + 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 + +juliusFile :: FilePath -> Q Exp +juliusFile fp = do + contents <- fmap BSU.toString $ qRunIO $ S8.readFile fp + juliusFromString contents + +data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin + +getVars :: Content -> [(Deref, VarType)] +getVars ContentRaw{} = [] +getVars (ContentVar d) = [(d, VTPlain)] +getVars (ContentUrl d) = [(d, VTUrl)] +getVars (ContentUrlParam d) = [(d, VTUrlParam)] +getVars (ContentMix d) = [(d, VTMixin)] + +data JDData url = JDPlain String + | JDUrl url + | JDUrlParam (url, [(String, String)]) + | JDMixin (Julius url) + +vtToExp :: (Deref, VarType) -> Q Exp +vtToExp (d, vt) = do + d' <- lift d + c' <- c vt + return $ TupE [d', c' `AppE` derefToExp d] + where + c VTPlain = [|JDPlain . toJavascript|] + c VTUrl = [|JDUrl|] + c VTUrlParam = [|JDUrlParam|] + c VTMixin = [|JDMixin|] + +juliusFileDebug :: FilePath -> Q Exp +juliusFileDebug fp = do + s <- fmap BSU.toString $ qRunIO $ S8.readFile fp + let a = either (error . show) id $ parse parseContents s s + b = concatMap getVars a + c <- mapM vtToExp b + cr <- [|juliusRuntime|] + return $ cr `AppE` (LitE $ StringL fp) `AppE` ListE c + +juliusRuntime :: FilePath -> [(Deref, JDData url)] -> Julius url +juliusRuntime fp cd render' = unsafePerformIO $ do + s <- fmap BSU.toString $ qRunIO $ S8.readFile 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 (ContentVar d) = + case lookup d cd of + Just (JDPlain s) -> Javascript $ fromString s + _ -> error $ show d ++ ": expected JDPlain" + go (ContentUrl d) = + case lookup d cd of + Just (JDUrl u) -> Javascript $ fromString $ render' u [] + _ -> error $ show d ++ ": expected JDUrl" + go (ContentUrlParam d) = + case lookup d cd of + Just (JDUrlParam (u, p)) -> + Javascript $ fromString $ render' u p + _ -> error $ show d ++ ": expected JDUrlParam" + go (ContentMix d) = + case lookup d cd of + Just (JDMixin m) -> m render' + _ -> error $ show d ++ ": expected JDMixin" diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.4.2 +version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -43,13 +43,17 @@ bytestring >= 0.9 && < 0.10, utf8-string >= 0.3.4 && < 0.4, template-haskell, - blaze-html >= 0.1.1 && < 0.2, + blaze-builder >= 0.1 && < 0.2, + neither >= 0.0.1 && < 0.1, parsec >= 2 && < 4, failure >= 0.1.0 && < 0.2 exposed-modules: Text.Hamlet Text.Hamlet.RT + Text.Cassius + Text.Julius other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi + Text.Hamlet.Debug ghc-options: -Wall executable runtests diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -5,7 +5,10 @@ import Test.HUnit hiding (Test) import Text.Hamlet +import Text.Cassius +import Text.Julius import Data.ByteString.Lazy.UTF8 (toString) +import Data.List (intercalate) main :: IO () main = defaultMain [testSuite] @@ -56,20 +59,66 @@ , testCase "currency symbols" caseCurrency , testCase "external" caseExternal , testCase "parens" caseParens + , testCase "hamlet literals"caseHamletLiterals , testCase "hamlet' and xhamlet'" caseHamlet' , testCase "hamletDebug" caseHamletDebug , testCase "hamlet runtime" caseHamletRT + , testCase "hamletFileDebug- changing file" caseHamletFileDebugChange + , testCase "hamletFileDebug- features" caseHamletFileDebugFeatures + , testCase "cassius" caseCassius + , testCase "cassiusFile" caseCassiusFile + , testCase "cassiusFileDebug" caseCassiusFileDebug + , testCase "cassiusFileDebugChange" caseCassiusFileDebugChange + , testCase "julius" caseJulius + , testCase "juliusFile" caseJuliusFile + , testCase "juliusFileDebug" caseJuliusFileDebug + , testCase "juliusFileDebugChange" caseJuliusFileDebugChange + , testCase "comments" caseComments + , testCase "hamletFileDebug double foralls" caseDoubleForalls + , testCase "cassius pseudo-class" casePseudo + , testCase "different binding names" caseDiffBindNames ] data Url = Home | Sub SubUrl data SubUrl = SubUrl -render :: Url -> String -render Home = "url" -render (Sub SubUrl) = "suburl" +render :: Url -> [(String, String)] -> String +render Home qs = "url" ++ showParams qs +render (Sub SubUrl) qs = "suburl" ++ showParams qs +showParams :: [(String, String)] -> String +showParams [] = "" +showParams z = + '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + data Arg url = Arg { getArg :: Arg url - , var :: Html () + , var :: Html , url :: Url , embed :: Hamlet url , true :: Bool @@ -120,11 +169,11 @@ 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 @@ -322,7 +371,7 @@ caseAttribVars = do helper "
" [$hamlet|#$var.theArg$|] helper "
" [$hamlet|.$var.theArg$|] - helper "
" [$hamlet|%div!f=$var.theArg$|] + helper "
" [$hamlet|!f=$var.theArg$|] caseStringsAndHtml :: Assertion caseStringsAndHtml = do @@ -393,7 +442,10 @@ $x$ |] -helper' :: String -> Html ()-> Assertion +caseHamletLiterals :: Assertion +caseHamletLiterals = helper "123" [$hamlet|$show.123$|] + +helper' :: String -> Html -> Assertion helper' res h = do let x = renderHtml h res @=? toString x @@ -402,6 +454,8 @@ caseHamlet' = do helper' "foo" [$hamlet'|foo|] helper' "foo" [$xhamlet'|foo|] + helper "
" $ const $ [$hamlet'|%br|] + helper "
" $ const $ [$xhamlet'|%br|] caseHamletDebug :: Assertion caseHamletDebug = do @@ -415,7 +469,7 @@ temp <- parseHamletRT defaultHamletSettings "$var$" rt <- parseHamletRT defaultHamletSettings $ unlines - [ "$foo.bar.baz$ bin $" + [ "$baz.bar.foo$ bin $" , "$forall list l" , " $l$" , "$maybe just j" @@ -435,26 +489,208 @@ , "@?urlp@" ] let scope = - HDMap - [ ("foo", HDMap - [ ("bar", HDMap - [ ("baz", HDHtml $ preEscapedString "foobaz") - ]) - ]) - , ("list", HDList - [ HDHtml $ string "1" - , HDHtml $ string "2" - , HDHtml $ string "3" - ]) - , ("just", HDMaybe $ Just $ HDHtml $ string "just") - , ("nothing", HDMaybe Nothing) - , ("template", HDTemplate temp) - , ("var", HDHtml $ string "var") - , ("url", HDUrl Home) - , ("urlp", HDUrlParams Home [("foo", "bar")]) - , ("true", HDBool True) - , ("false", HDBool False) - ] + [ (["foo", "bar", "baz"], HDHtml $ preEscapedString "foobaz") + , (["list"], HDList + [ [([], HDHtml $ string "1")] + , [([], HDHtml $ string "2")] + , [([], HDHtml $ string "3")] + ]) + , (["just"], HDMaybe $ Just + [ ([], HDHtml $ string "just") + ]) + , (["nothing"], HDMaybe Nothing) + , (["template"], HDTemplate temp) + , (["var"], HDHtml $ string "var") + , (["url"], HDUrl Home) + , (["urlp"], HDUrlParams Home [("foo", "bar")]) + , (["true"], HDBool True) + , (["false"], HDBool False) + ] rend <- renderHamletRT rt scope render toString (renderHtml rend) @?= "foobaz bin 123justnothingvarurlaburl?foo=bar" + +caseHamletFileDebugChange :: Assertion +caseHamletFileDebugChange = do + let foo = "foo" + writeFile "external-debug.hamlet" "$foo$ 1" + helper "foo 1" $ $(hamletFileDebug "external-debug.hamlet") + writeFile "external-debug.hamlet" "$foo$ 2" + helper "foo 2" $ $(hamletFileDebug "external-debug.hamlet") + writeFile "external-debug.hamlet" "$foo$ 1" + +caseHamletFileDebugFeatures :: Assertion +caseHamletFileDebugFeatures = do + let var = "var" + let url = Home + let urlp = (Home, [("foo", "bar")]) + let template = [$hamlet|template|] + let true = True + let just = Just "just" + nothing = Nothing + let list = words "1 2 3" + let extra = "e" + flip helper $(hamletFileDebug "external-debug2.hamlet") $ concat + [ "var" + , "var" + , "url" + , "url" + , "suburl" + , "url?foo=bar" + , "template" + , "truee" + , "not truee" + , "elseif truee" + , "just" + , "juste" + , "nothinge" + , "1e2e3e" + ] + +celper :: String -> Cassius Url -> Assertion +celper res h = do + let x = renderCassius render h + res @=? toString x + +mixin :: CassiusMixin a +mixin = [$cassiusMixin| +a: b +c: d +|] + +caseCassius :: Assertion +caseCassius = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip celper [$cassius| +foo + color: $colorRed$ + background: $colorBlack$ + bar: baz + bin + color: $(((Color 127) 100) 5)$ + bar: bar + unicode-test: שלום + f$var$x: someval + background-image: url(@Home@) + urlp: url(@?urlp@) + ^mixin^ +|] $ concat + [ "foo{color:#F00;background:#000;bar:baz;a:b;c:d}" + , "foo bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" + , "background-image:url(url);urlp:url(url?p=q)}" + ] + +caseCassiusFile :: Assertion +caseCassiusFile = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip celper $(cassiusFile "external1.cassius") $ concat + [ "foo{color:#F00;background:#000;bar:baz;a:b;c:d}" + , "foo bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" + , "background-image:url(url);urlp:url(url?p=q)}" + ] + +caseCassiusFileDebug :: Assertion +caseCassiusFileDebug = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip celper $(cassiusFileDebug "external1.cassius") $ concat + [ "foo{color:#F00;background:#000;bar:baz;a:b;c:d}" + , "foo bin{color:#7F6405;bar:bar;unicode-test:שלום;fvarx:someval;" + , "background-image:url(url);urlp:url(url?p=q)}" + ] + +caseCassiusFileDebugChange :: Assertion +caseCassiusFileDebugChange = do + let var = "var" + writeFile "external2.cassius" "foo\n $var$: 1" + celper "foo{var:1}" $(cassiusFileDebug "external2.cassius") + writeFile "external2.cassius" "foo\n $var$: 2" + celper "foo{var:2}" $(cassiusFileDebug "external2.cassius") + 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 @=? toString x + +caseJulius :: Assertion +caseJulius = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip jelper [$julius|שלום +%var% +@Home@ +@?urlp@ +^jmixin^ +|] $ intercalate "\r\n" + [ "שלום" + , var + , "url" + , "url?p=q" + , "var x;" + ] ++ "\r\n" + +caseJuliusFile :: Assertion +caseJuliusFile = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip jelper $(juliusFile "external1.julius") $ unlines + [ "שלום" + , var + , "url" + , "url?p=q" + , "var x;" + ] + +caseJuliusFileDebug :: Assertion +caseJuliusFileDebug = do + let var = "var" + let urlp = (Home, [("p", "q")]) + flip jelper $(juliusFileDebug "external1.julius") $ unlines + [ "שלום" + , var + , "url" + , "url?p=q" + , "var x;" + ] + +caseJuliusFileDebugChange :: Assertion +caseJuliusFileDebugChange = do + let var = "somevar" + writeFile "external2.julius" "var %var% = 1;" + jelper "var somevar = 1;" $(juliusFileDebug "external2.julius") + writeFile "external2.julius" "var %var% = 2;" + jelper "var somevar = 2;" $(juliusFileDebug "external2.julius") + writeFile "external2.julius" "var %var% = 1;" + +caseComments :: Assertion +caseComments = do + helper "" [$hamlet|$# this is a comment +$# another comment +$#a third one|] + celper "" [$cassius|$# this is a comment +$# another comment +$#a third one|] + +caseDoubleForalls :: Assertion +caseDoubleForalls = do + let list = map show [1..2] + helper "12" $(hamletFileDebug "double-foralls.hamlet") +instance Show Url where + show _ = "FIXME remove this instance show Url" + +casePseudo :: Assertion +casePseudo = do + flip celper [$cassius| +a:visited + color: blue +|] "a:visited{color:blue}" + +caseDiffBindNames :: Assertion +caseDiffBindNames = do + let list = words "1 2 3" + helper "123123" $(hamletFileDebug "external-debug3.hamlet")