shakespeare-2.0.14.1/Text/0000755000000000000000000000000013204302765013344 5ustar0000000000000000shakespeare-2.0.14.1/Text/Hamlet/0000755000000000000000000000000013204302765014556 5ustar0000000000000000shakespeare-2.0.14.1/Text/Internal/0000755000000000000000000000000013204302765015120 5ustar0000000000000000shakespeare-2.0.14.1/Text/Shakespeare/0000755000000000000000000000000013204302765015577 5ustar0000000000000000shakespeare-2.0.14.1/test/0000755000000000000000000000000013204302765013377 5ustar0000000000000000shakespeare-2.0.14.1/test-messages/0000755000000000000000000000000013204302765015204 5ustar0000000000000000shakespeare-2.0.14.1/test/Text/0000755000000000000000000000000013204302765014323 5ustar0000000000000000shakespeare-2.0.14.1/test/Text/Shakespeare/0000755000000000000000000000000013204302765016556 5ustar0000000000000000shakespeare-2.0.14.1/test/cassiuses/0000755000000000000000000000000013204302765015401 5ustar0000000000000000shakespeare-2.0.14.1/test/hamlets/0000755000000000000000000000000013204302765015034 5ustar0000000000000000shakespeare-2.0.14.1/test/juliuses/0000755000000000000000000000000013204302765015242 5ustar0000000000000000shakespeare-2.0.14.1/test/texts/0000755000000000000000000000000013204302765014546 5ustar0000000000000000shakespeare-2.0.14.1/Text/Shakespeare/I18N.hs0000644000000000000000000003511113204302765016613 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Shakespeare.I18N -- Copyright : 2012 Michael Snoyman , Jeremy Shaw -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : Michael Snoyman -- Stability : experimental -- Portability : portable -- -- This module provides a type-based system for providing translations -- for text strings. -- -- It is similar in purpose to gettext or Java message bundles. -- -- The core idea is to create simple data type where each constructor -- represents a phrase, sentence, paragraph, etc. For example: -- -- > data AppMessages = Hello | Goodbye -- -- The 'RenderMessage' class is used to retrieve the appropriate -- translation for a message value: -- -- > class RenderMessage master message where -- > renderMessage :: master -- ^ type that specifies which set of translations to use -- > -> [Lang] -- ^ acceptable languages in descending order of preference -- > -> message -- ^ message to translate -- > -> Text -- -- Defining the translation type and providing the 'RenderMessage' -- instance in Haskell is not very translator friendly. Instead, -- translations are generally provided in external translations -- files. Then the 'mkMessage' Template Haskell function is used to -- read the external translation files and automatically create the -- translation type and the @RenderMessage@ instance. -- -- A full description of using this module to create translations for @Hamlet@ can be found here: -- -- -- -- A full description of using the module to create translations for @HSP@ can be found here: -- -- -- -- You can also adapt those instructions for use with other systems. module Text.Shakespeare.I18N ( mkMessage , mkMessageFor , mkMessageVariant , RenderMessage (..) , ToMessage (..) , SomeMessage (..) , Lang ) where import Language.Haskell.TH.Syntax import Control.Applicative ((<$>)) import Control.Monad (filterM, forM) import Data.Text (Text, pack, unpack) import System.Directory import Data.Maybe (catMaybes) import Data.List (isSuffixOf, sortBy, foldl') import qualified Data.Map as Map import qualified Data.ByteString as S import Data.Text.Encoding (decodeUtf8) import Data.Char (isSpace, toLower, toUpper) import Data.Ord (comparing) import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp) import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>)) import Control.Arrow ((***)) import Data.Monoid (mempty, mappend) import qualified Data.Text as T import Data.String (IsString (fromString)) -- | 'ToMessage' is used to convert the value inside #{ } to 'Text' -- -- The primary purpose of this class is to allow the value in #{ } to -- be a 'String' or 'Text' rather than forcing it to always be 'Text'. class ToMessage a where toMessage :: a -> Text instance ToMessage Text where toMessage = id instance ToMessage String where toMessage = Data.Text.pack -- | the 'RenderMessage' is used to provide translations for a message types -- -- The 'master' argument exists so that it is possible to provide more -- than one set of translations for a 'message' type. This is useful -- if a library provides a default set of translations, but the user -- of the library wants to provide a different set of translations. class RenderMessage master message where renderMessage :: master -- ^ type that specifies which set of translations to use -> [Lang] -- ^ acceptable languages in descending order of preference -> message -- ^ message to translate -> Text instance RenderMessage master Text where renderMessage _ _ = id -- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc). type Lang = Text -- |generate translations from translation files -- -- This function will: -- -- 1. look in the supplied subdirectory for files ending in @.msg@ -- -- 2. generate a type based on the constructors found -- -- 3. create a 'RenderMessage' instance -- mkMessage :: String -- ^ base name to use for translation type -> FilePath -- ^ subdirectory which contains the translation files -> Lang -- ^ default translation language -> Q [Dec] mkMessage dt folder lang = mkMessageCommon True "Msg" "Message" dt dt folder lang -- | create 'RenderMessage' instance for an existing data-type mkMessageFor :: String -- ^ master translation data type -> String -- ^ existing type to add translations for -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec] mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang -- | create an additional set of translations for a type created by `mkMessage` mkMessageVariant :: String -- ^ master translation data type -> String -- ^ existing type to add translations for -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec] mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang -- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type mkMessageCommon :: Bool -- ^ generate a new datatype from the constructors found in the .msg files -> String -- ^ string to append to constructor names -> String -- ^ string to append to datatype name -> String -- ^ base name of master datatype -> String -- ^ base name of translation datatype -> FilePath -- ^ path to translation folder -> Lang -- ^ default lang -> Q [Dec] mkMessageCommon genType prefix postfix master dt folder lang = do files <- qRunIO $ getDirectoryContents folder let files' = filter (`notElem` [".", ".."]) files (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files' #ifdef GHC_7_4 mapM_ qAddDependentFile $ concat _files' #endif let contents' = Map.toList $ Map.fromListWith (++) contents sdef <- case lookup lang contents' of Nothing -> error $ "Did not find main language file: " ++ unpack lang Just def -> toSDefs def mapM_ (checkDef sdef) $ map snd contents' let mname = mkName $ dt ++ postfix c1 <- fmap concat $ mapM (toClauses prefix dt) contents' c2 <- mapM (sToClause prefix dt) sdef c3 <- defClause return $ ( if genType then ((DataD [] mname [] #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (map (toCon dt) sdef) []) :) else id) [ instanceD [] (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname) [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3] ] ] toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause] toClauses prefix dt (lang, defs) = mapM go defs where go def = do a <- newName "lang" (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def) guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|] return $ Clause [WildP, ConP (mkName ":") [VarP a, WildP], pat] (GuardedB [(guard, bod)]) [] mkBody :: String -- ^ datatype -> String -- ^ constructor -> [String] -- ^ variable names -> [Content] -> Q (Pat, Exp) mkBody dt cs vs ct = do vp <- mapM go vs let pat = RecP (mkName cs) (map (varName dt *** VarP) vp) let ct' = map (fixVars vp) ct pack' <- [|Data.Text.pack|] tomsg <- [|toMessage|] let ct'' = map (toH pack' tomsg) ct' mapp <- [|mappend|] let app a b = InfixE (Just a) mapp (Just b) e <- case ct'' of [] -> [|mempty|] [x] -> return x (x:xs) -> return $ foldl' app x xs return (pat, e) where toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String) toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d go x = do let y = mkName $ '_' : x return (x, y) fixVars vp (Var d) = Var $ fixDeref vp d fixVars _ (Raw s) = Raw s fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b) fixDeref _ d = d fixIdent vp i = case lookup i vp of Nothing -> i Just y -> nameBase y sToClause :: String -> String -> SDef -> Q Clause sToClause prefix dt sdef = do (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef) return $ Clause [WildP, ConP (mkName "[]") [], pat] (NormalB bod) [] defClause :: Q Clause defClause = do a <- newName "sub" c <- newName "langs" d <- newName "msg" rm <- [|renderMessage|] return $ Clause [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d] (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d) [] toCon :: String -> SDef -> Con toCon dt (SDef c vs _) = RecC (mkName $ "Msg" ++ c) $ map go vs where go (n, t) = (varName dt n, notStrict, ConT $ mkName t) varName :: String -> String -> Name varName a y = mkName $ concat [lower a, "Message", upper y] where lower (x:xs) = toLower x : xs lower [] = [] upper (x:xs) = toUpper x : xs upper [] = [] checkDef :: [SDef] -> [Def] -> Q () checkDef x y = go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y) where go _ [] = return () go [] (b:_) = error $ "Extra message constructor: " ++ constr b go (a:as) (b:bs) | sconstr a < constr b = go as (b:bs) | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b | otherwise = do go' (svars a) (vars b) go as bs go' ((an, at):as) ((bn, mbt):bs) | an /= bn = error "Mismatched variable names" | otherwise = case mbt of Nothing -> go' as bs Just bt | at == bt -> go' as bs | otherwise -> error "Mismatched variable types" go' [] [] = return () go' _ _ = error "Mistmached variable count" toSDefs :: [Def] -> Q [SDef] toSDefs = mapM toSDef toSDef :: Def -> Q SDef toSDef d = do vars' <- mapM go $ vars d return $ SDef (constr d) vars' (content d) where go (a, Just b) = return (a, b) go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a) data SDef = SDef { sconstr :: String , svars :: [(String, String)] , scontent :: [Content] } data Def = Def { constr :: String , vars :: [(String, Maybe String)] , content :: [Content] } () :: FilePath -> FilePath -> FilePath path file = path ++ '/' : file loadLang :: FilePath -> FilePath -> IO (Maybe ([FilePath], (Lang, [Def]))) loadLang folder file = do let file' = folder file isFile <- doesFileExist file' if isFile && ".msg" `isSuffixOf` file then do let lang = pack $ reverse $ drop 4 $ reverse file defs <- loadLangFile file' return $ Just ([file'], (lang, defs)) else do isDir <- doesDirectoryExist file' if isDir then do let lang = pack file (files, defs) <- unzip <$> loadLangDir file' return $ Just (files, (lang, concat defs)) else return Nothing loadLangDir :: FilePath -> IO [(FilePath, [Def])] loadLangDir folder = do paths <- map (folder ) . filter (`notElem` [".", ".."]) <$> getDirectoryContents folder files <- filterM doesFileExist paths dirs <- filterM doesDirectoryExist paths langFiles <- forM files $ \file -> do if ".msg" `isSuffixOf` file then do defs <- loadLangFile file return $ Just (file, defs) else do return Nothing langDirs <- mapM loadLangDir dirs return $ catMaybes langFiles ++ concat langDirs loadLangFile :: FilePath -> IO [Def] loadLangFile file = do bs <- S.readFile file let s = unpack $ decodeUtf8 bs defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s return defs parseDef :: String -> IO (Maybe Def) parseDef "" = return Nothing parseDef ('#':_) = return Nothing parseDef s = case end of ':':end' -> do content' <- fmap compress $ parseContent $ dropWhile isSpace end' case words begin of [] -> error $ "Missing constructor: " ++ s (w:ws) -> return $ Just Def { constr = w , vars = map parseVar ws , content = content' } _ -> error $ "Missing colon: " ++ s where (begin, end) = break (== ':') s data Content = Var Deref | Raw String compress :: [Content] -> [Content] compress [] = [] compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest compress (x:y) = x : compress y parseContent :: String -> IO [Content] parseContent s = either (error . show) return $ parse go s s where go = do x <- many go' eof return x go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash) parseVar :: String -> (String, Maybe String) parseVar s = case break (== '@') s of (x, '@':y) -> (x, Just y) _ -> (s, Nothing) data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg instance IsString (SomeMessage master) where fromString = SomeMessage . T.pack instance master ~ master' => RenderMessage master (SomeMessage master') where renderMessage a b (SomeMessage msg) = renderMessage a b msg #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness #else notStrict :: Strict notStrict = NotStrict #endif instanceD :: Cxt -> Type -> [Dec] -> Dec #if MIN_VERSION_template_haskell(2,11,0) instanceD = InstanceD Nothing #else instanceD = InstanceD #endif shakespeare-2.0.14.1/Text/Shakespeare/Text.hs0000644000000000000000000001214713204302765017064 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Shakespeare.Text ( TextUrl , ToText (..) , renderTextUrl , stext , text , textFile , textFileDebug , textFileReload , st -- | strict text , lt -- | lazy text, same as stext :) , sbt -- | strict text whose left edge is aligned with bar ('|') , lbt -- | lazy text, whose left edge is aligned with bar ('|') -- * Yesod code generation , codegen , codegenSt , codegenFile , codegenFileReload ) where import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText) import Data.Text.Lazy.Builder.Int (decimal) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Shakespeare import Data.Int (Int32, Int64) renderTextUrl :: RenderUrl url -> TextUrl url -> TL.Text renderTextUrl r s = toLazyText $ s r type TextUrl url = RenderUrl url -> Builder class ToText a where toText :: a -> Builder instance ToText Builder where toText = id instance ToText [Char ] where toText = fromLazyText . TL.pack instance ToText TS.Text where toText = fromText instance ToText TL.Text where toText = fromLazyText instance ToText Int32 where toText = decimal instance ToText Int64 where toText = decimal instance ToText Int where toText = decimal settings :: Q ShakespeareSettings settings = do toTExp <- [|toText|] wrapExp <- [|id|] unWrapExp <- [|id|] return $ defaultShakespeareSettings { toBuilder = toTExp , wrap = wrapExp , unwrap = unWrapExp } stext, lt, st, text, lbt, sbt :: QuasiQuoter stext = QuasiQuoter { quoteExp = \s -> do rs <- settings render <- [|toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } lt = stext st = QuasiQuoter { quoteExp = \s -> do rs <- settings render <- [|TL.toStrict . toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } text = QuasiQuoter { quoteExp = \s -> do rs <- settings quoteExp (shakespeare rs) $ filter (/='\r') s } dropBar :: [TL.Text] -> [TL.Text] dropBar [] = [] dropBar (c:cx) = c:dropBar' cx where dropBar' txt = reverse $ drop 1 $ map (TL.drop 1 . TL.dropWhile (/= '|')) $ reverse txt lbt = QuasiQuoter { quoteExp = \s -> do rs <- settings render <- [|TL.unlines . dropBar . TL.lines . toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } sbt = QuasiQuoter { quoteExp = \s -> do rs <- settings render <- [|TL.toStrict . TL.unlines . dropBar . TL.lines . toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } textFile :: FilePath -> Q Exp textFile fp = do rs <- settings shakespeareFile rs fp textFileDebug :: FilePath -> Q Exp textFileDebug = textFileReload {-# DEPRECATED textFileDebug "Please use textFileReload instead" #-} textFileReload :: FilePath -> Q Exp textFileReload fp = do rs <- settings shakespeareFileReload rs fp -- | codegen is designed for generating Yesod code, including templates -- So it uses different interpolation characters that won't clash with templates. codegenSettings :: Q ShakespeareSettings codegenSettings = do toTExp <- [|toText|] wrapExp <- [|id|] unWrapExp <- [|id|] return $ defaultShakespeareSettings { toBuilder = toTExp , wrap = wrapExp , unwrap = unWrapExp , varChar = '~' , urlChar = '*' , intChar = '&' , justVarInterpolation = True -- always! } -- | codegen is designed for generating Yesod code, including templates -- So it uses different interpolation characters that won't clash with templates. -- You can use the normal text quasiquoters to generate code codegen :: QuasiQuoter codegen = QuasiQuoter { quoteExp = \s -> do rs <- codegenSettings render <- [|toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } -- | Generates strict Text -- codegen is designed for generating Yesod code, including templates -- So it uses different interpolation characters that won't clash with templates. codegenSt :: QuasiQuoter codegenSt = QuasiQuoter { quoteExp = \s -> do rs <- codegenSettings render <- [|TL.toStrict . toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) } codegenFileReload :: FilePath -> Q Exp codegenFileReload fp = do rs <- codegenSettings render <- [|TL.toStrict . toLazyText|] rendered <- shakespeareFileReload rs{ justVarInterpolation = True } fp return (render `AppE` rendered) codegenFile :: FilePath -> Q Exp codegenFile fp = do rs <- codegenSettings render <- [|TL.toStrict . toLazyText|] rendered <- shakespeareFile rs{ justVarInterpolation = True } fp return (render `AppE` rendered) shakespeare-2.0.14.1/Text/Roy.hs0000644000000000000000000000607413204302765014460 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.14.1/Text/Julius.hs0000644000000000000000000001612413204302765015157 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.14.1/Text/Coffee.hs0000644000000000000000000000714213204302765015073 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.14.1/Text/Hamlet.hs0000644000000000000000000005615013204302765015121 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 , Render , hamlet , hamletFile , hamletFileReload , xhamlet , xhamletFile -- * I18N Hamlet , HtmlUrlI18n , Translate , ihamlet , ihamletFile , ihamletFileReload -- * 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 -- * low-level , hamletFromString ) 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 #if MIN_VERSION_template_haskell(2,11,0) DataConI _ _ typeName <- reify conName TyConI (DataD _ _ _ _ cons _) <- reify typeName #else DataConI _ _ typeName _ <- reify conName TyConI (DataD _ _ _ cons _) <- reify typeName #endif [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) -- | "Simple Hamlet" quasi-quoter. May only be used to generate expressions. -- -- Generated expressions have type 'Html'. -- -- @ -- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' ['shamlet'|\Hello, world!|]) -- \Hello, world!\ -- @ shamlet :: QuasiQuoter shamlet = hamletWithSettings htmlRules defaultHamletSettings -- | Like 'shamlet', but produces XHTML. xshamlet :: QuasiQuoter xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings htmlRules :: Q HamletRules htmlRules = do i <- [|id|] return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b) -- | Hamlet quasi-quoter. May only be used to generate expressions. -- -- Generated expression have type @'HtmlUrl' url@, for some @url@. -- -- @ -- data MyRoute = Home -- -- render :: 'Render' MyRoute -- render Home _ = \"/home\" -- -- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.String.renderHtml' (['hamlet'|\Home|] render)) -- \Home\<\/a\> -- @ hamlet :: QuasiQuoter hamlet = hamletWithSettings hamletRules defaultHamletSettings -- | Like 'hamlet', but produces XHTML. 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" -- | Hamlet quasi-quoter with internationalization. May only be used to generate -- expressions. -- -- Generated expressions have type @'HtmlUrlI18n' msg url@, for some @msg@ and -- @url@. -- -- @ -- data MyMsg = Hi | Bye -- -- data MyRoute = Home -- -- renderEnglish :: 'Translate' MyMsg -- renderEnglish Hi = \"hi\" -- renderEnglish Bye = \"bye\" -- -- renderUrl :: 'Render' MyRoute -- renderUrl Home _ = \"/home\" -- -- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' (['ihamlet'|@{Home} _{Hi} _{Bye}|] renderEnglish renderUrl)) -- \/home hi bye \ -- @ 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" -- | Quasiquoter that follows XHTML serialization rules and supports i18n. -- -- @since 2.0.10 ixhamlet :: QuasiQuoter ixhamlet = hamletWithSettings ihamletRules xhtmlHamletSettings 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 -- | Like 'hamlet', but reads an external file at compile time. -- -- @ -- $('hamletFile' \"foo.hamlet\") :: 'HtmlUrl' MyRoute -- @ hamletFile :: FilePath -> Q Exp hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings -- | Like 'hamletFile', but the external file is parsed at runtime. Allows for -- more rapid development, but should not be used in production. hamletFileReload :: FilePath -> Q Exp hamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = False } -- | Like 'ihamletFile', but the external file is parsed at runtime. Allows for -- more rapid development, but should not be used in production. ihamletFileReload :: FilePath -> Q Exp ihamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = True } -- | Like 'hamletFile', but produces XHTML. xhamletFile :: FilePath -> Q Exp xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings -- | Like 'shamlet', but reads an external file at compile time. -- -- @ -- $('shamletFile' \"foo.hamlet\") :: 'Html' -- @ shamletFile :: FilePath -> Q Exp shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings -- | Like 'shamletFile', but produces XHTML. xshamletFile :: FilePath -> Q Exp xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings -- | Like 'ihamlet', but reads an external file at compile time. -- -- @ -- $('ihamletFile' \"foo.hamlet\") :: 'HtmlUrlI18n' MyMsg MyRoute -- @ 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.14.1/Text/Hamlet/RT.hs0000644000000000000000000002016313204302765015441 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.14.1/Text/Hamlet/Runtime.hs0000644000000000000000000001121013204302765016530 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:" -- > , "