hamlet 0.9.0 → 1.2.0
raw patch · 13 files changed
Files
- LICENSE +17/−22
- Setup.lhs +1/−4
- Text/Cassius.hs +0/−299
- Text/Coffee.hs +0/−67
- Text/Css.hs +0/−214
- Text/Hamlet.hs +0/−266
- Text/Hamlet/Parse.hs +0/−457
- Text/Julius.hs +0/−64
- Text/Lucius.hs +0/−165
- Text/MkSizeType.hs +0/−73
- Text/Romeo.hs +0/−205
- Text/Shakespeare.hs +0/−225
- hamlet.cabal +8/−42
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2009, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Setup.lhs view
@@ -5,7 +5,4 @@ > import System.Cmd (system) > main :: IO ()-> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' })--> runTests' :: a -> b -> c -> d -> IO ()-> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return ()+> main = defaultMain
− Text/Cassius.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Cassius- ( -- * Datatypes- Cassius- , Css- -- * Type class- , ToCss (..)- -- * Rendering- , renderCassius- , renderCss- -- * Parsing- , cassius- , cassiusFile- , cassiusFileDebug- -- * ToCss instances- -- ** Color- , Color (..)- , colorRed- , colorBlack- -- ** Size- , mkSize- , AbsoluteUnit (..)- , AbsoluteSize (..)- , absoluteSize- , EmSize (..)- , ExSize (..)- , PercentageSize (..)- , percentageSize- , PixelSize (..)- ) where--import Text.Css-import Text.MkSizeType-import Text.Shakespeare-import Text.ParserCombinators.Parsec hiding (Line)-import Text.Printf (printf)-import Language.Haskell.TH.Quote (QuasiQuoter (..))-import Language.Haskell.TH.Syntax-import Language.Haskell.TH-import Data.Text.Lazy.Builder (fromText, fromLazyText)-import Data.Maybe (catMaybes)-import Data.Word (Word8)-import Data.Bits-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import Data.Char (isSpace)--data Color = Color Word8 Word8 Word8- deriving Show-instance ToCss Color where- toCss (Color r g b) =- let (r1, r2) = toHex r- (g1, g2) = toHex g- (b1, b2) = toHex b- in fromText $ TS.pack $ '#' :- if r1 == r2 && g1 == g2 && b1 == b2- then [r1, g1, b1]- else [r1, r2, g1, g2, b1, b2]- where- toHex :: Word8 -> (Char, Char)- toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15)- toChar :: Word8 -> Char- toChar c- | c < 10 = mkChar c 0 '0'- | otherwise = mkChar c 10 'A'- mkChar :: Word8 -> Word8 -> Char -> Char- mkChar a b' c =- toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c)--colorRed :: Color-colorRed = Color 255 0 0--colorBlack :: Color-colorBlack = Color 0 0 0--renderCassius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Cassius url -> TL.Text-renderCassius r s = renderCss $ s r--type Cassius url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Css--parseBlocks :: Parser [Block]-parseBlocks = (map compressBlock . catMaybes) `fmap` many parseBlock--parseEmptyLine :: Parser ()-parseEmptyLine = do- try $ skipMany $ oneOf " \t"- parseComment <|> eol--parseComment :: Parser ()-parseComment = do- _ <- try (skipMany (oneOf " \t") >> string "/*")- _ <- manyTill anyChar $ try $ string "*/"- -- FIXME This requires that any line beginning with a comment is entirely a comment- skipMany $ oneOf " \t"- _ <- eol <|> eof- return ()--parseIndent :: Parser Int-parseIndent =- sum `fmap` many ((char ' ' >> return 1) <|> (char '\t' >> return 4))--parseBlock :: Parser (Maybe Block)-parseBlock = do- indent <- parseIndent- (emptyBlock >> return Nothing)- <|> (eof >> if indent > 0 then return Nothing else fail "")- <|> realBlock indent- where- emptyBlock = parseEmptyLine- realBlock indent = do- name <- many1 $ parseContent True- eol- pairs <- fmap catMaybes $ many $ parsePair' indent- case pairs of- [] -> return Nothing- _ -> return $ Just $ Block [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 (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- where- parseHash' = either ContentRaw ContentVar `fmap` parseHash- parseAt' =- either ContentRaw go `fmap` parseAt- where- go (d, False) = ContentUrl d- go (d, True) = ContentUrlParam d- parseChar = (ContentRaw . return) `fmap` noneOf restricted- restricted = (if allowColon then id else (:) ':') "\r\n"- parseComment' = do- _ <- try $ string "/*"- _ <- manyTill anyChar $ try $ string "*/"- return $ ContentRaw ""--cassius :: QuasiQuoter-cassius = QuasiQuoter { quoteExp = cassiusFromString }--cassiusFromString :: String -> Q Exp-cassiusFromString s =- topLevelsToCassius $ map TopBlock- $ either (error . show) id $ parse parseBlocks s s--cassiusFile :: FilePath -> Q Exp-cassiusFile fp = do- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- cassiusFromString contents--cassiusFileDebug :: FilePath -> Q Exp-cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels--parseTopLevels :: Parser [TopLevel]-parseTopLevels = do- x <- parseBlocks- return $ map TopBlock x---- CSS size wrappers---- | Create a CSS size, e.g. $(mkSize "100px").-mkSize :: String -> ExpQ-mkSize s = appE nameE valueE- where [(value, unit)] = reads s :: [(Double, String)]- absoluteSizeE = varE $ mkName "absoluteSize"- nameE = case unit of- "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter")- "em" -> conE $ mkName "EmSize"- "ex" -> conE $ mkName "ExSize"- "in" -> appE absoluteSizeE (conE $ mkName "Inch")- "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter")- "pc" -> appE absoluteSizeE (conE $ mkName "Pica")- "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.-data AbsoluteUnit = Centimeter- | Inch- | Millimeter- | Pica- | Point- deriving (Eq, Show)---- | Not intended for direct use, see 'mkSize'.-data AbsoluteSize = AbsoluteSize- { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting.- , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters.- }---- | Absolute size unit convertion rate to centimeters.-absoluteUnitRate :: AbsoluteUnit -> Rational-absoluteUnitRate Centimeter = 1-absoluteUnitRate Inch = 2.54-absoluteUnitRate Millimeter = 0.1-absoluteUnitRate Pica = 12 * absoluteUnitRate Point-absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch---- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'.-absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize-absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit)--instance Show AbsoluteSize where- show (AbsoluteSize unit value') = printf "%f" value ++ suffix- where value = fromRational (value' / absoluteUnitRate unit) :: Double- suffix = case unit of- Centimeter -> "cm"- Inch -> "in"- Millimeter -> "mm"- Pica -> "pc"- Point -> "pt"--instance Eq AbsoluteSize where- (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2--instance Ord AbsoluteSize where- compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2--instance Num AbsoluteSize where- (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2)- (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2)- (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2)- abs (AbsoluteSize u v) = AbsoluteSize u (abs v)- signum (AbsoluteSize u v) = AbsoluteSize u (abs v)- fromInteger x = AbsoluteSize Centimeter (fromInteger x)--instance Fractional AbsoluteSize where- (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2)- fromRational x = AbsoluteSize Centimeter (fromRational x)--instance ToCss AbsoluteSize where- toCss = fromText . TS.pack . show---- | Not intended for direct use, see 'mkSize'.-data PercentageSize = PercentageSize- { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%.- }- deriving (Eq, Ord)---- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'.-percentageSize :: Rational -> PercentageSize-percentageSize value = PercentageSize (value / 100)--instance Show PercentageSize where- show (PercentageSize value') = printf "%f" value ++ "%"- where value = fromRational (value' * 100) :: Double--instance Num PercentageSize where- (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2)- (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2)- (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2)- abs (PercentageSize v) = PercentageSize (abs v)- signum (PercentageSize v) = PercentageSize (abs v)- fromInteger x = PercentageSize (fromInteger x)--instance Fractional PercentageSize where- (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2)- fromRational x = PercentageSize (fromRational x)--instance ToCss PercentageSize where- toCss = fromText . TS.pack . show---- | Converts number and unit suffix to CSS format.-showSize :: Rational -> String -> String-showSize value' unit = printf "%f" value ++ unit- where value = fromRational value' :: Double--mkSizeType "EmSize" "em"-mkSizeType "ExSize" "ex"-mkSizeType "PixelSize" "px"
− Text/Coffee.hs
@@ -1,67 +0,0 @@-{-# 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
@@ -1,214 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-module Text.Css where--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.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 :: [(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
@@ -1,266 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Hamlet- ( -- * Plain HTML- Html- , html- , htmlFile- , xhtml- , xhtmlFile- -- * Hamlet- , Hamlet- , hamlet- , hamletFile- , xhamlet- , xhamletFile- -- * I18N Hamlet- , IHamlet- , ihamlet- , ihamletFile- -- * Internal, for making more- , hamletWithSettings- , hamletFileWithSettings- , defaultHamletSettings- , xhtmlHamletSettings- , Env (..)- , HamletRules (..)- ) where--import Text.Shakespeare-import Text.Hamlet.Parse-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Data.Char (isUpper, isDigit)-import Data.Monoid (Monoid (..))-import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-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, preEscapedText, toHtml)-import qualified Data.Foldable as F-import Control.Applicative ((<$>))-import Control.Monad (ap)--type Render url = url -> [(Text, Text)] -> Text-type Translate msg = msg -> Html---- | A function generating an 'Html' given a URL-rendering function.-type Hamlet url = Render url -> Html---- | A function generating an 'Html' given a message translator and a URL rendering function.-type IHamlet msg url = Translate msg -> Render url -> Html--docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp-docsToExp env hr scope docs = do- exps <- mapM (docToExp env hr scope) docs- case exps of- [] -> [|return ()|]- [x] -> return x- _ -> return $ DoE $ map NoBindS exps--docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp-docToExp env hr scope (DocForall list ident@(Ident name) inside) = do- let list' = derefToExp scope list- name' <- newName name- let scope' = (ident, VarE name') : scope- mh <- [|F.mapM_|]- inside' <- docsToExp env hr scope' inside- let lam = LamE [VarP name'] inside'- return $ mh `AppE` lam `AppE` list'-docToExp env hr scope (DocWith [] inside) = do- inside' <- docsToExp env hr scope inside- return $ inside'-docToExp env hr 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 env hr scope' (DocWith dis inside)- let lam = LamE [VarP name'] inside'- return $ lam `AppE` deref'-docToExp env hr scope (DocMaybe val ident@(Ident name) inside mno) = do- let val' = derefToExp scope val- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docsToExp env hr scope' inside- let inside'' = LamE [VarP name'] inside'- ninside' <- case mno of- Nothing -> [|Nothing|]- Just no -> do- no' <- docsToExp env hr scope no- j <- [|Just|]- return $ j `AppE` no'- mh <- [|maybeH|]- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'-docToExp env hr scope (DocCond conds final) = do- conds' <- mapM go conds- final' <- case final of- Nothing -> [|Nothing|]- Just f -> do- f' <- docsToExp env hr scope f- j <- [|Just|]- return $ j `AppE` f'- ch <- [|condH|]- return $ ch `AppE` ListE conds' `AppE` final'- where- go :: (Deref, [Doc]) -> Q Exp- go (d, docs) = do- let d' = derefToExp scope d- docs' <- docsToExp env hr scope docs- return $ TupE [d', docs']-docToExp env hr v (DocContent c) = contentToExp env hr v c--contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp-contentToExp _ hr _ (ContentRaw s) = do- os <- [|preEscapedText . pack|]- let s' = LitE $ StringL s- return $ hrFromHtml hr `AppE` (os `AppE` s')-contentToExp _ hr scope (ContentVar d) = do- str <- [|toHtml|]- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)-contentToExp env hr scope (ContentUrl hasParams d) =- case urlRender env of- Nothing -> error "URL interpolation used, but no URL renderer provided"- Just wrender -> wrender $ \render -> do- let render' = return render- ou <- if hasParams- then [|\(u, p) -> $(render') u p|]- else [|\u -> $(render') u []|]- let d' = derefToExp scope d- pet <- [|toHtml|]- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d-contentToExp env hr scope (ContentMsg d) =- case msgRender env of- Nothing -> error "Message interpolation used, but no message renderer provided"- Just wrender -> wrender $ \render ->- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)--html :: QuasiQuoter-html = hamletWithSettings htmlRules defaultHamletSettings--xhtml :: QuasiQuoter-xhtml = hamletWithSettings htmlRules xhtmlHamletSettings--htmlRules :: Q HamletRules-htmlRules = do- i <- [|id|]- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)--hamlet :: QuasiQuoter-hamlet = hamletWithSettings hamletRules defaultHamletSettings--xhamlet :: QuasiQuoter-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings--hamletRules :: Q HamletRules-hamletRules = do- i <- [|id|]- let ur f = do- r <- newName "_render"- let env = Env- { urlRender = Just ($ (VarE r))- , msgRender = Nothing- }- h <- f env- return $ LamE [VarP r] h- let em (Env (Just urender) Nothing) e =- urender $ \ur -> return (e `AppE` ur)- return $ HamletRules i ur em--ihamlet :: QuasiQuoter-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings--ihamletRules :: Q HamletRules-ihamletRules = do- i <- [|id|]- let ur f = do- u <- newName "_urender"- m <- newName "_mrender"- let env = Env- { urlRender = Just ($ (VarE u))- , msgRender = Just ($ (VarE m))- }- h <- f env- return $ LamE [VarP m, VarP u] h- let em (Env (Just urender) (Just mrender)) e =- urender $ \ur -> mrender $ \mr -> return (e `AppE` mr `AppE` ur)- return $ HamletRules i ur em--hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter-hamletWithSettings hr set =- QuasiQuoter- { quoteExp = hamletFromString hr set- }--data HamletRules = HamletRules- { hrFromHtml :: Exp- , hrWithEnv :: (Env -> Q Exp) -> Q Exp- , hrEmbed :: Env -> Exp -> Q Exp- }--data Env = Env- { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- }--hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp-hamletFromString qhr set s = do- hr <- qhr- case parseDoc set s of- Error s' -> error s'- Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d--hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp-hamletFileWithSettings qhr set fp = do- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- hamletFromString qhr set contents--hamletFile :: FilePath -> Q Exp-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings--xhamletFile :: FilePath -> Q Exp-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings--htmlFile :: FilePath -> Q Exp-htmlFile = hamletFileWithSettings htmlRules defaultHamletSettings--xhtmlFile :: FilePath -> Q Exp-xhtmlFile = hamletFileWithSettings htmlRules xhtmlHamletSettings--ihamletFile :: FilePath -> Q Exp-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings--varName :: Scope -> String -> Exp-varName _ "" = error "Illegal empty varName"-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope--strToExp :: String -> Exp-strToExp s@(c:_)- | all isDigit s = LitE $ IntegerL $ read s- | isUpper c = ConE $ mkName s- | otherwise = VarE $ mkName s-strToExp "" = error "strToExp on empty string"---- | Checks for truth in the left value in each pair in the first argument. If--- a true exists, then the corresponding right action is performed. Only the--- first is performed. In there are no true values, then the second argument is--- performed, if supplied.-condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()-condH [] Nothing = return ()-condH [] (Just x) = x-condH ((True, y):_) _ = y-condH ((False, _):rest) z = condH rest z---- | Runs the second argument with the value in the first, if available.--- Otherwise, runs the third argument, if available.-maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()-maybeH Nothing _ Nothing = return ()-maybeH Nothing _ (Just x) = x-maybeH (Just v) f _ = f v
− Text/Hamlet/Parse.hs
@@ -1,457 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Text.Hamlet.Parse- ( Result (..)- , Content (..)- , Doc (..)- , parseDoc- , HamletSettings (..)- , defaultHamletSettings- , xhtmlHamletSettings- , debugHamletSettings- , CloseStyle (..)- )- where--import Text.Shakespeare-import Control.Applicative ((<$>), Applicative (..))-import Control.Monad-import Control.Arrow-import Data.Data-import Text.ParserCombinators.Parsec hiding (Line)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Maybe (mapMaybe)--data Result v = Error String | Ok v- deriving (Show, Eq, Read, Data, Typeable)-instance Monad Result where- return = Ok- Error s >>= _ = Error s- Ok v >>= f = f v- fail = Error-instance Functor Result where- fmap = liftM-instance Applicative Result where- pure = return- (<*>) = ap--data Content = ContentRaw String- | ContentVar Deref- | ContentUrl Bool Deref -- ^ bool: does it include params?- | ContentEmbed Deref- | ContentMsg Deref- deriving (Show, Eq, Read, Data, Typeable)--data Line = LineForall Deref Ident- | LineIf Deref- | LineElseIf Deref- | LineElse- | LineWith [(Deref, Ident)]- | LineMaybe Deref Ident- | LineNothing- | LineTag- { _lineTagName :: String- , _lineAttr :: [(Maybe Deref, String, [Content])]- , _lineContent :: [Content]- , _lineClasses :: [(Maybe Deref, [Content])]- }- | LineContent [Content]- deriving (Eq, Show, Read)--parseLines :: HamletSettings -> String -> Result [(Int, Line)]-parseLines set s =- case parse (many $ parseLine set) s s of- Left e -> Error $ show e- Right x -> Ok x--parseLine :: HamletSettings -> Parser (Int, Line)-parseLine set = do- ss <- fmap sum $ many ((char ' ' >> return 1) <|>- (char '\t' >> return 4))- x <- doctype <|>- comment <|>- htmlComment <|>- backslash <|>- controlIf <|>- controlElseIf <|>- (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>- controlMaybe <|>- (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>- controlForall <|>- controlWith <|>- angle <|>- (eol' >> return (LineContent [])) <|>- (do- cs <- content InContent- isEof <- (eof >> return True) <|> return False- if null cs && ss == 0 && isEof- then fail "End of Hamlet template"- else return $ LineContent cs)- return (ss, x)- where- eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())- eol = eof <|> eol'- spaceTabs = many $ oneOf " \t"- doctype = do- try $ string "!!!" >> eol- return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"]- comment = do- _ <- try $ string "$#"- _ <- many $ noneOf "\r\n"- eol- return $ LineContent []- htmlComment = do- _ <- try $ string "<!--"- _ <- manyTill anyChar $ try $ string "-->"- x <- many nonComments- eol- return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables?- nonComments = (many1 $ noneOf "\r\n<") <|> (do- _ <- char '<'- (do- try $ string "!--"- _ <- manyTill anyChar $ try $ string "-->"- return "") <|> return "<")- backslash = do- _ <- char '\\'- (eol >> return (LineContent [ContentRaw "\n"]))- <|> (LineContent <$> content InContent)- controlIf = do- _ <- try $ string "$if"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineIf x- controlElseIf = do- _ <- try $ string "$elseif"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineElseIf x- binding = do- y <- ident- spaces- _ <- string "<-"- spaces- x <- parseDeref- _ <- 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- (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- InQuotes -> char '"' >> return ()- NotInQuotes -> return ()- NotInQuotesAttr -> return ()- InContent -> eol- return $ cc x- where- cc [] = []- cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c- cc (a:b) = a : cc b- content' cr = contentHash <|> contentAt <|> contentCaret- <|> contentUnder- <|> contentReg cr- contentHash = do- x <- parseHash- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentVar deref- contentAt = do- x <- parseAt- return $ case x of- Left str -> ContentRaw str- Right (s, y) -> ContentUrl y s- contentCaret = do- x <- parseCaret- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentEmbed deref- contentUnder = do- x <- parseUnder- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentMsg deref- contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"- contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"- contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"- contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r>"- tagAttribValue notInQuotes = do- cr <- (char '"' >> return InQuotes) <|> return notInQuotes- content cr- tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes- tagCond = do- _ <- char ':'- d <- parseDeref- _ <- char ':'- tagClass (Just d) <|> tagAttrib (Just d)- tagClass x = char '.' >> (TagClass . (,) x) <$> tagAttribValue NotInQuotes- tagAttrib cond = do- s <- many1 $ noneOf " \t=\r\n>"- v <- (do- _ <- char '='- s' <- tagAttribValue NotInQuotesAttr- return s') <|> return []- return $ TagAttrib (cond, s, v)- tag' = foldr tag'' ("div", [], [])- tag'' (TagName s) (_, y, z) = (s, y, z)- tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z)- tag'' (TagClass s) (x, y, z) = (x, y, s : z)- tag'' (TagAttrib s) (x, y, z) = (x, s : y, z)- ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'')- angle = do- _ <- char '<'- name' <- many $ noneOf " \t.#\r\n!>"- let name = if null name' then "div" else name'- xs <- many $ try ((many $ oneOf " \t") >>- (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrib Nothing))- _ <- many $ oneOf " \t"- c <- (eol >> return []) <|> (do- _ <- char '>'- c <- content InContent- return c)- let (tn, attr, classes) = tag' $ TagName name : xs- return $ LineTag tn attr c classes--data TagPiece = TagName String- | TagIdent [Content]- | TagClass (Maybe Deref, [Content])- | TagAttrib (Maybe Deref, String, [Content])- deriving Show--data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent--data Nest = Nest Line [Nest]--nestLines :: [(Int, Line)] -> [Nest]-nestLines [] = []-nestLines ((i, l):rest) =- let (deeper, rest') = span (\(i', _) -> i' > i) rest- in Nest l (nestLines deeper) : nestLines rest'--data Doc = DocForall Deref Ident [Doc]- | DocWith [(Deref,Ident)] [Doc]- | DocCond [(Deref, [Doc])] (Maybe [Doc])- | DocMaybe Deref Ident [Doc] (Maybe [Doc])- | DocContent Content- deriving (Show, Eq, Read, Data, Typeable)--nestToDoc :: HamletSettings -> [Nest] -> Result [Doc]-nestToDoc _set [] = Ok []-nestToDoc set (Nest (LineForall d i) inside:rest) = do- 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- rest'' <- nestToDoc set rest'- Ok $ DocCond ifs el : rest''-nestToDoc set (Nest (LineMaybe d i) inside:rest) = do- inside' <- nestToDoc set inside- (nothing, rest') <-- case rest of- Nest LineNothing ninside:x -> do- ninside' <- nestToDoc set ninside- return (Just ninside', x)- _ -> return (Nothing, rest)- rest'' <- nestToDoc set rest'- Ok $ DocMaybe d i inside' nothing : rest''-nestToDoc set (Nest (LineTag tn attrs content classes) inside:rest) = do- let attrFix (x, y, z) = (x, y, [(Nothing, z)])- let takeClass (a, "class", b) = Just (a, b)- takeClass _ = Nothing- let clazzes = classes ++ mapMaybe takeClass attrs- let notClass (_, x, _) = x /= "class"- let noclass = filter notClass attrs- let attrs' =- case clazzes of- [] -> map attrFix noclass- _ -> (Nothing, "class", clazzes)- : map attrFix noclass- let closeStyle =- if not (null content) || not (null inside)- then CloseSeparate- else hamletCloseStyle set tn- let end = case closeStyle of- CloseSeparate ->- DocContent $ ContentRaw $ "</" ++ tn ++ ">"- _ -> DocContent $ ContentRaw ""- seal = case closeStyle of- CloseInside -> DocContent $ ContentRaw "/>"- _ -> DocContent $ ContentRaw ">"- start = DocContent $ ContentRaw $ "<" ++ tn- attrs'' = concatMap attrToContent attrs'- newline' = DocContent $ ContentRaw- $ if hamletCloseNewline set then "\n" else ""- inside' <- nestToDoc set inside- rest' <- nestToDoc set rest- Ok $ start- : attrs''- ++ seal- : map DocContent content- ++ inside'- ++ end- : newline'- : rest'-nestToDoc set (Nest (LineContent content) inside:rest) = do- inside' <- nestToDoc set inside- rest' <- nestToDoc set rest- Ok $ map DocContent content ++ inside' ++ rest'-nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"-nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else"-nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing"--compressDoc :: [Doc] -> [Doc]-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-compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest)- | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest-compressDoc (DocCond x y:rest) =- DocCond (map (second compressDoc) x) (compressDoc `fmap` y)- : compressDoc rest-compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest-compressDoc ( DocContent (ContentRaw x)- : DocContent (ContentRaw y)- : rest- ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest-compressDoc (DocContent x:rest) = DocContent x : compressDoc rest--parseDoc :: HamletSettings -> String -> Result [Doc]-parseDoc set s = do- ls <- parseLines set s- let notEmpty (_, LineContent []) = False- notEmpty _ = True- let ns = nestLines $ filter notEmpty ls- ds <- nestToDoc set ns- return $ compressDoc ds--attrToContent :: (Maybe Deref, String, [(Maybe Deref, [Content])]) -> [Doc]-attrToContent (Just cond, k, v) =- [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing]-attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, [])]) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, v)]) =- DocContent (ContentRaw (' ' : k ++ "=\""))- : map DocContent v- ++ [DocContent $ ContentRaw "\""]-attrToContent (Nothing, k, v) = -- only for class- DocContent (ContentRaw (' ' : k ++ "=\""))- : concat (map go $ init v)- ++ go' (last v)- ++ [DocContent $ ContentRaw "\""]- where- go (Nothing, x) = map DocContent x ++ [DocContent $ ContentRaw " "]- go (Just b, x) =- [ DocCond- [(b, map DocContent x ++ [DocContent $ ContentRaw " "])]- Nothing- ]- go' (Nothing, x) = map DocContent x- go' (Just b, x) =- [ DocCond- [(b, map DocContent x)]- Nothing- ]---- | Settings for parsing of a hamlet document.-data HamletSettings = HamletSettings- {- -- | The value to replace a \"!!!\" with. Do not include the trailing- -- newline.- hamletDoctype :: String- -- | Should we put a newline after closing a tag? Mostly useful for debug- -- output.- , hamletCloseNewline :: Bool- -- | How a tag should be closed. Use this to switch between HTML, XHTML- -- or even XML output.- , hamletCloseStyle :: String -> CloseStyle- }--htmlEmptyTags :: Set String-htmlEmptyTags = Set.fromAscList- [ "area"- , "base"- , "basefont"- , "br"- , "col"- , "frame"- , "hr"- , "img"- , "input"- , "isindex"- , "link"- , "meta"- , "param"- ]---- | Defaults settings: HTML5 doctype and HTML-style empty tags.-defaultHamletSettings :: HamletSettings-defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False htmlCloseStyle--xhtmlHamletSettings :: HamletSettings-xhtmlHamletSettings =- HamletSettings doctype False xhtmlCloseStyle- where- doctype =- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++- "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"--debugHamletSettings :: HamletSettings-debugHamletSettings = HamletSettings "<!DOCTYPE html>" True htmlCloseStyle--htmlCloseStyle :: String -> CloseStyle-htmlCloseStyle s =- if Set.member s htmlEmptyTags- then NoClose- else CloseSeparate--xhtmlCloseStyle :: String -> CloseStyle-xhtmlCloseStyle s =- if Set.member s htmlEmptyTags- then CloseInside- else CloseSeparate--data CloseStyle = NoClose | CloseInside | CloseSeparate--parseConds :: HamletSettings- -> ([(Deref, [Doc])] -> [(Deref, [Doc])])- -> [Nest]- -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])-parseConds set front (Nest LineElse inside:rest) = do- inside' <- nestToDoc set inside- Ok $ (front [], Just inside', rest)-parseConds set front (Nest (LineElseIf d) inside:rest) = do- inside' <- nestToDoc set inside- parseConds set (front . (:) (d, inside')) rest-parseConds _ front rest = Ok (front [], Nothing, rest)
− Text/Julius.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Julius- ( Julius- , Javascript (..)- , ToJavascript (..)- , renderJulius- , julius- , juliusFile- , juliusFileDebug- ) where--import Language.Haskell.TH.Quote (QuasiQuoter (..))-import Language.Haskell.TH.Syntax-import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)-import Data.Monoid-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import Text.Romeo--renderJavascript :: Javascript -> TL.Text-renderJavascript (Javascript b) = toLazyText b--renderJulius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Julius url -> TL.Text-renderJulius r s = renderJavascript $ s r--newtype Javascript = Javascript { unJavascript :: Builder }- deriving Monoid-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--settings :: Q RomeoSettings-settings = do- toJExp <- [|toJavascript|]- wrapExp <- [|Javascript|]- unWrapExp <- [|unJavascript|]- return $ defaultRomeoSettings { toBuilder = toJExp- , wrap = wrapExp- , unwrap = unWrapExp- }--julius :: QuasiQuoter-julius = QuasiQuoter { quoteExp = \s -> do- rs <- settings- quoteExp (romeo rs) s- }--juliusFile :: FilePath -> Q Exp-juliusFile fp = do- rs <- settings- romeoFile rs fp--juliusFileDebug :: FilePath -> Q Exp-juliusFileDebug fp = do- rs <- settings- romeoFileDebug rs fp
− Text/Lucius.hs
@@ -1,165 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Lucius- ( -- * Datatypes- Lucius- -- * Rendering- , renderLucius- -- * Parsing- , lucius- , luciusFile- , luciusFileDebug- -- * Re-export cassius- , module Text.Cassius- ) where--import Text.Cassius hiding (Cassius, renderCassius, cassius, cassiusFile, cassiusFileDebug)-import Text.Shakespeare-import Language.Haskell.TH.Quote (QuasiQuoter (..))-import Language.Haskell.TH.Syntax-import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL-import qualified Text.Cassius as C-import Text.ParserCombinators.Parsec hiding (Line)-import Text.Css-import Data.Char (isSpace)-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 =- topLevelsToCassius- $ either (error . show) id $ parse parseTopLevels s s--whiteSpace :: Parser ()-whiteSpace = many- ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))- >> return () -- FIXME comments, don't use many--parseBlock :: Parser Block-parseBlock = do- sel <- parseSelector- _ <- char '{'- whiteSpace- pairsBlocks <- parsePairsBlocks id- let (pairs, blocks) = partitionEithers pairsBlocks- whiteSpace- return $ Block sel pairs blocks--parseSelector :: Parser Selector-parseSelector =- go id- where- go front = do- c <- parseContents "{,"- let front' = front . (:) (trim c)- (char ',' >> go front') <|> return (front' [])--trim :: Contents -> Contents-trim =- reverse . trim' False . reverse . trim' True- where- trim' _ [] = []- trim' b (ContentRaw s:rest) =- let s' = trimS b s- in if null s' then trim' b rest else ContentRaw s' : rest- trim' _ x = x- trimS True = dropWhile isSpace- trimS False = reverse . dropWhile isSpace . reverse--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- key <- parseContents ":"- _ <- char ':'- whiteSpace- val <- parseContents ";}"- (char ';' >> return ()) <|> return ()- whiteSpace- return (key, val)--parseContents :: String -> Parser Contents-parseContents = many1 . parseContent--parseContent :: String -> Parser Content-parseContent restricted =- parseHash' <|> parseAt' <|> parseComment <|> parseChar- where- parseHash' = either ContentRaw ContentVar `fmap` parseHash- parseAt' =- either ContentRaw go `fmap` parseAt- where- go (d, False) = ContentUrl d- go (d, True) = ContentUrlParam d- parseChar = (ContentRaw . return) `fmap` noneOf restricted--parseComment :: Parser Content-parseComment = do- _ <- 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
@@ -1,73 +0,0 @@--- | Internal functions to generate CSS size wrapper types.-module Text.MkSizeType (mkSizeType) where--import Language.Haskell.TH.Syntax--mkSizeType :: String -> String -> Q [Dec]-mkSizeType name' unit = return [ dataDec name- , showInstanceDec name unit- , numInstanceDec name- , fractionalInstanceDec name- , toCssInstanceDec name ]- where name = mkName $ name'--dataDec :: Name -> Dec-dataDec name = DataD [] name [] [constructor] derives- where constructor = NormalC name [(NotStrict, ConT $ mkName "Rational")]- derives = map mkName ["Eq", "Ord"]--showInstanceDec :: Name -> String -> Dec-showInstanceDec name unit' = InstanceD [] (instanceType "Show" name) [showDec]- where showSize = VarE $ mkName "showSize"- x = mkName "x"- unit = LitE $ StringL unit'- showDec = FunD (mkName "show") [Clause [showPat] showBody []]- showPat = ConP name [VarP x]- showBody = NormalB $ AppE (AppE showSize $ VarE x) unit--numInstanceDec :: Name -> Dec-numInstanceDec name = InstanceD [] (instanceType "Num" name) decs- where decs = map (binaryFunDec name) ["+", "*", "-"] ++- map (unariFunDec1 name) ["abs", "signum"] ++- [unariFunDec2 name "fromInteger"]--fractionalInstanceDec :: Name -> Dec-fractionalInstanceDec name = InstanceD [] (instanceType "Fractional" name) decs- where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"]--toCssInstanceDec :: Name -> Dec-toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec]- where toCssDec = FunD (mkName "toCss") [Clause [] showBody []]- 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")--instanceType :: String -> Name -> Type-instanceType className name = AppT (ConT $ mkName className) (ConT name)--binaryFunDec :: Name -> String -> Dec-binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []]- where pat1 = ConP name [VarP v1]- pat2 = ConP name [VarP v2]- body = NormalB $ AppE (ConE name) result- result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2)- fun = mkName fun'- v1 = mkName "v1"- v2 = mkName "v2"--unariFunDec1 :: Name -> String -> Dec-unariFunDec1 name fun' = FunD fun [Clause [pat] body []]- where pat = ConP name [VarP v]- body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v))- fun = mkName fun'- v = mkName "v"--unariFunDec2 :: Name -> String -> Dec-unariFunDec2 name fun' = FunD fun [Clause [pat] body []]- where pat = VarP x- body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x))- fun = mkName fun'- x = mkName "x"
− Text/Romeo.hs
@@ -1,205 +0,0 @@-{-# 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.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
@@ -1,225 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}--- | General parsers, functions and datatypes for all three languages.-module Text.Shakespeare- ( Deref (..)- , Ident (..)- , Scope- , parseDeref- , parseHash- , parseVar- , parseAt- , parseUrl- , parseCaret- , parseUnder- , parseInt- , derefToExp- , flattenDeref- , readUtf8File- ) where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH (appE)-import Data.Char (isUpper)-import Text.ParserCombinators.Parsec-import Data.List (intercalate)-import Data.Ratio (Ratio, numerator, denominator, (%))-import Data.Data (Data)-import Data.Typeable (Typeable)-import qualified Data.Text.Lazy as TL-import qualified System.IO as SIO-import qualified Data.Text.Lazy.IO as TIO--newtype Ident = Ident String- deriving (Show, Eq, Read, Data, Typeable)--type Scope = [(Ident, Exp)]--data Deref = DerefModulesIdent [String] Ident- | DerefIdent Ident- | DerefIntegral Integer- | DerefRational Rational- | DerefString String- | DerefBranch Deref Deref- deriving (Show, Eq, Read, Data, Typeable)--instance Lift Ident where- lift (Ident s) = [|Ident|] `appE` lift s-instance Lift Deref where- lift (DerefModulesIdent v s) = do- dl <- [|DerefModulesIdent|]- v' <- lift v- s' <- lift s- return $ dl `AppE` v' `AppE` s'- lift (DerefIdent s) = do- dl <- [|DerefIdent|]- s' <- lift s- return $ dl `AppE` s'- lift (DerefBranch x y) = do- x' <- lift x- y' <- lift y- db <- [|DerefBranch|]- return $ db `AppE` x' `AppE` y'- lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i- lift (DerefRational r) = do- n <- lift $ numerator r- d <- lift $ denominator r- per <- [|(%) :: Int -> Int -> Ratio Int|]- dr <- [|DerefRational|]- return $ dr `AppE` (InfixE (Just n) per (Just d))- lift (DerefString s) = [|DerefString|] `appE` lift s--parseDeref :: Parser Deref-parseDeref = do- skipMany $ oneOf " \t"- x <- derefSingle- res <- deref' $ (:) x- skipMany $ oneOf " \t"- return res- where- delim = (many1 (char ' ') >> return())- <|> lookAhead (char '(' >> return ())- derefOp = try $ do- _ <- char '('- x <- many1 $ noneOf " \t\n\r()"- _ <- char ')'- return $ DerefIdent $ Ident x- derefParens = between (char '(') (char ')') parseDeref- derefSingle = derefOp <|> derefParens <|> numeric <|> strLit<|> ident- deref' lhs =- dollar <|> derefSingle'- <|> return (foldl1 DerefBranch $ lhs [])- where- dollar = do- _ <- try $ delim >> char '$'- rhs <- parseDeref- let lhs' = foldl1 DerefBranch $ lhs []- return $ DerefBranch lhs' rhs- derefSingle' = do- x <- try $ delim >> derefSingle- deref' $ lhs . (:) x- numeric = do- n <- (char '-' >> return "-") <|> return ""- x <- many1 digit- y <- (char '.' >> fmap Just (many1 digit)) <|> return Nothing- return $ case y of- Nothing -> DerefIntegral $ read' "Integral" $ n ++ x- Just z -> DerefRational $ toRational- (read' "Rational" $ n ++ x ++ '.' : z :: Double)- strLit = do- _ <- char '"'- chars <- many quotedChar- _ <- char '"'- return $ DerefString chars- quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""- escapedChar =- (char 'n' >> return '\n') <|>- (char 'r' >> return '\r') <|>- (char 'b' >> return '\b') <|>- (char 't' >> return '\t') <|>- (char '\\' >> return '\\') <|>- (char '"' >> return '"') <|>- (char '\'' >> return '\'')- ident = do- mods <- many modul- func <- many1 (alphaNum <|> char '_' <|> char '\'')- let func' = Ident func- return $- if null mods- then DerefIdent func'- else DerefModulesIdent mods func'- modul = try $ do- c <- upper- cs <- many (alphaNum <|> char '_')- _ <- char '.'- return $ c : cs--read' :: Read a => String -> String -> a-read' t s =- case reads s of- (x, _):_ -> x- [] -> error $ t ++ " read failed: " ++ s--expType :: Ident -> Name -> Exp-expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE-expType (Ident "") = error "Bad Ident"--derefToExp :: Scope -> Deref -> Exp-derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y-derefToExp _ (DerefModulesIdent mods i@(Ident s)) =- expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods)-derefToExp scope (DerefIdent i@(Ident s)) =- case lookup i scope of- Just e -> e- Nothing -> expType i $ mkName s-derefToExp _ (DerefIntegral i) = LitE $ IntegerL i-derefToExp _ (DerefRational r) = LitE $ RationalL r-derefToExp _ (DerefString s) = LitE $ StringL s---- FIXME shouldn't we use something besides a list here?-flattenDeref :: Deref -> Maybe [String]-flattenDeref (DerefIdent (Ident x)) = Just [x]-flattenDeref (DerefBranch (DerefIdent (Ident x)) y) = do- y' <- flattenDeref y- Just $ y' ++ [x]-flattenDeref _ = Nothing--parseHash :: Parser (Either String Deref)-parseHash = parseVar '#'--parseVar :: Char -> Parser (Either String Deref)-parseVar c = do- _ <- char c- (char '\\' >> return (Left [c])) <|> (do- _ <- char '{'- deref <- parseDeref- _ <- char '}'- return $ Right deref) <|> (do- -- Check for hash just before newline- _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof- return $ Left ""- ) <|> return (Left [c])--parseAt :: Parser (Either String (Deref, Bool))-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 [c, d] else [c]))--parseCaret :: Parser (Either String Deref)-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 [c])--parseUnder :: Parser (Either String Deref)-parseUnder = do- _ <- char '_'- (char '\\' >> return (Left "_")) <|> (do- _ <- char '{'- deref <- parseDeref- _ <- char '}'- return $ Right deref) <|> return (Left "_")--readUtf8File :: FilePath -> IO TL.Text-readUtf8File fp = do- h <- SIO.openFile fp SIO.ReadMode- SIO.hSetEncoding h SIO.utf8_bom- TIO.hGetContents h
hamlet.cabal view
@@ -1,14 +1,14 @@ name: hamlet-version: 0.9.0-license: BSD3+version: 1.2.0+license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Haml-like template files that are compile-time checked+synopsis: Haml-like template files that are compile-time checked (deprecated) description:- Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at <http://docs.yesodweb.com/book/hamlet/> for more details.+ Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at <http://www.yesodweb.com/book/shakespearean-templates> for more details. .- Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see http://docs.yesodweb.com/book/templates for a thorough description+ Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see <http://www.yesodweb.com/book/shakespearean-templates> for a thorough description . > !!! > <html>@@ -25,47 +25,13 @@ stability: Stable cabal-version: >= 1.8 build-type: Simple-homepage: http://www.yesodweb.com/book/templates+homepage: http://www.yesodweb.com/book/shakespearean-templates library build-depends: base >= 4 && < 5- , bytestring >= 0.9 && < 0.10- , template-haskell- , blaze-html >= 0.4 && < 0.5- , parsec >= 2 && < 4- , failure >= 0.1 && < 0.2- , text >= 0.7 && < 0.12- , containers >= 0.2 && < 0.5- , blaze-builder >= 0.2 && < 0.4- , process >= 1.0 && < 1.1- exposed-modules: Text.Hamlet- Text.Cassius- Text.Lucius- Text.Julius- Text.Coffee- Text.Romeo- Text.Shakespeare- other-modules: Text.Hamlet.Parse- Text.MkSizeType- Text.Css- ghc-options: -Wall--test-suite runtests- hs-source-dirs: tests- main-is: runtests.hs- type: exitcode-stdio-1.0-- ghc-options: -Wall- build-depends: hamlet >= 0.9 && < 0.10- , base >= 4 && < 5- , parsec >= 2 && < 4- , containers >= 0.2 && < 0.5- , text >= 0.7 && < 1- , HUnit- , hspec- , blaze-html >= 0.4 && < 0.5+ , shakespeare >= 2.0 source-repository head type: git- location: git://github.com/yesodweb/hamlet.git+ location: git://github.com/yesodweb/shakespeare.git