shakespeare-2.0.7/0000755000000000000000000000000012610626007012201 5ustar0000000000000000shakespeare-2.0.7/LICENSE0000644000000000000000000000207512610626007013212 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. shakespeare-2.0.7/shakespeare.cabal0000644000000000000000000001276712610626007015475 0ustar0000000000000000name: shakespeare version: 2.0.7 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: A toolkit for making compile-time interpolated templates description: Shakespeare is a family of type-safe, efficient template languages. Shakespeare templates are expanded at compile-time, ensuring that all interpolated variables are in scope. Variables are interpolated according to their type through a typeclass. . Shakespeare templates can be used inline with a quasi-quoter or in an external file. . Note there is no dependency on haskell-src-extras. Instead Shakespeare believes logic should stay out of templates and has its own minimal Haskell parser. . Packages that use this: shakespeare-js, shakespeare-css, shakespeare-text, hamlet, and xml-hamlet . Please see the documentation at for more details. category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates extra-source-files: test/reload.txt test/texts/*.text test/juliuses/*.julius test/juliuses/*.coffee test-messages/*.msg test/cassiuses/*.cassius test/cassiuses/*.lucius test/hamlets/*.hamlet test/tmp.hs ChangeLog.md library build-depends: base >= 4 && < 5 , time >= 1 , containers , template-haskell >= 2.7 , parsec >= 2 && < 4 , text >= 0.7 , process >= 1.0 , ghc-prim , bytestring , directory >= 1.2 , aeson , blaze-markup , blaze-html , exceptions , transformers , vector , unordered-containers , scientific exposed-modules: Text.Shakespeare.I18N Text.Shakespeare.Text Text.Roy Text.Julius Text.Coffee Text.Hamlet Text.Hamlet.RT Text.Hamlet.Runtime Text.Lucius Text.Cassius Text.Shakespeare.Base Text.Shakespeare Text.TypeScript other-modules: Text.Hamlet.Parse Text.Css Text.MkSizeType Text.IndentToBrace Text.CssCommon ghc-options: -Wall if flag(test_export) cpp-options: -DTEST_EXPORT extensions: TemplateHaskell if impl(ghc >= 7.4) cpp-options: -DGHC_7_4 if os(windows) CPP-Options: "-DWINDOWS" if flag(test_coffee) cpp-options: -DTEST_COFFEE if flag(test_roy) cpp-options: -DTEST_ROY if flag(test_export) cpp-options: -DTEST_EXPORT Flag test_export default: False flag test_coffee description: render tests through coffeescript render function -- cabal configure --enable-tests -ftest_coffee && cabal build && dist/build/test/test default: False flag test_roy description: render tests through coffeescript render function -- cabal configure --enable-tests -ftest_coffee && cabal build && dist/build/test/test default: False -- Commented out due to concerns that the Hackage page looks too intimidating. -- flag servius -- description: build the servius web server -- default: True -- -- Executable servius -- Main-is: servius.hs -- hs-source-dirs: app -- if flag(servius) -- buildable: True -- else -- buildable: False -- Build-depends: base >= 4 && < 5 -- , wai-app-static >= 2.0.1 && < 2.1 -- , bytestring >= 0.9.1.4 -- , text >= 0.7 -- , http-types -- , shakespeare -- , wai >= 1.3 && < 2.2 -- , blaze-html >= 0.5 -- , blaze-builder test-suite test hs-source-dirs: test main-is: Spec.hs other-modules: Text.Shakespeare.BaseSpec Text.Shakespeare.I18NSpec Text.Shakespeare.JsSpec Text.Shakespeare.TextSpec Text.Shakespeare.CssSpec Text.Shakespeare.HamletSpec Quoter HamletTestTypes cpp-options: -DTEST_EXPORT type: exitcode-stdio-1.0 ghc-options: -Wall build-depends: base >= 4 && < 5 , shakespeare , time >= 1 , containers , parsec >= 2 && < 4 , hspec == 2.* , text >= 0.7 , process , template-haskell >= 2.7 , ghc-prim , HUnit , bytestring , directory , aeson , transformers , blaze-markup , blaze-html , exceptions extensions: TemplateHaskell source-repository head type: git location: git://github.com/yesodweb/shakespeare.git shakespeare-2.0.7/Setup.lhs0000644000000000000000000000021712610626007014011 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain shakespeare-2.0.7/ChangeLog.md0000644000000000000000000000542412610626007014357 0ustar0000000000000000### 2.0.7 * Include aeson's JSON encoding and escape `<`, `>` and `&` to avoid XSS attacks ### 2.0.6 * Provide the `Text.Hamlet.Runtime` module ### 2.0.5 * Drop system-filepath ### 2.0.4.1 Fix build for GHC 7.10 [#151](https://github.com/yesodweb/shakespeare/pull/151) ### 2.0.4 * [Add multiline literal aligned with bar #148](https://github.com/yesodweb/shakespeare/pull/148) ### 2.0.3 * `cassiusMixin` added ### 2.0.2.2 GHC 7.10 support ### shakesepare 2.0.2 shakespeare-i18n supports message directories. ### Hamlet 0.5.0 (August 29, 2010) * Use can use parantheses when referencing variables. This allows you to have functions applied to multiple arguments. * Added the hamlet' and xhamlet' quasiquoters for generating plain Html values. * Added runtime Hamlet support. * Added "file debug" support. This is a mode that is a drop-in replacement for external files compiled via template haskell. However, this mode also has a runtime component, in that is reads your templates at runtime, thus avoiding the need to a recompile for each template change. This takes a runtime hit obviously, so it's recommended that you switch back to the compile-time templates for production systems. * Added the Cassius and Julius template languages for CSS and Javascript, respectively. The former is white-space sensitive, whereas the latter is just a passthrough for raw Javascript code. The big feature in both of them is that they support variable interpolation just like Hamlet does. ### New in Hamlet 0.4.0 * Internal template parsing is now done via Parsec. This opened the doors for the other changes mentioned below, but also hopefully gives more meaningful error messages. There's absolutely no runtime performance hit for this change, since all parsing is done at compile time, and if there *is* any compile-time hit, it's too negligible to be noticed. * Attribute values can now be quoted. This allows you to embed spaces, periods and pounds in an attribute value. For example: [$hamlet|%input!type=submit!value="Add new value"|]. * Space-delimited references in addition to period-delimited ones. This only applies to references in content, not in statements. For example, you could write [\$hamlet|\$foo bar baz\$|]. * Dollar-sign interpolation is now polymorphic, based on the ToHtml typeclass. You can now do away with \$string.var\$ and simply type \$var\$. Currently, the ToHtml typeclass is not exposed, and it only provides instances for String and Html, though this is open for discussion. * Added hamletFile and xhamletFile which loads a Hamlet template from an external file. The file is parsed at compile time, just like a quasi-quoted template, and must be UTF-8 encoded. Additionally, be warned that the compiler won't automatically know to recompile a module if the template file gets changed. shakespeare-2.0.7/Text/0000755000000000000000000000000012610626007013125 5ustar0000000000000000shakespeare-2.0.7/Text/IndentToBrace.hs0000644000000000000000000000542312610626007016146 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Text.IndentToBrace ( i2b ) where import Control.Monad.Trans.Writer (execWriter, tell, Writer) import Data.List (isInfixOf) import qualified Data.Text as T i2b :: String -> String i2b = ($ []) . execWriter . mapM_ unnest . map addClosingCount . nest . map toL . stripComments . lines . filter (/= '\r') stripComments :: [String] -> [String] stripComments = map T.unpack . go False . map T.pack where go _ [] = [] go False (l:ls) = let (before, after') = T.breakOn "/*" l in case T.stripPrefix "/*" after' of Nothing -> l : go False ls Just after -> let (x:xs) = go True $ after : ls in before `T.append` x : xs go True (l:ls) = let (_, after') = T.breakOn "*/" l in case T.stripPrefix "*/" after' of Nothing -> T.empty : go True ls Just after -> go False $ after : ls data Line = Line { lineIndent :: Int , lineContent :: String } deriving (Show, Eq) data Nest = Nest Line Int [Nest] | Blank String deriving (Show, Eq) isBlank :: Nest -> Bool isBlank Blank{} = True isBlank _ = False addClosingCount :: Nest -> Nest addClosingCount (Blank x) = Blank x addClosingCount (Nest l c children) = Nest l c $ increment $ map addClosingCount children where increment | any (not . isBlank) children = increment' | otherwise = id increment' [] = error "should never happen" increment' (Blank x:rest) = Blank x : increment' rest increment' (n@(Nest l' c' children'):rest) | any (not . isBlank) rest = n : increment' rest | any (not . isBlank) children' = Nest l' c' (increment' children') : rest | otherwise = Nest l' (c' + 1) children' : rest toL :: String -> Either String Line toL s | null y = Left s | otherwise = Right $ Line (length x) y where (x, y) = span (== ' ') s nest :: [Either String Line] -> [Nest] nest [] = [] nest (Left x:rest) = Blank x : nest rest nest (Right l:rest) = Nest l 0 (nest inside) : nest outside where (inside, outside) = span isNested rest isNested Left{} = True isNested (Right l2) = lineIndent l2 > lineIndent l tell' :: String -> Writer (String -> String) () tell' s = tell (s ++) unnest :: Nest -> Writer (String -> String) () unnest (Blank x) = do tell' x tell' "\n" unnest (Nest l count inside) = do tell' $ replicate (lineIndent l) ' ' tell' $ lineContent l tell' $ case () of () | not $ all isBlank inside -> " {" | ";" `isInfixOf` lineContent l -> "" | otherwise -> ";" tell' $ replicate count '}' tell' "\n" mapM_ unnest inside shakespeare-2.0.7/Text/Lucius.hs0000644000000000000000000003001312610626007014722 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Lucius ( -- * Parsing lucius , luciusFile , luciusFileDebug , luciusFileReload -- ** Mixins , luciusMixin , Mixin -- ** Runtime , luciusRT , luciusRT' , luciusRTMinified -- *** Mixin , luciusRTMixin , RTValue (..) , -- * Datatypes Css , CssUrl -- * Type class , ToCss (..) -- * Rendering , renderCss , renderCssUrl -- * ToCss instances -- ** Color , Color (..) , colorRed , colorBlack -- ** Size , mkSize , AbsoluteUnit (..) , AbsoluteSize (..) , absoluteSize , EmSize (..) , ExSize (..) , PercentageSize (..) , percentageSize , PixelSize (..) -- * Internal , parseTopLevels , luciusUsedIdentifiers ) where import Text.CssCommon import Text.Shakespeare.Base import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text (Text, unpack) import qualified Data.Text.Lazy as TL import Text.ParserCombinators.Parsec hiding (Line) import Text.Css import Data.Char (isSpace, toLower, toUpper) import Numeric (readHex) import Control.Applicative ((<$>)) import Control.Monad (when, unless) import Data.Monoid (mconcat) import Data.List (isSuffixOf) import Control.Arrow (second) import Text.Shakespeare (VarType) -- | -- -- >>> renderCss ([lucius|foo{bar:baz}|] undefined) -- "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 whiteSpace1 >> return () whiteSpace1 :: Parser () whiteSpace1 = ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ())) parseBlock :: Parser (Block Unresolved) parseBlock = do sel <- parseSelector _ <- char '{' whiteSpace pairsBlocks <- parsePairsBlocks id let (pairs, blocks, mixins) = partitionPBs pairsBlocks whiteSpace return $ Block sel pairs (map detectAmp blocks) mixins -- | Looks for an & at the beginning of a selector and, if present, indicates -- that we should not have a leading space. Otherwise, we should have the -- leading space. detectAmp :: Block Unresolved -> (Bool, Block Unresolved) detectAmp (Block (sel) b c d) = (hls, Block sel' b c d) where (hls, sel') = case sel of (ContentRaw "&":rest):others -> (False, rest : others) (ContentRaw ('&':s):rest):others -> (False, (ContentRaw s : rest) : others) _ -> (True, sel) partitionPBs :: [PairBlock] -> ([Attr Unresolved], [Block Unresolved], [Deref]) partitionPBs = go id id id where go a b c [] = (a [], b [], c []) go a b c (PBAttr x:xs) = go (a . (x:)) b c xs go a b c (PBBlock x:xs) = go a (b . (x:)) c xs go a b c (PBMixin x:xs) = go a b (c . (x:)) xs parseSelector :: Parser (Selector Unresolved) 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 data PairBlock = PBAttr (Attr Unresolved) | PBBlock (Block Unresolved) | PBMixin Deref parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock] parsePairsBlocks front = (char '}' >> return (front [])) <|> (do isBlock <- lookAhead checkIfBlock x <- grabMixin <|> (if isBlock then grabBlock else grabPair) parsePairsBlocks $ front . (:) x) where grabBlock = do b <- parseBlock whiteSpace return $ PBBlock b grabPair = PBAttr <$> parsePair grabMixin = try $ do whiteSpace Right x <- parseCaret whiteSpace return $ PBMixin x checkIfBlock = do skipMany $ noneOf "#@{};" (parseHash >> checkIfBlock) <|> (parseAt >> checkIfBlock) <|> (char '{' >> return True) <|> (oneOf ";}" >> return False) <|> (anyChar >> checkIfBlock) <|> fail "checkIfBlock" parsePair :: Parser (Attr Unresolved) parsePair = do key <- parseContents ":" _ <- char ':' whiteSpace val <- parseContents ";}" (char ';' >> return ()) <|> return () whiteSpace return $ Attr key val parseContents :: String -> Parser Contents parseContents = many1 . parseContent parseContent :: String -> Parser Content parseContent restricted = parseHash' <|> parseAt' <|> parseComment <|> parseBack <|> 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 parseBack = try $ do _ <- char '\\' hex <- atMost 6 $ satisfy isHex (int, _):_ <- return $ readHex $ dropWhile (== '0') hex when (length hex < 6) $ ((string "\r\n" >> return ()) <|> (satisfy isSpace >> return ())) return $ ContentRaw [toEnum int] parseChar = (ContentRaw . return) `fmap` noneOf restricted isHex :: Char -> Bool isHex c = ('0' <= c && c <= '9') || ('A' <= c && c <= 'F') || ('a' <= c && c <= 'f') atMost :: Int -> Parser a -> Parser [a] atMost 0 _ = return [] atMost i p = (do c <- p s <- atMost (i - 1) p return $ c : s) <|> return [] parseComment :: Parser Content parseComment = do _ <- try $ string "/*" _ <- manyTill anyChar $ try $ string "*/" return $ ContentRaw "" luciusFile :: FilePath -> Q Exp luciusFile fp = do #ifdef GHC_7_4 qAddDependentFile fp #endif contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp luciusFromString contents luciusFileDebug, luciusFileReload :: FilePath -> Q Exp luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels luciusFileReload = luciusFileDebug parseTopLevels :: Parser [TopLevel Unresolved] parseTopLevels = go id where go front = do let string' s = string s >> return () ignore = many (whiteSpace1 <|> string' "") >> return () ignore tl <- ((charset <|> media <|> impor <|> topAtBlock <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x)) <|> (return $ map compressTopLevel $ front []) ignore return tl charset = do try $ stringCI "@charset " cs <- parseContents ";" _ <- char ';' return $ TopAtDecl "charset" cs media = do try $ stringCI "@media " selector <- parseContents "{" _ <- char '{' b <- parseBlocks id return $ TopAtBlock "media" selector b impor = do try $ stringCI "@import "; val <- parseContents ";" _ <- char ';' return $ TopAtDecl "import" val var = try $ do _ <- char '@' isPage <- (try $ string "page " >> return True) <|> (try $ string "font-face " >> return True) <|> return False when isPage $ fail "page is not a variable" k <- many1 $ noneOf ":" _ <- char ':' v <- many1 $ noneOf ";" _ <- char ';' let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace return $ TopVar (trimS k) (trimS v) topAtBlock = do (name, selector) <- try $ do _ <- char '@' name <- many1 $ noneOf " \t" _ <- many1 $ oneOf " \t" unless ("keyframes" `isSuffixOf` name) $ fail "only accepting keyframes" selector <- parseContents "{" _ <- char '{' return (name, selector) b <- parseBlocks id return $ TopAtBlock name selector b parseBlocks front = do whiteSpace (char '}' >> return (map compressBlock $ front [])) <|> (parseBlock >>= \x -> parseBlocks (front . (:) x)) stringCI :: String -> Parser () stringCI [] = return () stringCI (c:cs) = (char (toLower c) <|> char (toUpper c)) >> stringCI cs luciusRT' :: TL.Text -> Either String ([(Text, Text)] -> Either String [TopLevel Resolved]) luciusRT' = either Left (Right . go) . luciusRTInternal where go :: ([(Text, RTValue)] -> Either String [TopLevel Resolved]) -> ([(Text, Text)] -> Either String [TopLevel Resolved]) go f = f . map (second RTVRaw) luciusRTInternal :: TL.Text -> Either String ([(Text, RTValue)] -> Either String [TopLevel Resolved]) luciusRTInternal tl = case parse parseTopLevels (TL.unpack tl) (TL.unpack tl) of Left s -> Left $ show s Right tops -> Right $ \scope -> go scope tops where go :: [(Text, RTValue)] -> [TopLevel Unresolved] -> Either String [TopLevel Resolved] go _ [] = Right [] go scope (TopAtDecl dec cs':rest) = do let scope' = map goScope scope render = error "luciusRT has no URLs" cs <- mapM (contentToBuilderRT scope' render) cs' rest' <- go scope rest Right $ TopAtDecl dec (mconcat cs) : rest' go scope (TopBlock b:rest) = do b' <- goBlock scope b rest' <- go scope rest Right $ map TopBlock b' ++ rest' go scope (TopAtBlock name m' bs:rest) = do let scope' = map goScope scope render = error "luciusRT has no URLs" m <- mapM (contentToBuilderRT scope' render) m' bs' <- mapM (goBlock scope) bs rest' <- go scope rest Right $ TopAtBlock name (mconcat m) (concat bs') : rest' go scope (TopVar k v:rest) = go ((pack k, RTVRaw $ pack v):scope) rest goBlock :: [(Text, RTValue)] -> Block Unresolved -> Either String [Block Resolved] goBlock scope = either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs") where scope' = map goScope scope goScope (k, rt) = (DerefIdent (Ident $ unpack k), cd) where cd = case rt of RTVRaw t -> CDPlain $ fromText t RTVMixin m -> CDMixin m luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl) -- | Runtime Lucius with mixin support. -- -- Since 1.0.6 luciusRTMixin :: TL.Text -- ^ template -> Bool -- ^ minify? -> [(Text, RTValue)] -- ^ scope -> Either String TL.Text luciusRTMixin tl minify scope = either Left (Right . renderCss . cw) $ either Left ($ scope) (luciusRTInternal tl) where cw | minify = CssNoWhitespace | otherwise = CssWhitespace data RTValue = RTVRaw Text | RTVMixin Mixin -- | Same as 'luciusRT', but output has no added whitespace. -- -- Since 1.0.3 luciusRTMinified :: TL.Text -> [(Text, Text)] -> Either String TL.Text luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $ either Left ($ scope) (luciusRT' tl) -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. luciusUsedIdentifiers :: String -> [(Deref, VarType)] luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels luciusMixin :: QuasiQuoter luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString } luciusMixinFromString :: String -> Q Exp luciusMixinFromString s' = do r <- newName "_render" case fmap compressBlock $ parse parseBlock s s of Left e -> error $ show e Right block -> blockToMixin r [] block where s = concat ["mixin{", s', "}"] shakespeare-2.0.7/Text/CssCommon.hs0000644000000000000000000001320512610626007015363 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} module Text.CssCommon where import Text.Css import Text.MkSizeType import qualified Data.Text as TS import Text.Printf (printf) import Language.Haskell.TH import Data.Word (Word8) import Data.Bits import qualified Data.Text.Lazy as TL renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text renderCssUrl r s = renderCss $ s r 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 -- 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" shakespeare-2.0.7/Text/Coffee.hs0000644000000000000000000000714212610626007014654 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for CoffeeScript, introducing type-safe, -- compile-time variable and url interpolation. It is exactly the same as -- "Text.Julius", except that the template is first compiled to Javascript with -- the system tool @coffee@. -- -- To use this module, @coffee@ must be installed on your system. -- -- @#{...}@ is the Shakespearean standard for variable interpolation, but -- CoffeeScript already uses that sequence for string interpolation. Therefore, -- Shakespearean interpolation is introduced with @%{...}@. -- -- If you interpolate variables, -- the template is first wrapped with a function containing javascript variables representing shakespeare variables, -- then compiled with @coffee@, -- and then the value of the variables are applied to the function. -- This means that in production the template can be compiled -- once at compile time and there will be no dependency in your production -- system on @coffee@. -- -- Your code: -- -- > b = 1 -- > console.log(#{a} + b) -- -- Function wrapper added to your coffeescript code: -- -- > ((shakespeare_var_a) => -- > b = 1 -- > console.log(shakespeare_var_a + b) -- > ) -- -- This is then compiled down to javascript, and the variables are applied: -- -- > ;(function(shakespeare_var_a){ -- > var b = 1; -- > console.log(shakespeare_var_a + b); -- > })(#{a}); -- -- -- Further reading: -- -- 1. Shakespearean templates: -- -- 2. CoffeeScript: module Text.Coffee ( -- * Functions -- ** Template-Reading Functions -- | These QuasiQuoter and Template Haskell methods return values of -- type @'JavascriptUrl' url@. See the Yesod book for details. coffee , coffeeFile , coffeeFileReload , coffeeFileDebug #ifdef TEST_EXPORT , coffeeSettings #endif ) where import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Text.Shakespeare import Text.Julius coffeeSettings :: Q ShakespeareSettings coffeeSettings = do jsettings <- javascriptSettings return $ jsettings { varChar = '%' , preConversion = Just PreConvert { preConvert = ReadProcess "coffee" ["-spb"] , preEscapeIgnoreBalanced = "'\"`" -- don't insert backtacks for variable already inside strings or backticks. , preEscapeIgnoreLine = "#" -- ignore commented lines , wrapInsertion = Just WrapInsertion { wrapInsertionIndent = Just " " , wrapInsertionStartBegin = "(" , wrapInsertionSeparator = ", " , wrapInsertionStartClose = ") =>" , wrapInsertionEnd = "" , wrapInsertionAddParens = False } } } -- | Read inline, quasiquoted CoffeeScript. coffee :: QuasiQuoter coffee = QuasiQuoter { quoteExp = \s -> do rs <- coffeeSettings quoteExp (shakespeare rs) s } -- | Read in a CoffeeScript template file. This function reads the file once, at -- compile time. coffeeFile :: FilePath -> Q Exp coffeeFile fp = do rs <- coffeeSettings shakespeareFile rs fp -- | Read in a CoffeeScript template file. This impure function uses -- unsafePerformIO to re-read the file on every call, allowing for rapid -- iteration. coffeeFileReload :: FilePath -> Q Exp coffeeFileReload fp = do rs <- coffeeSettings shakespeareFileReload rs fp -- | Deprecated synonym for 'coffeeFileReload' coffeeFileDebug :: FilePath -> Q Exp coffeeFileDebug = coffeeFileReload {-# DEPRECATED coffeeFileDebug "Please use coffeeFileReload instead." #-} shakespeare-2.0.7/Text/Julius.hs0000644000000000000000000001612412610626007014740 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for Javascript templates, introducing type-safe, -- compile-time variable and url interpolation.-- -- -- You might consider trying 'Text.Typescript' or 'Text.Coffee' which compile down to Javascript. -- -- Further reading: module Text.Julius ( -- * Functions -- ** Template-Reading Functions -- | These QuasiQuoter and Template Haskell methods return values of -- type @'JavascriptUrl' url@. See the Yesod book for details. js , julius , juliusFile , jsFile , juliusFileDebug , jsFileDebug , juliusFileReload , jsFileReload -- * Datatypes , JavascriptUrl , Javascript (..) , RawJavascript (..) -- * Typeclass for interpolated variables , ToJavascript (..) , RawJS (..) -- ** Rendering Functions , renderJavascript , renderJavascriptUrl -- ** internal, used by 'Text.Coffee' , javascriptSettings -- ** internal , juliusUsedIdentifiers , asJavascriptUrl ) 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.Shakespeare import Data.Aeson (Value) import Data.Aeson.Types (Value(..)) import Numeric (showHex) import qualified Data.HashMap.Strict as H import qualified Data.Vector as V import Data.Text.Lazy.Builder (singleton, fromString) import qualified Data.Text as T import Data.Scientific (FPFormat(..), Scientific, base10Exponent) import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) renderJavascript :: Javascript -> TL.Text renderJavascript (Javascript b) = toLazyText b -- | render with route interpolation. If using this module standalone, apart -- from type-safe routes, a dummy renderer can be used: -- -- > renderJavascriptUrl (\_ _ -> undefined) javascriptUrl -- -- When using Yesod, a renderer is generated for you, which can be accessed -- within the GHandler monad: 'Yesod.Core.Handler.getUrlRenderParams'. renderJavascriptUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> JavascriptUrl url -> TL.Text renderJavascriptUrl r s = renderJavascript $ s r -- | Newtype wrapper of 'Builder'. newtype Javascript = Javascript { unJavascript :: Builder } deriving Monoid -- | Return type of template-reading functions. type JavascriptUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript asJavascriptUrl :: JavascriptUrl url -> JavascriptUrl url asJavascriptUrl = id -- | A typeclass for types that can be interpolated in CoffeeScript templates. class ToJavascript a where toJavascript :: a -> Javascript instance ToJavascript Bool where toJavascript = Javascript . fromText . TS.toLower . TS.pack . show instance ToJavascript Value where toJavascript = Javascript . encodeToTextBuilder -- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be -- embedded efficiently in a text-based protocol. -- -- If you are going to immediately encode straight to a -- 'L.ByteString', it is more efficient to use 'encodeToBuilder' -- instead. encodeToTextBuilder :: Value -> Builder encodeToTextBuilder = go where go Null = {-# SCC "go/Null" #-} "null" go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false" go (Number s) = {-# SCC "go/Number" #-} fromScientific s go (String s) = {-# SCC "go/String" #-} string s go (Array v) | V.null v = {-# SCC "go/Array" #-} "[]" | otherwise = {-# SCC "go/Array" #-} singleton '[' <> go (V.unsafeHead v) <> V.foldr f (singleton ']') (V.unsafeTail v) where f a z = singleton ',' <> go a <> z go (Object m) = {-# SCC "go/Object" #-} case H.toList m of (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs _ -> "{}" where f a z = singleton ',' <> one a <> z one (k,v) = string k <> singleton ':' <> go v string :: T.Text -> Builder string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"' where quote q = case T.uncons t of Nothing -> fromText h Just (!c,t') -> fromText h <> escape c <> quote t' where (h,t) = {-# SCC "break" #-} T.break isEscape q isEscape c = c == '\"' || c == '\\' || c == '<' || c == '>' || c == '&' || c < '\x20' escape '\"' = "\\\"" escape '\\' = "\\\\" escape '\n' = "\\n" escape '\r' = "\\r" escape '\t' = "\\t" escape '<' = "\\u003c" escape '>' = "\\u003e" escape '&' = "\\u0026" escape c | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h | otherwise = singleton c where h = showHex (fromEnum c) "" fromScientific :: Scientific -> Builder fromScientific s = formatScientificBuilder format prec s where (format, prec) | base10Exponent s < 0 = (Generic, Nothing) | otherwise = (Fixed, Just 0) newtype RawJavascript = RawJavascript Builder instance ToJavascript RawJavascript where toJavascript (RawJavascript a) = Javascript a class RawJS a where rawJS :: a -> RawJavascript instance RawJS [Char] where rawJS = RawJavascript . fromLazyText . TL.pack instance RawJS TS.Text where rawJS = RawJavascript . fromText instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText instance RawJS Builder where rawJS = RawJavascript instance RawJS Bool where rawJS = RawJavascript . unJavascript . toJavascript javascriptSettings :: Q ShakespeareSettings javascriptSettings = do toJExp <- [|toJavascript|] wrapExp <- [|Javascript|] unWrapExp <- [|unJavascript|] asJavascriptUrl' <- [|asJavascriptUrl|] return $ defaultShakespeareSettings { toBuilder = toJExp , wrap = wrapExp , unwrap = unWrapExp , modifyFinalValue = Just asJavascriptUrl' } js, julius :: QuasiQuoter js = QuasiQuoter { quoteExp = \s -> do rs <- javascriptSettings quoteExp (shakespeare rs) s } julius = js jsFile, juliusFile :: FilePath -> Q Exp jsFile fp = do rs <- javascriptSettings shakespeareFile rs fp juliusFile = jsFile jsFileReload, juliusFileReload :: FilePath -> Q Exp jsFileReload fp = do rs <- javascriptSettings shakespeareFileReload rs fp juliusFileReload = jsFileReload jsFileDebug, juliusFileDebug :: FilePath -> Q Exp juliusFileDebug = jsFileReload {-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-} jsFileDebug = jsFileReload {-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-} -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. juliusUsedIdentifiers :: String -> [(Deref, VarType)] juliusUsedIdentifiers = shakespeareUsedIdentifiers defaultShakespeareSettings shakespeare-2.0.7/Text/Css.hs0000644000000000000000000004277312610626007014226 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} module Text.Css where import Data.List (intersperse, intercalate) import Data.Text.Lazy.Builder (Builder, singleton, toLazyText, fromLazyText, fromString) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Monoid (Monoid, mconcat, mappend, mempty) import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH.Syntax import System.IO.Unsafe (unsafePerformIO) import Text.ParserCombinators.Parsec (Parser, parse) import Text.Shakespeare.Base hiding (Scope) import Language.Haskell.TH import Control.Applicative ((<$>), (<*>)) import Control.Arrow ((***), second) import Text.IndentToBrace (i2b) import Data.Functor.Identity (runIdentity) import Text.Shakespeare (VarType (..)) #if MIN_VERSION_base(4,5,0) import Data.Monoid ((<>)) #else (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css type DList a = [a] -> [a] -- FIXME great use case for data kinds data Resolved data Unresolved type family Selector a type instance Selector Resolved = Builder type instance Selector Unresolved = [Contents] type family ChildBlocks a type instance ChildBlocks Resolved = () type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)] type HasLeadingSpace = Bool type family Str a type instance Str Resolved = Builder type instance Str Unresolved = Contents type family Mixins a type instance Mixins Resolved = () type instance Mixins Unresolved = [Deref] data Block a = Block { blockSelector :: !(Selector a) , blockAttrs :: ![Attr a] , blockBlocks :: !(ChildBlocks a) , blockMixins :: !(Mixins a) } data Mixin = Mixin { mixinAttrs :: ![Attr Resolved] , mixinBlocks :: ![Block Resolved] } instance Monoid Mixin where mempty = Mixin mempty mempty mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y) data TopLevel a where TopBlock :: !(Block a) -> TopLevel a TopAtBlock :: !String -- name e.g., media -> !(Str a) -- selector -> ![Block a] -> TopLevel a TopAtDecl :: !String -> !(Str a) -> TopLevel a TopVar :: !String -> !String -> TopLevel Unresolved data Attr a = Attr { attrKey :: !(Str a) , attrVal :: !(Str a) } data Css = CssWhitespace ![TopLevel Resolved] | CssNoWhitespace ![TopLevel Resolved] data Content = ContentRaw String | ContentVar Deref | ContentUrl Deref | ContentUrlParam Deref | ContentMixin Deref deriving (Show, Eq) type Contents = [Content] data CDData url = CDPlain Builder | CDUrl url | CDUrlParam (url, [(Text, Text)]) | CDMixin Mixin pack :: String -> Text pack = T.pack #if !MIN_VERSION_text(0, 11, 2) {-# NOINLINE pack #-} #endif fromText :: Text -> Builder fromText = TLB.fromText {-# NOINLINE fromText #-} 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 -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion -> Parser [TopLevel Unresolved] -> String -> [(Deref, VarType)] cssUsedIdentifiers toi2b parseBlocks s' = concat $ runIdentity $ mapM (getVars scope0) contents where s = if toi2b then i2b s' else s' a = either (error . show) id $ parse parseBlocks s s (scope0, contents) = go a go :: [TopLevel Unresolved] -> (Scope, [Content]) go [] = ([], []) go (TopAtDecl dec cs:rest) = (scope, rest'') where (scope, rest') = go rest rest'' = ContentRaw ('@' : dec ++ " ") : cs ++ ContentRaw ";" : rest' go (TopAtBlock _ _ blocks:rest) = (scope1 ++ scope2, rest1 ++ rest2) where (scope1, rest1) = go (map TopBlock blocks) (scope2, rest2) = go rest go (TopBlock (Block x y z mixins):rest) = (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm) where rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y (scope1, rest1) = go (map (TopBlock . snd) z) (scope2, rest2) = go rest restm = map ContentMixin mixins go (TopVar k v:rest) = ((k, v):scope, rest') where (scope, rest') = go rest go' (Attr k v) = k ++ v cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion -> Q Exp -> Parser [TopLevel Unresolved] -> FilePath -> Q Exp cssFileDebug toi2b parseBlocks' parseBlocks fp = do s <- fmap TL.unpack $ qRunIO $ readUtf8File fp #ifdef GHC_7_4 qAddDependentFile fp #endif let vs = cssUsedIdentifiers toi2b parseBlocks s c <- mapM vtToExp vs cr <- [|cssRuntime toi2b|] parseBlocks'' <- parseBlocks' return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c combineSelectors :: HasLeadingSpace -> [Contents] -> [Contents] -> [Contents] combineSelectors hsl a b = do a' <- a b' <- b return $ a' ++ addSpace b' where addSpace | hsl = (ContentRaw " " :) | otherwise = id blockRuntime :: [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text) -> Block Unresolved -> Either String (DList (Block Resolved)) -- FIXME share code with blockToCss blockRuntime cd render' (Block x attrs z mixinsDerefs) = do mixins <- mapM getMixin mixinsDerefs x' <- mapM go' $ intercalate [ContentRaw ","] x attrs' <- mapM resolveAttr attrs z' <- mapM (subGo x) z -- FIXME use difflists again Right $ \rest -> Block { blockSelector = mconcat x' , blockAttrs = concat $ attrs' : map mixinAttrs mixins , blockBlocks = () , blockMixins = () } : foldr ($) rest z' {- (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) . foldr (.) id (map (subGo x) z) -} where go' = contentToBuilderRT cd render' getMixin d = case lookup d cd of Nothing -> Left $ "Mixin not found: " ++ show d Just (CDMixin m) -> Right m Just _ -> Left $ "For " ++ show d ++ ", expected Mixin" resolveAttr :: Attr Unresolved -> Either String (Attr Resolved) resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v) subGo :: [Contents] -- ^ parent selectors -> (HasLeadingSpace, Block Unresolved) -> Either String (DList (Block Resolved)) subGo x' (hls, Block a b c d) = blockRuntime cd render' (Block a' b c d) where a' = combineSelectors hls x' a contentToBuilderRT :: [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text) -> Content -> Either String Builder contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s contentToBuilderRT cd _ (ContentVar d) = case lookup d cd of Just (CDPlain s) -> Right s _ -> Left $ show d ++ ": expected CDPlain" contentToBuilderRT cd render' (ContentUrl d) = case lookup d cd of Just (CDUrl u) -> Right $ fromText $ render' u [] _ -> Left $ show d ++ ": expected CDUrl" contentToBuilderRT cd render' (ContentUrlParam d) = case lookup d cd of Just (CDUrlParam (u, p)) -> Right $ fromText $ render' u p _ -> Left $ show d ++ ": expected CDUrlParam" contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" cssRuntime :: Bool -- ^ i2b? -> Parser [TopLevel Unresolved] -> FilePath -> [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text) -> Css cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp let s = if toi2b then i2b s' else s' let a = either (error . show) id $ parse parseBlocks s s return $ CssWhitespace $ goTop [] a where goTop :: [(String, String)] -- ^ scope -> [TopLevel Unresolved] -> [TopLevel Resolved] goTop _ [] = [] goTop scope (TopAtDecl dec cs':rest) = TopAtDecl dec cs : goTop scope rest where cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs' goTop scope (TopBlock b:rest) = map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ goTop scope rest goTop scope (TopAtBlock name s' b:rest) = TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : goTop scope rest where s = either error mconcat $ mapM (contentToBuilderRT cd render') s' goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd 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|] c VTMixin = [|CDMixin|] getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] getVars _ ContentRaw{} = return [] getVars scope (ContentVar d) = case lookupD d scope of Just _ -> return [] Nothing -> return [(d, VTPlain)] getVars scope (ContentUrl d) = case lookupD d scope of Nothing -> return [(d, VTUrl)] Just s -> fail $ "Expected URL for " ++ s getVars scope (ContentUrlParam d) = case lookupD d scope of Nothing -> return [(d, VTUrlParam)] Just s -> fail $ "Expected URLParam for " ++ s getVars scope (ContentMixin d) = case lookupD d scope of Nothing -> return [(d, VTMixin)] Just s -> fail $ "Expected Mixin for " ++ s lookupD :: Deref -> [(String, b)] -> Maybe String lookupD (DerefIdent (Ident s)) scope = case lookup s scope of Nothing -> Nothing Just _ -> Just s lookupD _ _ = Nothing compressTopLevel :: TopLevel Unresolved -> TopLevel Unresolved compressTopLevel (TopBlock b) = TopBlock $ compressBlock b compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b compressTopLevel x@TopAtDecl{} = x compressTopLevel x@TopVar{} = x compressBlock :: Block Unresolved -> Block Unresolved compressBlock (Block x y blocks mixins) = Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins where go (Attr k v) = Attr (cc k) (cc v) cc [] = [] cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c cc (a:b) = a : cc b blockToMixin :: Name -> Scope -> Block Unresolved -> Q Exp blockToMixin r scope (Block _sel props subblocks mixins) = [|Mixin { mixinAttrs = concat $ $(listE $ map go props) : map mixinAttrs $mixinsE -- FIXME too many complications to implement sublocks for now... , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] }|] {- . foldr (.) id $(listE $ map subGo subblocks) . (concatMap mixinBlocks $mixinsE ++) |] -} where mixinsE = return $ ListE $ map (derefToExp []) mixins go (Attr x y) = conE 'Attr `appE` (contentsToBuilder r scope x) `appE` (contentsToBuilder r scope y) subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d blockToCss :: Name -> Scope -> Block Unresolved -> Q Exp blockToCss r scope (Block sel props subblocks mixins) = [|((Block { blockSelector = $(selectorToBuilder r scope sel) , blockAttrs = concat $ $(listE $ map go props) : map mixinAttrs $mixinsE , blockBlocks = () , blockMixins = () } :: Block Resolved):) . foldr (.) id $(listE $ map subGo subblocks) . (concatMap mixinBlocks $mixinsE ++) |] where mixinsE = return $ ListE $ map (derefToExp []) mixins go (Attr x y) = conE 'Attr `appE` (contentsToBuilder r scope x) `appE` (contentsToBuilder r scope y) subGo (hls, Block sel' b c d) = blockToCss r scope $ Block sel'' b c d where sel'' = combineSelectors hls sel sel' selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp selectorToBuilder r scope sels = contentsToBuilder r scope $ intercalate [ContentRaw ","] sels contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp contentsToBuilder r scope contents = appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents contentToBuilder :: Name -> Scope -> Content -> Q Exp contentToBuilder _ _ (ContentRaw x) = [|fromText . pack|] `appE` litE (StringL x) contentToBuilder _ scope (ContentVar d) = case d of DerefIdent (Ident s) | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val) _ -> [|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)) contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" type Scope = [(String, String)] topLevelsToCassius :: [TopLevel Unresolved] -> Q Exp topLevelsToCassius a = do r <- newName "_render" lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a where go _ _ [] = return [] go r scope (TopBlock b:rest) = do e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|] es <- go r scope rest return $ e : es go r scope (TopAtBlock name s b:rest) = do let s' = contentsToBuilder r scope s e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] es <- go r scope rest return $ e : es go r scope (TopAtDecl dec cs:rest) = do e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|] es <- go r scope rest return $ e : es go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest blocksToCassius :: Name -> Scope -> [Block Unresolved] -> Q Exp blocksToCassius r scope a = do appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a renderCss :: Css -> TL.Text renderCss css = toLazyText $ mconcat $ map go tops where (haveWhiteSpace, tops) = case css of CssWhitespace x -> (True, x) CssNoWhitespace x -> (False, x) go (TopBlock x) = renderBlock haveWhiteSpace mempty x go (TopAtBlock name s x) = fromText (pack $ concat ["@", name, " "]) `mappend` s `mappend` startBlock `mappend` foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString " ")) x) go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` cs `mappend` endDecl startBlock | haveWhiteSpace = fromString " {\n" | otherwise = singleton '{' endBlock | haveWhiteSpace = fromString "}\n" | otherwise = singleton '}' endDecl | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' renderBlock :: Bool -- ^ have whitespace? -> Builder -- ^ indentation -> Block Resolved -> Builder renderBlock haveWhiteSpace indent (Block sel attrs () ()) | null attrs = mempty | otherwise = startSelect <> sel <> startBlock <> mconcat (intersperse endDecl $ map renderAttr attrs) <> endBlock where renderAttr (Attr k v) = startDecl <> k <> colon <> v colon | haveWhiteSpace = fromString ": " | otherwise = singleton ':' startSelect | haveWhiteSpace = indent | otherwise = mempty startBlock | haveWhiteSpace = fromString " {\n" | otherwise = singleton '{' endBlock | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n" | otherwise = singleton '}' startDecl | haveWhiteSpace = indent `mappend` fromString " " | otherwise = mempty endDecl | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' instance Lift Mixin where lift (Mixin a b) = [|Mixin a b|] instance Lift (Attr Unresolved) where lift (Attr k v) = [|Attr k v :: Attr Unresolved |] instance Lift (Attr Resolved) where lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] liftBuilder :: Builder -> Q Exp liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] instance Lift Content where lift (ContentRaw s) = [|ContentRaw s|] lift (ContentVar d) = [|ContentVar d|] lift (ContentUrl d) = [|ContentUrl d|] lift (ContentUrlParam d) = [|ContentUrlParam d|] lift (ContentMixin m) = [|ContentMixin m|] instance Lift (Block Unresolved) where lift (Block a b c d) = [|Block a b c d|] instance Lift (Block Resolved) where lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] shakespeare-2.0.7/Text/Roy.hs0000644000000000000000000000607412610626007014241 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for Roy, introducing type-safe, -- compile-time variable and url interpolation. It is exactly the same as -- "Text.Julius", except that the template is first compiled to Javascript with -- the system tool @roy@. -- -- To use this module, @roy@ must be installed on your system. -- -- If you interpolate variables, -- the template is first wrapped with a function containing javascript variables representing shakespeare variables, -- then compiled with @roy@, -- and then the value of the variables are applied to the function. -- This means that in production the template can be compiled -- once at compile time and there will be no dependency in your production -- system on @roy@. -- -- Your code: -- -- > let b = 1 -- > console.log(#{a} + b) -- -- Final Result: -- -- > ;(function(shakespeare_var_a){ -- > var b = 1; -- > console.log(shakespeare_var_a + b); -- > })(#{a}); -- -- Further reading: -- -- 1. Shakespearean templates: -- -- 2. Roy: module Text.Roy ( -- * Functions -- ** Template-Reading Functions -- | These QuasiQuoter and Template Haskell methods return values of -- type @'JavascriptUrl' url@. See the Yesod book for details. roy , royFile , royFileReload #ifdef TEST_EXPORT , roySettings #endif ) where import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Text.Shakespeare import Text.Julius -- | The Roy language compiles down to Javascript. -- We do this compilation once at compile time to avoid needing to do it during the request. -- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call. roySettings :: Q ShakespeareSettings roySettings = do jsettings <- javascriptSettings return $ jsettings { varChar = '#' , preConversion = Just PreConvert { preConvert = ReadProcess "roy" ["--stdio", "--browser"] , preEscapeIgnoreBalanced = "'\"" , preEscapeIgnoreLine = "//" , wrapInsertion = Just WrapInsertion { wrapInsertionIndent = Just " " , wrapInsertionStartBegin = "(\\" , wrapInsertionSeparator = " " , wrapInsertionStartClose = " ->\n" , wrapInsertionEnd = ")" , wrapInsertionAddParens = True } } } -- | Read inline, quasiquoted Roy. roy :: QuasiQuoter roy = QuasiQuoter { quoteExp = \s -> do rs <- roySettings quoteExp (shakespeare rs) s } -- | Read in a Roy template file. This function reads the file once, at -- compile time. royFile :: FilePath -> Q Exp royFile fp = do rs <- roySettings shakespeareFile rs fp -- | Read in a Roy template file. This impure function uses -- unsafePerformIO to re-read the file on every call, allowing for rapid -- iteration. royFileReload :: FilePath -> Q Exp royFileReload fp = do rs <- roySettings shakespeareFileReload rs fp shakespeare-2.0.7/Text/MkSizeType.hs0000644000000000000000000000561312610626007015532 0ustar0000000000000000-- | Internal functions to generate CSS size wrapper types. module Text.MkSizeType (mkSizeType) where import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (fromLazyText) import qualified Data.Text.Lazy as TL 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') from = VarE 'fromLazyText pack = VarE 'TL.pack dot = VarE 'Prelude.fmap show' = VarE 'Prelude.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" shakespeare-2.0.7/Text/TypeScript.hs0000644000000000000000000001023612610626007015571 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for TypeScript, introducing type-safe, -- compile-time variable and url interpolation. It is exactly the same as -- "Text.Julius", except that the template is first compiled to Javascript with -- the system tool @tsc@. -- -- To use this module, @tsc@ must be installed on your system. -- -- If you interpolate variables, -- the template is first wrapped with a function containing javascript variables representing shakespeare variables, -- then compiled with @tsc@, -- and then the value of the variables are applied to the function. -- This means that in production the template can be compiled -- once at compile time and there will be no dependency in your production -- system on @tsc@. -- -- Your code: -- -- > var b = 1 -- > console.log(#{a} + b) -- -- Final Result: -- -- > ;(function(shakespeare_var_a){ -- > var b = 1; -- > console.log(shakespeare_var_a + b); -- > })(#{a}); -- -- -- Important Warnings! This integration is not ideal. -- -- Due to the function wrapper, all type declarations must be in separate .d.ts files. -- However, if you don't interpolate variables, no function wrapper will be -- created, and you can make type declarations in the same file. -- -- This does not work cross-platform! -- -- Unfortunately tsc does not support stdin and stdout. -- So a hack of writing to temporary files using the mktemp -- command is used. This works on my version of Linux, but not for windows -- unless perhaps you install a mktemp utility, which I have not tested. -- Please vote up this bug: -- -- Making this work on Windows would not be very difficult, it will just require a new -- package with a dependency on a package like temporary. -- -- Further reading: -- -- 1. Shakespearean templates: -- -- 2. TypeScript: module Text.TypeScript ( -- * Functions -- ** Template-Reading Functions -- | These QuasiQuoter and Template Haskell methods return values of -- type @'JavascriptUrl' url@. See the Yesod book for details. tsc , typeScriptFile , typeScriptFileReload #ifdef TEST_EXPORT , typeScriptSettings #endif ) where import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Text.Shakespeare import Text.Julius -- | The TypeScript language compiles down to Javascript. -- We do this compilation once at compile time to avoid needing to do it during the request. -- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call. typeScriptSettings :: Q ShakespeareSettings typeScriptSettings = do jsettings <- javascriptSettings return $ jsettings { varChar = '#' , preConversion = Just PreConvert { preConvert = ReadProcess "sh" ["-c", "TMP_IN=$(mktemp XXXXXXXXXX.ts); TMP_OUT=$(mktemp XXXXXXXXXX.js); cat /dev/stdin > ${TMP_IN} && tsc --out ${TMP_OUT} ${TMP_IN} && cat ${TMP_OUT}; rm ${TMP_IN} && rm ${TMP_OUT}"] , preEscapeIgnoreBalanced = "'\"" , preEscapeIgnoreLine = "//" , wrapInsertion = Just WrapInsertion { wrapInsertionIndent = Nothing , wrapInsertionStartBegin = ";(function(" , wrapInsertionSeparator = ", " , wrapInsertionStartClose = "){" , wrapInsertionEnd = "})" , wrapInsertionAddParens = False } } } -- | Read inline, quasiquoted TypeScript tsc :: QuasiQuoter tsc = QuasiQuoter { quoteExp = \s -> do rs <- typeScriptSettings quoteExp (shakespeare rs) s } -- | Read in a TypeScript template file. This function reads the file once, at -- compile time. typeScriptFile :: FilePath -> Q Exp typeScriptFile fp = do rs <- typeScriptSettings shakespeareFile rs fp -- | Read in a TypeScript template file. This impure function uses -- unsafePerformIO to re-read the file on every call, allowing for rapid -- iteration. typeScriptFileReload :: FilePath -> Q Exp typeScriptFileReload fp = do rs <- typeScriptSettings shakespeareFileReload rs fp shakespeare-2.0.7/Text/Shakespeare.hs0000644000000000000000000004422712610626007015725 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- | NOTE: This module should be considered internal, and will be hidden in -- future releases. module Text.Shakespeare ( ShakespeareSettings (..) , PreConvert (..) , WrapInsertion (..) , PreConversion (..) , defaultShakespeareSettings , shakespeare , shakespeareFile , shakespeareFileReload -- * low-level , shakespeareFromString , shakespeareUsedIdentifiers , RenderUrl , VarType (..) , Deref , Parser , preFilter -- * Internal -- can we remove this? , shakespeareRuntime , pack' ) where import Data.List (intersperse) import Data.Char (isAlphaNum, isSpace) import Text.ParserCombinators.Parsec hiding (Line, parse, Parser) import Text.Parsec.Prim (modifyState, Parsec) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH (appE) import Language.Haskell.TH.Syntax #if !MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH.Syntax.Internals #endif 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.Base import System.Directory (getModificationTime) import Data.Time (UTCTime) import Data.IORef import qualified Data.Map as M import GHC.Generics (Generic) import Data.Typeable (Typeable) import Data.Data (Data) -- for pre conversion import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) #if !MIN_VERSION_base(4,5,0) (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif -- | A parser with a user state of [String] type Parser = Parsec String [String] -- | run a parser with a user state of [String] parse :: GenParser tok [a1] a -> SourceName -> [tok] -> Either ParseError a parse p = runParser p [] -- move to Shakespeare.Base? readFileQ :: FilePath -> Q String readFileQ fp = qRunIO $ readFileUtf8 fp -- move to Shakespeare.Base? readFileUtf8 :: FilePath -> IO String readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp -- | Coffeescript, TypeScript, and other languages compiles down to Javascript. -- Previously we waited until the very end, at the rendering stage to perform this compilation. -- Lets call is a post-conversion -- This had the advantage that all Haskell values were inserted first: -- for example a value could be inserted that Coffeescript would compile into Javascript. -- While that is perhaps a safer approach, the advantage is not used in practice: -- it was that way mainly for ease of implementation. -- The down-side is the template must be compiled down to Javascript during every request. -- If instead we do a pre-conversion to compile down to Javascript, -- we only need to perform the compilation once. -- -- The problem then is the insertion of Haskell values: we need a hole for -- them. This can be done with variables known to the language. -- During the pre-conversion we first modify all Haskell insertions -- So #{a} is change to shakespeare_var_a -- Then we can place the Haskell values in a function wrapper that exposes -- those variables: (function(shakespeare_var_a){ ... shakespeare_var_a ...}) -- TypeScript can compile that, and then we tack an application of the -- Haskell values onto the result: (#{a}) -- -- preEscapeIgnoreBalanced is used to not insert backtacks for variable already inside strings or backticks. -- coffeescript will happily ignore the interpolations, and backticks would not be treated as escaping in that context. -- preEscapeIgnoreLine was added to ignore comments (which in Coffeescript begin with a '#') data PreConvert = PreConvert { preConvert :: PreConversion , preEscapeIgnoreBalanced :: [Char] , preEscapeIgnoreLine :: [Char] , wrapInsertion :: Maybe WrapInsertion } data WrapInsertion = WrapInsertion { wrapInsertionIndent :: Maybe String , wrapInsertionStartBegin :: String , wrapInsertionSeparator :: String , wrapInsertionStartClose :: String , wrapInsertionEnd :: String , wrapInsertionAddParens :: Bool } data PreConversion = ReadProcess String [String] | Id data ShakespeareSettings = ShakespeareSettings { varChar :: Char , urlChar :: Char , intChar :: Char , toBuilder :: Exp , wrap :: Exp , unwrap :: Exp , justVarInterpolation :: Bool , preConversion :: Maybe PreConvert , modifyFinalValue :: Maybe Exp -- ^ A transformation applied to the final expression. Most often, this -- would be used to force the type of the expression to help make more -- meaningful error messages. } defaultShakespeareSettings :: ShakespeareSettings defaultShakespeareSettings = ShakespeareSettings { varChar = '#' , urlChar = '@' , intChar = '^' , justVarInterpolation = False , preConversion = Nothing , modifyFinalValue = Nothing } instance Lift PreConvert where lift (PreConvert convert ignore comment wrapInsertion) = [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|] instance Lift WrapInsertion where lift (WrapInsertion indent sb sep sc e wp) = [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|] instance Lift PreConversion where lift (ReadProcess command args) = [|ReadProcess $(lift command) $(lift args)|] lift Id = [|Id|] instance Lift ShakespeareSettings where lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) = [|ShakespeareSettings $(lift x1) $(lift x2) $(lift x3) $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|] where liftExp (VarE n) = [|VarE $(liftName n)|] liftExp (ConE n) = [|ConE $(liftName n)|] liftExp _ = error "liftExp only supports VarE and ConE" liftMExp Nothing = [|Nothing|] liftMExp (Just e) = [|Just|] `appE` liftExp e 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 QueryParameters = [(TS.Text, TS.Text)] type RenderUrl url = (url -> QueryParameters -> TS.Text) type Shakespeare url = RenderUrl url -> Builder data Content = ContentRaw String | ContentVar Deref | ContentUrl Deref | ContentUrlParam Deref | ContentMix Deref deriving (Show, Eq) type Contents = [Content] eShowErrors :: Either ParseError c -> c eShowErrors = either (error . show) id contentFromString :: ShakespeareSettings -> String -> [Content] contentFromString _ "" = [] contentFromString rs s = compressContents $ eShowErrors $ 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 :: ShakespeareSettings -> Parser Contents parseContents = many1 . parseContent where parseContent :: ShakespeareSettings -> Parser Content parseContent ShakespeareSettings {..} = parseVar' <|> parseUrl' <|> parseInt' <|> parseChar' where parseVar' = either ContentRaw ContentVar `fmap` parseVar varChar parseUrl' = either ContentRaw contentUrl `fmap` parseUrl urlChar '?' where contentUrl (d, False) = ContentUrl d contentUrl (d, True) = ContentUrlParam d parseInt' = either ContentRaw ContentMix `fmap` parseInt intChar parseChar' = ContentRaw `fmap` many1 (noneOf [varChar, urlChar, intChar]) -- | calls 'error' when there is stderr or exit code failure readProcessError :: FilePath -> [String] -> String -> Maybe FilePath -- ^ for error reporting -> IO String readProcessError cmd args input mfp = do (ex, output, err) <- readProcessWithExitCode cmd args input case ex of ExitSuccess -> case err of [] -> return output msg -> error $ "stderr received during readProcess:" ++ displayCmd ++ "\n\n" ++ msg ExitFailure r -> error $ "exit code " ++ show r ++ " from readProcess: " ++ displayCmd ++ "\n\n" ++ "stderr:\n" ++ err where displayCmd = cmd ++ ' ':unwords (map show args) ++ case mfp of Nothing -> "" Just fp -> ' ':fp preFilter :: Maybe FilePath -- ^ for error reporting -> ShakespeareSettings -> String -> IO String preFilter mfp ShakespeareSettings {..} template = case preConversion of Nothing -> return template Just pre@(PreConvert convert _ _ mWrapI) -> if all isSpace template then return template else let (groups, rvars) = eShowErrors $ parse (parseConvertWrapInsertion mWrapI pre) template template vars = reverse rvars parsed = mconcat groups withVars = (addVars mWrapI vars parsed) in applyVars mWrapI vars `fmap` case convert of Id -> return withVars ReadProcess command args -> readProcessError command args withVars mfp where addIndent :: Maybe String -> String -> String addIndent Nothing str = str addIndent (Just indent) str = mapLines (\line -> indent <> line) str where mapLines f = unlines . map f . lines shakespeare_prefix = "shakespeare_var_" shakespeare_var_conversion ('@':'?':'{':str) = shakespeare_var_conversion ('@':'{':str) shakespeare_var_conversion (_:'{':str) = shakespeare_prefix <> filter isAlphaNum (init str) shakespeare_var_conversion err = error $ "did not expect: " <> err applyVars _ [] str = str applyVars Nothing _ str = str applyVars (Just WrapInsertion {..}) vars str = (if wrapInsertionAddParens then "(" else "") <> removeTrailingSemiColon <> (if wrapInsertionAddParens then ")" else "") <> "(" <> mconcat (intersperse ", " vars) <> ");\n" where removeTrailingSemiColon = reverse $ dropWhile (\c -> c == ';' || isSpace c) (reverse str) addVars _ [] str = str addVars Nothing _ str = str addVars (Just WrapInsertion {..}) vars str = wrapInsertionStartBegin <> mconcat (intersperse wrapInsertionSeparator $ map shakespeare_var_conversion vars) <> wrapInsertionStartClose <> addIndent wrapInsertionIndent str <> wrapInsertionEnd parseConvertWrapInsertion Nothing = parseConvert id parseConvertWrapInsertion (Just _) = parseConvert shakespeare_var_conversion parseConvert varConvert PreConvert {..} = do str <- many1 $ choice $ map (try . escapedParse) preEscapeIgnoreBalanced ++ [mainParser] st <- getState return (str, st) where escapedParse ignoreC = do _<- char ignoreC inside <- many $ noneOf [ignoreC] _<- char ignoreC return $ ignoreC:inside ++ [ignoreC] mainParser = parseVar' <|> parseUrl' <|> parseInt' <|> parseCommentLine preEscapeIgnoreLine <|> parseChar' preEscapeIgnoreLine preEscapeIgnoreBalanced recordRight (Left str) = return str recordRight (Right str) = modifyState (\vars -> str:vars) >> return (varConvert str) newLine = "\r\n" parseCommentLine cs = do begin <- oneOf cs comment <- many $ noneOf newLine return $ begin : comment parseVar' :: (Parsec String [String]) String parseVar' = recordRight =<< parseVarString varChar parseUrl' = recordRight =<< parseUrlString urlChar '?' parseInt' = recordRight =<< parseIntString intChar parseChar' comments ignores = many1 (noneOf ([varChar, urlChar, intChar] ++ comments ++ ignores)) pack' :: String -> TS.Text pack' = TS.pack #if !MIN_VERSION_text(0, 11, 2) {-# NOINLINE pack' #-} #endif contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp contentsToShakespeare rs a = do r <- newName "_render" c <- mapM (contentToBuilder r) a compiledTemplate <- case c of -- Make sure we convert this mempty using toBuilder to pin down the -- type appropriately [] -> fmap (AppE $ wrap rs) [|mempty|] [x] -> return x _ -> do mc <- [|mconcat|] return $ mc `AppE` ListE c fmap (maybe id AppE $ modifyFinalValue rs) $ return $ if justVarInterpolation rs then compiledTemplate else LamE [VarP r] compiledTemplate where contentToBuilder :: Name -> Content -> Q Exp contentToBuilder _ (ContentRaw s') = do ts <- [|fromText . pack'|] return $ wrap rs `AppE` (ts `AppE` LitE (StringL s')) contentToBuilder _ (ContentVar d) = return (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) = return $ derefToExp [] d `AppE` VarE r shakespeare :: ShakespeareSettings -> QuasiQuoter shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r } shakespeareFromString :: ShakespeareSettings -> String -> Q Exp shakespeareFromString r str = do s <- qRunIO $ preFilter Nothing r $ #ifdef WINDOWS filter (/='\r') #endif str contentsToShakespeare r $ contentFromString r s shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp shakespeareFile r fp = #ifdef GHC_7_4 qAddDependentFile fp >> #endif readFileQ fp >>= shakespeareFromString r data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) 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, QueryParameters) | EMixin (Shakespeare url) -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)] shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings type MTime = UTCTime {-# NOINLINE reloadMapRef #-} reloadMapRef :: IORef (M.Map FilePath (MTime, [Content])) reloadMapRef = unsafePerformIO $ newIORef M.empty lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content])) lookupReloadMap fp = do reloads <- readIORef reloadMapRef return $ M.lookup fp reloads insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content] insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef (\reloadMap -> (M.insert fp (mt, content) reloadMap, content)) shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp shakespeareFileReload settings fp = do str <- readFileQ fp s <- qRunIO $ preFilter (Just fp) settings str let b = shakespeareUsedIdentifiers settings s c <- mapM vtToExp b rt <- [|shakespeareRuntime settings fp|] wrap' <- [|\x -> $(return $ wrap settings) . x|] return $ wrap' `AppE` (rt `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 $ InfixE (Just $ unwrap settings) (VarE '(.)) (Just $ toBuilder settings))|] c VTUrl = [|EUrl|] c VTUrlParam = [|EUrlParam|] c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap settings) $ x r|] nothingError :: Show a => String -> a -> b nothingError expected d = error $ "expected " ++ expected ++ " but got Nothing for: " ++ show d shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url shakespeareRuntime settings fp cd render' = unsafePerformIO $ do mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) -> if mtime == lastMtime then return $ go' lastContents else fmap go' $ newContent mtime Nothing -> fmap go' $ newContent mtime where newContent mtime = do str <- readFileUtf8 fp s <- preFilter (Just fp) settings str insertReloadMap fp (mtime, contentFromString settings s) go' = mconcat . map go go :: Content -> Builder go (ContentRaw s) = fromText $ TS.pack s go (ContentVar d) = case lookup d cd of Just (EPlain s) -> s _ -> nothingError "EPlain" d go (ContentUrl d) = case lookup d cd of Just (EUrl u) -> fromText $ render' u [] _ -> nothingError "EUrl" d go (ContentUrlParam d) = case lookup d cd of Just (EUrlParam (u, p)) -> fromText $ render' u p _ -> nothingError "EUrlParam" d go (ContentMix d) = case lookup d cd of Just (EMixin m) -> m render' _ -> nothingError "EMixin" d shakespeare-2.0.7/Text/Cassius.hs0000644000000000000000000000473712610626007015106 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Cassius ( -- * Datatypes Css , CssUrl -- * Type class , ToCss (..) -- * Rendering , renderCss , renderCssUrl -- * Parsing , cassius , cassiusFile , cassiusFileDebug , cassiusFileReload -- ** Mixims , cassiusMixin , Mixin -- * ToCss instances -- ** Color , Color (..) , colorRed , colorBlack -- ** Size , mkSize , AbsoluteUnit (..) , AbsoluteSize (..) , absoluteSize , EmSize (..) , ExSize (..) , PercentageSize (..) , percentageSize , PixelSize (..) -- * Internal , cassiusUsedIdentifiers ) where import Text.Css import Text.Shakespeare.Base import Text.Shakespeare (VarType) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import qualified Data.Text.Lazy as TL import Text.CssCommon import Text.Lucius (lucius) import qualified Text.Lucius import Text.IndentToBrace (i2b) cassius :: QuasiQuoter cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } cassiusFile :: FilePath -> Q Exp cassiusFile fp = do #ifdef GHC_7_4 qAddDependentFile fp #endif contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp quoteExp cassius contents cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels cassiusFileReload = cassiusFileDebug -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. cassiusUsedIdentifiers :: String -> [(Deref, VarType)] cassiusUsedIdentifiers = cssUsedIdentifiers True Text.Lucius.parseTopLevels -- | Create a mixin with Cassius syntax. -- -- Since 2.0.3 cassiusMixin :: QuasiQuoter cassiusMixin = QuasiQuoter { quoteExp = quoteExp Text.Lucius.luciusMixin . i2bMixin } i2bMixin :: String -> String i2bMixin s' = TL.unpack $ stripEnd "}" $ stripFront "mixin {" $ TL.strip $ TL.pack $ i2b $ unlines $ "mixin" : (map (" " ++) $ lines s') where stripFront x y = case TL.stripPrefix x y of Nothing -> y Just z -> z stripEnd x y = case TL.stripSuffix x y of Nothing -> y Just z -> z shakespeare-2.0.7/Text/Hamlet.hs0000644000000000000000000005126512610626007014704 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet ( -- * Plain HTML Html , shamlet , shamletFile , xshamlet , xshamletFile -- * Hamlet , HtmlUrl , hamlet , hamletFile , hamletFileReload , ihamletFileReload , xhamlet , xhamletFile -- * I18N Hamlet , HtmlUrlI18n , ihamlet , ihamletFile -- * Type classes , ToAttributes (..) -- * Internal, for making more , HamletSettings (..) , NewlineStyle (..) , hamletWithSettings , hamletFileWithSettings , defaultHamletSettings , xhtmlHamletSettings , Env (..) , HamletRules (..) , hamletRules , ihamletRules , htmlRules , CloseStyle (..) -- * Used by generated code , condH , maybeH , asHtmlUrl , attrsToHtml ) where import Text.Shakespeare.Base import Text.Hamlet.Parse #if MIN_VERSION_template_haskell(2,9,0) import Language.Haskell.TH.Syntax hiding (Module) #else import Language.Haskell.TH.Syntax #endif import Language.Haskell.TH.Quote import Data.Char (isUpper, isDigit) import Data.Maybe (fromMaybe) import Data.Text (Text, pack) import qualified Data.Text.Lazy as TL import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Internal (preEscapedText) import qualified Data.Foldable as F import Control.Monad (mplus) import Data.Monoid (mempty, mappend, mconcat) import Control.Arrow ((***)) import Data.List (intercalate) import Data.IORef import qualified Data.Map as M import System.IO.Unsafe (unsafePerformIO) import System.Directory (getModificationTime) import Data.Time (UTCTime) import Text.Blaze.Html (preEscapedToHtml) -- | Convert some value to a list of attribute pairs. class ToAttributes a where toAttributes :: a -> [(Text, Text)] instance ToAttributes (Text, Text) where toAttributes = return instance ToAttributes (String, String) where toAttributes (k, v) = [(pack k, pack v)] instance ToAttributes [(Text, Text)] where toAttributes = id instance ToAttributes [(String, String)] where toAttributes = map (pack *** pack) attrsToHtml :: [(Text, Text)] -> Html attrsToHtml = foldr go mempty where go (k, v) rest = toHtml " " `mappend` preEscapedText k `mappend` preEscapedText (pack "=\"") `mappend` toHtml v `mappend` preEscapedText (pack "\"") `mappend` rest type Render url = url -> [(Text, Text)] -> Text type Translate msg = msg -> Html -- | A function generating an 'Html' given a URL-rendering function. type HtmlUrl url = Render url -> Html -- | A function generating an 'Html' given a message translator and a URL rendering function. type HtmlUrlI18n 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 unIdent :: Ident -> String unIdent (Ident s) = s bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) bindingPattern (BindAs i@(Ident s) b) = do name <- newName s (pattern, scope) <- bindingPattern b return (AsP name pattern, (i, VarE name):scope) bindingPattern (BindVar i@(Ident s)) | s == "_" = return (WildP, []) | all isDigit s = do return (LitP $ IntegerL $ read s, []) | otherwise = do name <- newName s return (VarP name, [(i, VarE name)]) bindingPattern (BindTuple is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (TupP patterns, concat scopes) bindingPattern (BindList is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ListP patterns, concat scopes) bindingPattern (BindConstr con is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ConP (mkConName con) patterns, concat scopes) bindingPattern (BindRecord con fields wild) = do let f (Ident field,b) = do (p,s) <- bindingPattern b return ((mkName field,p),s) (patterns, scopes) <- fmap unzip $ mapM f fields (patterns1, scopes1) <- if wild then bindWildFields con $ map fst fields else return ([],[]) return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1) mkConName :: DataConstr -> Name mkConName = mkName . conToStr conToStr :: DataConstr -> String conToStr (DCUnqualified (Ident x)) = x conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] -- Wildcards bind all of the unbound fields to variables whose name -- matches the field name. -- -- For example: data R = C { f1, f2 :: Int } -- C {..} is equivalent to C {f1=f1, f2=f2} -- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2} -- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a} bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]) bindWildFields conName fields = do fieldNames <- recordToFieldNames conName let available n = nameBase n `notElem` map unIdent fields let remainingFields = filter available fieldNames let mkPat n = do e <- newName (nameBase n) return ((n,VarP e), (Ident (nameBase n), VarE e)) fmap unzip $ mapM mkPat remainingFields -- Important note! reify will fail if the record type is defined in the -- same module as the reify is used. This means quasi-quoted Hamlet -- literals will not be able to use wildcards to match record types -- defined in the same module. recordToFieldNames :: DataConstr -> Q [Name] recordToFieldNames conStr = do -- use 'lookupValueName' instead of just using 'mkName' so we reify the -- data constructor and not the type constructor if their names match. Just conName <- lookupValueName $ conToStr conStr DataConI _ _ typeName _ <- reify conName TyConI (DataD _ _ _ cons _) <- reify typeName [fields] <- return [fields | RecC name fields <- cons, name == conName] return [fieldName | (fieldName, _, _) <- fields] docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp docToExp env hr scope (DocForall list idents inside) = do let list' = derefToExp scope list (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope mh <- [|F.mapM_|] inside' <- docsToExp env hr scope' inside let lam = LamE [pat] 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, idents):dis) inside) = do let deref' = derefToExp scope deref (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope inside' <- docToExp env hr scope' (DocWith dis inside) let lam = LamE [pat] inside' return $ lam `AppE` deref' docToExp env hr scope (DocMaybe val idents inside mno) = do let val' = derefToExp scope val (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope inside' <- docsToExp env hr scope' inside let inside'' = LamE [pat] 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 ((specialOrIdent, VarE 'or):scope) d docs' <- docsToExp env hr scope docs return $ TupE [d', docs'] docToExp env hr scope (DocCase deref cases) = do let exp_ = derefToExp scope deref matches <- mapM toMatch cases return $ CaseE exp_ matches where toMatch :: (Binding, [Doc]) -> Q Match toMatch (idents, inside) = do (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope insideExp <- docsToExp env hr scope' inside return $ Match pat (NormalB insideExp) [] 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) contentToExp _ hr scope (ContentAttrs d) = do html <- [|attrsToHtml . toAttributes|] return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d) shamlet :: QuasiQuoter shamlet = hamletWithSettings htmlRules defaultHamletSettings xshamlet :: QuasiQuoter xshamlet = 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 asHtmlUrl :: HtmlUrl url -> HtmlUrl url asHtmlUrl = id 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 return $ HamletRules i ur em where em (Env (Just urender) Nothing) e = do asHtmlUrl' <- [|asHtmlUrl|] urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur') em _ _ = error "bad Env" 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 return $ HamletRules i ur em where em (Env (Just urender) (Just mrender)) e = urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur') em _ _ = error "bad Env" 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 hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s docFromString :: HamletSettings -> String -> [Doc] docFromString set s = case parseDoc set s of Error s' -> error s' Ok (_, d) -> d hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp hamletFileWithSettings qhr set fp = do #ifdef GHC_7_4 qAddDependentFile fp #endif contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp hamletFromString qhr set contents hamletFile :: FilePath -> Q Exp hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings hamletFileReload :: FilePath -> Q Exp hamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = False } ihamletFileReload :: FilePath -> Q Exp ihamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = True } xhamletFile :: FilePath -> Q Exp xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings shamletFile :: FilePath -> Q Exp shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings xshamletFile :: FilePath -> Q Exp xshamletFile = 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 bms mm = fromMaybe (return ()) $ lookup True bms `mplus` mm -- | 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 mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm type MTime = UTCTime data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin | VTMsg | VTAttrs type QueryParameters = [(Text, Text)] type RenderUrl url = (url -> QueryParameters -> Text) type Shakespeare url = RenderUrl url -> Html data VarExp msg url = EPlain Html | EUrl url | EUrlParam (url, QueryParameters) | EMixin (HtmlUrl url) | EMixinI18n (HtmlUrlI18n msg url) | EMsg msg instance Show (VarExp msg url) where show (EPlain html) = "EPlain" show (EUrl url) = "EUrl" show (EUrlParam url) = "EUrlParam" show (EMixin url) = "EMixin" show (EMixinI18n msg_url) = "EMixinI18n" show (EMsg msg) = "EMsg" getVars :: Content -> [(Deref, VarType)] getVars ContentRaw{} = [] getVars (ContentVar d) = [(d, VTPlain)] getVars (ContentUrl False d) = [(d, VTUrl)] getVars (ContentUrl True d) = [(d, VTUrlParam)] getVars (ContentEmbed d) = [(d, VTMixin)] getVars (ContentMsg d) = [(d, VTMsg)] getVars (ContentAttrs d) = [(d, VTAttrs)] hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)] hamletUsedIdentifiers settings = concatMap getVars . contentFromString settings data HamletRuntimeRules = HamletRuntimeRules { hrrI18n :: Bool } hamletFileReloadWithSettings :: HamletRuntimeRules -> HamletSettings -> FilePath -> Q Exp hamletFileReloadWithSettings hrr settings fp = do s <- readFileQ fp let b = hamletUsedIdentifiers settings s c <- mapM vtToExp b rt <- if hrrI18n hrr then [|hamletRuntimeMsg settings fp|] else [|hamletRuntime settings fp|] return $ rt `AppE` ListE c where vtToExp :: (Deref, VarType) -> Q Exp vtToExp (d, vt) = do d' <- lift d c' <- toExp vt return $ TupE [d', c' `AppE` derefToExp [] d] where toExp = c where c :: VarType -> Q Exp c VTAttrs = [|EPlain . attrsToHtml . toAttributes|] c VTPlain = [|EPlain . toHtml|] c VTUrl = [|EUrl|] c VTUrlParam = [|EUrlParam|] c VTMixin = [|\r -> EMixin $ \c -> r c|] c VTMsg = [|EMsg|] -- move to Shakespeare.Base? readFileUtf8 :: FilePath -> IO String readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp -- move to Shakespeare.Base? readFileQ :: FilePath -> Q String readFileQ fp = qRunIO $ readFileUtf8 fp {-# NOINLINE reloadMapRef #-} reloadMapRef :: IORef (M.Map FilePath (MTime, [Content])) reloadMapRef = unsafePerformIO $ newIORef M.empty lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content])) lookupReloadMap fp = do reloads <- readIORef reloadMapRef return $ M.lookup fp reloads insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content] insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef (\reloadMap -> (M.insert fp (mt, content) reloadMap, content)) contentFromString :: HamletSettings -> String -> [Content] contentFromString set = map justContent . docFromString set where unsupported msg = error $ "hamletFileReload does not support " ++ msg justContent :: Doc -> Content justContent (DocContent c) = c justContent DocForall{} = unsupported "$forall" justContent DocWith{} = unsupported "$with" justContent DocMaybe{} = unsupported "$maybe" justContent DocCase{} = unsupported "$case" justContent DocCond{} = unsupported "attribute conditionals" hamletRuntime :: HamletSettings -> FilePath -> [(Deref, VarExp msg url)] -> Shakespeare url hamletRuntime settings fp cd render = unsafePerformIO $ do mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) -> if mtime == lastMtime then return $ go' lastContents else fmap go' $ newContent mtime Nothing -> fmap go' $ newContent mtime where newContent mtime = do s <- readFileUtf8 fp insertReloadMap fp (mtime, contentFromString settings s) go' = mconcat . map (runtimeContentToHtml cd render (error "I18n embed IMPOSSIBLE") handleMsgEx) handleMsgEx _ = error "i18n _{} encountered, but did not use ihamlet" type RuntimeVars msg url = [(Deref, VarExp msg url)] hamletRuntimeMsg :: HamletSettings -> FilePath -> RuntimeVars msg url -> HtmlUrlI18n msg url hamletRuntimeMsg settings fp cd i18nRender render = unsafePerformIO $ do mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) -> if mtime == lastMtime then return $ go' lastContents else fmap go' $ newContent mtime Nothing -> fmap go' $ newContent mtime where newContent mtime = do s <- readFileUtf8 fp insertReloadMap fp (mtime, contentFromString settings s) go' = mconcat . map (runtimeContentToHtml cd render i18nRender handleMsg) handleMsg d = case lookup d cd of Just (EMsg s) -> i18nRender s _ -> nothingError "EMsg for ContentMsg" d nothingError :: Show a => String -> a -> b nothingError expected d = error $ "expected " ++ expected ++ " but got Nothing for: " ++ show d runtimeContentToHtml :: RuntimeVars msg url -> Render url -> Translate msg -> (Deref -> Html) -> Content -> Html runtimeContentToHtml cd render i18nRender handleMsg = go where go :: Content -> Html go (ContentMsg d) = handleMsg d go (ContentRaw s) = preEscapedToHtml s go (ContentAttrs d) = case lookup d cd of Just (EPlain s) -> s _ -> error $ show d ++ ": expected EPlain for ContentAttrs" go (ContentVar d) = case lookup d cd of Just (EPlain s) -> s _ -> error $ show d ++ ": expected EPlain for ContentVar" go (ContentUrl False d) = case lookup d cd of Just (EUrl u) -> toHtml $ render u [] Just wrong -> error $ "expected EUrl but got: " ++ show wrong ++ "\nfor: " ++ show d _ -> nothingError "EUrl" d go (ContentUrl True d) = case lookup d cd of Just (EUrlParam (u, p)) -> toHtml $ render u p _ -> error $ show d ++ ": expected EUrlParam" go (ContentEmbed d) = case lookup d cd of Just (EMixin m) -> m render Just (EMixinI18n m) -> m i18nRender render _ -> error $ show d ++ ": expected EMixin" shakespeare-2.0.7/Text/Hamlet/0000755000000000000000000000000012610626007014337 5ustar0000000000000000shakespeare-2.0.7/Text/Hamlet/Parse.hs0000644000000000000000000006211612610626007015753 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Parse ( Result (..) , Content (..) , Doc (..) , parseDoc , HamletSettings (..) , defaultHamletSettings , xhtmlHamletSettings , CloseStyle (..) , Binding (..) , NewlineStyle (..) , specialOrIdent , DataConstr (..) , Module (..) ) where import Text.Shakespeare.Base import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow import Data.Char (isUpper) import Data.Data import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe (mapMaybe, fromMaybe, isNothing) import Language.Haskell.TH.Syntax (Lift (..)) 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 | ContentAttrs Deref deriving (Show, Eq, Read, Data, Typeable) data Line = LineForall Deref Binding | LineIf Deref | LineElseIf Deref | LineElse | LineWith [(Deref, Binding)] | LineMaybe Deref Binding | LineNothing | LineCase Deref | LineOf Binding | LineTag { _lineTagName :: String , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] , _lineContent :: [Content] , _lineClasses :: [(Maybe Deref, [Content])] , _lineAttrs :: [Deref] , _lineNoNewline :: Bool } | LineContent [Content] Bool -- ^ True == avoid newlines deriving (Eq, Show, Read) parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) parseLines set s = case parse parser s s of Left e -> Error $ show e Right x -> Ok x where parser = do mnewline <- parseNewline let set' = case mnewline of Nothing -> case hamletNewlines set of DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } _ -> set Just n -> set { hamletNewlines = n } res <- many (parseLine set') return (mnewline, set', res) parseNewline = (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> return Nothing parseNewline' = (try (string "always") >> return (Just AlwaysNewlines)) <|> (try (string "never") >> return (Just NoNewlines)) <|> (try (string "text") >> return (Just NewlinesText)) eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) parseLine :: HamletSettings -> Parser (Int, Line) parseLine set = do ss <- fmap sum $ many ((char ' ' >> return 1) <|> (char '\t' >> fail "Tabs are not allowed in Hamlet indentation")) x <- doctype <|> doctypeDollar <|> comment <|> ssiInclude <|> htmlComment <|> doctypeRaw <|> backslash <|> controlIf <|> controlElseIf <|> (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> controlMaybe <|> (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> controlForall <|> controlWith <|> controlCase <|> controlOf <|> angle <|> invalidDollar <|> (eol' >> return (LineContent [] True)) <|> (do (cs, avoidNewLines) <- content InContent isEof <- (eof >> return True) <|> return False if null cs && ss == 0 && isEof then fail "End of Hamlet template" else return $ LineContent cs avoidNewLines) return (ss, x) where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol' doctype = do try $ string "!!!" >> eol return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True doctypeDollar = do _ <- try $ string "$doctype " name <- many $ noneOf "\r\n" eol case lookup name $ hamletDoctypeNames set of Nothing -> fail $ "Unknown doctype name: " ++ name Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True doctypeRaw = do x <- try $ string "" x <- many nonComments eol return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- 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"] True)) <|> (uncurry 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 <- identPattern 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)]] controlCase = do _ <- try $ string "$case" spaces x <- parseDeref _ <- spaceTabs eol return $ LineCase x controlOf = do _ <- try $ string "$of" spaces x <- identPattern _ <- spaceTabs eol return $ LineOf x content cr = do x <- many $ content' cr case cr of InQuotes -> void $ char '"' NotInQuotes -> return () NotInQuotesAttr -> return () InContent -> eol return (cc $ map fst x, any snd 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, null str) Right deref -> return (ContentVar deref, False) contentAt = do x <- parseAt return $ case x of Left str -> (ContentRaw str, null str) Right (s, y) -> (ContentUrl y s, False) contentCaret = do x <- parseCaret case x of Left str -> return (ContentRaw str, null str) Right deref -> return (ContentEmbed deref, False) contentUnder = do x <- parseUnder case x of Left str -> return (ContentRaw str, null str) Right deref -> return (ContentMsg deref, False) contentReg' x = (flip (,) False) <$> contentReg x 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 fst <$> content cr tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes tagCond = do d <- between (char ':') (char ':') parseDeref tagClass (Just d) <|> tagAttrib (Just d) tagClass x = do clazz <- char '.' >> tagAttribValue NotInQuotes let hasHash (ContentRaw s) = any (== '#') s hasHash _ = False if any hasHash clazz then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?" else return (TagClass (x, clazz)) tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n><" v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing return $ TagAttrib (cond, s, v) tagAttrs = do _ <- char '*' d <- between (char '{') (char '}') parseDeref return $ TagAttribs d tag' = foldr tag'' ("div", [], [], []) tag'' (TagName s) (_, y, z, as) = (s, y, z, as) tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) ident :: Parser Ident ident = do i <- many1 (alphaNum <|> char '_' <|> char '\'') white return (Ident i) "identifier" parens = between (char '(' >> white) (char ')' >> white) brackets = between (char '[' >> white) (char ']' >> white) braces = between (char '{' >> white) (char '}' >> white) comma = char ',' >> white atsign = char '@' >> white equals = char '=' >> white white = skipMany $ char ' ' wildDots = string ".." >> white isVariable (Ident (x:_)) = not (isUpper x) isVariable (Ident []) = error "isVariable: bad identifier" isConstructor (Ident (x:_)) = isUpper x isConstructor (Ident []) = error "isConstructor: bad identifier" identPattern :: Parser Binding identPattern = gcon True <|> apat where apat = choice [ varpat , gcon False , parens tuplepat , brackets listpat ] varpat = do v <- try $ do v <- ident guard (isVariable v) return v option (BindVar v) $ do atsign b <- apat return (BindAs v b) "variable" gcon :: Bool -> Parser Binding gcon allowArgs = do c <- try $ do c <- dataConstr return c choice [ record c , fmap (BindConstr c) (guard allowArgs >> many apat) , return (BindConstr c []) ] "constructor" dataConstr = do p <- dcPiece ps <- many dcPieces return $ toDataConstr p ps dcPiece = do x@(Ident y) <- ident guard $ isConstructor x return y dcPieces = do _ <- char '.' dcPiece toDataConstr x [] = DCUnqualified $ Ident x toDataConstr x (y:ys) = go (x:) y ys where go front next [] = DCQualified (Module $ front []) (Ident next) go front next (rest:rests) = go (front . (next:)) rest rests record c = braces $ do (fields, wild) <- option ([], False) $ go return (BindRecord c fields wild) where go = (wildDots >> return ([], True)) <|> (do x <- recordField (xs,wild) <- option ([],False) (comma >> go) return (x:xs,wild)) recordField = do field <- ident p <- option (BindVar field) -- support punning (equals >> identPattern) return (field,p) tuplepat = do xs <- identPattern `sepBy` comma return $ case xs of [x] -> x _ -> BindTuple xs listpat = BindList <$> identPattern `sepBy` comma angle = do _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" let name = if null name' then "div" else name' xs <- many $ try ((many $ oneOf " \t\r\n") >> (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) _ <- many $ oneOf " \t\r\n" _ <- char '>' (c, avoidNewLines) <- content InContent let (tn, attr, classes, attrsd) = tag' $ TagName name : xs if '/' `elem` tn then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." else return $ LineTag tn attr c classes attrsd avoidNewLines data TagPiece = TagName String | TagIdent [Content] | TagClass (Maybe Deref, [Content]) | TagAttrib (Maybe Deref, String, Maybe [Content]) | TagAttribs Deref 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 Binding [Doc] | DocWith [(Deref, Binding)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) | DocMaybe Deref Binding [Doc] (Maybe [Doc]) | DocCase Deref [(Binding, [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 (LineCase d) inside:rest) = do let getOf (Nest (LineOf x) insideC) = do insideC' <- nestToDoc set insideC Ok (x, insideC') getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard." cases <- mapM getOf inside rest' <- nestToDoc set rest Ok $ DocCase d cases : rest' nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do let attrFix (x, y, z) = (x, y, [(Nothing, z)]) let takeClass (a, "class", b) = Just (a, fromMaybe [] 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 _ -> (testIncludeClazzes clazzes, "class", map (second Just) 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 $ "" _ -> DocContent $ ContentRaw "" seal = case closeStyle of CloseInside -> DocContent $ ContentRaw "/>" _ -> DocContent $ ContentRaw ">" start = DocContent $ ContentRaw $ "<" ++ tn attrs'' = concatMap attrToContent attrs' newline' = DocContent $ ContentRaw $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ start : attrs'' ++ map (DocContent . ContentAttrs) attrsD ++ seal : map DocContent content ++ inside' ++ end : newline' : rest' nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do inside' <- nestToDoc set inside rest' <- nestToDoc set rest let newline' = DocContent $ ContentRaw $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } nextIsContent = case (inside, rest) of ([], Nest LineContent{} _:_) -> True ([], Nest LineTag{} _:_) -> True _ -> False Ok $ map DocContent content ++ newline':inside' ++ rest' nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing" nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)" 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 (DocCase d cs:rest) = DocCase d (map (second compressDoc) cs) : 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 (Maybe NewlineStyle, [Doc]) parseDoc set s = do (mnl, set', ls) <- parseLines set s let notEmpty (_, LineContent [] _) = False notEmpty _ = True let ns = nestLines $ filter notEmpty ls ds <- nestToDoc set' ns return (mnl, compressDoc ds) attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] attrToContent (Just cond, k, v) = [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] attrToContent (Nothing, k, [(Nothing, Just v)]) = DocContent (ContentRaw (' ' : k ++ "=\"")) : map DocContent v ++ [DocContent $ ContentRaw "\""] attrToContent (Nothing, k, v) = -- only for class DocContent (ContentRaw (' ' : k ++ "=\"")) : concatMap go (init v) ++ go' (last v) ++ [DocContent $ ContentRaw "\""] where go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] go (Just b, x) = [ DocCond [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] Nothing ] go' (Nothing, x) = maybe [] (map DocContent) x go' (Just b, x) = [ DocCond [(b, maybe [] (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 add newlines to the output, making it more human-readable? -- Useful for client-side debugging but may alter browser page layout. , hamletNewlines :: NewlineStyle -- | How a tag should be closed. Use this to switch between HTML, XHTML -- or even XML output. , hamletCloseStyle :: String -> CloseStyle -- | Mapping from short names in \"$doctype\" statements to full doctype. , hamletDoctypeNames :: [(String, String)] } data NewlineStyle = NoNewlines -- ^ never add newlines | NewlinesText -- ^ add newlines between consecutive text lines | AlwaysNewlines -- ^ add newlines everywhere | DefaultNewlineStyle deriving Show instance Lift NewlineStyle where lift NoNewlines = [|NoNewlines|] lift NewlinesText = [|NewlinesText|] lift AlwaysNewlines = [|AlwaysNewlines|] lift DefaultNewlineStyle = [|DefaultNewlineStyle|] instance Lift (String -> CloseStyle) where lift _ = [|\s -> htmlCloseStyle s|] instance Lift HamletSettings where lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|] 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 "" DefaultNewlineStyle htmlCloseStyle doctypeNames xhtmlHamletSettings :: HamletSettings xhtmlHamletSettings = HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames where doctype = "" 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) doctypeNames :: [(String, String)] doctypeNames = [ ("5", "") , ("html", "") , ("1.1", "") , ("strict", "") ] data Binding = BindVar Ident | BindAs Ident Binding | BindConstr DataConstr [Binding] | BindTuple [Binding] | BindList [Binding] | BindRecord DataConstr [(Ident, Binding)] Bool deriving (Eq, Show, Read, Data, Typeable) data DataConstr = DCQualified Module Ident | DCUnqualified Ident deriving (Eq, Show, Read, Data, Typeable) newtype Module = Module [String] deriving (Eq, Show, Read, Data, Typeable) spaceTabs :: Parser String spaceTabs = many $ oneOf " \t" -- | When using conditional classes, it will often be a single class, e.g.: -- -- >
-- -- If isHome is False, we do not want any class attribute to be present. -- However, due to combining multiple classes together, the most obvious -- implementation would produce a class="". The purpose of this function is to -- work around that. It does so by checking if all the classes on this tag are -- optional. If so, it will only include the class attribute if at least one -- conditional is true. testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref testIncludeClazzes cs | any (isNothing . fst) cs = Nothing | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs -- | This funny hack is to allow us to refer to the 'or' function without -- requiring the user to have it in scope. See how this function is used in -- Text.Hamlet. specialOrIdent :: Ident specialOrIdent = Ident "__or__hamlet__special" shakespeare-2.0.7/Text/Hamlet/RT.hs0000644000000000000000000002016312610626007015222 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} -- | Provides functionality for runtime Hamlet templates. Please use -- "Text.Hamlet.Runtime" instead. module Text.Hamlet.RT ( -- * Public API HamletRT (..) , HamletData (..) , HamletMap , HamletException (..) , parseHamletRT , renderHamletRT , renderHamletRT' , SimpleDoc (..) ) where import Text.Shakespeare.Base import Data.Monoid (mconcat) import Control.Monad (liftM, forM) import Control.Exception (Exception) import Data.Typeable (Typeable) import Text.Hamlet.Parse import Data.List (intercalate) #if MIN_VERSION_blaze_html(0,5,0) import Text.Blaze.Html (Html) import Text.Blaze.Internal (preEscapedString, preEscapedText) #else import Text.Blaze (preEscapedString, preEscapedText, Html) #endif import Data.Text (Text) #if MIN_VERSION_exceptions(0,4,0) import Control.Monad.Catch (MonadThrow, throwM) #else import Control.Monad.Catch (MonadCatch, throwM) #define MonadThrow MonadCatch #endif type HamletMap url = [([String], HamletData url)] type UrlRenderer url = (url -> [(Text, Text)] -> Text) data HamletData url = HDHtml Html | HDUrl url | 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] | SDTemplate [String] | SDForall [String] String [SimpleDoc] | SDMaybe [String] String [SimpleDoc] [SimpleDoc] | SDCond [([String], [SimpleDoc])] [SimpleDoc] newtype HamletRT = HamletRT [SimpleDoc] data HamletException = HamletParseException String | HamletUnsupportedDocException Doc | HamletRenderException String deriving (Show, Typeable) instance Exception HamletException parseHamletRT :: MonadThrow m => HamletSettings -> String -> m HamletRT parseHamletRT set s = case parseDoc set s of Error s' -> throwM $ HamletParseException s' Ok (_, x) -> liftM HamletRT $ mapM convert x where convert x@(DocForall deref (BindAs _ _) docs) = error "Runtime Hamlet does not currently support 'as' patterns" convert x@(DocForall deref (BindVar (Ident ident)) docs) = do deref' <- flattenDeref' x deref docs' <- mapM convert docs return $ SDForall deref' ident docs' convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns" convert x@(DocMaybe deref (BindAs _ _) jdocs ndocs) = error "Runtime Hamlet does not currently support 'as' patterns" convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do deref' <- flattenDeref' x deref jdocs' <- mapM convert jdocs ndocs' <- maybe (return []) (mapM convert) ndocs return $ SDMaybe deref' ident jdocs' ndocs' convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns" convert (DocContent (ContentRaw s')) = return $ SDRaw s' convert x@(DocContent (ContentVar deref)) = do y <- flattenDeref' x deref return $ SDVar y convert x@(DocContent (ContentUrl p deref)) = do y <- flattenDeref' x deref return $ SDUrl p y convert x@(DocContent (ContentEmbed deref)) = do y <- flattenDeref' x deref return $ SDTemplate y convert (DocContent ContentMsg{}) = error "Runtime hamlet does not currently support message interpolation" convert (DocContent ContentAttrs{}) = error "Runtime hamlet does not currently support attrs interpolation" convert x@(DocCond conds els) = do conds' <- mapM go conds els' <- maybe (return []) (mapM convert) els return $ SDCond conds' els' where -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional -- added there doesn't work for runtime Hamlet, so we remove it here. go (DerefBranch (DerefIdent x) _, docs') | x == specialOrIdent = do docs'' <- mapM convert docs' return (["True"], docs'') go (deref, docs') = do deref' <- flattenDeref' x deref docs'' <- mapM convert docs' return (deref', docs'') convert DocWith{} = error "Runtime hamlet does not currently support $with" convert DocCase{} = error "Runtime hamlet does not currently support $case" renderHamletRT :: MonadThrow m => HamletRT -> HamletMap url -> UrlRenderer url -> m Html renderHamletRT = renderHamletRT' False #if MIN_VERSION_exceptions(0,4,0) renderHamletRT' :: MonadThrow m #else renderHamletRT' :: MonadCatch m #endif => Bool -- ^ should embeded template (via ^{..}) be plain Html or actual templates? -> HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = liftM mconcat $ mapM (go scope0) docs where go _ (SDRaw s) = return $ preEscapedString s go scope (SDVar n) = do v <- lookup' n n scope case v of HDHtml h -> return h _ -> fa $ showName n ++ ": expected HDHtml" go scope (SDUrl p n) = do v <- lookup' n n scope case (p, v) of (False, HDUrl u) -> return $ preEscapedText $ renderUrl u [] (True, HDUrlParams u q) -> return $ preEscapedText $ renderUrl u q (False, _) -> fa $ showName n ++ ": expected HDUrl" (True, _) -> fa $ showName n ++ ": expected HDUrlParams" go scope (SDTemplate n) = do v <- lookup' n n scope case (tempAsHtml, v) of (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl (False, _) -> fa $ showName n ++ ": expected HDTemplate" (True, HDHtml h) -> return h (True, _) -> fa $ showName n ++ ": expected HDHtml" go scope (SDForall n ident docs') = do v <- lookup' n n scope case v of HDList os -> liftM mconcat $ forM os $ \o -> do let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl _ -> fa $ showName n ++ ": expected HDList" go scope (SDMaybe n ident jdocs ndocs) = do v <- lookup' n n scope (scope', docs') <- case v of HDMaybe Nothing -> return (scope, ndocs) HDMaybe (Just o) -> do let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope return (scope', jdocs) _ -> fa $ showName n ++ ": expected HDMaybe" renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl go scope (SDCond [] docs') = renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl go scope (SDCond ((b, docs'):cs) els) = do v <- lookup' b b scope case v of HDBool True -> renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl HDBool False -> go scope (SDCond cs els) _ -> fa $ showName b ++ ": expected HDBool" #if MIN_VERSION_exceptions(0,4,0) lookup' :: MonadThrow m #else lookup' :: MonadCatch m #endif => [String] -> [String] -> HamletMap url -> m (HamletData url) lookup' orig k m = case lookup k m of Nothing | k == ["True"] -> return $ HDBool True Nothing -> fa $ showName orig ++ ": not found" Just x -> return x fa :: MonadThrow m => String -> m a fa = throwM . HamletRenderException showName :: [String] -> String showName = intercalate "." . reverse #if MIN_VERSION_exceptions(0,4,0) flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String] #else flattenDeref' :: MonadCatch f => Doc -> Deref -> f [String] #endif flattenDeref' orig deref = case flattenDeref deref of Nothing -> throwM $ HamletUnsupportedDocException orig Just x -> return x shakespeare-2.0.7/Text/Hamlet/Runtime.hs0000644000000000000000000001121012610626007016311 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Module for parsing and rendering Hamlet templates at runtime, not compile -- time. This uses the same Hamlet parsing as compile-time Hamlet, but has some -- limitations, such as: -- -- * No compile-time checking of validity -- -- * Can't apply functions at runtime -- -- * No URL rendering -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Text.Hamlet.Runtime -- > import qualified Data.Map as Map -- > import Text.Blaze.Html.Renderer.String (renderHtml) -- > -- > main :: IO () -- > main = do -- > template <- parseHamletTemplate defaultHamletSettings $ unlines -- > [ "

Hello, #{name}" -- > , "$if hungry" -- > , "

Available food:" -- > , "