module Snap.Extras.Tabs
(
initTabs
, tabsSplice
, TabActiveMode (..)
, Tab
, mkTabs
, tab
) where
import Control.Monad
import Control.Monad.Trans.Class
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap.Core
import Text.Templating.Heist
import Snap.Snaplet
import Snap.Snaplet.Heist
import Text.Templating.Heist
import Text.XmlHtml
import qualified Text.XmlHtml as X
initTabs :: HasHeist b => Initializer b v ()
initTabs = do
addSplices [ ("tabs", liftHeist tabsSplice) ]
tabsSplice :: MonadSnap m => Splice m
tabsSplice = do
context <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest
let bind = bindSplices [("tab", tabSplice context)]
n <- getParamNode
case n of
Element t attrs ch -> localTS bind $ runNodeList [X.Element "ul" attrs ch]
_ -> error "tabs tag has to be an Element"
tabSplice :: MonadSnap m => Text -> Splice m
tabSplice context = do
n@(Element t attrs ch) <- getParamNode
let ps = do
m <- wErr "tab must specify a 'match' attribute" $ lookup "match" attrs
url <- wErr "tabs must specify a 'url' attribute" $ getAttribute "url" n
m' <- return $ case m of
"Exact" -> url == context
"Prefix" -> url `T.isPrefixOf` context
"Infix" -> url `T.isInfixOf` context
"None" -> False
_ -> error "Tab: Unknown match type"
ch <- return $ childNodes n
return (url, ch, m')
case ps of
Left e -> error $ "Tab error: " ++ e
Right (url, ch, match) -> do
let attr' = if match then ("class", "active") : attrs
else attrs
return $ [X.Element "li" attr' [link url ch]]
wErr err m = maybe (Left err) Right m
data TabActiveMode
= TAMExactMatch
| TAMPrefixMatch
| TAMInfixMatch
| TAMDontMatch
type Tab = Text -> Node
mkTabs
:: MonadSnap m
=> Text
-> [Tab]
-> Splice m
mkTabs klass ts = do
p <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest
return [X.Element "ul" [("class", klass)] (map ($ p) ts)]
tab
:: Text
-> Text
-> [(Text, Text)]
-> TabActiveMode
-> Tab
tab url text attr md context = X.Element "li" attr' [tlink url text]
where
cur = case md of
TAMExactMatch -> url == context
TAMPrefixMatch -> url `T.isPrefixOf` context
TAMInfixMatch -> url `T.isInfixOf` context
TAMDontMatch -> False
attr' = if cur
then ("class", klass) : attr
else attr
klass = case lookup "class" attr of
Just k -> T.concat [k, " ", "active"]
Nothing -> "active"
tlink :: Text -> Text -> Node
tlink target text = X.Element "a" [("href", target)] [X.TextNode text]
link :: Text -> [Node] -> Node
link target ch = X.Element "a" [("href", target)] ch