{-# LANGUAGE OverloadedStrings #-}
module Snap.Extras.SpliceUtils.Compiled
( utilSplices
, refererCSplice
, paramSplice
, scriptsSplice
, fancyLoopSplice
) where
-------------------------------------------------------------------------------
import Blaze.ByteString.Builder.ByteString
import Control.Monad
import Control.Monad.Trans
import qualified Data.Map.Syntax as MS
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Heist
import Heist.Compiled
import Heist.Compiled.LowLevel
import Snap.Core
import qualified Snap.Extras.SpliceUtils.Interpreted as I
import Text.XmlHtml
import Text.XmlHtml.Cursor
-------------------------------------------------------------------------------
utilSplices :: MonadSnap m => Splices (Splice m)
utilSplices = do
"rqparam" MS.## paramSplice
"refererLink" MS.## refererCSplice
refererCSplice :: MonadSnap m => Splice m
refererCSplice = return $ yieldRuntimeText $ return .
maybe "/" T.decodeUtf8 =<< lift (getsRequest (getHeader "Referer"))
------------------------------------------------------------------------------
-- | Gets the value of a request parameter. Example use:
--
--
paramSplice :: MonadSnap m => Splice m
paramSplice = do
node <- getParamNode
let mat = getAttribute "name" node
case mat of
Nothing -> error $ (T.unpack $ elementTag node) ++
" must have a 'name' attribute"
Just at -> return $ yieldRuntime $ do
val <- lift $ getParam $ T.encodeUtf8 at
return $ maybe mempty fromByteString val
------------------------------------------------------------------------------
-- | Searches a directory on disk and all its subdirectories for all files
-- with names that don't begin with an underscore and end with a .js
-- extension. It then returns script tags for each of these files.
--
-- You can use this function to create a splice:
--
-- > ("staticscripts", scriptsSplice "static/js" "/")
--
-- Then when you use the @\@ tag in your templates, it will
-- automatically include all the javascript code in the @static/js@ directory.
scriptsSplice :: MonadIO m
=> FilePath
-- ^ Path to the directory on disk holding the javascript
-- files.
-> String
-- ^ A prefix to add to the src attribute of each script tag.
-> Splice m
scriptsSplice d prefix = runNodeList =<< I.scriptsSplice d prefix
------------------------------------------------------------------------------
-- | Sometimes in a loop you don't always want the same behavior for every
-- item. If you have a comma separated list, you usually don't want a comma
-- after the last item. If you have a list surrounded by parentheses, you
-- might not want the parentheses to show up if the list is empty. Dealing
-- with these situations can be a pain with the stock looping splices, so
-- we've provided this helper that solves all of these problems.
--
-- This function is similar to manyWithSplices, but it binds three additional
-- splices: \"prelude\", \"interlude\", and \"postlude\". The children of
-- the prelude and postlude splices only show up before the beginning of the
-- list and after the end of the list if the list is non-empty. The
-- children of the interlude splice are used as a separator between each list
-- element. If the list has only one element, then the separator does not
-- appear. These splices have this behavior regardless of where they appear
-- in the parent tag.
fancyLoopSplice :: Monad n
=> Splices (RuntimeSplice n a -> Splice n)
-> RuntimeSplice n [a]
-> Splice n
fancyLoopSplice splices action = do
n <- getParamNode
p <- newEmptyPromise
let splices' = do
MS.mapV ($ getPromise p) splices
"prelude" MS.## return mempty
"interlude" MS.## return mempty
"postlude" MS.## return mempty
preChunks <- findNamedChild n "prelude"
interChunks <- findNamedChild n "interlude"
postChunks <- findNamedChild n "postlude"
itemChunks <- withLocalSplices splices' mempty runChildren
return $ yieldRuntime $ do
items <- action
case items of
[] -> return mempty
(i:is) -> do
pre <- codeGen preChunks
post <- codeGen postChunks
front <- putPromise p i >> codeGen itemChunks
body <- forM is $ \item -> do
putPromise p item
inter <- codeGen interChunks
res <- codeGen itemChunks
return $ inter <> res
return $ pre <> front <> mconcat body <> post
findNamedChild :: Monad n => Node -> T.Text -> Splice n
findNamedChild node name =
maybe (return mempty) (runNodeList . childNodes . current) $
findChild (\c -> tagName (current c) == Just name) $ fromNode node