Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

…ally add compiled splices
  • Loading branch information...
commit 1a0539c5cf60a5dba01473d9c5d6e7a42fe71e08 1 parent b2a464b
@mightybyte mightybyte authored
View
29 snap-extras.cabal
@@ -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
7 src/Snap/Extras.hs
@@ -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
View
10 src/Snap/Extras/FlashNotice.hs
@@ -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
43 src/Snap/Extras/Tabs.hs
@@ -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]
Please sign in to comment.
Something went wrong with that request. Please try again.