diff --git a/snap-extras.cabal b/snap-extras.cabal --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -1,5 +1,5 @@ Name: snap-extras -Version: 0.6 +Version: 0.7 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 @@ -47,16 +47,16 @@ , containers >= 0.3 && < 0.6 , data-default >= 0.5 && < 0.6 , digestive-functors >= 0.3 && < 0.7 - , digestive-functors-heist >= 0.5.2 && < 0.8 + , digestive-functors-heist >= 0.8 && < 0.9 , digestive-functors-snap >= 0.3 && < 0.7 , directory-tree >= 0.10 && < 0.12 , errors >= 1.4 && < 1.5 , filepath >= 1.1 && < 1.4 - , heist >= 0.12 && < 0.13 + , heist >= 0.13 && < 0.14 , mtl >= 2.0 && < 2.2 , readable >= 0.1 && < 0.2 , safe >= 0.3 && < 0.4 - , snap >= 0.10 && < 0.13 + , snap >= 0.13 && < 0.14 , snap-core >= 0.7 && < 0.10 , text >= 0.11 && < 0.12 , transformers >= 0.2 && < 0.4 diff --git a/src/Snap/Extras/FlashNotice.hs b/src/Snap/Extras/FlashNotice.hs --- a/src/Snap/Extras/FlashNotice.hs +++ b/src/Snap/Extras/FlashNotice.hs @@ -36,8 +36,8 @@ :: HasHeist b => Snaplet (Heist b) -> SnapletLens b SessionManager -> Initializer b v () initFlashNotice h session = do - let splices = [ ("flash", flashSplice session) ] - csplices = [ ("flash", flashCSplice session) ] + let splices = ("flash" ## flashSplice session) + csplices = ("flash" ## flashCSplice session) addConfig h $ mempty { hcCompiledSplices = csplices , hcInterpretedSplices = splices } @@ -72,16 +72,17 @@ -- Ex: flashSplice :: SnapletLens b SessionManager -> SnapletISplice b flashSplice session = do - typ <- liftM (getAttribute "type") getParamNode - let typ' = maybe "warning" id typ - let k = T.concat ["_", typ'] - msg <- lift $ withTop session $ getFromSession k - case msg of - Nothing -> return [] - Just msg' -> do - lift $ withTop session $ deleteFromSession k >> commitSession - callTemplateWithText "_flash" - [ ("type", typ') , ("message", msg') ] + typ <- liftM (getAttribute "type") getParamNode + let typ' = maybe "warning" id typ + let k = T.concat ["_", typ'] + msg <- lift $ withTop session $ getFromSession k + case msg of + Nothing -> return [] + Just msg' -> do + lift $ withTop session $ deleteFromSession k >> commitSession + callTemplateWithText "_flash" $ do + "type" ## typ' + "message" ## msg' ------------------------------------------------------------------------------- @@ -94,20 +95,22 @@ 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) + getVal = lift $ withTop session $ getFromSession k + ss = do + "type" ## return $ C.yieldPureText typ + "message" ## return $ C.yieldRuntimeText + $ liftM (fromMaybe "Flash notice cookie error") + getVal + flashTemplate <- C.withLocalSplices ss noSplices (C.callTemplate "_flash") + return $ C.yieldRuntime $ do + msg <- getVal + case msg of + Nothing -> return mempty + Just _ -> do + res <- C.codeGen flashTemplate + lift $ withTop session $ do + deleteFromSession k + commitSession + return res diff --git a/src/Snap/Extras/NavTrails.hs b/src/Snap/Extras/NavTrails.hs --- a/src/Snap/Extras/NavTrails.hs +++ b/src/Snap/Extras/NavTrails.hs @@ -128,12 +128,12 @@ addNavTrailSplices heist = do lens <- getLens addConfig heist $ - mempty { hcCompiledSplices = - [ ("linkToFocus", focusCSplice lens) - , ("linkToBack", backCSplice) ] - , hcInterpretedSplices = - [ ("linkToFocus", focusSplice lens) - , ("linkToBack", backSplice) ] + mempty { hcCompiledSplices = do + "linkToFocus" ## focusCSplice lens + "linkToBack" ## backCSplice + , hcInterpretedSplices = do + "linkToFocus" ## focusSplice lens + "linkToBack" ## backSplice } diff --git a/src/Snap/Extras/SpliceUtils/Common.hs b/src/Snap/Extras/SpliceUtils/Common.hs --- a/src/Snap/Extras/SpliceUtils/Common.hs +++ b/src/Snap/Extras/SpliceUtils/Common.hs @@ -10,7 +10,7 @@ getScripts d = do tree <- liftIO $ build d let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ free tree - return $ filter visibleScripts files + return $ sort $ filter visibleScripts files where visibleScripts fname = isSuffixOf ".js" fname && not (isPrefixOf "_" (takeFileName fname)) diff --git a/src/Snap/Extras/SpliceUtils/Compiled.hs b/src/Snap/Extras/SpliceUtils/Compiled.hs --- a/src/Snap/Extras/SpliceUtils/Compiled.hs +++ b/src/Snap/Extras/SpliceUtils/Compiled.hs @@ -6,7 +6,6 @@ import Blaze.ByteString.Builder.ByteString import Control.Monad.Trans import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Snap.Core @@ -17,10 +16,10 @@ ------------------------------------------------------------------------------- -utilSplices :: MonadSnap m => [(Text, Splice m)] -utilSplices = [ ("rqparam", paramSplice) - , ("refererLink", refererCSplice) - ] +utilSplices :: MonadSnap m => Splices (Splice m) +utilSplices = do + "rqparam" ## paramSplice + "refererLink" ## refererCSplice refererCSplice :: MonadSnap m => Splice m diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs --- a/src/Snap/Extras/SpliceUtils/Interpreted.hs +++ b/src/Snap/Extras/SpliceUtils/Interpreted.hs @@ -30,11 +30,10 @@ ------------------------------------------------------------------------------- -- | A list of splices offered in this module -utilSplices :: [(Text, SnapletISplice b)] -utilSplices = - [ ("rqparam", paramSplice) - , ("refererLink", refererSplice) - ] +utilSplices :: Splices (SnapletISplice b) +utilSplices = do + "rqparam" ## paramSplice + "refererLink" ## refererSplice refererSplice :: MonadSnap m => Splice m @@ -64,7 +63,7 @@ -- -- > heistLocal runTextAreas $ render "joo/index" runTextAreas :: Monad m => HeistState m -> HeistState m -runTextAreas = bindSplices [ ("textarea", ta)] +runTextAreas = bindSplices ("textarea" ## ta) where ta = do hs <- getHS @@ -91,15 +90,17 @@ -- ^ Default value -> Splice m selectSplice nm fid xs defv = - callTemplate "_select" - [("options", opts), ("name", textSplice nm), ("id", textSplice fid)] + callTemplate "_select" $ do + "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) ] + gen (val,txt) = runChildrenWith $ do + "val" ## textSplice val + "text" ## textSplice txt + "ifSelected" ## ifISplice $ maybe False (== val) defv + "ifNotSelected" ## ifISplice $ maybe True (/= val) defv ------------------------------------------------------------------------------ diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs --- a/src/Snap/Extras/Tabs.hs +++ b/src/Snap/Extras/Tabs.hs @@ -43,8 +43,8 @@ ------------------------------------------------------------------------------- initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v () initTabs h = do - let splices = [ ("tabs", tabsSplice) ] - csplices = [ ("tabs", tabsCSplice) ] + let splices = ("tabs" ## tabsSplice) + csplices = ("tabs" ## tabsCSplice) addConfig h $ mempty { hcCompiledSplices = csplices , hcInterpretedSplices = splices } @@ -60,9 +60,9 @@ tabsCSplice = do n <- getParamNode let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest - splices = [("tab", C.defer tabCSplice getCtx)] + splices = ("tab" ## tabCSplice getCtx) case n of - Element _ attrs ch -> C.withLocalSplices splices [] $ + Element _ attrs ch -> C.withLocalSplices splices noSplices $ C.runNode $ X.Element "ul" attrs ch _ -> error "tabs tag has to be an Element" @@ -70,8 +70,8 @@ ------------------------------------------------------------------------------ -- | 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 +tabCSplice :: Monad m => RuntimeSplice m Text -> C.Splice m +tabCSplice getCtx = do (Element _ attrs ch) <- getParamNode attrsAction <- C.runAttributesRaw attrs let ps as context = do @@ -85,7 +85,7 @@ _ -> Left "Unknown match type" return (url, ch, m') return $ C.yieldRuntime $ do - ctx <- C.getPromise promise + ctx <- getCtx as <- attrsAction let res = case ps as ctx of Left e -> error $ "Tab error: " ++ e @@ -122,7 +122,7 @@ tabsSplice :: MonadSnap m => Splice m tabsSplice = do context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest - let bind = bindSplices [("tab", tabSplice context)] + let bind = bindSplices ("tab" ## tabSplice context) n <- getParamNode case n of Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]