Permalink
Browse files

Fix bug in tabs compiled splice, make tabs and flash notice automatic…

…ally add compiled splices
  • Loading branch information...
mightybyte committed Mar 18, 2013
1 parent b2a464b commit 1a0539c5cf60a5dba01473d9c5d6e7a42fe71e08
Showing with 61 additions and 28 deletions.
  1. +16 −13 snap-extras.cabal
  2. +4 −3 src/Snap/Extras.hs
  3. +6 −4 src/Snap/Extras/FlashNotice.hs
  4. +35 −8 src/Snap/Extras/Tabs.hs
View
@@ -1,5 +1,5 @@
Name: snap-extras
-Version: 0.4
+Version: 0.5
Synopsis: A collection of useful helpers and utilities for Snap web applications.
Description: This package contains a collection of helper functions
that come in handy in most practical, real-world
@@ -30,6 +30,7 @@ Library
Snap.Extras.SpliceUtils.Compiled
Snap.Extras.SpliceUtils.Interpreted
Snap.Extras.FormUtils
+-- Snap.Extras.REST
Snap.Extras.Tabs
Snap.Extras.NavTrails
other-modules:
@@ -38,27 +39,29 @@ Library
hs-source-dirs: src
Build-depends:
- aeson >= 0.6
- , base >= 4 && < 5
+ aeson >= 0.6
+ , base >= 4 && < 5
, blaze-builder
, blaze-html
, bytestring
, containers
- , digestive-functors >= 0.3
+ , data-default
+ , digestive-functors >= 0.3
, digestive-functors-heist >= 0.5.2
- , digestive-functors-snap >= 0.3
- , directory-tree >= 0.10 && < 0.12
- , errors >= 1.4 && < 1.5
+ , digestive-functors-snap >= 0.3
+ , directory-tree >= 0.10 && < 0.12
+ , errors >= 1.4 && < 1.5
, filepath
- , heist >= 0.11
- , mtl >= 2.0 && < 2.2
+ , heist >= 0.11
+ , mtl >= 2.0 && < 2.2
+ , readable >= 0.1 && < 0.2
, safe
- , snap >= 0.10
- , snap-core >= 0.7
+ , snap >= 0.10
+ , snap-core >= 0.7
, text
, transformers
- , xmlhtml >= 0.1.6
- , configurator >= 0.2
+ , xmlhtml >= 0.1.6
+ , configurator >= 0.2
-- Other-modules:
View
@@ -40,7 +40,8 @@ initExtras heistSnaplet session =
"Snap Extras"
"Collection of utilities for web applications"
(Just getDataDir) $ do
- addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath
- initFlashNotice session
+ addTemplatesAt heistSnaplet "" . (</> "resources/templates")
+ =<< getSnapletFilePath
+ initFlashNotice heistSnaplet session
I.addUtilSplices
- initTabs
+ initTabs heistSnaplet
@@ -34,10 +34,12 @@ import Text.XmlHtml
-- for examples.
initFlashNotice
:: HasHeist b
- => SnapletLens b SessionManager -> Initializer b v ()
-initFlashNotice session = do
- addSplices [("flash", flashSplice session)]
-
+ => Snaplet (Heist b) -> SnapletLens b SessionManager -> Initializer b v ()
+initFlashNotice h session = do
+ let splices = [ ("flash", flashSplice session) ]
+ csplices = [ ("flash", flashCSplice session) ]
+ addConfig h $ mempty { hcCompiledSplices = csplices
+ , hcInterpretedSplices = splices }
-------------------------------------------------------------------------------
-- | Display an info message on next load of a page
View
@@ -21,8 +21,11 @@ module Snap.Extras.Tabs
) where
-------------------------------------------------------------------------------
+import Blaze.ByteString.Builder
import Control.Monad
+import Control.Monad.Trans
import Control.Monad.Trans.Class
+import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -39,9 +42,12 @@ import qualified Text.XmlHtml as X
-------------------------------------------------------------------------------
-initTabs :: HasHeist b => Initializer b v ()
-initTabs = do
- addSplices [ ("tabs", tabsSplice) ]
+initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()
+initTabs h = do
+ let splices = [ ("tabs", tabsSplice) ]
+ csplices = [ ("tabs", tabsCSplice) ]
+ addConfig h $ mempty { hcCompiledSplices = csplices
+ , hcInterpretedSplices = splices }
-------------------
@@ -50,8 +56,7 @@ initTabs = do
-------------------------------------------------------------------------------
--- | Compiled splice for tabs. This is not automatically bound by initTabs.
--- You have to bind it yourself.
+-- | Compiled splice for tabs.
tabsCSplice :: MonadSnap m => C.Splice m
tabsCSplice = do
n <- getParamNode
@@ -63,11 +68,33 @@ tabsCSplice = do
_ -> 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 => C.Promise Text -> C.Splice m
tabCSplice promise = do
- n <- getParamNode
- C.pureSplice (C.nodeSplice $ tabSpliceWorker n) promise
+ n@(Element _ attrs ch) <- getParamNode
+ attrsAction <- C.runAttributesRaw attrs
+ let ps as context = do
+ m <- wErr "tab must specify a 'match' attribute" $ lookup "match" as
+ url <- wErr "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
+ "None" -> Right $ False
+ _ -> Left "Unknown match type"
+ return (url, ch, m')
+ return $ C.yieldRuntime $ do
+ ctx <- C.getPromise promise
+ as <- attrsAction
+ let res = case ps as ctx of
+ Left e -> error $ "Tab error: " ++ e
+ Right (url, ch, match) ->
+ let attr' = if match then ("class", "active") : as else as
+ a = X.Element "a" (("href", url) : as) ch
+ in X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]]
+ return res
tabSpliceWorker :: Node -> Text -> [Node]

0 comments on commit 1a0539c

Please sign in to comment.