{-# LANGUAGE OverloadedStrings #-} {-| Purpose of this module is to provide a simple, functional way to define tabs in Snap applications. -} module Snap.Extras.Tabs ( -- * Define Tabs in DOM via Heist initTabs , tabsSplice , tabsCSplice -- * Define Tabs in Haskell , TabActiveMode (..) , Tab , mkTabs , tab ) where ------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Lens import Control.Monad import Control.Monad.Trans import qualified Data.Map.Syntax as MS import Data.Maybe import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Heist import qualified Heist.Compiled as C import Heist.Interpreted import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Text.Regex.PCRE.Light import Text.XmlHtml import qualified Text.XmlHtml as X ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v () initTabs h = do let splices = ("tabs" MS.## tabsSplice) csplices = ("tabs" MS.## tabsCSplice) addConfig h $ mempty & scCompiledSplices .~ csplices & scInterpretedSplices .~ splices ------------------- -- Splice-Driven -- ------------------- ------------------------------------------------------------------------------- -- | Compiled splice for tabs. tabsCSplice :: MonadSnap m => C.Splice m tabsCSplice = do n <- getParamNode let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest splices = ("tab" MS.## tabCSplice getCtx) case n of Element _ attrs ch -> C.withLocalSplices splices mempty $ C.runNode $ X.Element "ul" attrs ch _ -> error "tabs tag has to be an Element" ------------------------------------------------------------------------------ -- | Can't use tabSpliceWorker because we have to explicitly run the -- attributes in order to get ${} splice substitution. tabCSplice :: Monad m => RuntimeSplice m Text -> C.Splice m tabCSplice getCtx = do (Element _ attrs ch) <- getParamNode attrsAction <- C.runAttributesRaw attrs nodes <- C.codeGen `fmap` C.runNodeList ch let ps as context = do m <- note "tab must specify a 'match' attribute" $ lookup "match" as url <- note "tabs must specify a 'url' attribute" $ lookup "url" as m' <- case m of "Exact" -> Right $ url == context "Prefix" -> Right $ url `T.isPrefixOf` context "Infix" -> Right $ url `T.isInfixOf` context "Regex" -> do pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" as let r = compile (T.encodeUtf8 pat) [] Right $ isJust $ match r (T.encodeUtf8 context) [] "None" -> Right $ False _ -> Left "Unknown match type" return (url, m') return $ C.yieldRuntime $ do ctx <- getCtx as <- attrsAction ns <- nodes let innerFrag = X.parseHTML "inner" $ B.toByteString ns let res = either (error . ("Tab errror: " ++) ) id $ do (url, matches) <- ps as ctx inner <- innerFrag let actClass = maybe "active" (T.append "active " ) $ lookup "class" as attr' = if matches then ("class", actClass) : as else as a = X.Element "a" (("href", url) : as) (X.docContent inner) return $ X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]] return res tabSpliceWorker :: Node -> Text -> [Node] tabSpliceWorker (Element _ attrs ch) context = case ps of Left e -> error $ "Tab error: " ++ e Right (url, c, matches) -> let attr' = if matches then ("class", "active") : attrs else attrs a = X.Element "a" (("href", url) : attrs) c in [X.Element "li" attr' [a]] where ps = do m <- note "tab must specify a 'match' attribute" $ lookup "match" attrs url <- note "tabs must specify a 'url' attribute" $ lookup "url" attrs m' <- case m of "Exact" -> Right $ url == context "Prefix" -> Right $ url `T.isPrefixOf` context "Infix" -> Right $ url `T.isInfixOf` context "Regex" -> do pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" attrs let r = compile (T.encodeUtf8 pat) [] Right $ isJust $ match r (T.encodeUtf8 context) [] "None" -> Right $ False _ -> Left "Unknown match type" return (url, ch, m') tabSpliceWorker _ _ = [] ------------------------------------------------------------------------------- tabsSplice :: MonadSnap m => Splice m tabsSplice = do context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest let bind = bindSplices ("tab" MS.## tabSplice context) n <- getParamNode case n of Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch] _ -> error "tabs tag has to be an Element" ------------------------------------------------------------------------------- tabSplice :: Monad m => Text -> HeistT n m [Node] tabSplice context = do n <- getParamNode return $ tabSpliceWorker n context -------------------- -- Haskell-Driven -- -------------------- ------------------------------------------------------------------------------- -- | How do we decide "active" for tab state? data TabActiveMode = TAMExactMatch -- ^ Current url has to match exactly | TAMPrefixMatch -- ^ Only the prefix needs to match current url | TAMInfixMatch -- ^ A sub-set of the current url has to match | TAMDontMatch ------------------------------------------------------------------------------- -- | A tab is a 'Node' generator upon receiving a current URL context. type Tab = Text -> Node ------------------------------------------------------------------------------- -- | Make tabs from tab definitions. Use the 'tab' combinator to -- define individual options. mkTabs :: MonadSnap m => Text -- ^ A class to be given to the parent ul tag -> [Tab] -- ^ List of tabs in order -> Splice m mkTabs klass ts = do p <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest return [X.Element "ul" [("class", klass)] (map ($ p) ts)] ------------------------------------------------------------------------------- -- | Tab item constructor to be used with 'mkTabs'. Just supply the -- given arguments here and it will create a 'Tab' ready to be used in -- 'mkTabs'. -- -- If the tab is currently active, the li tag will get a class of -- \'active\'. -- -- Make sure to provide a trailing / when indicating URLs as snap -- context paths contain it and active tab checks will be confused -- without it. tab :: Text -- ^ Target URL for tab -> Text -- ^ A text/label for tab -> [(Text, Text)] -- ^ A list of attributes as key=val -> TabActiveMode -- ^ A 'TabActiveMode' for this tab -> 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] ------------------------------------------------------------------------------- note :: a -> Maybe b -> Either a b note a = maybe (Left a) Right