shakespeare (empty) → 0.10.0
raw patch · 5 files changed
+513/−0 lines, 5 filesdep +basedep +blaze-builderdep +blaze-htmlsetup-changed
Dependencies added: base, blaze-builder, blaze-html, bytestring, containers, failure, parsec, process, template-haskell, text
Files
- LICENSE +25/−0
- Setup.lhs +8/−0
- Text/Shakespeare.hs +214/−0
- Text/Shakespeare/Base.hs +225/−0
- shakespeare.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain
+ Text/Shakespeare.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+-- | For lack of a better name... a parameterized version of Julius.+module Text.Shakespeare+ ( ShakespeareSettings (..)+ , defaultShakespeareSettings+ , shakespeare+ , shakespeareFile+ , shakespeareFileDebug+ -- * low-level+ , shakespeareFromString+ , RenderUrl+ ) where++import Text.ParserCombinators.Parsec hiding (Line)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax.Internals+import Data.Text.Lazy.Builder (Builder, fromText)+import Data.Monoid+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Text.Shakespeare.Base++-- move to Shakespeare?+readFileQ :: FilePath -> Q [Char]+readFileQ fp = do+ qRunIO $ readFileUtf8 fp++-- move to Shakespeare?+readFileUtf8 :: FilePath -> IO String+readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp++data ShakespeareSettings = ShakespeareSettings+ { varChar :: Char+ , urlChar :: Char+ , intChar :: Char+ , toBuilder :: Exp+ , wrap :: Exp+ , unwrap :: Exp+ , justVarInterpolation :: Bool+ }+defaultShakespeareSettings :: ShakespeareSettings+defaultShakespeareSettings = ShakespeareSettings {+ varChar = '#'+ , urlChar = '@'+ , intChar = '^'+ , justVarInterpolation = False+}+++instance Lift ShakespeareSettings where+ lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7) =+ [|ShakespeareSettings+ $(lift x1) $(lift x2) $(lift x3)+ $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7)|]+ where+ liftExp (VarE n) = [|VarE $(liftName n)|]+ liftExp (ConE n) = [|ConE $(liftName n)|]+ liftExp _ = error "liftExp only supports VarE and ConE"+ liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]+ liftFlavour NameS = [|NameS|]+ liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]+ liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]+ liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]+ liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]+ liftNS VarName = [|VarName|]+ liftNS DataName = [|DataName|]++type 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]++contentFromString :: ShakespeareSettings -> (String -> [Content])+contentFromString rs s = do+ compressContents $ either (error . show) id $ parse (parseContents rs) s s+ where+ compressContents :: Contents -> Contents+ compressContents [] = []+ compressContents (ContentRaw x:ContentRaw y:z) =+ compressContents $ ContentRaw (x ++ y) : z+ compressContents (x:y) = x : compressContents y++parseContents :: ShakespeareSettings -> Parser Contents+parseContents = many1 . parseContent+ where+ parseContent :: ShakespeareSettings -> Parser Content+ parseContent ShakespeareSettings {..} =+ parseHash' <|> parseAt' <|> parseCaret' <|> parseChar+ where+ parseHash' = either ContentRaw ContentVar `fmap` parseVar varChar+ parseAt' =+ either ContentRaw go `fmap` parseUrl urlChar '?'+ where+ go (d, False) = ContentUrl d+ go (d, True) = ContentUrlParam d+ parseCaret' = either ContentRaw ContentMix `fmap` parseInt intChar+ parseChar = ContentRaw `fmap` (many1 $ noneOf [varChar, urlChar, intChar])++contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp+contentsToShakespeare rs a = do+ r <- newName "_render"+ c <- mapM (contentToBuilder r) a+ compiledTemplate <- case c of+ [] -> [|mempty|]+ [x] -> return x+ _ -> do+ mc <- [|mconcat|]+ return $ mc `AppE` ListE c+ if justVarInterpolation rs+ then return compiledTemplate+ else return $ LamE [VarP r] compiledTemplate+ where+ contentToBuilder :: Name -> Content -> Q Exp+ contentToBuilder _ (ContentRaw s') = do+ ts <- [|fromText . TS.pack|]+ return $ (wrap rs) `AppE` (ts `AppE` LitE (StringL s'))+ contentToBuilder _ (ContentVar d) = do+ return $ (wrap rs) `AppE` ((toBuilder rs) `AppE` derefToExp [] d)+ contentToBuilder r (ContentUrl d) = do+ ts <- [|fromText|]+ return $ (wrap rs) `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))+ contentToBuilder r (ContentUrlParam d) = do+ ts <- [|fromText|]+ up <- [|\r' (u, p) -> r' u p|]+ return $ (wrap rs) `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))+ contentToBuilder r (ContentMix d) = do+ return $ derefToExp [] d `AppE` VarE r++shakespeare :: ShakespeareSettings -> QuasiQuoter+shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }++shakespeareFromString :: ShakespeareSettings -> String -> Q Exp+shakespeareFromString r s = do+ contentsToShakespeare r $ contentFromString r s++shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp+shakespeareFile r fp = readFileQ fp >>= shakespeareFromString r++data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin++getVars :: Content -> [(Deref, VarType)]+getVars ContentRaw{} = []+getVars (ContentVar d) = [(d, VTPlain)]+getVars (ContentUrl d) = [(d, VTUrl)]+getVars (ContentUrlParam d) = [(d, VTUrlParam)]+getVars (ContentMix d) = [(d, VTMixin)]++data VarExp url = EPlain Builder+ | EUrl url+ | EUrlParam (url, [(TS.Text, TS.Text)])+ | EMixin (Shakespeare url)++shakespeareFileDebug :: ShakespeareSettings -> FilePath -> Q Exp+shakespeareFileDebug rs fp = do+ s <- readFileQ fp+ let b = concatMap getVars $ contentFromString rs s+ c <- mapM vtToExp b+ rt <- [|shakespeareRuntime|]+ wrap' <- [|\x -> $(return $ wrap rs) . x|]+ r' <- lift rs+ return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c)+ where+ vtToExp :: (Deref, VarType) -> Q Exp+ vtToExp (d, vt) = do+ d' <- lift d+ c' <- c vt+ return $ TupE [d', c' `AppE` derefToExp [] d]+ where+ c :: VarType -> Q Exp+ c VTPlain = [|EPlain . $(return $ toBuilder rs)|]+ c VTUrl = [|EUrl|]+ c VTUrlParam = [|EUrlParam|]+ c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|]+++shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url+shakespeareRuntime rs fp cd render' = unsafePerformIO $ do+ s <- readFileUtf8 fp+ return $ mconcat $ map go $ contentFromString rs s+ where+ go :: Content -> Builder+ go (ContentRaw s) = fromText $ TS.pack s+ go (ContentVar d) =+ case lookup d cd of+ Just (EPlain s) -> s+ _ -> error $ show d ++ ": expected EPlain"+ go (ContentUrl d) =+ case lookup d cd of+ Just (EUrl u) -> fromText $ render' u []+ _ -> error $ show d ++ ": expected EUrl"+ go (ContentUrlParam d) =+ case lookup d cd of+ Just (EUrlParam (u, p)) ->+ fromText $ render' u p+ _ -> error $ show d ++ ": expected EUrlParam"+ go (ContentMix d) =+ case lookup d cd of+ Just (EMixin m) -> m render'+ _ -> error $ show d ++ ": expected EMixin"
+ Text/Shakespeare/Base.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+-- | General parsers, functions and datatypes for all Shakespeare languages.+module Text.Shakespeare.Base+ ( Deref (..)+ , Ident (..)+ , Scope+ , parseDeref+ , parseHash+ , parseVar+ , parseAt+ , parseUrl+ , parseCaret+ , parseUnder+ , parseInt+ , derefToExp+ , flattenDeref+ , readUtf8File+ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH (appE)+import Data.Char (isUpper)+import Text.ParserCombinators.Parsec+import Data.List (intercalate)+import Data.Ratio (Ratio, numerator, denominator, (%))+import Data.Data (Data)+import Data.Typeable (Typeable)+import qualified Data.Text.Lazy as TL+import qualified System.IO as SIO+import qualified Data.Text.Lazy.IO as TIO++newtype Ident = Ident String+ deriving (Show, Eq, Read, Data, Typeable)++type Scope = [(Ident, Exp)]++data Deref = DerefModulesIdent [String] Ident+ | DerefIdent Ident+ | DerefIntegral Integer+ | DerefRational Rational+ | DerefString String+ | DerefBranch Deref Deref+ deriving (Show, Eq, Read, Data, Typeable)++instance Lift Ident where+ lift (Ident s) = [|Ident|] `appE` lift s+instance Lift Deref where+ lift (DerefModulesIdent v s) = do+ dl <- [|DerefModulesIdent|]+ v' <- lift v+ s' <- lift s+ return $ dl `AppE` v' `AppE` s'+ lift (DerefIdent s) = do+ dl <- [|DerefIdent|]+ s' <- lift s+ return $ dl `AppE` s'+ lift (DerefBranch x y) = do+ x' <- lift x+ y' <- lift y+ db <- [|DerefBranch|]+ return $ db `AppE` x' `AppE` y'+ lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i+ lift (DerefRational r) = do+ n <- lift $ numerator r+ d <- lift $ denominator r+ per <- [|(%) :: Int -> Int -> Ratio Int|]+ dr <- [|DerefRational|]+ return $ dr `AppE` (InfixE (Just n) per (Just d))+ lift (DerefString s) = [|DerefString|] `appE` lift s++parseDeref :: Parser Deref+parseDeref = do+ skipMany $ oneOf " \t"+ x <- derefSingle+ res <- deref' $ (:) x+ skipMany $ oneOf " \t"+ return res+ where+ delim = (many1 (char ' ') >> return())+ <|> lookAhead (char '(' >> return ())+ derefOp = try $ do+ _ <- char '('+ x <- many1 $ noneOf " \t\n\r()"+ _ <- char ')'+ return $ DerefIdent $ Ident x+ derefParens = between (char '(') (char ')') parseDeref+ derefSingle = derefOp <|> derefParens <|> numeric <|> strLit<|> ident+ deref' lhs =+ dollar <|> derefSingle'+ <|> return (foldl1 DerefBranch $ lhs [])+ where+ dollar = do+ _ <- try $ delim >> char '$'+ rhs <- parseDeref+ let lhs' = foldl1 DerefBranch $ lhs []+ return $ DerefBranch lhs' rhs+ derefSingle' = do+ x <- try $ delim >> derefSingle+ deref' $ lhs . (:) x+ numeric = do+ n <- (char '-' >> return "-") <|> return ""+ x <- many1 digit+ y <- (char '.' >> fmap Just (many1 digit)) <|> return Nothing+ return $ case y of+ Nothing -> DerefIntegral $ read' "Integral" $ n ++ x+ Just z -> DerefRational $ toRational+ (read' "Rational" $ n ++ x ++ '.' : z :: Double)+ strLit = do+ _ <- char '"'+ chars <- many quotedChar+ _ <- char '"'+ return $ DerefString chars+ quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""+ escapedChar =+ (char 'n' >> return '\n') <|>+ (char 'r' >> return '\r') <|>+ (char 'b' >> return '\b') <|>+ (char 't' >> return '\t') <|>+ (char '\\' >> return '\\') <|>+ (char '"' >> return '"') <|>+ (char '\'' >> return '\'')+ ident = do+ mods <- many modul+ func <- many1 (alphaNum <|> char '_' <|> char '\'')+ let func' = Ident func+ return $+ if null mods+ then DerefIdent func'+ else DerefModulesIdent mods func'+ modul = try $ do+ c <- upper+ cs <- many (alphaNum <|> char '_')+ _ <- char '.'+ return $ c : cs++read' :: Read a => String -> String -> a+read' t s =+ case reads s of+ (x, _):_ -> x+ [] -> error $ t ++ " read failed: " ++ s++expType :: Ident -> Name -> Exp+expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE+expType (Ident "") = error "Bad Ident"++derefToExp :: Scope -> Deref -> Exp+derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y+derefToExp _ (DerefModulesIdent mods i@(Ident s)) =+ expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods)+derefToExp scope (DerefIdent i@(Ident s)) =+ case lookup i scope of+ Just e -> e+ Nothing -> expType i $ mkName s+derefToExp _ (DerefIntegral i) = LitE $ IntegerL i+derefToExp _ (DerefRational r) = LitE $ RationalL r+derefToExp _ (DerefString s) = LitE $ StringL s++-- FIXME shouldn't we use something besides a list here?+flattenDeref :: Deref -> Maybe [String]+flattenDeref (DerefIdent (Ident x)) = Just [x]+flattenDeref (DerefBranch (DerefIdent (Ident x)) y) = do+ y' <- flattenDeref y+ Just $ y' ++ [x]+flattenDeref _ = Nothing++parseHash :: Parser (Either String Deref)+parseHash = parseVar '#'++parseVar :: Char -> Parser (Either String Deref)+parseVar c = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right deref) <|> (do+ -- Check for hash just before newline+ _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof+ return $ Left ""+ ) <|> return (Left [c])++parseAt :: Parser (Either String (Deref, Bool))+parseAt = parseUrl '@' '?'++parseUrl :: Char -> Char -> Parser (Either String (Deref, Bool))+parseUrl c d = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do+ x <- (char d >> return True) <|> return False+ (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right (deref, x))+ <|> return (Left $ if x then [c, d] else [c]))++parseCaret :: Parser (Either String Deref)+parseCaret = parseInt '^'++parseInt :: Char -> Parser (Either String Deref)+parseInt c = do+ _ <- char c+ (char '\\' >> return (Left [c])) <|> (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right deref) <|> return (Left [c])++parseUnder :: Parser (Either String Deref)+parseUnder = do+ _ <- char '_'+ (char '\\' >> return (Left "_")) <|> (do+ _ <- char '{'+ deref <- parseDeref+ _ <- char '}'+ return $ Right deref) <|> return (Left "_")++readUtf8File :: FilePath -> IO TL.Text+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ TIO.hGetContents h
+ shakespeare.cabal view
@@ -0,0 +1,41 @@+name: shakespeare+version: 0.10.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: A toolkit for making compile-time interpolated templates+description:+ Shakespeare is a template family for type-safe, efficient templates with simple variable interpolation . Shakespeare templates can be used inline with a quasi-quoter or in an external file. Shakespeare interpolates variables according to the type being inserted.+ .+ Note there is no dependency on haskell-src-extras.+ .+ packages that use this: shakespeare-js, shakespeare-css, shakespeare-interpolated, hamlet, and xml-hamlet+ Please see the documentation at <http://docs.yesodweb.com/book/hamlet/> for more details.++category: Web, Yesod+stability: Stable+cabal-version: >= 1.8+build-type: Simple+homepage: http://www.yesodweb.com/book/templates++library+ build-depends: base >= 4 && < 5+ , bytestring >= 0.9 && < 0.10+ , template-haskell+ , blaze-html >= 0.4 && < 0.5+ , parsec >= 2 && < 4+ , failure >= 0.1 && < 0.2+ , text >= 0.7 && < 0.12+ , containers >= 0.2 && < 0.5+ , blaze-builder >= 0.2 && < 0.4+ , process >= 1.0 && < 1.2+ exposed-modules: + Text.Shakespeare+ Text.Shakespeare.Base+ ghc-options: -Wall+++source-repository head+ type: git+ location: git://github.com/yesodweb/hamlet.git