hamlet 0.7.3 → 0.8.0
raw patch · 15 files changed
+710/−1416 lines, 15 filesdep +processdep −HUnitdep −QuickCheckdep −json-enumeratordep ~blaze-builderPVP ok
version bump matches the API change (PVP)
Dependencies added: process
Dependencies removed: HUnit, QuickCheck, json-enumerator, json-types, test-framework, test-framework-hunit
Dependency ranges changed: blaze-builder
API changes (from Hackage documentation)
- Text.Cassius: instance Eq Content
- Text.Cassius: instance Show Content
- Text.Cassius: instance ToCss Text
- Text.Cassius: instance ToCss [Char]
- Text.Julius: instance Eq Content
- Text.Julius: instance Show Content
- Text.Julius: instance ToJavascript Root
- Text.Julius: instance ToJavascript Value
- Text.Lucius: instance Eq Content
- Text.Lucius: instance Show Content
+ Text.Coffee: class ToCoffee c
+ Text.Coffee: coffee :: QuasiQuoter
+ Text.Coffee: coffeeFile :: FilePath -> Q Exp
+ Text.Coffee: coffeeFileDebug :: FilePath -> Q Exp
+ Text.Coffee: instance Monoid Coffeescript
+ Text.Coffee: instance ToCoffee Text
+ Text.Coffee: instance ToCoffee [Char]
+ Text.Coffee: renderCoffee :: (url -> [(Text, Text)] -> Text) -> Coffee url -> IO Text
+ Text.Coffee: toCoffee :: ToCoffee c => c -> Builder
+ Text.Coffee: type Coffee url = (url -> [(Text, Text)] -> Text) -> Coffeescript
+ Text.Hamlet: toHtml :: ToHtml a => a -> Html
+ Text.Julius: unJavascript :: Javascript -> Builder
+ Text.Lucius: luciusFile :: FilePath -> Q Exp
+ Text.Lucius: luciusFileDebug :: FilePath -> Q Exp
+ Text.Romeo: RomeoSettings :: Char -> Char -> Char -> Exp -> Exp -> Exp -> RomeoSettings
+ Text.Romeo: data RomeoSettings
+ Text.Romeo: defaultRomeoSettings :: RomeoSettings
+ Text.Romeo: instance Eq Content
+ Text.Romeo: instance Lift RomeoSettings
+ Text.Romeo: instance Show Content
+ Text.Romeo: intChar :: RomeoSettings -> Char
+ Text.Romeo: romeo :: RomeoSettings -> QuasiQuoter
+ Text.Romeo: romeoFile :: RomeoSettings -> FilePath -> Q Exp
+ Text.Romeo: romeoFileDebug :: RomeoSettings -> FilePath -> Q Exp
+ Text.Romeo: toBuilder :: RomeoSettings -> Exp
+ Text.Romeo: unwrap :: RomeoSettings -> Exp
+ Text.Romeo: urlChar :: RomeoSettings -> Char
+ Text.Romeo: varChar :: RomeoSettings -> Char
+ Text.Romeo: wrap :: RomeoSettings -> Exp
- Text.Cassius: renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> Text
+ Text.Cassius: renderCassius :: (url -> [(Text, Text)] -> Text) -> Cassius url -> Text
- Text.Cassius: toCss :: ToCss a => a -> Text
+ Text.Cassius: toCss :: ToCss a => a -> Builder
- Text.Cassius: type Cassius url = (url -> [(String, String)] -> String) -> Css
+ Text.Cassius: type Cassius url = (url -> [(Text, Text)] -> Text) -> Css
- Text.Cassius: type Css = [Css']
+ Text.Cassius: type Css = [CssTop]
- Text.Hamlet: HDUrlParams :: url -> [(String, String)] -> HamletData url
+ Text.Hamlet: HDUrlParams :: url -> [(Text, Text)] -> HamletData url
- Text.Hamlet: renderHamlet :: (url -> [(String, String)] -> String) -> Hamlet url -> ByteString
+ Text.Hamlet: renderHamlet :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> ByteString
- Text.Hamlet: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(String, String)] -> String) -> m Html
+ Text.Hamlet: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Hamlet: renderHamletText :: (url -> [(String, String)] -> String) -> Hamlet url -> Text
+ Text.Hamlet: renderHamletText :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> Text
- Text.Hamlet: type Hamlet url = (url -> [(String, String)] -> String) -> Html
+ Text.Hamlet: type Hamlet url = (url -> [(Text, Text)] -> Text) -> Html
- Text.Hamlet: urlToHamletMonad :: HamletValue a => HamletUrl a -> [(String, String)] -> HamletMonad a ()
+ Text.Hamlet: urlToHamletMonad :: HamletValue a => HamletUrl a -> [(Text, Text)] -> HamletMonad a ()
- Text.Hamlet.RT: HDUrlParams :: url -> [(String, String)] -> HamletData url
+ Text.Hamlet.RT: HDUrlParams :: url -> [(Text, Text)] -> HamletData url
- Text.Hamlet.RT: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(String, String)] -> String) -> m Html
+ Text.Hamlet.RT: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Hamlet.RT: renderHamletRT' :: Failure HamletException m => Bool -> HamletRT -> HamletMap url -> (url -> [(String, String)] -> String) -> m Html
+ Text.Hamlet.RT: renderHamletRT' :: Failure HamletException m => Bool -> HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Julius: renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> Text
+ Text.Julius: renderJulius :: (url -> [(Text, Text)] -> Text) -> Julius url -> Text
- Text.Julius: type Julius url = (url -> [(String, String)] -> String) -> Javascript
+ Text.Julius: type Julius url = (url -> [(Text, Text)] -> Text) -> Javascript
- Text.Lucius: renderLucius :: (url -> [(String, String)] -> String) -> Cassius url -> Text
+ Text.Lucius: renderLucius :: (url -> [(Text, Text)] -> Text) -> Lucius url -> Text
Files
- Text/Cassius.hs +31/−145
- Text/Coffee.hs +67/−0
- Text/Css.hs +209/−5
- Text/Hamlet.hs +5/−3
- Text/Hamlet/Debug.hs +2/−1
- Text/Hamlet/Parse.hs +28/−15
- Text/Hamlet/Quasi.hs +19/−6
- Text/Hamlet/RT.hs +8/−6
- Text/Julius.hs +22/−140
- Text/Lucius.hs +74/−72
- Text/MkSizeType.hs +4/−2
- Text/Romeo.hs +206/−0
- Text/Shakespeare.hs +27/−15
- hamlet.cabal +8/−16
- runtests.hs +0/−990
Text/Cassius.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Cassius ( -- * Datatypes Cassius@@ -40,16 +41,14 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Language.Haskell.TH-import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton)+import Data.Text.Lazy.Builder (fromText, fromLazyText) import Data.Maybe (catMaybes)-import Data.Monoid import Data.Word (Word8) import Data.Bits-import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Hamlet.Quasi (readUtf8File)-import Data.List (intersperse)+import Data.Char (isSpace) data Color = Color Word8 Word8 Word8 deriving Show@@ -58,7 +57,7 @@ let (r1, r2) = toHex r (g1, g2) = toHex g (b1, b2) = toHex b- in TL.pack $ '#' :+ in fromText $ TS.pack $ '#' : if r1 == r2 && g1 == g2 && b1 == b2 then [r1, g1, b1] else [r1, r2, g1, g2, b1, b2]@@ -79,56 +78,14 @@ colorBlack :: Color colorBlack = Color 0 0 0 -renderCss :: Css -> TL.Text-renderCss =- toLazyText . mconcat . map go- where- go (Css' x y) = mconcat- [ x- , singleton '{'- , mconcat $ intersperse (singleton ';') $ map go' y- , singleton '}'- ]- go' (k, v) = mconcat- [ fromLazyText k- , singleton ':'- , v- ]--renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> TL.Text+renderCassius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Cassius url -> TL.Text renderCassius r s = renderCss $ s r -type Css = [Css']--type Cassius url = (url -> [(String, String)] -> String) -> Css--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, Eq)-type Contents = [Content]-type ContentPair = (Contents, Contents)-type Block = (Contents, [ContentPair])+type Cassius url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Css parseBlocks :: Parser [Block] 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"@@ -161,7 +118,7 @@ pairs <- fmap catMaybes $ many $ parsePair' indent case pairs of [] -> return Nothing- _ -> return $ Just (name, pairs)+ _ -> return $ Just $ Block [name] pairs [] parsePair' indent = try (parseEmptyLine >> return Nothing) <|> try (Just `fmap` parsePair indent) @@ -172,14 +129,26 @@ key <- manyTill (parseContent False) $ char ':' spaces value <- manyTill (parseContent True) $ eol <|> eof- return (key, value)+ return (trim key, value) -- FIXME consider trimming value as well +trim :: Contents -> Contents+trim =+ reverse . go . reverse . go+ where+ go [] = []+ go (ContentRaw x:xs) =+ case dropWhile isSpace x of+ [] -> go xs+ y -> ContentRaw y:xs+ go x = x++ eol :: Parser () eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) parseContent :: Bool -> Parser Content parseContent allowColon =- parseHash' <|> parseAt' <|> parseComment <|> parseChar+ parseHash' <|> parseAt' <|> parseComment' <|> parseChar where parseHash' = either ContentRaw ContentVar `fmap` parseHash parseAt' =@@ -189,115 +158,31 @@ go (d, True) = ContentUrlParam d parseChar = (ContentRaw . return) `fmap` noneOf restricted restricted = (if allowColon then id else (:) ':') "\r\n"- parseComment = do+ parseComment' = do _ <- try $ string "/*" _ <- manyTill anyChar $ try $ string "*/" return $ ContentRaw "" -blocksToCassius :: [(Contents, [ContentPair])] -> Q Exp-blocksToCassius a = do- r <- newName "_render"- lamE [varP r] $ listE $ map (blockToCss r) a- cassius :: QuasiQuoter cassius = QuasiQuoter { quoteExp = cassiusFromString } cassiusFromString :: String -> Q Exp cassiusFromString s =- blocksToCassius+ topLevelsToCassius $ map TopBlock $ either (error . show) id $ parse parseBlocks s s --blockToCss :: Name -> (Contents, [ContentPair]) -> Q Exp-blockToCss r (sel, props) = do- css' <- [|Css'|]- let sel' = contentsToBuilder r sel- props' <- 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 TL.unpack $ qRunIO $ readUtf8File fp cassiusFromString contents -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)]--data CDData url = CDPlain TL.Text- | CDUrl url- | CDUrlParam (url, [(String, String)])--vtToExp :: (Deref, VarType) -> Q Exp-vtToExp (d, vt) = do- d' <- lift d- c' <- c vt- return $ TupE [d', c' `AppE` derefToExp [] d]- where- c :: VarType -> Q Exp- c VTPlain = [|CDPlain . toCss|]- c VTUrl = [|CDUrl|]- c VTUrlParam = [|CDUrlParam|]- cassiusFileDebug :: FilePath -> Q Exp-cassiusFileDebug fp = do- 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 TL.unpack $ qRunIO $ readUtf8File fp- let a = either (error . show) id $ parse parseBlocks s s- return $ map go a- where- go :: (Contents, [ContentPair]) -> Css'- go (x, y) = Css' (mconcat $ map go' x) $ map go'' y- go' :: Content -> Builder- go' (ContentRaw s) = fromText $ TS.pack s- go' (ContentVar d) =- case lookup d cd of- Just (CDPlain s) -> fromLazyText s- _ -> error $ show d ++ ": expected CDPlain"- go' (ContentUrl d) =- case lookup d cd of- Just (CDUrl u) -> fromText $ TS.pack $ render' u []- _ -> error $ show d ++ ": expected CDUrl"- go' (ContentUrlParam d) =- case lookup d cd of- Just (CDUrlParam (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)+cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels +parseTopLevels :: Parser [TopLevel]+parseTopLevels = do+ x <- parseBlocks+ return $ map TopBlock x -- CSS size wrappers @@ -316,6 +201,7 @@ "pt" -> appE absoluteSizeE (conE $ mkName "Point") "px" -> conE $ mkName "PixelSize" "%" -> varE $ mkName "percentageSize"+ _ -> error $ "In mkSize, invalid unit: " ++ unit valueE = litE $ rationalL (toRational value) -- | Absolute size units.@@ -373,7 +259,7 @@ fromRational x = AbsoluteSize Centimeter (fromRational x) instance ToCss AbsoluteSize where- toCss = TL.pack . show+ toCss = fromText . TS.pack . show -- | Not intended for direct use, see 'mkSize'. data PercentageSize = PercentageSize@@ -402,7 +288,7 @@ fromRational x = PercentageSize (fromRational x) instance ToCss PercentageSize where- toCss = TL.pack . show+ toCss = fromText . TS.pack . show -- | Converts number and unit suffix to CSS format. showSize :: Rational -> String -> String
+ Text/Coffee.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Coffee+ ( ToCoffee (..)+ , Coffee+ , coffee+ , coffeeFile+ , coffeeFileDebug+ , renderCoffee+ ) where++import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import System.Process (readProcess)+import Data.Monoid+import Text.Romeo++renderCoffee :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Coffee url -> IO TL.Text+renderCoffee r s = do+ out <- readProcess "coffee" ["-epb", TL.unpack $ toLazyText $ unCoffee $ s r] []+ return $ TL.pack out+ where unCoffee (Coffeescript c) = c++newtype Coffeescript = Coffeescript { unCoffeescript :: Builder }+ deriving Monoid++type Coffee url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Coffeescript++-- the types that can be placed in a template+class ToCoffee c where+ toCoffee :: c -> Builder+instance ToCoffee [Char] where toCoffee = fromLazyText . TL.pack+instance ToCoffee TS.Text where toCoffee = fromText+instance ToCoffee TL.Text where toCoffee = fromLazyText++settings :: Q RomeoSettings+settings = do+ toExp <- [|toCoffee|]+ wrapExp <- [|Coffeescript|]+ unWrapExp <- [|unCoffeescript|]+ return $ defaultRomeoSettings { varChar = '%'+ , toBuilder = toExp+ , wrap = wrapExp+ , unwrap = unWrapExp+ }++coffee :: QuasiQuoter+coffee = QuasiQuoter { quoteExp = \s -> do+ rs <- settings+ quoteExp (romeo rs) s+ }++coffeeFile :: FilePath -> Q Exp+coffeeFile fp = do+ rs <- settings+ romeoFile rs fp++coffeeFileDebug :: FilePath -> Q Exp+coffeeFileDebug fp = do+ rs <- settings+ romeoFileDebug rs fp
Text/Css.hs view
@@ -1,11 +1,215 @@-module Text.Css- ( Css' (..)- ) where+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.Css where -import Data.Text.Lazy.Builder (Builder)+import Data.List (intersperse, intercalate)+import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText, fromLazyText) import qualified Data.Text.Lazy as TL+import Data.Monoid (mconcat, mappend, mempty)+import Data.Text (Text, pack)+import Language.Haskell.TH.Syntax+import System.IO.Unsafe (unsafePerformIO)+import Text.Hamlet.Quasi (readUtf8File)+import Text.ParserCombinators.Parsec (Parser, parse)+import Text.Shakespeare+import Language.Haskell.TH +class ToCss a where+ toCss :: a -> Builder++instance ToCss [Char] where toCss = fromLazyText . TL.pack+instance ToCss Text where toCss = fromText+instance ToCss TL.Text where toCss = fromLazyText+ data Css' = Css' { _cssSelectors :: Builder- , _cssAttributes :: [(TL.Text, Builder)]+ , _cssAttributes :: [(Builder, Builder)] }+data CssTop = Media String [Css'] | Css Css'++type Css = [CssTop]++data Content = ContentRaw String+ | ContentVar Deref+ | ContentUrl Deref+ | ContentUrlParam Deref+ deriving (Show, Eq)++type Contents = [Content]+type ContentPair = (Contents, Contents)++data VarType = VTPlain | VTUrl | VTUrlParam++data CDData url = CDPlain Builder+ | CDUrl url+ | CDUrlParam (url, [(Text, Text)])++cssFileDebug :: Q Exp -> Parser [TopLevel] -> FilePath -> Q Exp+cssFileDebug parseBlocks' parseBlocks fp = do+ 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 <- [|cssRuntime|]+ parseBlocks'' <- parseBlocks'+ return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c+ where+ go :: TopLevel -> [Content] -- FIXME use blockToCss+ go (MediaBlock _ blocks) = concatMap (go . TopBlock) blocks+ go (TopBlock (Block x y z)) =+ intercalate [ContentRaw ","] x +++ concatMap go' y +++ concatMap (go . TopBlock) z+ go' (k, v) = k ++ v++combineSelectors :: Selector -> Selector -> Selector+combineSelectors a b = do+ a' <- a+ b' <- b+ return $ a' ++ ContentRaw " " : b'++cssRuntime :: Parser [TopLevel]+ -> FilePath+ -> [(Deref, CDData url)]+ -> (url -> [(Text, Text)] -> Text)+ -> Css+cssRuntime parseBlocks fp cd render' = unsafePerformIO $ do+ s <- fmap TL.unpack $ qRunIO $ readUtf8File fp+ let a = either (error . show) id $ parse parseBlocks s s+ return $ foldr ($) [] $ map goTop a+ where+ goTop :: TopLevel -> Css -> Css+ goTop (TopBlock b) x = map Css (go b []) ++ x+ goTop (MediaBlock s b) x = Media s (foldr go [] b) : x+ go :: Block -> [Css'] -> [Css']+ -- FIXME share code with blockToCss+ go (Block x y z) =+ (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))+ . foldr (.) id (map (subGo x) z)+ subGo :: Selector -> Block -> [Css'] -> [Css']+ subGo x (Block a b c) =+ go (Block a' b c)+ where+ a' = combineSelectors x a+ go' :: Content -> Builder+ go' (ContentRaw s) = fromText $ pack s+ go' (ContentVar d) =+ case lookup d cd of+ Just (CDPlain s) -> s+ _ -> error $ show d ++ ": expected CDPlain"+ go' (ContentUrl d) =+ case lookup d cd of+ Just (CDUrl u) -> fromText $ render' u []+ _ -> error $ show d ++ ": expected CDUrl"+ go' (ContentUrlParam d) =+ case lookup d cd of+ Just (CDUrlParam (u, p)) ->+ fromText $ render' u p+ _ -> error $ show d ++ ": expected CDUrlParam"+ go'' (k, v) = (mconcat $ map go' k, mconcat $ map go' v)++vtToExp :: (Deref, VarType) -> Q Exp+vtToExp (d, vt) = do+ d' <- lift d+ c' <- c vt+ return $ TupE [d', c' `AppE` derefToExp [] d]+ where+ c :: VarType -> Q Exp+ c VTPlain = [|CDPlain . toCss|]+ c VTUrl = [|CDUrl|]+ c VTUrlParam = [|CDUrlParam|]++getVars :: Content -> [(Deref, VarType)]+getVars ContentRaw{} = []+getVars (ContentVar d) = [(d, VTPlain)]+getVars (ContentUrl d) = [(d, VTUrl)]+getVars (ContentUrlParam d) = [(d, VTUrlParam)]++data Block = Block Selector Pairs [Block]++data TopLevel = TopBlock Block | MediaBlock String [Block]++type Pairs = [Pair]++type Pair = (Contents, Contents)++type Selector = [Contents]++compressTopLevel :: TopLevel -> TopLevel+compressTopLevel (TopBlock b) = TopBlock $ compressBlock b+compressTopLevel (MediaBlock s b) = MediaBlock s $ map compressBlock b++compressBlock :: Block -> Block+compressBlock (Block x y blocks) =+ Block (map cc x) (map go y) (map compressBlock blocks)+ 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++blockToCss :: Name -> Block -> Q Exp+blockToCss r (Block sel props subblocks) =+ [|(:) (Css' $(selectorToBuilder r sel) $(listE $ map go props))+ . foldr (.) id $(listE $ map subGo subblocks)+ |]+ where+ go (x, y) = tupE [contentsToBuilder r x, contentsToBuilder r y]+ subGo (Block sel' b c) =+ blockToCss r $ Block sel'' b c+ where+ sel'' = combineSelectors sel sel'++selectorToBuilder :: Name -> Selector -> Q Exp+selectorToBuilder r sels =+ contentsToBuilder r $ intercalate [ContentRaw ","] sels++contentsToBuilder :: Name -> [Content] -> Q Exp+contentsToBuilder r contents =+ appE [|mconcat|] $ listE $ map (contentToBuilder r) contents++contentToBuilder :: Name -> Content -> Q Exp+contentToBuilder _ (ContentRaw x) =+ [|fromText . pack|] `appE` litE (StringL x)+contentToBuilder _ (ContentVar d) =+ [|toCss|] `appE` return (derefToExp [] d)+contentToBuilder r (ContentUrl u) =+ [|fromText|] `appE`+ (varE r `appE` return (derefToExp [] u) `appE` listE [])+contentToBuilder r (ContentUrlParam u) =+ [|fromText|] `appE`+ ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))++topLevelsToCassius :: [TopLevel] -> Q Exp+topLevelsToCassius a = do+ r <- newName "_render"+ lamE [varP r] $ appE [|foldr ($) []|] $ listE $ map (go r) a+ where+ go r (TopBlock b) = [|(++) $ map Css ($(blockToCss r b) [])|]+ go r (MediaBlock s b) = [|(:) $ Media $(lift s) $(blocksToCassius r b)|]++blocksToCassius :: Name -> [Block] -> Q Exp+blocksToCassius r a = do+ appE [|foldr ($) []|] $ listE $ map (blockToCss r) a++renderCss :: Css -> TL.Text+renderCss =+ toLazyText . mconcat . map go -- FIXME use a foldr+ where+ go (Css x) = renderCss' x+ go (Media s x) =+ fromText (pack "@media ") `mappend`+ fromText (pack s) `mappend`+ singleton '{' `mappend`+ foldr mappend (singleton '}') (map renderCss' x)++renderCss' :: Css' -> Builder+renderCss' (Css' _x []) = mempty+renderCss' (Css' x y) =+ x+ `mappend` singleton '{'+ `mappend` mconcat (intersperse (singleton ';') $ map go' y)+ `mappend` singleton '}'+ where+ go' (k, v) = k `mappend` singleton ':' `mappend` v
Text/Hamlet.hs view
@@ -24,6 +24,7 @@ , string , unsafeByteString , cdata+ , toHtml -- * Rendering -- ** ByteString , renderHamlet@@ -50,13 +51,14 @@ 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)+import Text.Blaze (preEscapedText, preEscapedString, string, unsafeByteString, toHtml)+import Data.Text (Text) -- | Converts a 'Hamlet' to lazy bytestring.-renderHamlet :: (url -> [(String, String)] -> String) -> Hamlet url -> L.ByteString+renderHamlet :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> L.ByteString renderHamlet render h = renderHtml $ h render -renderHamletText :: (url -> [(String, String)] -> String) -> Hamlet url+renderHamletText :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> T.Text renderHamletText render h = T.decodeUtf8With T.lenientDecode $ renderHtml $ h render
Text/Hamlet/Debug.hs view
@@ -13,9 +13,10 @@ import Control.Monad (forM) import qualified Data.Text.Lazy as T import Text.Blaze (toHtml)+import Data.Text (Text) unsafeRenderTemplate :: FilePath -> HamletMap url- -> (url -> [(String, String)] -> String) -> Html+ -> (url -> [(Text, Text)] -> Text) -> Html unsafeRenderTemplate fp hd render = unsafePerformIO $ do contents <- fmap T.unpack $ readUtf8File fp temp <- parseHamletRT defaultHamletSettings contents
Text/Hamlet/Parse.hs view
@@ -18,7 +18,6 @@ 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@@ -47,6 +46,7 @@ | LineIf Deref | LineElseIf Deref | LineElse+ | LineWith [(Deref, Ident)] | LineMaybe Deref Ident | LineNothing | LineTag@@ -74,10 +74,11 @@ backslash <|> controlIf <|> controlElseIf <|>- (try (string "$else") >> many (oneOf " \t") >> eol >> return LineElse) <|>+ (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> controlMaybe <|>- (try (string "$nothing") >> many (oneOf " \t") >> eol >> return LineNothing) <|>+ (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> controlForall <|>+ controlWith <|> angle <|> (eol' >> return (LineContent [])) <|> (do@@ -90,6 +91,7 @@ where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol'+ spaceTabs = many $ oneOf " \t" doctype = do try $ string "!!!" >> eol return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"]@@ -111,38 +113,42 @@ _ <- try $ string "$if" spaces x <- parseDeref- _ <- many $ oneOf " \t"+ _ <- spaceTabs eol return $ LineIf x controlElseIf = do _ <- try $ string "$elseif" spaces x <- parseDeref- _ <- many $ oneOf " \t"+ _ <- spaceTabs eol return $ LineElseIf x- controlMaybe = do- _ <- try $ string "$maybe"- spaces+ binding = do y <- ident spaces _ <- string "<-" spaces x <- parseDeref- _ <- many $ oneOf " \t"+ _ <- spaceTabs+ return (x,y)+ bindingSep = char ',' >> spaceTabs+ controlMaybe = do+ _ <- try $ string "$maybe"+ spaces+ (x,y) <- binding eol return $ LineMaybe x y controlForall = do _ <- try $ string "$forall" spaces- y <- ident- spaces- _ <- string "<-"- spaces- x <- parseDeref- _ <- many $ oneOf " \t"+ (x,y) <- binding eol return $ LineForall x y+ controlWith = do+ _ <- try $ string "$with"+ spaces+ bindings <- (binding `sepBy` bindingSep) `endBy` eol+ return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] content cr = do x <- many $ content' cr case cr of@@ -230,6 +236,7 @@ in Nest l (nestLines deeper) : nestLines rest' data Doc = DocForall Deref Ident [Doc]+ | DocWith [(Deref,Ident)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) | DocMaybe Deref Ident [Doc] (Maybe [Doc]) | DocContent Content@@ -241,6 +248,10 @@ inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ DocForall d i inside' : rest'+nestToDoc set (Nest (LineWith dis) inside:rest) = do+ inside' <- nestToDoc set inside+ rest' <- nestToDoc set rest+ Ok $ DocWith dis inside' : rest' nestToDoc set (Nest (LineIf d) inside:rest) = do inside' <- nestToDoc set inside (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest@@ -305,6 +316,8 @@ compressDoc [] = [] compressDoc (DocForall d i doc:rest) = DocForall d i (compressDoc doc) : compressDoc rest+compressDoc (DocWith dis doc:rest) =+ DocWith dis (compressDoc doc) : compressDoc rest compressDoc (DocMaybe d i doc mnothing:rest) = DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) : compressDoc rest
Text/Hamlet/Quasi.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE EmptyDataDecls #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet.Quasi ( hamlet , xhamlet@@ -28,10 +29,12 @@ import Data.Char (isUpper, isDigit) import Data.Monoid (Monoid (..)) import Data.Maybe (fromMaybe)+import Data.Text (Text) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TIO import qualified System.IO as SIO-import Text.Blaze (Html, preEscapedString, string, toHtml)+import Text.Blaze (Html, preEscapedString, toHtml)+import qualified Data.Foldable as F readUtf8File :: FilePath -> IO TL.Text readUtf8File fp = do@@ -52,10 +55,20 @@ let list' = derefToExp scope list name' <- newName name let scope' = (ident, VarE name') : scope- mh <- [|mapM_|]+ mh <- [|F.mapM_|] inside' <- docsToExp scope' inside let lam = LamE [VarP name'] inside' return $ mh `AppE` lam `AppE` list'+docToExp scope (DocWith [] inside) = do+ inside' <- docsToExp scope inside+ return $ inside'+docToExp scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do+ let deref' = derefToExp scope deref+ name' <- newName name+ let scope' = (ident, VarE name') : scope+ inside' <- docToExp scope' (DocWith dis inside)+ let lam = LamE [VarP name'] inside'+ return $ lam `AppE` deref' docToExp scope (DocMaybe val ident@(Ident name) inside mno) = do let val' = derefToExp scope val name' <- newName name@@ -193,17 +206,17 @@ maybeH (Just v) f _ = f v -- | An function generating an 'Html' given a URL-rendering function.-type Hamlet url = (url -> [(String, String)] -> String) -> Html+type Hamlet url = (url -> [(Text, Text)] -> Text) -> Html class Monad (HamletMonad a) => HamletValue a where data HamletMonad a :: * -> * type HamletUrl a toHamletValue :: HamletMonad a () -> a htmlToHamletMonad :: Html -> HamletMonad a ()- urlToHamletMonad :: HamletUrl a -> [(String, String)] -> HamletMonad a ()+ urlToHamletMonad :: HamletUrl a -> [(Text, Text)] -> HamletMonad a () fromHamletValue :: a -> HamletMonad a () -type Render url = url -> [(String, String)] -> String+type Render url = url -> [(Text, Text)] -> Text instance HamletValue (Hamlet url) where newtype HamletMonad (Hamlet url) a = HMonad { runHMonad :: Render url -> (Html, a) }@@ -211,7 +224,7 @@ toHamletValue = fmap fst . runHMonad htmlToHamletMonad x = HMonad $ const (x, ()) urlToHamletMonad url pairs = HMonad $ \r ->- (string $ r url pairs, ())+ (toHtml $ 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
@@ -23,19 +23,21 @@ import Text.Hamlet.Parse import Text.Hamlet.Quasi (Html) import Data.List (intercalate)-import Text.Blaze (preEscapedString)+import Text.Blaze (preEscapedString, preEscapedText)+import Data.Text (Text) type HamletMap url = [([String], HamletData url)] data HamletData url = HDHtml Html | HDUrl url- | HDUrlParams url [(String, String)]+ | HDUrlParams url [(Text, Text)] | HDTemplate HamletRT | HDBool Bool | HDMaybe (Maybe (HamletMap url)) | HDList [HamletMap url] +-- FIXME switch to Text? data SimpleDoc = SDRaw String | SDVar [String] | SDUrl Bool [String]@@ -91,7 +93,7 @@ renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url- -> (url -> [(String, String)] -> String)+ -> (url -> [(Text, Text)] -> Text) -> m Html renderHamletRT = renderHamletRT' False @@ -99,7 +101,7 @@ => Bool -> HamletRT -> HamletMap url- -> (url -> [(String, String)] -> String)+ -> (url -> [(Text, Text)] -> Text) -> m Html renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = liftM mconcat $ mapM (go scope0) docs@@ -113,9 +115,9 @@ go scope (SDUrl p n) = do v <- lookup' n n scope case (p, v) of- (False, HDUrl u) -> return $ preEscapedString $ renderUrl u []+ (False, HDUrl u) -> return $ preEscapedText $ renderUrl u [] (True, HDUrlParams u q) ->- return $ preEscapedString $ renderUrl u q+ return $ preEscapedText $ renderUrl u q (False, _) -> fa $ showName n ++ ": expected HDUrl" (True, _) -> fa $ showName n ++ ": expected HDUrlParams" go scope (SDTemplate n) = do
Text/Julius.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Julius ( Julius , Javascript (..)@@ -12,171 +13,52 @@ , juliusFileDebug ) where -import Text.ParserCombinators.Parsec hiding (Line) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText) import Data.Monoid-import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL-import Text.Hamlet.Quasi (readUtf8File)-import Text.Shakespeare-import qualified Data.JSON.Types as J-import qualified Text.JSON.Enumerator as JE-import Data.Text.Lazy.Encoding (decodeUtf8)-import Blaze.ByteString.Builder (toLazyByteString)+import Text.Romeo renderJavascript :: Javascript -> TL.Text renderJavascript (Javascript b) = toLazyText b -renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> TL.Text+renderJulius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Julius url -> TL.Text renderJulius r s = renderJavascript $ s r -newtype Javascript = Javascript Builder+newtype Javascript = Javascript { unJavascript :: Builder } deriving Monoid-type Julius url = (url -> [(String, String)] -> String) -> Javascript+type Julius url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript 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-instance ToJavascript J.Root where- toJavascript (J.RootObject o) = toJavascript $ J.ValueObject o- toJavascript (J.RootArray o) = toJavascript $ J.ValueArray o-instance ToJavascript J.Value where- toJavascript = fromLazyText . decodeUtf8 . toLazyByteString . JE.renderValue -data Content = ContentRaw String- | ContentVar Deref- | ContentUrl Deref- | ContentUrlParam Deref- | ContentMix Deref- deriving (Show, Eq)-type Contents = [Content]--parseContents :: Parser Contents-parseContents = many1 parseContent--parseContent :: Parser Content-parseContent =- parseHash' <|> parseAt' <|> parseCaret' <|> parseChar- where- parseHash' = either ContentRaw ContentVar `fmap` parseHash- parseAt' =- either ContentRaw go `fmap` parseAt- where- go (d, False) = ContentUrl d- go (d, True) = ContentUrlParam d- parseCaret' = either ContentRaw ContentMix `fmap` parseCaret- parseChar = (ContentRaw . return) `fmap` anyChar--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) a- d <- case c of- [] -> [|mempty|]- [x] -> return x- _ -> do- mc <- [|mconcat|]- return $ mc `AppE` ListE c- return $ LamE [VarP r] d+settings :: Q RomeoSettings+settings = do+ toJExp <- [|toJavascript|]+ wrapExp <- [|Javascript|]+ unWrapExp <- [|unJavascript|]+ return $ defaultRomeoSettings { toBuilder = toJExp+ , wrap = wrapExp+ , unwrap = unWrapExp+ } julius :: QuasiQuoter-julius = QuasiQuoter { quoteExp = juliusFromString }--juliusFromString :: String -> Q Exp-juliusFromString s = do- let a = either (error . show) id $ parse parseContents s s- contentsToJulius $ compressContents a--contentToJavascript :: Name -> Content -> Q Exp-contentToJavascript _ (ContentRaw s') = do- ts <- [|Javascript . fromText . TS.pack|]- return $ ts `AppE` LitE (StringL s')-contentToJavascript _ (ContentVar d) = do- ts <- [|Javascript . toJavascript|]- return $ ts `AppE` derefToExp [] d-contentToJavascript r (ContentUrl d) = do- ts <- [|Javascript . fromText . TS.pack|]- return $ ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE [])-contentToJavascript r (ContentUrlParam d) = do- ts <- [|Javascript . fromText . TS.pack|]- 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+julius = QuasiQuoter { quoteExp = \s -> do+ rs <- settings+ quoteExp (romeo rs) s+ } juliusFile :: FilePath -> Q Exp juliusFile fp = do- contents <- qRunIO $ readUtf8File fp- juliusFromString $ TL.unpack 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 Builder- | 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 :: VarType -> Q Exp- c VTPlain = [|JDPlain . toJavascript|]- c VTUrl = [|JDUrl|]- c VTUrlParam = [|JDUrlParam|]- c VTMixin = [|JDMixin|]+ rs <- settings+ romeoFile rs fp juliusFileDebug :: FilePath -> Q Exp juliusFileDebug fp = do- 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- 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 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 $ fromText $ TS.pack s- go (ContentVar d) =- case lookup d cd of- Just (JDPlain s) -> Javascript s- _ -> error $ show d ++ ": expected JDPlain"- go (ContentUrl d) =- case lookup d cd of- 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 $ fromText $ TS.pack $ 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"+ rs <- settings+ romeoFileDebug rs fp
Text/Lucius.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Lucius ( -- * Datatypes Lucius@@ -9,6 +11,8 @@ , renderLucius -- * Parsing , lucius+ , luciusFile+ , luciusFileDebug -- * Re-export cassius , module Text.Cassius ) where@@ -17,88 +21,36 @@ import Text.Shakespeare import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax-import Language.Haskell.TH-import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton)-import Data.Maybe (catMaybes)-import Data.Monoid-import Data.Word (Word8)-import Data.Bits-import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL-import Text.Hamlet.Quasi (readUtf8File)-import Data.List (intersperse) import qualified Text.Cassius as C import Text.ParserCombinators.Parsec hiding (Line) import Text.Css-import Text.Shakespeare import Data.Char (isSpace)+import Text.Hamlet.Quasi (readUtf8File)+import Control.Applicative ((<$>))+import Data.Either (partitionEithers) type Lucius a = C.Cassius a +renderLucius :: (url -> [(TS.Text, TS.Text)] -> TS.Text)+ -> Lucius url+ -> TL.Text renderLucius = C.renderCassius +-- |+--+-- >>> renderLucius undefined [lucius|foo{bar:baz}|]+-- "foo{bar:baz}" lucius :: QuasiQuoter lucius = QuasiQuoter { quoteExp = luciusFromString } luciusFromString :: String -> Q Exp luciusFromString s =- blocksToLucius- $ either (error . show) id $ parse (parseBlocks id) s s--type Block = (Selector, Pairs)--type Pairs = [Pair]--type Pair = (Contents, Contents)--type Selector = Contents--blocksToLucius :: [Block] -> Q Exp-blocksToLucius blocks = do- r <- newName "_render"- lamE [varP r] $ listE $ map (blockToCss r) blocks--blockToCss :: Name -> Block -> Q Exp-blockToCss r (sel, pairs) = do- css' <- [|Css'|]- let sel' = contentsToBuilder r sel- props' <- listE (map go pairs)- return css' `appE` sel' `appE` return props'- where- go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y]- tlt = appE [|toLazyText|]--data Content = ContentRaw String- | ContentVar Deref- | ContentUrl Deref- | ContentUrlParam Deref- deriving (Show, Eq)-type Contents = [Content]--contentsToBuilder :: Name -> [Content] -> Q Exp-contentsToBuilder r contents =- appE [|mconcat|] $ listE $ map (contentToBuilder r) contents--contentToBuilder :: Name -> Content -> Q Exp-contentToBuilder _ (ContentRaw x) =- [|fromText . TS.pack|] `appE` litE (StringL x)-contentToBuilder _ (ContentVar d) =- [|fromLazyText . toCss|] `appE` return (derefToExp [] d)-contentToBuilder r (ContentUrl u) =- [|fromText . TS.pack|] `appE`- (varE r `appE` return (derefToExp [] u) `appE` listE [])-contentToBuilder r (ContentUrlParam u) =- [|fromText . TS.pack|] `appE`- ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))--parseBlocks :: ([Block] -> [Block]) -> Parser [Block]-parseBlocks front = do- whiteSpace- (parseBlock >>= (\b -> parseBlocks (front . (:) b))) <|> (return $ map compressBlock $ front [])--compressBlock = id -- FIXME+ topLevelsToCassius+ $ either (error . show) id $ parse parseTopLevels s s +whiteSpace :: Parser () whiteSpace = many (oneOf " \t\n\r" >> return ()) >> return () -- FIXME comments, don't use many parseBlock :: Parser Block@@ -106,12 +58,19 @@ sel <- parseSelector _ <- char '{' whiteSpace- pairs <- parsePairs id+ pairsBlocks <- parsePairsBlocks id+ let (pairs, blocks) = partitionEithers pairsBlocks whiteSpace- return (sel, pairs)+ return $ Block sel pairs blocks parseSelector :: Parser Selector-parseSelector = fmap trim $ parseContents "{"+parseSelector =+ go id+ where+ go front = do+ c <- parseContents "{,"+ let front' = front . (:) (trim c)+ (char ',' >> go front') <|> return (front' []) trim :: Contents -> Contents trim =@@ -125,10 +84,26 @@ trimS True = dropWhile isSpace trimS False = reverse . dropWhile isSpace . reverse -parsePairs :: ([Pair] -> [Pair]) -> Parser [Pair]-parsePairs front = (char '}' >> return (front [])) <|> (do- x <- parsePair- parsePairs $ front . (:) x)+type PairBlock = Either Pair Block+parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]+parsePairsBlocks front = (char '}' >> return (front [])) <|> (do+ isBlock <- lookAhead checkIfBlock+ x <- if isBlock+ then (do+ b <- parseBlock+ whiteSpace+ return $ Right b)+ else Left <$> parsePair+ parsePairsBlocks $ front . (:) x)+ where+ checkIfBlock = do+ skipMany $ noneOf "#@{};"+ (parseHash >> checkIfBlock)+ <|> (parseAt >> checkIfBlock)+ <|> (char '{' >> return True)+ <|> (oneOf ";}" >> return False)+ <|> (anyChar >> checkIfBlock)+ <|> fail "checkIfBlock" parsePair :: Parser Pair parsePair = do@@ -158,3 +133,30 @@ _ <- try $ string "/*" _ <- manyTill anyChar $ try $ string "*/" return $ ContentRaw ""++luciusFile :: FilePath -> Q Exp+luciusFile fp = do+ contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+ luciusFromString contents++luciusFileDebug :: FilePath -> Q Exp+luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels++parseTopLevels :: Parser [TopLevel]+parseTopLevels =+ go id+ where+ go front = do+ whiteSpace+ ((media <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))+ <|> (return $ map compressTopLevel $ front [])+ media = do+ try $ string "@media "+ name <- many1 $ noneOf "{"+ _ <- char '{'+ b <- parseBlocks id+ return $ MediaBlock name b+ parseBlocks front = do+ whiteSpace+ (char '}' >> return (map compressBlock $ front []))+ <|> (parseBlock >>= \x -> parseBlocks (front . (:) x))
Text/MkSizeType.hs view
@@ -38,10 +38,12 @@ toCssInstanceDec :: Name -> Dec toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec] where toCssDec = FunD (mkName "toCss") [Clause [] showBody []]- showBody = NormalB $ AppE (AppE dot pack) show+ showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show')+ -- FIXME this whole section makes me a little nervous+ from = VarE (mkName "fromLazyText") pack = VarE (mkName "TL.pack") dot = VarE (mkName ".")- show = VarE (mkName "show")+ show' = VarE (mkName "show") instanceType :: String -> Name -> Type instanceType className name = AppT (ConT $ mkName className) (ConT name)
+ Text/Romeo.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+-- | For lack of a better name... a parameterized version of Julius.+module Text.Romeo+ ( RomeoSettings (..)+ , defaultRomeoSettings+ , romeo+ , romeoFile+ , romeoFileDebug+ ) where++import Text.ParserCombinators.Parsec hiding (Line)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax.Internals+import Data.Text.Lazy.Builder (Builder, fromText)+import Data.Monoid+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Text.Hamlet.Quasi (readUtf8File)+import Text.Shakespeare++-- move to Shakespeare?+readFileQ :: FilePath -> Q [Char]+readFileQ fp = do+ qRunIO $ readFileUtf8 fp++-- move to Shakespeare?+readFileUtf8 :: FilePath -> IO String+readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp++data RomeoSettings = RomeoSettings+ { varChar :: Char+ , urlChar :: Char+ , intChar :: Char+ , toBuilder :: Exp+ , wrap :: Exp+ , unwrap :: Exp+ }+defaultRomeoSettings :: RomeoSettings+defaultRomeoSettings = RomeoSettings {+ varChar = '#'+ , urlChar = '@'+ , intChar = '^'+}+++instance Lift RomeoSettings where+ lift (RomeoSettings x1 x2 x3 x4 x5 x6) =+ [|RomeoSettings+ $(lift x1) $(lift x2) $(lift x3)+ $(liftExp x4) $(liftExp x5) $(liftExp x6)|]+ where+ liftExp (VarE n) = [|VarE $(liftName n)|]+ liftExp (ConE n) = [|ConE $(liftName n)|]+ liftExp _ = error "liftExp only supports VarE and ConE"+ liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]+ liftFlavour NameS = [|NameS|]+ liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]+ liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]+ liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]+ liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]+ liftNS VarName = [|VarName|]+ liftNS DataName = [|DataName|]++type Romeo url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Builder++data Content = ContentRaw String+ | ContentVar Deref+ | ContentUrl Deref+ | ContentUrlParam Deref+ | ContentMix Deref+ deriving (Show, Eq)+type Contents = [Content]++contentFromString :: RomeoSettings -> (String -> [Content])+contentFromString rs s = do+ compressContents $ either (error . show) id $ parse (parseContents rs) s s+ where+ compressContents :: Contents -> Contents+ compressContents [] = []+ compressContents (ContentRaw x:ContentRaw y:z) =+ compressContents $ ContentRaw (x ++ y) : z+ compressContents (x:y) = x : compressContents y++parseContents :: RomeoSettings -> Parser Contents+parseContents = many1 . parseContent+ where+ parseContent :: RomeoSettings -> Parser Content+ parseContent RomeoSettings {..} =+ parseHash' <|> parseAt' <|> parseCaret' <|> parseChar+ where+ parseHash' = either ContentRaw ContentVar `fmap` parseVar varChar+ parseAt' =+ either ContentRaw go `fmap` parseUrl urlChar '?'+ where+ go (d, False) = ContentUrl d+ go (d, True) = ContentUrlParam d+ parseCaret' = either ContentRaw ContentMix `fmap` parseInt intChar+ parseChar = ContentRaw `fmap` (many1 $ noneOf [varChar, urlChar, intChar])++contentsToRomeo :: RomeoSettings -> [Content] -> Q Exp+contentsToRomeo rs a = do+ r <- newName "_render"+ c <- mapM (contentToBuilder r) a+ d <- case c of+ [] -> [|mempty|]+ [x] -> return x+ _ -> do+ mc <- [|mconcat|]+ return $ mc `AppE` ListE c+ return $ LamE [VarP r] d+ where+ contentToBuilder :: Name -> Content -> Q Exp+ contentToBuilder _ (ContentRaw s') = do+ ts <- [|fromText . TS.pack|]+ return $ (wrap rs) `AppE` (ts `AppE` LitE (StringL s'))+ contentToBuilder _ (ContentVar d) = do+ return $ (wrap rs) `AppE` ((toBuilder rs) `AppE` derefToExp [] d)+ contentToBuilder r (ContentUrl d) = do+ ts <- [|fromText|]+ return $ (wrap rs) `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))+ contentToBuilder r (ContentUrlParam d) = do+ ts <- [|fromText|]+ up <- [|\r' (u, p) -> r' u p|]+ return $ (wrap rs) `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))+ contentToBuilder r (ContentMix d) = do+ return $ derefToExp [] d `AppE` VarE r++romeo :: RomeoSettings -> QuasiQuoter+romeo r = QuasiQuoter { quoteExp = romeoFromString r }++romeoFromString :: RomeoSettings -> String -> Q Exp+romeoFromString r s = do+ contentsToRomeo r $ contentFromString r s++romeoFile :: RomeoSettings -> FilePath -> Q Exp+romeoFile r fp = readFileQ fp >>= romeoFromString r++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 VarExp url = EPlain Builder+ | EUrl url+ | EUrlParam (url, [(TS.Text, TS.Text)])+ | EMixin (Romeo url)++romeoFileDebug :: RomeoSettings -> FilePath -> Q Exp+romeoFileDebug rs fp = do+ s <- readFileQ fp+ let b = concatMap getVars $ contentFromString rs s+ c <- mapM vtToExp b+ rt <- [|romeoRuntime|]+ wrap' <- [|\x -> $(return $ wrap rs) . x|]+ r' <- lift rs+ return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c)+ where+ vtToExp :: (Deref, VarType) -> Q Exp+ vtToExp (d, vt) = do+ d' <- lift d+ c' <- c vt+ return $ TupE [d', c' `AppE` derefToExp [] d]+ where+ c :: VarType -> Q Exp+ c VTPlain = [|EPlain . $(return $ toBuilder rs)|]+ c VTUrl = [|EUrl|]+ c VTUrlParam = [|EUrlParam|]+ c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|]+++romeoRuntime :: RomeoSettings -> FilePath -> [(Deref, VarExp url)] -> Romeo url+romeoRuntime rs fp cd render' = unsafePerformIO $ do+ s <- readFileUtf8 fp+ return $ mconcat $ map go $ contentFromString rs s+ where+ go :: Content -> Builder+ go (ContentRaw s) = fromText $ TS.pack s+ go (ContentVar d) =+ case lookup d cd of+ Just (EPlain s) -> s+ _ -> error $ show d ++ ": expected EPlain"+ go (ContentUrl d) =+ case lookup d cd of+ Just (EUrl u) -> fromText $ render' u []+ _ -> error $ show d ++ ": expected EUrl"+ go (ContentUrlParam d) =+ case lookup d cd of+ Just (EUrlParam (u, p)) ->+ fromText $ render' u p+ _ -> error $ show d ++ ": expected EUrlParam"+ go (ContentMix d) =+ case lookup d cd of+ Just (EMixin m) -> m render'+ _ -> error $ show d ++ ": expected EMixin"
Text/Shakespeare.hs view
@@ -9,8 +9,11 @@ , Scope , parseDeref , parseHash+ , parseVar , parseAt+ , parseUrl , parseCaret+ , parseInt , derefToExp , flattenDeref ) where@@ -20,7 +23,7 @@ import Data.Char (isUpper) import Text.ParserCombinators.Parsec import Data.List (intercalate)-import Data.Ratio (numerator, denominator, (%))+import Data.Ratio (Ratio, numerator, denominator, (%)) import Data.Data (Data) import Data.Typeable (Typeable) @@ -58,7 +61,7 @@ lift (DerefRational r) = do n <- lift $ numerator r d <- lift $ denominator r- per <- [|(%)|]+ per <- [|(%) :: Int -> Int -> Ratio Int|] dr <- [|DerefRational|] return $ dr `AppE` (InfixE (Just n) per (Just d)) lift (DerefString s) = [|DerefString|] `appE` lift s@@ -159,9 +162,12 @@ flattenDeref _ = Nothing parseHash :: Parser (Either String Deref)-parseHash = do- _ <- char '#'- (char '\\' >> return (Left "#")) <|> (do+parseHash = parseVar '#'++parseVar :: Char -> Parser (Either String Deref)+parseVar c = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do _ <- char '{' deref <- parseDeref _ <- char '}'@@ -169,25 +175,31 @@ -- Check for hash just before newline _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof return $ Left ""- ) <|> return (Left "#")+ ) <|> return (Left [c]) parseAt :: Parser (Either String (Deref, Bool))-parseAt = do- _ <- char '@'- (char '\\' >> return (Left "@")) <|> (do- x <- (char '?' >> return True) <|> return False+parseAt = parseUrl '@' '?'++parseUrl :: Char -> Char -> Parser (Either String (Deref, Bool))+parseUrl c d = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do+ x <- (char d >> return True) <|> return False (do _ <- char '{' deref <- parseDeref _ <- char '}' return $ Right (deref, x))- <|> return (Left $ if x then "@?" else "@"))+ <|> return (Left $ if x then [c, d] else [c])) parseCaret :: Parser (Either String Deref)-parseCaret = do- _ <- char '^'- (char '\\' >> return (Left "^")) <|> (do+parseCaret = parseInt '^'++parseInt :: Char -> Parser (Either String Deref)+parseInt c = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do _ <- char '{' deref <- parseDeref _ <- char '}'- return $ Right deref) <|> return (Left "^")+ return $ Right deref) <|> return (Left [c])
hamlet.cabal view
@@ -1,5 +1,5 @@ name: hamlet-version: 0.7.3+version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -23,7 +23,7 @@ > Not married category: Web, Yesod stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple homepage: http://docs.yesodweb.com/ @@ -32,6 +32,8 @@ default: False library+ if flag(test)+ Buildable: False build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , template-haskell@@ -40,14 +42,15 @@ , failure >= 0.1 && < 0.2 , text >= 0.7 && < 0.12 , containers >= 0.2 && < 0.5- , json-types >= 0.1 && < 0.2- , json-enumerator >= 0.0 && < 0.1- , blaze-builder >= 0.2 && < 0.3+ , blaze-builder >= 0.2 && < 0.4+ , process >= 1.0 && < 1.1 exposed-modules: Text.Hamlet Text.Hamlet.RT Text.Cassius Text.Lucius Text.Julius+ Text.Coffee+ Text.Romeo other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi Text.Hamlet.Debug@@ -56,17 +59,6 @@ Text.Css ghc-options: -Wall -executable runtests- if flag(test)- Buildable: True- cpp-options: -DTEST- build-depends: QuickCheck >= 2 && < 3,- HUnit,- test-framework-hunit,- test-framework- else- Buildable: False- main-is: runtests.hs source-repository head type: git
− runtests.hs
@@ -1,990 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -import Prelude hiding (reverse) -import Text.Hamlet -import Text.Cassius -import Text.Lucius -import Text.Julius -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import qualified Data.JSON.Types as J -import qualified Data.Map as Map - -main :: IO () -main = defaultMain [testSuite] - -testSuite :: Test -testSuite = testGroup "Text.Hamlet" - [ testCase "empty" caseEmpty - , testCase "static" caseStatic - , testCase "tag" caseTag - , testCase "var" caseVar - , testCase "var chain " caseVarChain - , testCase "url" caseUrl - , testCase "url chain " caseUrlChain - , testCase "embed" caseEmbed - , testCase "embed chain " caseEmbedChain - , testCase "if" caseIf - , testCase "if chain " caseIfChain - , testCase "else" caseElse - , testCase "else chain " caseElseChain - , testCase "elseif" caseElseIf - , testCase "elseif chain " caseElseIfChain - , testCase "list" caseList - , testCase "list chain" caseListChain - , testCase "script not empty" caseScriptNotEmpty - , testCase "meta empty" caseMetaEmpty - , testCase "input empty" caseInputEmpty - , testCase "multiple classes" caseMultiClass - , testCase "attrib order" caseAttribOrder - , testCase "nothing" caseNothing - , testCase "nothing chain " caseNothingChain - , testCase "just" caseJust - , testCase "just chain " caseJustChain - , testCase "constructor" caseConstructor - , testCase "url + params" caseUrlParams - , testCase "escape" caseEscape - , testCase "empty statement list" caseEmptyStatementList - , testCase "attribute conditionals" caseAttribCond - , testCase "non-ascii" caseNonAscii - , testCase "maybe function" caseMaybeFunction - , testCase "trailing dollar sign" caseTrailingDollarSign - , testCase "non leading percent sign" caseNonLeadingPercent - , testCase "quoted attributes" caseQuotedAttribs - , testCase "spaced derefs" caseSpacedDerefs - , testCase "attrib vars" caseAttribVars - , testCase "strings and html" caseStringsAndHtml - , testCase "nesting" caseNesting - , testCase "trailing space" caseTrailingSpace - , 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 - -- 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 - , testCase "embed json" caseEmbedJson - , testCase "interpolated operators" caseOperators - , testCase "HTML comments" caseHtmlComments - , testCase "multi cassius" caseMultiCassius - , testCase "nested maybes" caseNestedMaybes - , testCase "lucius" caseLucius - , testCase "conditional class" caseCondClass - ] - -data Url = Home | Sub SubUrl -data 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 - , url :: Url - , embed :: Hamlet url - , true :: Bool - , false :: Bool - , list :: [Arg url] - , nothing :: Maybe String - , just :: Maybe String - , urlParams :: (Url, [(String, String)]) - } - -theArg :: Arg url -theArg = Arg - { getArg = theArg - , var = string "<var>" - , url = Home - , embed = [$hamlet|embed|] - , true = True - , false = False - , list = [theArg, theArg, theArg] - , nothing = Nothing - , just = Just "just" - , urlParams = (Home, [("foo", "bar"), ("foo1", "bar1")]) - } - -helper :: String -> Hamlet Url -> Assertion -helper res h = do - let x = renderHamletText render h - T.pack res @=? x - -caseEmpty :: Assertion -caseEmpty = helper "" [$hamlet||] - -caseStatic :: Assertion -caseStatic = helper "some static content" [$hamlet|some static content|] - -caseTag :: Assertion -caseTag = do - helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [$hamlet| -<p .foo - <#bar>baz -|] - helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [$hamlet| -<p class=foo.bar - <#bar>baz -|] - -caseVar :: Assertion -caseVar = do - helper "<var>" [$hamlet|#{var theArg}|] - -caseVarChain :: Assertion -caseVarChain = do - helper "<var>" [$hamlet|#{var (getArg (getArg (getArg theArg)))}|] - -caseUrl :: Assertion -caseUrl = do - helper (render Home []) [$hamlet|@{url theArg}|] - -caseUrlChain :: Assertion -caseUrlChain = do - helper (render Home []) [$hamlet|@{url (getArg (getArg (getArg theArg)))}|] - -caseEmbed :: Assertion -caseEmbed = do - helper "embed" [$hamlet|^{embed theArg}|] - -caseEmbedChain :: Assertion -caseEmbedChain = do - helper "embed" [$hamlet|^{embed (getArg (getArg (getArg theArg)))}|] - -caseIf :: Assertion -caseIf = do - helper "if" [$hamlet| -$if true theArg - if -|] - -caseIfChain :: Assertion -caseIfChain = do - helper "if" [$hamlet| -$if true (getArg (getArg (getArg theArg))) - if -|] - -caseElse :: Assertion -caseElse = helper "else" [$hamlet| -$if false theArg - if -$else - else -|] - -caseElseChain :: Assertion -caseElseChain = helper "else" [$hamlet| -$if false (getArg (getArg (getArg theArg))) - if -$else - else -|] - -caseElseIf :: Assertion -caseElseIf = helper "elseif" [$hamlet| -$if false theArg - if -$elseif true theArg - elseif -$else - else -|] - -caseElseIfChain :: Assertion -caseElseIfChain = helper "elseif" [$hamlet| -$if false(getArg(getArg(getArg theArg))) - if -$elseif true(getArg(getArg(getArg theArg))) - elseif -$else - else -|] - -caseList :: Assertion -caseList = do - helper "xxx" [$hamlet| -$forall _x <- (list theArg) - x -|] - -caseListChain :: Assertion -caseListChain = do - helper "urlurlurl" [$hamlet| -$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) - @{url x} -|] - -caseScriptNotEmpty :: Assertion -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>|] - -caseInputEmpty :: Assertion -caseInputEmpty = do - 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>|] - -caseAttribOrder :: Assertion -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 _n <- nothing theArg - nothing -|] - helper "nothing" [$hamlet| -$maybe _n <- nothing theArg - something -$nothing - nothing -|] - -caseNothingChain :: Assertion -caseNothingChain = helper "" [$hamlet| -$maybe n <- nothing(getArg(getArg(getArg theArg))) - nothing #{n} -|] - -caseJust :: Assertion -caseJust = helper "it's just" [$hamlet| -$maybe n <- just theArg - it's #{n} -|] - -caseJustChain :: Assertion -caseJustChain = helper "it's just" [$hamlet| -$maybe n <- just(getArg(getArg(getArg theArg))) - it's #{n} -|] - -caseConstructor :: Assertion -caseConstructor = do - helper "url" [$hamlet|@{Home}|] - helper "suburl" [$hamlet|@{Sub SubUrl}|] - let text = "<raw text>" - helper "<raw text>" [$hamlet|#{preEscapedString text}|] - -caseUrlParams :: Assertion -caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [$hamlet|@?{urlParams theArg}|] - -caseEscape :: Assertion -caseEscape = do - helper "#this is raw\n " [$hamlet| -\#this is raw -\ -\ -|] - helper "$@^" [$hamlet|$@^|] - -caseEmptyStatementList :: Assertion -caseEmptyStatementList = do - helper "" [$hamlet|$if True|] - helper "" [$hamlet|$maybe _x <- Nothing|] - let emptyList = [] - 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 selected></select>" - [$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|עִבְרִי|] - -caseMaybeFunction :: Assertion -caseMaybeFunction = do - helper "url?foo=bar&foo1=bar1" [$hamlet| -$maybe x <- Just urlParams - @?{x theArg} -|] - -caseTrailingDollarSign :: Assertion -caseTrailingDollarSign = - helper "trailing space \ndollar sign #" [$hamlet|trailing space # -\ -dollar sign #\ -|] - -caseNonLeadingPercent :: Assertion -caseNonLeadingPercent = - helper "<span style=\"height:100%\">foo</span>" [$hamlet| -<span style=height:100%>foo -|] - -caseQuotedAttribs :: Assertion -caseQuotedAttribs = - helper "<input type=\"submit\" value=\"Submit response\">" [$hamlet| -<input type=submit value="Submit response" -|] - -caseSpacedDerefs :: Assertion -caseSpacedDerefs = do - 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}>|] - -caseStringsAndHtml :: Assertion -caseStringsAndHtml = do - let str = "<string>" - let html = preEscapedString "<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 user <- users - <tr - <td>#{user} -|] - helper - (concat - [ "<select id=\"foo\" name=\"foo\"><option selected></option>" - , "<option value=\"true\">Yes</option>" - , "<option value=\"false\">No</option>" - , "</select>" - ]) - [$hamlet| -<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"] - name = "foo" - val = 5 :: Int - isBoolBlank _ = True - isBoolTrue _ = False - isBoolFalse _ = False - -caseTrailingSpace :: Assertion -caseTrailingSpace = - helper "" [$hamlet| |] - -caseCurrency :: Assertion -caseCurrency = - 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") - where - foo = "foo" - -caseParens :: Assertion -caseParens = do - let plus = (++) - x = "x" - y = "y" - helper "xy" [$hamlet|#{(plus x) y}|] - helper "xxy" [$hamlet|#{plus (plus x x) y}|] - let alist = ["1", "2", "3"] - helper "123" [$hamlet| -$forall x <- (id id id id alist) - #{x} -|] - -caseHamletLiterals :: Assertion -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 = 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|] - - -- new with generalized stuff - helper' "foo" [$hamlet|foo|] - helper' "foo" [$xhamlet|foo|] - 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 -|] - -caseHamletRT :: Assertion -caseHamletRT = do - temp <- parseHamletRT defaultHamletSettings "#{var}" - rt <- parseHamletRT defaultHamletSettings $ - unlines - [ "#{baz(bar foo)} bin #" - , "$forall l <- list" - , " #{l}" - , "$maybe j <- just" - , " #{j}" - , "$maybe n <- nothing" - , "$nothing" - , " nothing" - , "^{template}" - , "@{url}" - , "$if false" - , "$elseif false" - , "$elseif true" - , " a" - , "$if false" - , "$else" - , " b" - , "@?{urlp}" - ] - let scope = - [ (["foo", "bar", "baz"], HDHtml $ preEscapedString "foo<bar>baz") - , (["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 - renderHtmlText rend @?= - T.pack "foo<bar>baz 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 - T.pack res @=? x - -caseCassius :: Assertion -caseCassius = do - let var = "var" - let urlp = (Home, [("p", "q")]) - flip celper [$cassius| -foo - background: #{colorBlack} - bar: baz - color: #{colorRed} -bin - background-image: url(@{Home}) - bar: bar - color: #{(((Color 127) 100) 5)} - f#{var}x: someval - unicode-test: שלום - urlp: url(@?{urlp}) -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusFile :: Assertion -caseCassiusFile = do - let var = "var" - let urlp = (Home, [("p", "q")]) - flip celper $(cassiusFile "external1.cassius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusFileDebug :: Assertion -caseCassiusFileDebug = do - let var = "var" - let urlp = (Home, [("p", "q")]) - flip celper $(cassiusFileDebug "external1.cassius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -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 = 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} -|] $ 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 - -- 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*/|] - -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" - -- FIXME helper "123123" $(hamletFileDebug "external-debug3.hamlet") - error "test has been disabled" - -caseBlankLine :: Assertion -caseBlankLine = do - helper "<p>foo</p>" [$hamlet| -<p - - foo - -|] - celper "foo{bar:baz}" [$cassius| -foo - - bar: baz - -|] - -caseLeadingSpaces :: Assertion -caseLeadingSpaces = - celper "foo{bar:baz}" [$cassius| - foo - bar: baz -|] - -caseTrailingSpaces :: Assertion -caseTrailingSpaces = helper "" [$hamlet| -$if True -$elseif False -$else -$maybe x <- Nothing -$nothing -$forall x <- empty -|] - 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 - |] - -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"}|] - -caseEmbedJson :: Assertion -caseEmbedJson = do - let v = J.ValueObject $ Map.fromList - [ ( T.pack "foo", J.ValueArray - [ J.ValueAtom $ J.AtomText $ T.pack "bar" - , J.ValueAtom $ J.AtomNumber 5 - ]) - ] - jelper "{\"foo\":[\"bar\",5.0]}" [$julius|#{v}|] - -caseOperators = do - helper "3" [$hamlet|#{show $ (+) 1 2}|] - helper "6" [$hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|] - -caseHtmlComments = do - helper "<p>1</p><p>2</p>" [$hamlet| -<p>1 -<!-- ignored comment --> -<p - 2 -|] - -caseMultiCassius :: Assertion -caseMultiCassius = do - celper "foo{bar:baz;bar:bin}" [$cassius| -foo - bar: baz - bar: bin -|] - -caseNestedMaybes :: Assertion -caseNestedMaybes = do - let muser = Just "User" :: Maybe String - mprof = Nothing :: Maybe Int - m3 = Nothing :: Maybe String - helper "justnothing" [$hamlet| -$maybe user <- muser - $maybe profile <- mprof - First two are Just - $maybe desc <- m3 - \ and left us a description: - <p>#{desc} - $nothing - and has left us no description. - $nothing - justnothing -$nothing - <h1>No such Person exists. - |] - - -caseLucius :: Assertion -caseLucius = do - let var = "var" - let urlp = (Home, [("p", "q")]) - flip celper [$lucius| -foo { - background: #{colorBlack}; - bar: baz; - color: #{colorRed}; -} -bin { - background-image: url(@{Home}); - bar: bar; - color: #{(((Color 127) 100) 5)}; - f#{var}x: someval; - unicode-test: שלום; - urlp: url(@?{urlp}); -} -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCondClass :: Assertion -caseCondClass = do - helper "<p class=\"current\"></p>" [$hamlet| -<p :False:.ignored :True:.current -|] - - helper "<p class=\"1 3 2 4\"></p>" [$hamlet| -<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4 -|] - - helper "<p class=\"foo bar baz\"></p>" [$hamlet| -<p class=foo class=bar class=baz -|]