packages feed

snap-extras 0.3 → 0.4

raw patch · 11 files changed

+508/−209 lines, 11 filesdep +blaze-builderdep +digestive-functors-heistdep −data-lensdep ~errorsdep ~heist

Dependencies added: blaze-builder, digestive-functors-heist

Dependencies removed: data-lens

Dependency ranges changed: errors, heist

Files

snap-extras.cabal view
@@ -1,5 +1,5 @@ Name:                snap-extras-Version:             0.3+Version:             0.4 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@@ -26,26 +26,30 @@     Snap.Extras.TextUtils     Snap.Extras.JSON     Snap.Extras.FlashNotice-    Snap.Extras.SpliceUtils+    Snap.Extras.SpliceUtils.Compiled+    Snap.Extras.SpliceUtils.Interpreted     Snap.Extras.FormUtils     Snap.Extras.Tabs+    Snap.Extras.NavTrails   other-modules:+    Snap.Extras.SpliceUtils.Common     Paths_snap_extras    hs-source-dirs: src   Build-depends:       aeson >= 0.6     , base >= 4 && < 5+    , blaze-builder     , blaze-html     , bytestring     , containers-    , data-lens >= 2.0     , digestive-functors >= 0.3+    , digestive-functors-heist >= 0.5.2     , digestive-functors-snap >= 0.3     , directory-tree >= 0.10 && < 0.12-    , errors >= 1.3.1 && < 1.4+    , errors >= 1.4 && < 1.5     , filepath-    , heist >= 0.10+    , heist >= 0.11     , mtl >= 2.0 && < 2.2     , safe     , snap >= 0.10
src/Snap/Extras.hs view
@@ -5,25 +5,24 @@     , module Snap.Extras.TextUtils     , module Snap.Extras.JSON     , module Snap.Extras.FlashNotice-    , module Snap.Extras.SpliceUtils     , module Snap.Extras.FormUtils     , module Snap.Extras.Tabs     , initExtras     ) where  --------------------------------------------------------------------------------import Snap.Snaplet-import Snap.Snaplet.Heist-import Snap.Snaplet.Session-import System.FilePath.Posix+import           Snap.Snaplet+import           Snap.Snaplet.Heist+import           Snap.Snaplet.Session+import           System.FilePath.Posix --------------------------------------------------------------------------------import Snap.Extras.CoreUtils-import Snap.Extras.FlashNotice-import Snap.Extras.FormUtils-import Snap.Extras.JSON-import Snap.Extras.SpliceUtils-import Snap.Extras.Tabs-import Snap.Extras.TextUtils+import           Snap.Extras.CoreUtils+import           Snap.Extras.FlashNotice+import           Snap.Extras.FormUtils+import           Snap.Extras.JSON+import qualified Snap.Extras.SpliceUtils.Interpreted as I+import           Snap.Extras.Tabs+import           Snap.Extras.TextUtils ------------------------------------------------------------------------------- import Paths_snap_extras -------------------------------------------------------------------------------@@ -43,5 +42,5 @@     (Just getDataDir) $ do       addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath       initFlashNotice session-      addUtilSplices+      I.addUtilSplices       initTabs
src/Snap/Extras/CoreUtils.hs view
@@ -18,6 +18,8 @@     , redirectRefererFunc     , dirify     , undirify+    , maybeBadReq+    , fromMaybeM     ) where  -------------------------------------------------------------------------------@@ -155,4 +157,15 @@     if B.length uri > 1 && B.last uri == '/'       then redirect (B.init uri)       else return ()+++-------------------------------------------------------------------------------+maybeBadReq :: MonadSnap m => ByteString -> m (Maybe a) -> m a+maybeBadReq e f = fromMaybeM (badReq e) f+++-------------------------------------------------------------------------------+-- | Evaluates an action that returns a Maybe and +fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a+fromMaybeM e f = maybe e return =<< f
src/Snap/Extras/FlashNotice.hs view
@@ -8,11 +8,14 @@     , flashSuccess     , flashError     , flashSplice+    , flashCSplice     ) where  ------------------------------------------------------------------------------- import           Control.Monad import           Control.Monad.Trans+import           Data.Maybe+import           Data.Monoid import           Data.Text             (Text) import qualified Data.Text             as T import           Snap.Snaplet@@ -20,6 +23,7 @@ import           Snap.Snaplet.Session import           Heist import           Heist.Interpreted+import qualified Heist.Compiled        as C import           Text.XmlHtml ------------------------------------------------------------------------------- @@ -76,4 +80,32 @@       lift $ withTop session $ deleteFromSession k >> commitSession       callTemplateWithText "_flash"            [ ("type", typ') , ("message", msg') ]+++-------------------------------------------------------------------------------+-- | A compiled splice for rendering a given flash notice dirctive.+--+-- Ex: <flash type='warning'/>+-- Ex: <flash type='success'/>+flashCSplice :: SnapletLens b SessionManager -> SnapletCSplice b+flashCSplice session = do+    n <- getParamNode+    let typ = maybe "warning" id $ getAttribute "type" n+        k = T.concat ["_", typ]+        splice prom = do+            flashTemplate <- C.withLocalSplices+              [ ("type", return $ C.yieldPureText typ)+              , ("message", return $ C.yieldRuntimeText $ liftM fromJust+                                   $ C.getPromise prom) ]+              [] (C.callTemplate "_flash")+            return $ C.yieldRuntime $ do+                msg <- C.getPromise prom+                case msg of+                  Nothing -> return mempty+                  Just _ -> do+                    lift $ withTop session $+                      deleteFromSession k >> commitSession+                    C.codeGen flashTemplate+    C.defer splice (lift $ withTop session $ getFromSession k)+
src/Snap/Extras/FormUtils.hs view
@@ -8,6 +8,9 @@       maybeTrans     , readMayTrans     , readTrans+    -- * Compiled splices+    , editFormSplice+     -- -- * Form Elements     -- , submitCancel     -- , submitOnly@@ -20,6 +23,7 @@     ) where  -------------------------------------------------------------------------------+import           Control.Error import           Control.Monad import qualified Data.ByteString.Char8 as B import           Data.List             (find)@@ -27,12 +31,14 @@ import           Data.Maybe import           Data.String import           Data.Text             (Text)+import           Data.Text.Encoding import qualified Data.Text             as T+import           Heist import           Safe import           Snap.Core import           Text.Digestive import           Text.Digestive.Snap-import           Heist+import qualified Text.XmlHtml           as X -------------------------------------------------------------------------------  @@ -172,3 +178,27 @@ --     Nothing -> do --       view' <- viewForm form nm --       return $ (view', Nothing)++-------------------------------------------------------------------------------+-- | Constructs a generalized edit form splice that looks up an ID param+-- specified by the @by@ attribute.  You might use this splice as follows:+--+-- > <editFormSplice by="id">+--+-- If you don't specify the @by@ attribute, the default is @by=\"id\"@.+editFormSplice :: (Monad m, MonadSnap n)+               => (n (Maybe a) -> HeistT n m b)+               -- ^ Function for generating a splice from an optional default+               -- value calculated at runtime.+               -> (B.ByteString -> n (Maybe a))+               -- ^ Function for retrieving the form default by ID.+               -> HeistT n m b+editFormSplice formSplice getById = do+    node <- getParamNode+    let param = fromMaybe "id" $ X.getAttribute "by" node+    formSplice $ do+      runMaybeT $ do+        key <- MaybeT $ getParam $ encodeUtf8 param+        MaybeT (getById key)++
+ src/Snap/Extras/NavTrails.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE ScopedTypeVariables       #-}++module Snap.Extras.NavTrails where++import           Blaze.ByteString.Builder.ByteString+import           Control.Monad.State.Strict+import           Data.ByteString            (ByteString)+import qualified Data.ByteString.Char8      as B+import           Data.Maybe+import           Data.Monoid+import qualified Data.Set                   as S+import           Data.Text                  (Text)+import qualified Data.Text.Encoding         as T+import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Heist+import           Snap.Snaplet.Session+import           Heist+import qualified Heist.Compiled as C+import           Heist.Interpreted++++-------------------------------------------------------------------------------+data NavTrail b = NavTrail {+      ntSes :: SnapletLens b SessionManager+      -- ^ A session manager for the base+    }+++-------------------------------------------------------------------------------+--initNavTrail+--    :: HasHeist b+--    => SnapletLens b SessionManager+--    -> Bool+--    -- ^ Auto-add all splices?+--    -> SnapletInit b (NavTrail b)+initNavTrail :: SnapletLens b SessionManager+             -- ^ Lens to the session snaplet+             -> Maybe (Snaplet (Heist b))+             -- ^ The heist snaplet (not a lens), if you want splices to be+             -- added automatically.+             -> SnapletInit b (NavTrail b)+initNavTrail ses heist =+  makeSnaplet "NavTrail"+              "Makes it easier for you to navigate back to key app points."+              Nothing $ do+  maybe (return ()) addNavTrailSplices heist+  return $ NavTrail ses+++-------------------------------------------------------------------------------+-- |+setFocus = do+  setFocus' =<< rqURI `fmap` getRequest+++-------------------------------------------------------------------------------+-- |+setFocus' uri = do+  sl <- gets ntSes+  withSession sl $ withTop sl $ do+    setInSession "_nt_focus" $ T.decodeUtf8 uri+++-------------------------------------------------------------------------------+-- |+setFocusToRef = do+  sl <- gets ntSes+  (maybe "/" id . getHeader "Referer") `fmap` getRequest >>=+    withTop sl . setInSession "_nt_focus" . T.decodeUtf8+++-------------------------------------------------------------------------------+-- |+getFocus = do+  sl <- gets ntSes+  withTop sl (getFromSession "_nt_focus")+++getFocusDef def = (fromJust . (`mplus` Just def)) `fmap` getFocus++++-------------------------------------------------------------------------------+-- |+redirBack = redirect =<< (maybe "/" id . getHeader "Referer") `fmap` getRequest+++-------------------------------------------------------------------------------+-- |+redirFocus def = do+  f <- (`mplus` Just def) `fmap` (fmap T.encodeUtf8 `fmap` getFocus)+  redirect $ fromJust f+++-------------------------------------------------------------------------------+-- |+backSplice :: MonadSnap m => HeistT m m Template+backSplice = do+  f <- rqURI `fmap` getRequest+  textSplice $ T.decodeUtf8 f++backCSplice :: C.Splice (Handler b v)+backCSplice = return $ C.yieldRuntime $ do+  lift $ (fromByteString . rqURI) `fmap` getRequest++-------------------------------------------------------------------------------+-- |+focusSplice :: SnapletLens (Snaplet v) (NavTrail b)+            -> Splice (Handler b v)+focusSplice lens = do+  uri <- lift $ with' lens getFocus+  maybe (return []) textSplice uri++focusCSplice :: SnapletLens (Snaplet v) (NavTrail b)+             -> C.Splice (Handler b v)+focusCSplice lens = return $ C.yieldRuntimeText $ do+  uri <- lift $ with' lens getFocus+  return $ fromMaybe "" uri++-------------------------------------------------------------------------------+-- |+addNavTrailSplices heist = do+  lens <- getLens+  addConfig heist $+    mempty { hcCompiledSplices =+               [ ("linkToFocus", focusCSplice lens)+               , ("linkToBack", backCSplice) ]+           , hcInterpretedSplices =+               [ ("linkToFocus", focusSplice lens)+               , ("linkToBack", backSplice) ]+           }++
− src/Snap/Extras/SpliceUtils.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings         #-}--module Snap.Extras.SpliceUtils-    ( ifSplice-    , paramSplice-    , utilSplices-    , addUtilSplices-    , selectSplice-    , runTextAreas-    , scriptsSplice-    , ifFlagSplice-    ) where----------------------------------------------------------------------------------import           Control.Monad-import           Control.Monad.Trans.Class-import qualified Data.Configurator         as C-import qualified Data.Foldable             as F-import           Data.List-import           Data.Text                 (Text)-import qualified Data.Text                 as T-import qualified Data.Text.Encoding        as T-import           Snap-import           Snap.Snaplet.Heist-import           System.Directory.Tree-import           System.FilePath-import           Heist-import           Heist.Interpreted-import           Text.XmlHtml--------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Bind splices offered in this module in your 'Initializer'-addUtilSplices :: HasHeist b => Initializer b v ()-addUtilSplices = addSplices utilSplices------------------------------------------------------------------------------------- | A list of splices offered in this module-utilSplices :: [(Text, SnapletISplice b)]-utilSplices =-  [ ("rqparam", paramSplice)-  ]------------------------------------------------------------------------------------- | Run the splice contents if given condition is True, make splice--- disappear if not.-ifSplice :: Monad m => Bool -> Splice m-ifSplice cond =-    case cond of-      False -> return []-      True -> runChildren----------------------------------------------------------------------------------- | Gets the value of a request parameter.  Example use:------ <rqparam name="username"/>-paramSplice :: MonadSnap m => Splice m-paramSplice = do-  at <- liftM (getAttribute "name") getParamNode-  val <- case at of-    Just at' -> lift . getParam $ T.encodeUtf8 at'-    Nothing -> return Nothing-  return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val-------------------------------------------------------------------------------------- | Assume text are contains the name of a splice as Text.------ This is helpful when you pass a default value to digestive-functors--- by putting the name of a splice as the value of a textarea tag.------ > heistLocal runTextAreas $ render "joo/index"-runTextAreas :: Monad m => HeistState m -> HeistState m-runTextAreas = bindSplices [ ("textarea", ta)]- where-   ta = do-     hs <- getHS-     n@(Element t ats _) <- getParamNode-     let nm = nodeText n-     case lookupSplice nm hs of-       Just spl -> do-         ns <- spl-         return [Element t ats ns]-       Nothing -> return $ [Element t ats []]------------------------------------------------------------------------------------- | Splice helper for when you're rendering a select element-selectSplice-    :: Monad m-    => Text-    -- ^ A name for the select element-    -> Text-    -- ^ An id for the select element-    -> [(Text, Text)]-    -- ^ value, shown text pairs-    -> Maybe Text-    -- ^ Default value-    -> Splice m-selectSplice nm fid xs defv =-    callTemplate "_select"-      [("options", opts), ("name", textSplice nm), ("id", textSplice fid)]-    where-      opts = mapSplices gen xs-      gen (val,txt) = runChildrenWith-        [ ("val", textSplice val)-        , ("text", textSplice txt)-        , ("ifSelected", ifSplice $ maybe False (== val) defv)-        , ("ifNotSelected", ifSplice $ maybe True (/= val) defv) ]------------------------------------------------------------------------------------ | 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 @\<staticscripts/\>@ 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.-              -> m [Node]-scriptsSplice dir prefix = do-    tree <- liftIO $ build dir-    let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ free tree-        scripts = filter visibleScripts files-    return $ concat $ map includeJavascript scripts-  where-    visibleScripts fname =-        isSuffixOf ".js" fname && not (isPrefixOf "_" (takeFileName fname))-    includeJavascript script =-        [Element "script" [("src", T.pack $ prefix ++ script)] []]-------------------------------------------------------------------------------------- | Check to see if the boolean flag named by the "ref" attribute is--- present and set to true in snaplet user config file. If so, run--- what's inside this splice, if not, simply omit that part.------ Example:------ > <flag ref="beta-functions-enabled">--- > stuff...--- > </flag>------ This will look for an entry inside your .cfg file:------ > beta-functions-enabled = true-ifFlagSplice :: SnapletISplice b-ifFlagSplice = do-  Element t ats es <- getParamNode-  conf <- lift getSnapletUserConfig-  case lookup "ref" ats of-    Nothing -> return []-    Just flag -> do-      res <- liftIO $ C.lookup conf flag-      case res of-        Just True -> return es-        _         -> return []
+ src/Snap/Extras/SpliceUtils/Common.hs view
@@ -0,0 +1,17 @@+module Snap.Extras.SpliceUtils.Common where++import qualified Data.Foldable             as F+import           Data.List+import           Snap+import           System.Directory.Tree+import           System.FilePath++getScripts :: MonadIO m => FilePath -> m [String]+getScripts d = do+    tree <- liftIO $ build d+    let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ free tree+    return $ filter visibleScripts files+  where+    visibleScripts fname =+        isSuffixOf ".js" fname && not (isPrefixOf "_" (takeFileName fname))+
+ src/Snap/Extras/SpliceUtils/Compiled.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extras.SpliceUtils.Compiled where++-------------------------------------------------------------------------------+import           Blaze.ByteString.Builder.ByteString+import           Control.Monad.Trans+import           Data.Monoid+import qualified Data.Text                 as T+import qualified Data.Text.Encoding        as T+import           Snap.Core+import qualified Snap.Extras.SpliceUtils.Interpreted as I+import           Heist+import           Heist.Compiled+import           Text.XmlHtml+-------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Gets the value of a request parameter.  Example use:+--+-- <rqparam name="username"/>+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 @\<staticscripts/\>@ 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++
+ src/Snap/Extras/SpliceUtils/Interpreted.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}++module Snap.Extras.SpliceUtils.Interpreted+    ( paramSplice+    , utilSplices+    , addUtilSplices+    , selectSplice+    , runTextAreas+    , scriptsSplice+    , ifFlagSplice+    ) where++-------------------------------------------------------------------------------+import           Control.Monad+import           Control.Monad.Trans.Class+import qualified Data.Configurator         as C+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.Encoding        as T+import           Snap+import           Snap.Extras.SpliceUtils.Common+import           Snap.Snaplet.Heist.Interpreted+import           Heist+import           Heist.Splices+import           Heist.Interpreted+import           Text.XmlHtml+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Bind splices offered in this module in your 'Initializer'+addUtilSplices :: HasHeist b => Initializer b v ()+addUtilSplices = addSplices utilSplices+++-------------------------------------------------------------------------------+-- | A list of splices offered in this module+utilSplices :: [(Text, SnapletISplice b)]+utilSplices =+  [ ("rqparam", paramSplice)+  ]+++------------------------------------------------------------------------------+-- | Gets the value of a request parameter.  Example use:+--+-- <rqparam name="username"/>+paramSplice :: MonadSnap m => Splice m+paramSplice = do+  at <- liftM (getAttribute "name") getParamNode+  val <- case at of+    Just at' -> lift . getParam $ T.encodeUtf8 at'+    Nothing -> return Nothing+  return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val++++-------------------------------------------------------------------------------+-- | Assume text area contains the name of a splice as Text.+--+-- This is helpful when you pass a default value to digestive-functors+-- by putting the name of a splice as the value of a textarea tag.+--+-- > heistLocal runTextAreas $ render "joo/index"+runTextAreas :: Monad m => HeistState m -> HeistState m+runTextAreas = bindSplices [ ("textarea", ta)]+ where+   ta = do+     hs <- getHS+     n@(Element t ats _) <- getParamNode+     let nm = nodeText n+     case lookupSplice nm hs of+       Just spl -> do+         ns <- spl+         return [Element t ats ns]+       Nothing -> return $ [Element t ats []]+++-------------------------------------------------------------------------------+-- | Splice helper for when you're rendering a select element+selectSplice+    :: Monad m+    => Text+    -- ^ A name for the select element+    -> Text+    -- ^ An id for the select element+    -> [(Text, Text)]+    -- ^ value, shown text pairs+    -> Maybe Text+    -- ^ Default value+    -> Splice m+selectSplice nm fid xs defv =+    callTemplate "_select"+      [("options", opts), ("name", textSplice nm), ("id", textSplice fid)]+    where+      opts = mapSplices gen xs+      gen (val,txt) = runChildrenWith+        [ ("val", textSplice val)+        , ("text", textSplice txt)+        , ("ifSelected", ifISplice $ maybe False (== val) defv)+        , ("ifNotSelected", ifISplice $ maybe True (/= val) defv) ]+++------------------------------------------------------------------------------+-- | 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 @\<staticscripts/\>@ 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.+              -> m [Node]+scriptsSplice d prefix = do+    scripts <- getScripts d+    return $ concat $ map includeJavascript scripts+  where+    includeJavascript script =+        [Element "script" [("src", T.pack $ prefix ++ script)] []]++++-------------------------------------------------------------------------------+-- | Check to see if the boolean flag named by the "ref" attribute is+-- present and set to true in snaplet user config file. If so, run+-- what's inside this splice, if not, simply omit that part.+--+-- Example:+--+-- > <flag ref="beta-functions-enabled">+-- > stuff...+-- > </flag>+--+-- This will look for an entry inside your .cfg file:+--+-- > beta-functions-enabled = true+ifFlagSplice :: SnapletISplice b+ifFlagSplice = do+  Element _ ats es <- getParamNode+  conf <- lift getSnapletUserConfig+  case lookup "ref" ats of+    Nothing -> return []+    Just flag -> do+      res <- liftIO $ C.lookup conf flag+      case res of+        Just True -> return es+        _         -> return []
src/Snap/Extras/Tabs.hs view
@@ -11,6 +11,7 @@     -- * Define Tabs in DOM via Heist       initTabs     , tabsSplice+    , tabsCSplice      -- * Define Tabs in Haskell     , TabActiveMode (..)@@ -29,6 +30,7 @@ import           Snap.Snaplet import           Snap.Snaplet.Heist import           Heist+import qualified Heist.Compiled            as C import           Heist.Interpreted import           Text.XmlHtml import qualified Text.XmlHtml              as X@@ -48,6 +50,48 @@   -------------------------------------------------------------------------------+-- | Compiled splice for tabs.  This is not automatically bound by initTabs.+-- You have to bind it yourself.+tabsCSplice :: MonadSnap m => C.Splice m+tabsCSplice = do+    n <- getParamNode+    let getContext = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest+        splices = [("tab", C.defer tabCSplice getContext)]+    case n of+      Element t attrs ch -> C.withLocalSplices splices [] $+          C.runNode $ X.Element "ul" attrs ch+      _ -> error "tabs tag has to be an Element"+++-------------------------------------------------------------------------------+tabCSplice :: Monad m => C.Promise Text -> C.Splice m+tabCSplice promise = do+  n <- getParamNode+  C.pureSplice (C.nodeSplice $ tabSpliceWorker n) promise+++tabSpliceWorker :: Node -> Text -> [Node]+tabSpliceWorker n@(Element _ attrs ch) context =+    case ps of+      Left e -> error $ "Tab error: " ++ e+      Right (url, ch, match) ->+        let attr' = if match then ("class", "active") : attrs else attrs+            a = X.Element "a" (("href", url) : attrs) ch+         in [X.Element "li" attr' [a]]+  where+    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' <- 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')+++------------------------------------------------------------------------------- tabsSplice :: MonadSnap m => Splice m tabsSplice = do   context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest@@ -60,26 +104,10 @@   --------------------------------------------------------------------------------tabSplice :: MonadSnap m => Text -> Splice m+tabSplice :: Monad m => Text -> HeistT n m [Node] 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' <- 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"-        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-          a = X.Element "a" (("href", url) : attrs) ch-      return $ [X.Element "li" attr' [a]]+  n <- getParamNode+  return $ tabSpliceWorker n context   -------------------------------------------------------------------------------