1{-# LANGUAGE TypeSynonymInstances #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE DeriveDataTypeable #-} 5-- | Provides functionality for runtime Hamlet templates. Please use 6-- "Text.Hamlet.Runtime" instead. 7module Text.Hamlet.RT 8 ( -- * Public API 9 HamletRT (..) 10 , HamletData (..) 11 , HamletMap 12 , HamletException (..) 13 , parseHamletRT 14 , renderHamletRT 15 , renderHamletRT' 16 , SimpleDoc (..) 17 ) where 18 19import Text.Shakespeare.Base 20import Data.Monoid (mconcat) 21import Control.Monad (liftM, forM) 22import Control.Exception (Exception) 23import Data.Typeable (Typeable) 24import Text.Hamlet.Parse 25import Data.List (intercalate) 26import Text.Blaze.Html (Html) 27import Text.Blaze.Internal (preEscapedString, preEscapedText) 28import Data.Text (Text) 29 30import Control.Monad.Catch (MonadThrow, throwM) 31 32type HamletMap url = [([String], HamletData url)] 33type UrlRenderer url = (url -> [(Text, Text)] -> Text) 34 35data HamletData url 36 = HDHtml Html 37 | HDUrl url 38 | HDUrlParams url [(Text, Text)] 39 | HDTemplate HamletRT 40 | HDBool Bool 41 | HDMaybe (Maybe (HamletMap url)) 42 | HDList [HamletMap url] 43 44-- FIXME switch to Text? 45data SimpleDoc = SDRaw String 46 | SDVar [String] 47 | SDUrl Bool [String] 48 | SDTemplate [String] 49 | SDForall [String] String [SimpleDoc] 50 | SDMaybe [String] String [SimpleDoc] [SimpleDoc] 51 | SDCond [([String], [SimpleDoc])] [SimpleDoc] 52 53newtype HamletRT = HamletRT [SimpleDoc] 54 55data HamletException = HamletParseException String 56 | HamletUnsupportedDocException Doc 57 | HamletRenderException String 58 deriving (Show, Typeable) 59instance Exception HamletException 60 61 62 63parseHamletRT :: MonadThrow m 64 => HamletSettings -> String -> m HamletRT 65parseHamletRT set s = 66 case parseDoc set s of 67 Error s' -> throwM $ HamletParseException s' 68 Ok (_, x) -> liftM HamletRT $ mapM convert x 69 where 70 convert x@(DocForall deref (BindAs _ _) docs) = 71 error "Runtime Hamlet does not currently support 'as' patterns" 72 convert x@(DocForall deref (BindVar (Ident ident)) docs) = do 73 deref' <- flattenDeref' x deref 74 docs' <- mapM convert docs 75 return $ SDForall deref' ident docs' 76 convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns" 77 convert x@(DocMaybe deref (BindAs _ _) jdocs ndocs) = 78 error "Runtime Hamlet does not currently support 'as' patterns" 79 convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do 80 deref' <- flattenDeref' x deref 81 jdocs' <- mapM convert jdocs 82 ndocs' <- maybe (return []) (mapM convert) ndocs 83 return $ SDMaybe deref' ident jdocs' ndocs' 84 convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns" 85 convert (DocContent (ContentRaw s')) = return $ SDRaw s' 86 convert x@(DocContent (ContentVar deref)) = do 87 y <- flattenDeref' x deref 88 return $ SDVar y 89 convert x@(DocContent (ContentUrl p deref)) = do 90 y <- flattenDeref' x deref 91 return $ SDUrl p y 92 convert x@(DocContent (ContentEmbed deref)) = do 93 y <- flattenDeref' x deref 94 return $ SDTemplate y 95 convert (DocContent ContentMsg{}) = 96 error "Runtime hamlet does not currently support message interpolation" 97 convert (DocContent ContentAttrs{}) = 98 error "Runtime hamlet does not currently support attrs interpolation" 99 100 convert x@(DocCond conds els) = do 101 conds' <- mapM go conds 102 els' <- maybe (return []) (mapM convert) els 103 return $ SDCond conds' els' 104 where 105 -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional 106 -- added there doesn't work for runtime Hamlet, so we remove it here. 107 go (DerefBranch (DerefIdent x) _, docs') | x == specialOrIdent = do 108 docs'' <- mapM convert docs' 109 return (["True"], docs'') 110 go (deref, docs') = do 111 deref' <- flattenDeref' x deref 112 docs'' <- mapM convert docs' 113 return (deref', docs'') 114 convert DocWith{} = error "Runtime hamlet does not currently support $with" 115 convert DocCase{} = error "Runtime hamlet does not currently support $case" 116 117renderHamletRT :: MonadThrow m 118 => HamletRT 119 -> HamletMap url 120 -> UrlRenderer url 121 -> m Html 122renderHamletRT = renderHamletRT' False 123 124renderHamletRT' :: MonadThrow m 125 => Bool -- ^ should embeded template (via ^{..}) be plain Html or actual templates? 126 -> HamletRT 127 -> HamletMap url 128 -> (url -> [(Text, Text)] -> Text) 129 -> m Html 130renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = 131 liftM mconcat $ mapM (go scope0) docs 132 where 133 go _ (SDRaw s) = return $ preEscapedString s 134 go scope (SDVar n) = do 135 v <- lookup' n n scope 136 case v of 137 HDHtml h -> return h 138 _ -> fa $ showName n ++ ": expected HDHtml" 139 go scope (SDUrl p n) = do 140 v <- lookup' n n scope 141 case (p, v) of 142 (False, HDUrl u) -> return $ preEscapedText $ renderUrl u [] 143 (True, HDUrlParams u q) -> 144 return $ preEscapedText $ renderUrl u q 145 (False, _) -> fa $ showName n ++ ": expected HDUrl" 146 (True, _) -> fa $ showName n ++ ": expected HDUrlParams" 147 go scope (SDTemplate n) = do 148 v <- lookup' n n scope 149 case (tempAsHtml, v) of 150 (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl 151 (False, _) -> fa $ showName n ++ ": expected HDTemplate" 152 (True, HDHtml h) -> return h 153 (True, _) -> fa $ showName n ++ ": expected HDHtml" 154 go scope (SDForall n ident docs') = do 155 v <- lookup' n n scope 156 case v of 157 HDList os -> 158 liftM mconcat $ forM os $ \o -> do 159 let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope 160 renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl 161 _ -> fa $ showName n ++ ": expected HDList" 162 go scope (SDMaybe n ident jdocs ndocs) = do 163 v <- lookup' n n scope 164 (scope', docs') <- 165 case v of 166 HDMaybe Nothing -> return (scope, ndocs) 167 HDMaybe (Just o) -> do 168 let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope 169 return (scope', jdocs) 170 _ -> fa $ showName n ++ ": expected HDMaybe" 171 renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl 172 go scope (SDCond [] docs') = 173 renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl 174 go scope (SDCond ((b, docs'):cs) els) = do 175 v <- lookup' b b scope 176 case v of 177 HDBool True -> 178 renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl 179 HDBool False -> go scope (SDCond cs els) 180 _ -> fa $ showName b ++ ": expected HDBool" 181 lookup' :: MonadThrow m => [String] -> [String] -> HamletMap url -> m (HamletData url) 182 lookup' orig k m = 183 case lookup k m of 184 Nothing | k == ["True"] -> return $ HDBool True 185 Nothing -> fa $ showName orig ++ ": not found" 186 Just x -> return x 187 188fa :: MonadThrow m => String -> m a 189fa = throwM . HamletRenderException 190 191showName :: [String] -> String 192showName = intercalate "." . reverse 193 194flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String] 195flattenDeref' orig deref = 196 case flattenDeref deref of 197 Nothing -> throwM $ HamletUnsupportedDocException orig 198 Just x -> return x 199