hamlet 0.8.2.1 → 0.9.0
raw patch · 11 files changed
+273/−911 lines, 11 filesdep +hspecdep −QuickCheckdep −json-typesdep −test-frameworkdep ~hamletdep ~textPVP ok
version bump matches the API change (PVP)
Dependencies added: hspec
Dependencies removed: QuickCheck, json-types, test-framework, test-framework-hunit
Dependency ranges changed: hamlet, text
API changes (from Hackage documentation)
- Text.Hamlet: HDBool :: Bool -> HamletData url
- Text.Hamlet: HDHtml :: Html -> HamletData url
- Text.Hamlet: HDList :: [HamletMap url] -> HamletData url
- Text.Hamlet: HDMaybe :: (Maybe (HamletMap url)) -> HamletData url
- Text.Hamlet: HDTemplate :: HamletRT -> HamletData url
- Text.Hamlet: HDUrl :: url -> HamletData url
- Text.Hamlet: HDUrlParams :: url -> [(Text, Text)] -> HamletData url
- Text.Hamlet: HamletParseException :: String -> HamletException
- Text.Hamlet: HamletRenderException :: String -> HamletException
- Text.Hamlet: HamletSettings :: String -> Bool -> (String -> CloseStyle) -> HamletSettings
- Text.Hamlet: HamletUnsupportedDocException :: Doc -> HamletException
- Text.Hamlet: cdata :: Html -> Html
- Text.Hamlet: class Monad (HamletMonad a) => HamletValue a where { data family HamletMonad a :: * -> *; type family HamletUrl a; }
- Text.Hamlet: data HamletData url
- Text.Hamlet: data HamletException
- Text.Hamlet: data HamletRT
- Text.Hamlet: data HamletSettings
- Text.Hamlet: fromHamletValue :: HamletValue a => a -> HamletMonad a ()
- Text.Hamlet: hamletCloseNewline :: HamletSettings -> Bool
- Text.Hamlet: hamletCloseStyle :: HamletSettings -> String -> CloseStyle
- Text.Hamlet: hamletDebug :: QuasiQuoter
- Text.Hamlet: hamletDoctype :: HamletSettings -> String
- Text.Hamlet: hamletFileDebug :: FilePath -> Q Exp
- Text.Hamlet: htmlToHamletMonad :: HamletValue a => Html -> HamletMonad a ()
- Text.Hamlet: parseHamletRT :: Failure HamletException m => HamletSettings -> String -> m HamletRT
- Text.Hamlet: preEscapedLazyText :: Text -> Html
- Text.Hamlet: preEscapedString :: String -> Html
- Text.Hamlet: preEscapedText :: Text -> Html
- Text.Hamlet: renderHamlet :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> ByteString
- Text.Hamlet: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Hamlet: renderHamletText :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> Text
- Text.Hamlet: renderHtml :: Html -> ByteString
- Text.Hamlet: renderHtmlText :: Html -> Text
- Text.Hamlet: string :: String -> Html
- Text.Hamlet: toHamletValue :: HamletValue a => HamletMonad a () -> a
- Text.Hamlet: toHtml :: ToHtml a => a -> Html
- Text.Hamlet: unsafeByteString :: ByteString -> Html
- Text.Hamlet: urlToHamletMonad :: HamletValue a => HamletUrl a -> [(Text, Text)] -> HamletMonad a ()
- Text.Hamlet.NonPoly: Env :: Maybe ((Exp -> Q Exp) -> Q Exp) -> Maybe ((Exp -> Q Exp) -> Q Exp) -> Env
- Text.Hamlet.NonPoly: HamletRules :: Exp -> ((Env -> Q Exp) -> Q Exp) -> (Env -> Exp -> Q Exp) -> HamletRules
- Text.Hamlet.NonPoly: data Env
- Text.Hamlet.NonPoly: data HamletRules
- Text.Hamlet.NonPoly: defaultHamletSettings :: HamletSettings
- Text.Hamlet.NonPoly: hamlet :: QuasiQuoter
- Text.Hamlet.NonPoly: hamletFile :: FilePath -> Q Exp
- Text.Hamlet.NonPoly: hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
- Text.Hamlet.NonPoly: hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
- Text.Hamlet.NonPoly: hrEmbed :: HamletRules -> Env -> Exp -> Q Exp
- Text.Hamlet.NonPoly: hrFromHtml :: HamletRules -> Exp
- Text.Hamlet.NonPoly: hrWithEnv :: HamletRules -> (Env -> Q Exp) -> Q Exp
- Text.Hamlet.NonPoly: html :: QuasiQuoter
- Text.Hamlet.NonPoly: htmlFile :: FilePath -> Q Exp
- Text.Hamlet.NonPoly: ihamlet :: QuasiQuoter
- Text.Hamlet.NonPoly: ihamletFile :: FilePath -> Q Exp
- Text.Hamlet.NonPoly: msgRender :: Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
- Text.Hamlet.NonPoly: type Hamlet url = Render url -> Html
- Text.Hamlet.NonPoly: type Html = HtmlM ()
- Text.Hamlet.NonPoly: type IHamlet msg url = Translate msg -> Render url -> Html
- Text.Hamlet.NonPoly: urlRender :: Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
- Text.Hamlet.RT: HDBool :: Bool -> HamletData url
- Text.Hamlet.RT: HDHtml :: Html -> HamletData url
- Text.Hamlet.RT: HDList :: [HamletMap url] -> HamletData url
- Text.Hamlet.RT: HDMaybe :: (Maybe (HamletMap url)) -> HamletData url
- Text.Hamlet.RT: HDTemplate :: HamletRT -> HamletData url
- Text.Hamlet.RT: HDUrl :: url -> HamletData url
- Text.Hamlet.RT: HDUrlParams :: url -> [(Text, Text)] -> HamletData url
- Text.Hamlet.RT: HamletParseException :: String -> HamletException
- Text.Hamlet.RT: HamletRT :: [SimpleDoc] -> HamletRT
- Text.Hamlet.RT: HamletRenderException :: String -> HamletException
- Text.Hamlet.RT: HamletUnsupportedDocException :: Doc -> HamletException
- Text.Hamlet.RT: SDCond :: [([String], [SimpleDoc])] -> [SimpleDoc] -> SimpleDoc
- Text.Hamlet.RT: SDForall :: [String] -> String -> [SimpleDoc] -> SimpleDoc
- Text.Hamlet.RT: SDMaybe :: [String] -> String -> [SimpleDoc] -> [SimpleDoc] -> SimpleDoc
- Text.Hamlet.RT: SDRaw :: String -> SimpleDoc
- Text.Hamlet.RT: SDTemplate :: [String] -> SimpleDoc
- Text.Hamlet.RT: SDUrl :: Bool -> [String] -> SimpleDoc
- Text.Hamlet.RT: SDVar :: [String] -> SimpleDoc
- Text.Hamlet.RT: data HamletData url
- Text.Hamlet.RT: data HamletException
- Text.Hamlet.RT: data SimpleDoc
- Text.Hamlet.RT: instance Exception HamletException
- Text.Hamlet.RT: instance Show HamletException
- Text.Hamlet.RT: instance Typeable HamletException
- Text.Hamlet.RT: newtype HamletRT
- Text.Hamlet.RT: parseHamletRT :: Failure HamletException m => HamletSettings -> String -> m HamletRT
- Text.Hamlet.RT: renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Hamlet.RT: renderHamletRT' :: Failure HamletException m => Bool -> HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) -> m Html
- Text.Hamlet.RT: type HamletMap url = [([String], HamletData url)]
+ Text.Hamlet: Env :: Maybe ((Exp -> Q Exp) -> Q Exp) -> Maybe ((Exp -> Q Exp) -> Q Exp) -> Env
+ Text.Hamlet: HamletRules :: Exp -> ((Env -> Q Exp) -> Q Exp) -> (Env -> Exp -> Q Exp) -> HamletRules
+ Text.Hamlet: data Env
+ Text.Hamlet: data HamletRules
+ Text.Hamlet: hrEmbed :: HamletRules -> Env -> Exp -> Q Exp
+ Text.Hamlet: hrFromHtml :: HamletRules -> Exp
+ Text.Hamlet: hrWithEnv :: HamletRules -> (Env -> Q Exp) -> Q Exp
+ Text.Hamlet: html :: QuasiQuoter
+ Text.Hamlet: htmlFile :: FilePath -> Q Exp
+ Text.Hamlet: ihamlet :: QuasiQuoter
+ Text.Hamlet: ihamletFile :: FilePath -> Q Exp
+ Text.Hamlet: msgRender :: Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
+ Text.Hamlet: type IHamlet msg url = Translate msg -> Render url -> Html
+ Text.Hamlet: urlRender :: Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
+ Text.Hamlet: xhtml :: QuasiQuoter
+ Text.Hamlet: xhtmlFile :: FilePath -> Q Exp
+ Text.Shakespeare: readUtf8File :: FilePath -> IO Text
- Text.Hamlet: hamletFileWithSettings :: HamletSettings -> FilePath -> Q Exp
+ Text.Hamlet: hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
- Text.Hamlet: hamletWithSettings :: HamletSettings -> QuasiQuoter
+ Text.Hamlet: hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
- Text.Hamlet: type Hamlet url = (url -> [(Text, Text)] -> Text) -> Html
+ Text.Hamlet: type Hamlet url = Render url -> Html
Files
- Text/Cassius.hs +0/−1
- Text/Css.hs +0/−1
- Text/Hamlet.hs +252/−64
- Text/Hamlet/Debug.hs +0/−140
- Text/Hamlet/NonPoly.hs +0/−255
- Text/Hamlet/Quasi.hs +0/−251
- Text/Hamlet/RT.hs +0/−174
- Text/Lucius.hs +0/−1
- Text/Romeo.hs +0/−1
- Text/Shakespeare.hs +10/−0
- hamlet.cabal +11/−23
Text/Cassius.hs view
@@ -47,7 +47,6 @@ import Data.Bits import qualified Data.Text as TS import qualified Data.Text.Lazy as TL-import Text.Hamlet.Quasi (readUtf8File) import Data.Char (isSpace) data Color = Color Word8 Word8 Word8
Text/Css.hs view
@@ -11,7 +11,6 @@ import Data.Text (Text, pack) import Language.Haskell.TH.Syntax import System.IO.Unsafe (unsafePerformIO)-import Text.Hamlet.Quasi (readUtf8File) import Text.ParserCombinators.Parsec (Parser, parse) import Text.Shakespeare import Language.Haskell.TH
Text/Hamlet.hs view
@@ -1,78 +1,266 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet- ( -- * Basic quasiquoters- hamlet- , xhamlet- , hamletDebug- -- * Load from external file+ ( -- * Plain HTML+ Html+ , html+ , htmlFile+ , xhtml+ , xhtmlFile+ -- * Hamlet+ , Hamlet+ , hamlet , hamletFile+ , xhamlet , xhamletFile- , hamletFileDebug- -- * Customized settings+ -- * I18N Hamlet+ , IHamlet+ , ihamlet+ , ihamletFile+ -- * Internal, for making more , hamletWithSettings , hamletFileWithSettings- , HamletSettings (..) , defaultHamletSettings , xhtmlHamletSettings- -- * Datatypes- , Html- , Hamlet- -- * Typeclass- , HamletValue (..)- -- * Construction- , preEscapedString- , preEscapedText- , preEscapedLazyText- , string- , unsafeByteString- , cdata- , toHtml- -- * Rendering- -- ** ByteString- , renderHamlet- , renderHtml- -- ** Text- , renderHamletText- , renderHtmlText- -- * Runtime Hamlet- , HamletRT- , HamletData (..)- , HamletException (..)- , parseHamletRT- , renderHamletRT+ , Env (..)+ , HamletRules (..) ) where +import Text.Shakespeare import Text.Hamlet.Parse-import Text.Hamlet.Quasi-import Text.Hamlet.RT-import Text.Hamlet.Debug-import qualified Data.ByteString.Lazy as L-import Data.Monoid (mappend)-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T-import qualified Data.Text.Encoding.Error as T-import Text.Blaze.Renderer.Utf8 (renderHtml)-import qualified Text.Blaze.Renderer.Text as BT-import Text.Blaze (preEscapedText, preEscapedString, string, unsafeByteString, toHtml, preEscapedLazyText)-import Data.Text (Text)+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Data.Char (isUpper, isDigit)+import Data.Monoid (Monoid (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TIO+import qualified System.IO as SIO+import Text.Blaze (Html, preEscapedText, toHtml)+import qualified Data.Foldable as F+import Control.Applicative ((<$>))+import Control.Monad (ap) --- | Converts a 'Hamlet' to lazy bytestring.-renderHamlet :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> L.ByteString-renderHamlet render h = renderHtml $ h render+type Render url = url -> [(Text, Text)] -> Text+type Translate msg = msg -> Html -renderHamletText :: (url -> [(Text, Text)] -> Text) -> Hamlet url- -> T.Text-renderHamletText render h =- T.decodeUtf8With T.lenientDecode $ renderHtml $ h render+-- | A function generating an 'Html' given a URL-rendering function.+type Hamlet url = Render url -> Html -renderHtmlText :: Html -> T.Text-renderHtmlText = BT.renderHtml+-- | A function generating an 'Html' given a message translator and a URL rendering function.+type IHamlet msg url = Translate msg -> Render url -> Html --- | Wrap an 'Html' for embedding in an XML file.-cdata :: Html -> Html-cdata h =- preEscapedText "<![CDATA["- `mappend`- h- `mappend`- preEscapedText "]]>"+docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp+docsToExp env hr scope docs = do+ exps <- mapM (docToExp env hr scope) docs+ case exps of+ [] -> [|return ()|]+ [x] -> return x+ _ -> return $ DoE $ map NoBindS exps++docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp+docToExp env hr scope (DocForall list ident@(Ident name) inside) = do+ let list' = derefToExp scope list+ name' <- newName name+ let scope' = (ident, VarE name') : scope+ mh <- [|F.mapM_|]+ inside' <- docsToExp env hr scope' inside+ let lam = LamE [VarP name'] inside'+ return $ mh `AppE` lam `AppE` list'+docToExp env hr scope (DocWith [] inside) = do+ inside' <- docsToExp env hr scope inside+ return $ inside'+docToExp env hr scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do+ let deref' = derefToExp scope deref+ name' <- newName name+ let scope' = (ident, VarE name') : scope+ inside' <- docToExp env hr scope' (DocWith dis inside)+ let lam = LamE [VarP name'] inside'+ return $ lam `AppE` deref'+docToExp env hr scope (DocMaybe val ident@(Ident name) inside mno) = do+ let val' = derefToExp scope val+ name' <- newName name+ let scope' = (ident, VarE name') : scope+ inside' <- docsToExp env hr scope' inside+ let inside'' = LamE [VarP name'] inside'+ ninside' <- case mno of+ Nothing -> [|Nothing|]+ Just no -> do+ no' <- docsToExp env hr scope no+ j <- [|Just|]+ return $ j `AppE` no'+ mh <- [|maybeH|]+ return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'+docToExp env hr scope (DocCond conds final) = do+ conds' <- mapM go conds+ final' <- case final of+ Nothing -> [|Nothing|]+ Just f -> do+ f' <- docsToExp env hr scope f+ j <- [|Just|]+ return $ j `AppE` f'+ ch <- [|condH|]+ return $ ch `AppE` ListE conds' `AppE` final'+ where+ go :: (Deref, [Doc]) -> Q Exp+ go (d, docs) = do+ let d' = derefToExp scope d+ docs' <- docsToExp env hr scope docs+ return $ TupE [d', docs']+docToExp env hr v (DocContent c) = contentToExp env hr v c++contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp+contentToExp _ hr _ (ContentRaw s) = do+ os <- [|preEscapedText . pack|]+ let s' = LitE $ StringL s+ return $ hrFromHtml hr `AppE` (os `AppE` s')+contentToExp _ hr scope (ContentVar d) = do+ str <- [|toHtml|]+ return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)+contentToExp env hr scope (ContentUrl hasParams d) =+ case urlRender env of+ Nothing -> error "URL interpolation used, but no URL renderer provided"+ Just wrender -> wrender $ \render -> do+ let render' = return render+ ou <- if hasParams+ then [|\(u, p) -> $(render') u p|]+ else [|\u -> $(render') u []|]+ let d' = derefToExp scope d+ pet <- [|toHtml|]+ return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))+contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d+contentToExp env hr scope (ContentMsg d) =+ case msgRender env of+ Nothing -> error "Message interpolation used, but no message renderer provided"+ Just wrender -> wrender $ \render ->+ return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)++html :: QuasiQuoter+html = hamletWithSettings htmlRules defaultHamletSettings++xhtml :: QuasiQuoter+xhtml = hamletWithSettings htmlRules xhtmlHamletSettings++htmlRules :: Q HamletRules+htmlRules = do+ i <- [|id|]+ return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)++hamlet :: QuasiQuoter+hamlet = hamletWithSettings hamletRules defaultHamletSettings++xhamlet :: QuasiQuoter+xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings++hamletRules :: Q HamletRules+hamletRules = do+ i <- [|id|]+ let ur f = do+ r <- newName "_render"+ let env = Env+ { urlRender = Just ($ (VarE r))+ , msgRender = Nothing+ }+ h <- f env+ return $ LamE [VarP r] h+ let em (Env (Just urender) Nothing) e =+ urender $ \ur -> return (e `AppE` ur)+ return $ HamletRules i ur em++ihamlet :: QuasiQuoter+ihamlet = hamletWithSettings ihamletRules defaultHamletSettings++ihamletRules :: Q HamletRules+ihamletRules = do+ i <- [|id|]+ let ur f = do+ u <- newName "_urender"+ m <- newName "_mrender"+ let env = Env+ { urlRender = Just ($ (VarE u))+ , msgRender = Just ($ (VarE m))+ }+ h <- f env+ return $ LamE [VarP m, VarP u] h+ let em (Env (Just urender) (Just mrender)) e =+ urender $ \ur -> mrender $ \mr -> return (e `AppE` mr `AppE` ur)+ return $ HamletRules i ur em++hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter+hamletWithSettings hr set =+ QuasiQuoter+ { quoteExp = hamletFromString hr set+ }++data HamletRules = HamletRules+ { hrFromHtml :: Exp+ , hrWithEnv :: (Env -> Q Exp) -> Q Exp+ , hrEmbed :: Env -> Exp -> Q Exp+ }++data Env = Env+ { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)+ , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)+ }++hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp+hamletFromString qhr set s = do+ hr <- qhr+ case parseDoc set s of+ Error s' -> error s'+ Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d++hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp+hamletFileWithSettings qhr set fp = do+ contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+ hamletFromString qhr set contents++hamletFile :: FilePath -> Q Exp+hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings++xhamletFile :: FilePath -> Q Exp+xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings++htmlFile :: FilePath -> Q Exp+htmlFile = hamletFileWithSettings htmlRules defaultHamletSettings++xhtmlFile :: FilePath -> Q Exp+xhtmlFile = hamletFileWithSettings htmlRules xhtmlHamletSettings++ihamletFile :: FilePath -> Q Exp+ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings++varName :: Scope -> String -> Exp+varName _ "" = error "Illegal empty varName"+varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope++strToExp :: String -> Exp+strToExp s@(c:_)+ | all isDigit s = LitE $ IntegerL $ read s+ | isUpper c = ConE $ mkName s+ | otherwise = VarE $ mkName s+strToExp "" = error "strToExp on empty string"++-- | Checks for truth in the left value in each pair in the first argument. If+-- a true exists, then the corresponding right action is performed. Only the+-- first is performed. In there are no true values, then the second argument is+-- performed, if supplied.+condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()+condH [] Nothing = return ()+condH [] (Just x) = x+condH ((True, y):_) _ = y+condH ((False, _):rest) z = condH rest z++-- | Runs the second argument with the value in the first, if available.+-- Otherwise, runs the third argument, if available.+maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()+maybeH Nothing _ Nothing = return ()+maybeH Nothing _ (Just x) = x+maybeH (Just v) f _ = f v
− Text/Hamlet/Debug.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Text.Hamlet.Debug- ( hamletFileDebug- ) where--import Text.Hamlet.Parse-import Text.Hamlet.Quasi-import Text.Hamlet.RT-import Language.Haskell.TH.Syntax-import System.IO.Unsafe (unsafePerformIO)-import Control.Arrow-import Data.Either-import Control.Monad (forM)-import qualified Data.Text.Lazy as T-import Text.Blaze (toHtml)-import Data.Text (Text)--unsafeRenderTemplate :: FilePath -> HamletMap url- -> (url -> [(Text, Text)] -> Text) -> Html-unsafeRenderTemplate fp hd render = unsafePerformIO $ do- contents <- fmap T.unpack $ readUtf8File fp- temp <- parseHamletRT defaultHamletSettings contents- renderHamletRT' True temp hd render--hamletFileDebug :: FilePath -> Q Exp-hamletFileDebug fp = do- contents <- fmap T.unpack $ qRunIO $ readUtf8File fp- HamletRT docs <- qRunIO $ parseHamletRT defaultHamletSettings contents- urt <- [|unsafeRenderTemplate|]- render <- newName "render"- let hd = combineDVals $ concatMap getHD docs- hd' <- liftDVals (VarE render) hd- let h = urt `AppE` LitE (StringL fp) `AppE` hd' `AppE` VarE render- return $ LamE [VarP render] h--derefToExp :: [Exp] -> Exp-derefToExp = foldr1 AppE . reverse--type DVal = ([Exp], DVal')-data DVal' = DHtml- | DUrl- | DUrlParam- | DTemplate- | DBool- | DMaybe [([String], DVal)]- | DList [([String], DVal)]- deriving (Show, Eq)--liftDVals :: Exp -> [([String], DVal)] -> Q Exp-liftDVals render pairs = do- pairs' <- forM pairs $ \(k, d) -> do- let k' = ListE $ map (LitE . StringL) k- d' <- liftDVal render d- return $ TupE [k', d']- return $ ListE pairs'--liftDVal :: Exp -> DVal -> Q Exp-liftDVal _ (x, DHtml) = do- f <- [|HDHtml . toHtml|]- return $ f `AppE` derefToExp x-liftDVal _ (x, DUrl) = do- f <- [|HDUrl|]- return $ f `AppE` derefToExp x-liftDVal _ (x, DUrlParam) = do- f <- [|uncurry HDUrlParams|]- return $ f `AppE` derefToExp x-liftDVal render (x, DTemplate) = do- f <- [|HDHtml|]- return $ f `AppE` (derefToExp x `AppE` render)-liftDVal _ (x, DBool) = do- f <- [|HDBool|]- return $ f `AppE` derefToExp x-liftDVal render (x, DMaybe each) = do- var <- newName "_var"- each' <- liftDVals render $ map (second $ replaceFirst $ VarE var) each- let each'' = LamE [VarP var] each'- hdlist <- [|HDMaybe|]- map' <- [|fmap|]- return $ hdlist `AppE` (map' `AppE` each'' `AppE` derefToExp x)-liftDVal render (x, DList each) = do- var <- newName "_var"- each' <- liftDVals render $ map (second $ replaceFirst $ VarE var) each- let each'' = LamE [VarP var] each'- hdlist <- [|HDList|]- map' <- [|map|]- return $ hdlist `AppE` (map' `AppE` each'' `AppE` derefToExp x)--combineDVals :: [([String], DVal)] -> [([String], DVal)]-combineDVals [] = []-combineDVals ((x1, y1):rest) =- case matches of- [] -> (x1, y1) : combineDVals rest- ys -> (x1, foldr combine' y1 ys) : combineDVals nomatch- where- matches = map snd $ filter (\(x, _) -> x == x1) rest- nomatch = filter (\(x, _) -> x /= x1) rest- combine' (a, x) (b, y)- | a == b = (a, combine x y)- | otherwise = error $ "Bad parameters to combine': " ++ show ((a, x), (b, y))- combine (DList x) (DList y) = DList $ combineDVals $ x ++ y- combine (DMaybe x) (DMaybe y) = DMaybe $ combineDVals $ x ++ y- combine x y- | x == y = x- combine x y = error $ "Bad parameters to combine: " ++ show (x, y)--varNames :: [String] -> [Exp]-varNames = map $ varName []-getHD :: SimpleDoc -> [([String], DVal)]-getHD SDRaw{} = []-getHD (SDVar x) = [(x, (varNames x, DHtml))]-getHD (SDUrl hasParams x) =- [(x, (varNames x, if hasParams then DUrlParam else DUrl))]-getHD (SDTemplate x) = [(x, (varNames x, DTemplate))]-getHD (SDCond xs edocs) =- let hd = concatMap getHD $ edocs ++ concatMap snd xs- bools = map (\(x, _) -> (x, (varNames x, DBool))) xs- in hd ++ bools-getHD (SDMaybe x y docs ndocs) =- (x, (varNames x, DMaybe subs)) : tops ++ ntops- where- hd = concatMap getHD docs- (tops, subs) = partitionEithers $ map go hd- ntops = concatMap getHD ndocs- go (a@(y':rest), e)- | y == y' = Right (rest, e)- | otherwise = Left (a, e)- go ([], _) = error "getHD of SDMaybe"-getHD (SDForall x y docs) =- (x, (varNames x, DList subs)) : tops- where- hd = concatMap getHD docs- (tops, subs) = partitionEithers $ map go hd- go (a@(y':rest), e)- | y == y' = Right (rest, e)- | otherwise = Left (a, e)- go ([], _) = error "getHD of SDForall"--replaceFirst :: Exp -> DVal -> DVal-replaceFirst x (_:y, z) = (x:y, z)-replaceFirst _ _ = error "replaceFirst on something empty"
− Text/Hamlet/NonPoly.hs
@@ -1,255 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Hamlet.NonPoly- ( -- * Plain HTML- Html- , html- , htmlFile- -- * Hamlet- , Hamlet- , hamlet- , hamletFile- -- * I18N Hamlet- , IHamlet- , ihamlet- , ihamletFile- -- * Internal, for making more- , hamletWithSettings- , hamletFileWithSettings- , defaultHamletSettings- , Env (..)- , HamletRules (..)- ) where--import Text.Shakespeare-import Text.Hamlet.Parse-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Data.Char (isUpper, isDigit)-import Data.Monoid (Monoid (..))-import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TIO-import qualified System.IO as SIO-import Text.Blaze (Html, preEscapedText, toHtml)-import qualified Data.Foldable as F-import Control.Applicative ((<$>))-import Control.Monad (ap)--type Render url = url -> [(Text, Text)] -> Text-type Translate msg = msg -> Html---- | A function generating an 'Html' given a URL-rendering function.-type Hamlet url = Render url -> Html---- | A function generating an 'Html' given a message translator and a URL rendering function.-type IHamlet msg url = Translate msg -> Render url -> Html--readUtf8File :: FilePath -> IO TL.Text-readUtf8File fp = do- h <- SIO.openFile fp SIO.ReadMode- SIO.hSetEncoding h SIO.utf8_bom- TIO.hGetContents h--docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp-docsToExp env hr scope docs = do- exps <- mapM (docToExp env hr scope) docs- case exps of- [] -> [|return ()|]- [x] -> return x- _ -> return $ DoE $ map NoBindS exps--docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp-docToExp env hr scope (DocForall list ident@(Ident name) inside) = do- let list' = derefToExp scope list- name' <- newName name- let scope' = (ident, VarE name') : scope- mh <- [|F.mapM_|]- inside' <- docsToExp env hr scope' inside- let lam = LamE [VarP name'] inside'- return $ mh `AppE` lam `AppE` list'-docToExp env hr scope (DocWith [] inside) = do- inside' <- docsToExp env hr scope inside- return $ inside'-docToExp env hr scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do- let deref' = derefToExp scope deref- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docToExp env hr scope' (DocWith dis inside)- let lam = LamE [VarP name'] inside'- return $ lam `AppE` deref'-docToExp env hr scope (DocMaybe val ident@(Ident name) inside mno) = do- let val' = derefToExp scope val- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docsToExp env hr scope' inside- let inside'' = LamE [VarP name'] inside'- ninside' <- case mno of- Nothing -> [|Nothing|]- Just no -> do- no' <- docsToExp env hr scope no- j <- [|Just|]- return $ j `AppE` no'- mh <- [|maybeH|]- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'-docToExp env hr scope (DocCond conds final) = do- conds' <- mapM go conds- final' <- case final of- Nothing -> [|Nothing|]- Just f -> do- f' <- docsToExp env hr scope f- j <- [|Just|]- return $ j `AppE` f'- ch <- [|condH|]- return $ ch `AppE` ListE conds' `AppE` final'- where- go :: (Deref, [Doc]) -> Q Exp- go (d, docs) = do- let d' = derefToExp scope d- docs' <- docsToExp env hr scope docs- return $ TupE [d', docs']-docToExp env hr v (DocContent c) = contentToExp env hr v c--contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp-contentToExp _ hr _ (ContentRaw s) = do- os <- [|preEscapedText . pack|]- let s' = LitE $ StringL s- return $ hrFromHtml hr `AppE` (os `AppE` s')-contentToExp _ hr scope (ContentVar d) = do- str <- [|toHtml|]- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)-contentToExp env hr scope (ContentUrl hasParams d) =- case urlRender env of- Nothing -> error "URL interpolation used, but no URL renderer provided"- Just wrender -> wrender $ \render -> do- let render' = return render- ou <- if hasParams- then [|\(u, p) -> $(render') u p|]- else [|\u -> $(render') u []|]- let d' = derefToExp scope d- pet <- [|preEscapedText|]- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d-contentToExp env hr scope (ContentMsg d) =- case msgRender env of- Nothing -> error "Message interpolation used, but no message renderer provided"- Just wrender -> wrender $ \render ->- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)--html :: QuasiQuoter-html = hamletWithSettings htmlRules defaultHamletSettings--htmlRules :: Q HamletRules-htmlRules = do- i <- [|id|]- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)--hamlet :: QuasiQuoter-hamlet = hamletWithSettings hamletRules defaultHamletSettings--hamletRules :: Q HamletRules-hamletRules = do- i <- [|id|]- let ur f = do- r <- newName "_render"- let env = Env- { urlRender = Just ($ (VarE r))- , msgRender = Nothing- }- h <- f env- return $ LamE [VarP r] h- let em (Env (Just urender) Nothing) e =- urender $ \ur -> return (e `AppE` ur)- return $ HamletRules i ur em--ihamlet :: QuasiQuoter-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings--ihamletRules :: Q HamletRules-ihamletRules = do- i <- [|id|]- let ur f = do- u <- newName "_urender"- m <- newName "_mrender"- let env = Env- { urlRender = Just ($ (VarE u))- , msgRender = Just ($ (VarE m))- }- h <- f env- return $ LamE [VarP m, VarP u] h- let em (Env (Just urender) (Just mrender)) e =- urender $ \ur -> mrender $ \mr -> return (e `AppE` mr `AppE` ur)- return $ HamletRules i ur em--hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter-hamletWithSettings hr set =- QuasiQuoter- { quoteExp = hamletFromString hr set- }--data HamletRules = HamletRules- { hrFromHtml :: Exp- , hrWithEnv :: (Env -> Q Exp) -> Q Exp- , hrEmbed :: Env -> Exp -> Q Exp- }--data Env = Env- { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- }--hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp-hamletFromString qhr set s = do- hr <- qhr- case parseDoc set s of- Error s' -> error s'- Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d--hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp-hamletFileWithSettings qhr set fp = do- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- hamletFromString qhr set contents--hamletFile :: FilePath -> Q Exp-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings--htmlFile :: FilePath -> Q Exp-htmlFile = hamletFileWithSettings htmlRules defaultHamletSettings--ihamletFile :: FilePath -> Q Exp-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings--varName :: Scope -> String -> Exp-varName _ "" = error "Illegal empty varName"-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope--strToExp :: String -> Exp-strToExp s@(c:_)- | all isDigit s = LitE $ IntegerL $ read s- | isUpper c = ConE $ mkName s- | otherwise = VarE $ mkName s-strToExp "" = error "strToExp on empty string"---- | Checks for truth in the left value in each pair in the first argument. If--- a true exists, then the corresponding right action is performed. Only the--- first is performed. In there are no true values, then the second argument is--- performed, if supplied.-condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()-condH [] Nothing = return ()-condH [] (Just x) = x-condH ((True, y):_) _ = y-condH ((False, _):rest) z = condH rest z---- | Runs the second argument with the value in the first, if available.--- Otherwise, runs the third argument, if available.-maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()-maybeH Nothing _ Nothing = return ()-maybeH Nothing _ (Just x) = x-maybeH (Just v) f _ = f v
− Text/Hamlet/Quasi.hs
@@ -1,251 +0,0 @@--- NOTE: This module is being deprecated, in favor of NonPoly. In Hamlet 0.9,--- this code will be replaced entirely. Avoid changes here whenever possible.--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Hamlet.Quasi- ( hamlet- , xhamlet- , hamletDebug- , hamletWithSettings- , hamletWithSettings'- , hamletFile- , xhamletFile- , hamletFileWithSettings- , HamletValue (..)- , varName- , Html- , Hamlet- , readUtf8File- ) where--import Text.Shakespeare-import Text.Hamlet.Parse-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Data.Char (isUpper, isDigit)-import Data.Monoid (Monoid (..))-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TIO-import qualified System.IO as SIO-import Text.Blaze (Html, preEscapedString, toHtml)-import qualified Data.Foldable as F--readUtf8File :: FilePath -> IO TL.Text-readUtf8File fp = do- h <- SIO.openFile fp SIO.ReadMode- SIO.hSetEncoding h SIO.utf8_bom- TIO.hGetContents h--docsToExp :: Scope -> [Doc] -> Q Exp-docsToExp scope docs = do- exps <- mapM (docToExp scope) docs- case exps of- [] -> [|return ()|]- [x] -> return x- _ -> return $ DoE $ map NoBindS exps--docToExp :: Scope -> Doc -> Q Exp-docToExp scope (DocForall list ident@(Ident name) inside) = do- let list' = derefToExp scope list- name' <- newName name- let scope' = (ident, VarE name') : scope- mh <- [|F.mapM_|]- inside' <- docsToExp scope' inside- let lam = LamE [VarP name'] inside'- return $ mh `AppE` lam `AppE` list'-docToExp scope (DocWith [] inside) = do- inside' <- docsToExp scope inside- return $ inside'-docToExp scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do- let deref' = derefToExp scope deref- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docToExp scope' (DocWith dis inside)- let lam = LamE [VarP name'] inside'- return $ lam `AppE` deref'-docToExp scope (DocMaybe val ident@(Ident name) inside mno) = do- let val' = derefToExp scope val- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docsToExp scope' inside- let inside'' = LamE [VarP name'] inside'- ninside' <- case mno of- Nothing -> [|Nothing|]- Just no -> do- no' <- docsToExp scope no- j <- [|Just|]- return $ j `AppE` no'- mh <- [|maybeH|]- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'-docToExp scope (DocCond conds final) = do- conds' <- mapM go conds- final' <- case final of- Nothing -> [|Nothing|]- Just f -> do- f' <- docsToExp scope f- j <- [|Just|]- return $ j `AppE` f'- ch <- [|condH|]- return $ ch `AppE` ListE conds' `AppE` final'- where- go :: (Deref, [Doc]) -> Q Exp- go (d, docs) = do- let d' = derefToExp scope d- docs' <- docsToExp scope docs- return $ TupE [d', docs']-docToExp v (DocContent c) = contentToExp v c--contentToExp :: Scope -> Content -> Q Exp-contentToExp _ (ContentRaw s) = do- os <- [|htmlToHamletMonad . preEscapedString|]- let s' = LitE $ StringL s- return $ os `AppE` s'-contentToExp scope (ContentVar d) = do- str <- [|htmlToHamletMonad . toHtml|]- return $ str `AppE` derefToExp scope d-contentToExp scope (ContentUrl hasParams d) = do- ou <- if hasParams- then [|\(u, p) -> urlToHamletMonad u p|]- else [|\u -> urlToHamletMonad u []|]- let d' = derefToExp scope d- return $ ou `AppE` d'-contentToExp scope (ContentEmbed d) = do- let d' = derefToExp scope d- fhv <- [|fromHamletValue|]- return $ fhv `AppE` d'-contentToExp _ ContentMsg{} = error "Poly-Hamlet does not support messages"---- | Calls 'hamletWithSettings' with 'defaultHamletSettings'.-hamlet :: QuasiQuoter-hamlet = hamletWithSettings defaultHamletSettings---- | Calls 'hamletWithSettings' with 'debugHamletSettings'.-hamletDebug :: QuasiQuoter-hamletDebug = hamletWithSettings debugHamletSettings---- | Calls 'hamletWithSettings' using XHTML 1.0 Strict settings.-xhamlet :: QuasiQuoter-xhamlet = hamletWithSettings xhtmlHamletSettings---- | A quasi-quoter that converts Hamlet syntax into a function of form:------ > (url -> String) -> Html------ Please see accompanying documentation for a description of Hamlet syntax.-hamletWithSettings :: HamletSettings -> QuasiQuoter-hamletWithSettings set =- QuasiQuoter- { quoteExp = hamletFromString set- }---- | A quasi-quoter that converts Hamlet syntax into a 'Html' ().------ Please see accompanying documentation for a description of Hamlet syntax.-hamletWithSettings' :: HamletSettings -> QuasiQuoter-hamletWithSettings' set =- QuasiQuoter- { quoteExp = \s -> do- x <- hamletFromString set s- id' <- [|(\y _ -> y) :: String -> [(String, String)] -> String|]- return $ x `AppE` id'- }--hamletFromString :: HamletSettings -> String -> Q Exp-hamletFromString set s = do- case parseDoc set s of- Error s' -> error s'- Ok d -> do- thv <- [|toHamletValue|]- exp' <- docsToExp [] d- return $ thv `AppE` exp'--hamletFileWithSettings :: HamletSettings -> FilePath -> Q Exp-hamletFileWithSettings set fp = do- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- hamletFromString set contents---- | Calls 'hamletFileWithSettings' with 'defaultHamletSettings'.-hamletFile :: FilePath -> Q Exp-hamletFile = hamletFileWithSettings defaultHamletSettings---- | Calls 'hamletFileWithSettings' using XHTML 1.0 Strict settings.-xhamletFile :: FilePath -> Q Exp-xhamletFile = hamletFileWithSettings xhtmlHamletSettings--varName :: Scope -> String -> Exp-varName _ "" = error "Illegal empty varName"-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope--strToExp :: String -> Exp-strToExp s@(c:_)- | all isDigit s = LitE $ IntegerL $ read s- | isUpper c = ConE $ mkName s- | otherwise = VarE $ mkName s-strToExp "" = error "strToExp on empty string"---- | Checks for truth in the left value in each pair in the first argument. If--- a true exists, then the corresponding right action is performed. Only the--- first is performed. In there are no true values, then the second argument is--- performed, if supplied.-condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()-condH [] Nothing = return ()-condH [] (Just x) = x-condH ((True, y):_) _ = y-condH ((False, _):rest) z = condH rest z---- | Runs the second argument with the value in the first, if available.--- Otherwise, runs the third argument, if available.-maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()-maybeH Nothing _ Nothing = return ()-maybeH Nothing _ (Just x) = x-maybeH (Just v) f _ = f v---- | An function generating an 'Html' given a URL-rendering function.-type Hamlet url = (url -> [(Text, Text)] -> Text) -> Html--class Monad (HamletMonad a) => HamletValue a where- data HamletMonad a :: * -> *- type HamletUrl a- toHamletValue :: HamletMonad a () -> a- htmlToHamletMonad :: Html -> HamletMonad a ()- urlToHamletMonad :: HamletUrl a -> [(Text, Text)] -> HamletMonad a ()- fromHamletValue :: a -> HamletMonad a ()--type Render url = url -> [(Text, Text)] -> Text-instance HamletValue (Hamlet url) where- newtype HamletMonad (Hamlet url) a =- HMonad { runHMonad :: Render url -> (Html, a) }- type HamletUrl (Hamlet url) = url- toHamletValue = fmap fst . runHMonad- htmlToHamletMonad x = HMonad $ const (x, ())- urlToHamletMonad url pairs = HMonad $ \r ->- (toHtml $ r url pairs, ())- fromHamletValue f = HMonad $ \r -> (f r, ())-instance Monad (HamletMonad (Hamlet url)) where- return x = HMonad $ const (mempty, x)- (HMonad f) >>= g = HMonad $ \render ->- let (html1, x) = f render- (html2, y) = runHMonad (g x) render- in (html1 `mappend` html2, y)-data NoConstructor-instance HamletValue Html where- newtype HamletMonad Html a = HtmlMonad { runHtmlMonad :: (Html, a) }- type HamletUrl Html = NoConstructor- toHamletValue = fst . runHtmlMonad- htmlToHamletMonad x = HtmlMonad (x, ())- urlToHamletMonad = error "urlToHamletMonad on NoConstructor"- fromHamletValue h = HtmlMonad (h, ())-instance Monad (HamletMonad Html) where- return x = HtmlMonad (mempty, x)- HtmlMonad (html1, x) >>= g = HtmlMonad $- let HtmlMonad (html2, y) = g x- in (html1 `mappend` html2, y)
− Text/Hamlet/RT.hs
@@ -1,174 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | Most everything exported here is exported also by "Text.Hamlet". The--- exceptions to that rule should not be necessary for normal usage.-module Text.Hamlet.RT- ( -- * Public API- HamletRT (..)- , HamletData (..)- , HamletMap- , HamletException (..)- , parseHamletRT- , renderHamletRT- , renderHamletRT'- , SimpleDoc (..)- ) where--import Text.Shakespeare-import Data.Monoid (mconcat)-import Control.Monad (liftM, forM)-import Control.Exception (Exception)-import Data.Typeable (Typeable)-import Control.Failure-import Text.Hamlet.Parse-import Text.Hamlet.Quasi (Html)-import Data.List (intercalate)-import Text.Blaze (preEscapedString, preEscapedText)-import Data.Text (Text)--type HamletMap url = [([String], HamletData url)]--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 :: Failure HamletException m- => HamletSettings -> String -> m HamletRT-parseHamletRT set s =- case parseDoc set s of- Error s' -> failure $ HamletParseException s'- Ok x -> liftM HamletRT $ mapM convert x- where- convert x@(DocForall deref (Ident ident) docs) = do- deref' <- flattenDeref' x deref- docs' <- mapM convert docs- return $ SDForall deref' ident docs'- convert x@(DocMaybe deref (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 (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 x@(DocCond conds els) = do- conds' <- mapM go conds- els' <- maybe (return []) (mapM convert) els- return $ SDCond conds' els'- where- go (deref, docs') = do- deref' <- flattenDeref' x deref- docs'' <- mapM convert docs'- return (deref', docs'')--renderHamletRT :: Failure HamletException m- => HamletRT- -> HamletMap url- -> (url -> [(Text, Text)] -> Text)- -> m Html-renderHamletRT = renderHamletRT' False--renderHamletRT' :: Failure HamletException m- => Bool- -> 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"- lookup' :: Failure HamletException m- => [String] -> [String] -> HamletMap url -> m (HamletData url)- lookup' orig k m =- case lookup k m of- Nothing -> fa $ showName orig ++ ": not found"- Just x -> return x--fa :: Failure HamletException m => String -> m a-fa = failure . HamletRenderException--showName :: [String] -> String-showName = intercalate "." . reverse--flattenDeref' :: Failure HamletException f => Doc -> Deref -> f [String]-flattenDeref' orig deref =- case flattenDeref deref of- Nothing -> failure $ HamletUnsupportedDocException orig- Just x -> return x
Text/Lucius.hs view
@@ -27,7 +27,6 @@ import Text.ParserCombinators.Parsec hiding (Line) import Text.Css import Data.Char (isSpace)-import Text.Hamlet.Quasi (readUtf8File) import Control.Applicative ((<$>)) import Data.Either (partitionEithers)
Text/Romeo.hs view
@@ -23,7 +23,6 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL-import Text.Hamlet.Quasi (readUtf8File) import Text.Shakespeare -- move to Shakespeare?
Text/Shakespeare.hs view
@@ -17,6 +17,7 @@ , parseInt , derefToExp , flattenDeref+ , readUtf8File ) where import Language.Haskell.TH.Syntax@@ -27,6 +28,9 @@ 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)@@ -213,3 +217,9 @@ deref <- parseDeref _ <- char '}' return $ Right deref) <|> return (Left "_")++readUtf8File :: FilePath -> IO TL.Text+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ TIO.hGetContents h
hamlet.cabal view
@@ -1,5 +1,5 @@ name: hamlet-version: 0.8.2.1+version: 0.9.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -25,15 +25,9 @@ stability: Stable cabal-version: >= 1.8 build-type: Simple-homepage: http://www.yesodweb.com/--flag test- description: Build the executable to run unit tests- default: False+homepage: http://www.yesodweb.com/book/templates library- if flag(test)- Buildable: False build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , template-haskell@@ -45,8 +39,6 @@ , blaze-builder >= 0.2 && < 0.4 , process >= 1.0 && < 1.1 exposed-modules: Text.Hamlet- Text.Hamlet.NonPoly- Text.Hamlet.RT Text.Cassius Text.Lucius Text.Julius@@ -54,8 +46,6 @@ Text.Romeo Text.Shakespeare other-modules: Text.Hamlet.Parse- Text.Hamlet.Quasi- Text.Hamlet.Debug Text.MkSizeType Text.Css ghc-options: -Wall@@ -66,18 +56,16 @@ type: exitcode-stdio-1.0 ghc-options: -Wall- build-depends: hamlet >= 0.7.2,- base >= 4 && < 5,- parsec >= 2 && < 4,- containers >= 0.2 && < 0.5,- json-types >= 0.1 && < 0.2,- text >= 0.7 && < 0.12,- HUnit,- QuickCheck >= 2 && < 3,- test-framework-hunit,- test-framework+ build-depends: hamlet >= 0.9 && < 0.10+ , base >= 4 && < 5+ , parsec >= 2 && < 4+ , containers >= 0.2 && < 0.5+ , text >= 0.7 && < 1+ , HUnit+ , hspec+ , blaze-html >= 0.4 && < 0.5 source-repository head type: git- location: git://github.com/snoyberg/hamlet.git+ location: git://github.com/yesodweb/hamlet.git