hamlet 0.5.1.2 → 0.6.0

raw patch · 5 files changed

+102/−206 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/Cassius.hs +63/−173
• Text/Hamlet.hs +0/−2
• Text/Hamlet/Quasi.hs +0/−12
• hamlet.cabal +1/−1
• runtests.hs +38/−18

@@ -5,8 +5,6 @@     ( Cassius     , Css (..)     , renderCassius-    , CassiusMixin-    , cassiusMixin     , cassius     , Color (..)     , colorRed@@ -16,8 +14,6 @@     ) where  import Text.ParserCombinators.Parsec hiding (Line)-import Data.Traversable (sequenceA)-import Control.Applicative ((<$>)) import Data.List (intercalate) import Data.Char (isUpper, isDigit) import Language.Haskell.TH.Quote (QuasiQuoter (..))@@ -32,7 +28,6 @@ import Data.Bits import System.IO.Unsafe (unsafePerformIO) import Text.Utf8-import Control.Applicative (Applicative (..))  data Color = Color Word8 Word8 Word8     deriving Show@@ -76,15 +71,8 @@     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+contentPairToContents (x, y) = concat [x, ContentRaw ":" : y]  data Deref = DerefLeaf String            | DerefBranch Deref Deref@@ -104,69 +92,63 @@              | 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)+type ContentPair = (Contents, Contents)+type Block = (Contents, [ContentPair]) -eol :: Parser ()-eol =-    (char '\n' >> return ()) <|> (string "\r\n" >> return ())+parseBlocks :: Parser [Block]+parseBlocks = catMaybes `fmap` many parseBlock -parseEmptyLine :: Parser (Maybe (Int, Line))-parseEmptyLine = eol >> return Nothing+parseEmptyLine :: Parser ()+parseEmptyLine = do+    try $ skipMany $ oneOf " \t"+    parseComment <|> eol -parseComment :: Parser (Maybe (Int, Line))+parseComment :: Parser () parseComment = do-    _ <- many $ oneOf " \t"+    skipMany $ oneOf " \t"     _ <- string "$#"-    _ <- many $ noneOf "\r\n"-    eol <|> return ()-    return Nothing+    _ <- manyTill anyChar $ eol <|> eof+    return () -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)+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-    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+    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 '$' >> (parseDollar <|> parseVar)) <|>+    (char '$' >> (parseComment <|> parseDollar <|> parseVar)) <|>       (char '@' >> (parseAt <|> parseUrl)) <|> safeColon <|> do         s <- many1 $ noneOf $ (if allowColon then id else (:) ':') "\r\n$@"         return $ ContentRaw s@@ -186,6 +168,8 @@         d <- parseDeref         _ <- char '$'         return $ ContentVar d+    parseComment = char '#' >> skipMany (noneOf "\r\n")+                            >> return (ContentRaw "")  parseDeref :: Parser Deref parseDeref =@@ -200,49 +184,8 @@         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) =+render :: Block -> Contents+render (n, pairs) =     let inner = intercalate [ContentRaw ";"]               $ map contentPairToContents pairs      in concat [n, [ContentRaw "{"], inner, [ContentRaw "}"]]@@ -265,34 +208,13 @@                 return $ mc `AppE` ListE c     return $ LamE [VarP r] d -cassiusMixin :: QuasiQuoter-cassiusMixin =-    QuasiQuoter { quoteExp = e }-  where-    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 { quoteExp = cassiusFromString }  cassiusFromString :: String -> Q Exp-cassiusFromString s = do-    let a = either (error . show) id $ parse parseLines s s-    let b = aeither (error . unlines) id-          $ sequenceA $ map (nestToDec True) $ nestLines a-    contentsToCassius $ concatMap render $ concatMap flatDec b+cassiusFromString s =+    contentsToCassius+  $ concatMap render $ either (error . show) id $ parse parseBlocks s s  contentToCss :: Name -> Content -> Q Exp contentToCss _ (ContentRaw s') = do@@ -309,9 +231,6 @@     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) =@@ -329,24 +248,17 @@     contents <- fmap bsToChars $ 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)]+data VarType = VTPlain | VTUrl | VTUrlParam -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)]+getVars :: Content -> [(Deref, VarType)]+getVars ContentRaw{} = []+getVars (ContentVar d) = [(d, VTPlain)]+getVars (ContentUrl d) = [(d, VTUrl)]+getVars (ContentUrlParam d) = [(d, VTUrlParam)]  data CDData url = CDPlain String                 | CDUrl url                 | CDUrlParam (url, [(String, String)])-                | CDMixin (CassiusMixin url)  vtToExp :: (Deref, VarType) -> Q Exp vtToExp (d, vt) = do@@ -357,24 +269,20 @@     c VTPlain = [|CDPlain . toCss|]     c VTUrl = [|CDUrl|]     c VTUrlParam = [|CDUrlParam|]-    c VTMixin = [|CDMixin|]  cassiusFileDebug :: FilePath -> Q Exp cassiusFileDebug fp = do     s <- fmap bsToChars $ qRunIO $ S8.readFile fp-    let a = either (error . show) id $ parse parseLines s s-        b = concatMap (getVars . snd) a-    c <- mapM vtToExp b+    let a = concatMap render $ either (error . show) id $ parse parseBlocks s s+    c <- mapM vtToExp $ concatMap getVars a     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 bsToChars $ qRunIO $ S8.readFile fp-    let a = either (error . show) id $ parse parseLines s s-    let b = aeither (error . unlines) id-          $ sequenceA $ map (nestToDec True) $ nestLines a-    return $ mconcat $ map go $ concatMap render $ concatMap flatDec b+    let a = either (error . show) id $ parse parseBlocks s s+    return $ mconcat $ map go $ concatMap render a   where     go :: Content -> Css     go (ContentRaw s) = Css $ fromString s@@ -391,21 +299,3 @@             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"--data AEither a b = ALeft a | ARight b-instance Functor (AEither a) where-    fmap _ (ALeft a) = ALeft a-    fmap f (ARight b) = ARight $ f b-instance Monoid a => Applicative (AEither a) where-    pure = ARight-    ALeft x <*> ALeft y = ALeft $ x `mappend` y-    ALeft x <*> _ = ALeft x-    _ <*> ALeft y = ALeft y-    ARight x <*> ARight y = ARight $ x y-aeither :: (a -> c) -> (b -> c) -> AEither a b -> c-aeither f _ (ALeft a) = f a-aeither _ f (ARight b) = f b

@@ -3,8 +3,6 @@     ( -- * Basic quasiquoters       hamlet     , xhamlet-    , hamlet'-    , xhamlet'     , hamletDebug       -- * Load from external file     , hamletFile

@@ -8,8 +8,6 @@ module Text.Hamlet.Quasi     ( hamlet     , xhamlet-    , hamlet'-    , xhamlet'     , hamletDebug     , hamletWithSettings     , hamletWithSettings'@@ -114,16 +112,6 @@     let d' = deref scope d     fhv <- [|fromHamletValue|]     return $ fhv `AppE` d'---- | Calls 'hamletWithSettings'' with 'defaultHamletSettings'.-hamlet' :: QuasiQuoter-hamlet' = hamletWithSettings' defaultHamletSettings-{-# DEPRECATED hamlet' "Use hamlet directly now" #-}---- | Calls 'hamletWithSettings'' using XHTML 1.0 Strict settings.-xhamlet' :: QuasiQuoter-xhamlet' = hamletWithSettings' xhtmlHamletSettings-{-# DEPRECATED xhamlet' "Use xhamlet directly now" #-}  -- | Calls 'hamletWithSettings' with 'defaultHamletSettings'. hamlet :: QuasiQuoter

@@ -1,5 +1,5 @@ name:            hamlet-version:         0.5.1.2+version:         0.6.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>

@@ -79,6 +79,9 @@     , 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
     ]
 
 data Url = Home | Sub SubUrl
@@ -454,10 +457,10 @@ 
 caseHamlet' :: Assertion
 caseHamlet' = do
-    helper' "foo" [$hamlet'|foo|]
-    helper' "foo" [$xhamlet'|foo|]
-    helper "<br>" $ const $ [$hamlet'|%br|]
-    helper "<br/>" $ const $ [$xhamlet'|%br|]
+    helper' "foo" [$hamlet|foo|]
+    helper' "foo" [$xhamlet|foo|]
+    helper "<br>" $ const $ [$hamlet|%br|]
+    helper "<br/>" $ const $ [$xhamlet|%br|]
 
     -- new with generalized stuff
     helper' "foo" [$hamlet|foo|]
@@ -560,12 +563,6 @@     let x = renderCassius render h
     res @=? lbsToChars x
 
-mixin :: CassiusMixin a
-mixin = [$cassiusMixin|
-a: b
-c: d
-|]
-
 caseCassius :: Assertion
 caseCassius = do
     let var = "var"
@@ -575,17 +572,16 @@     color: $colorRed$
     background: $colorBlack$
     bar: baz
-    bin
+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;"
+        [ "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)}"
         ]
 
@@ -594,8 +590,8 @@     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;"
+        [ "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)}"
         ]
 
@@ -604,8 +600,8 @@     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;"
+        [ "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)}"
         ]
 
@@ -735,3 +731,27 @@ |]
   where
     empty = []
+
+caseCassiusAllSpaces :: Assertion
+caseCassiusAllSpaces = do
+    celper "h1{color:green }" [$cassius|
+    h1
+        color: green 
+    |]
+
+caseCassiusWhitespaceColons :: Assertion
+caseCassiusWhitespaceColons = do
+    celper "h1:hover{color:green ;font-family:sans-serif}" [$cassius|
+    h1:hover
+        color: green 
+        font-family:sans-serif
+    |]
+
+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.
+        font-family:sans-serif
+    |]