Skip to content
Browse files

Fix warnings and add version bounds

  • Loading branch information...
1 parent 2915b02 commit 10d706a8d4227b9750ca04fedb37af3253ae906e @mightybyte mightybyte committed
Showing with 48 additions and 63 deletions.
  1. +23 −23 snap-extras.cabal
  2. +0 −6 src/Snap/Extras/FormUtils.hs
  3. +10 −8 src/Snap/Extras/NavTrails.hs
  4. +15 −23 src/Snap/Extras/Tabs.hs
  5. +0 −3 src/Snap/Extras/TextUtils.hs
View
46 snap-extras.cabal
@@ -38,29 +38,29 @@ Library
hs-source-dirs: src
Build-depends:
- aeson >= 0.6
- , base >= 4 && < 5
- , blaze-builder
- , blaze-html
- , bytestring
- , containers
- , 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
- , filepath
- , heist >= 0.12
- , mtl >= 2.0 && < 2.2
- , readable >= 0.1 && < 0.2
- , safe
- , snap >= 0.10
- , snap-core >= 0.7
- , text
- , transformers
- , xmlhtml >= 0.1.6
- , configurator >= 0.2
+ aeson >= 0.6 && < 0.7
+ , base >= 4 && < 5
+ , blaze-builder >= 0.3 && < 0.4
+ , blaze-html >= 0.6 && < 0.7
+ , bytestring >= 0.9.1 && < 0.11
+ , configurator >= 0.2 && < 0.3
+ , 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-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
+ , mtl >= 2.0 && < 2.2
+ , readable >= 0.1 && < 0.2
+ , safe >= 0.3 && < 0.4
+ , snap >= 0.10 && < 0.13
+ , snap-core >= 0.7 && < 0.10
+ , text >= 0.11 && < 0.12
+ , transformers >= 0.2 && < 0.4
+ , xmlhtml >= 0.1.6 && < 0.3
-- Other-modules:
View
6 src/Snap/Extras/FormUtils.hs
@@ -24,20 +24,14 @@ module Snap.Extras.FormUtils
-------------------------------------------------------------------------------
import Control.Error
-import Control.Monad
import qualified Data.ByteString.Char8 as B
-import Data.List (find)
-import qualified Data.Map as M
-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 qualified Text.XmlHtml as X
-------------------------------------------------------------------------------
View
18 src/Snap/Extras/NavTrails.hs
@@ -7,10 +7,8 @@ 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
@@ -31,12 +29,6 @@ data NavTrail b = NavTrail {
-------------------------------------------------------------------------------
---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))
@@ -53,12 +45,14 @@ initNavTrail ses heist =
-------------------------------------------------------------------------------
-- |
+setFocus :: Handler b (NavTrail b) ()
setFocus = do
setFocus' =<< rqURI `fmap` getRequest
-------------------------------------------------------------------------------
-- |
+setFocus' :: ByteString -> Handler b (NavTrail b) ()
setFocus' uri = do
sl <- gets ntSes
withSession sl $ withTop sl $ do
@@ -67,6 +61,7 @@ setFocus' uri = do
-------------------------------------------------------------------------------
-- |
+setFocusToRef :: Handler b (NavTrail b) ()
setFocusToRef = do
sl <- gets ntSes
(maybe "/" id . getHeader "Referer") `fmap` getRequest >>=
@@ -75,22 +70,26 @@ setFocusToRef = do
-------------------------------------------------------------------------------
-- |
+getFocus :: Handler b (NavTrail b) (Maybe Text)
getFocus = do
sl <- gets ntSes
withTop sl (getFromSession "_nt_focus")
+getFocusDef :: Text -> Handler b (NavTrail b) Text
getFocusDef def = (fromJust . (`mplus` Just def)) `fmap` getFocus
-------------------------------------------------------------------------------
-- |
+redirBack :: MonadSnap m => m a
redirBack = redirect =<< (maybe "/" id . getHeader "Referer") `fmap` getRequest
-------------------------------------------------------------------------------
-- |
+redirFocus :: ByteString -> Handler b (NavTrail b) a
redirFocus def = do
f <- (`mplus` Just def) `fmap` (fmap T.encodeUtf8 `fmap` getFocus)
redirect $ fromJust f
@@ -107,6 +106,7 @@ backCSplice :: C.Splice (Handler b v)
backCSplice = return $ C.yieldRuntime $ do
lift $ (fromByteString . rqURI) `fmap` getRequest
+
-------------------------------------------------------------------------------
-- |
focusSplice :: SnapletLens (Snaplet v) (NavTrail b)
@@ -121,8 +121,10 @@ focusCSplice lens = return $ C.yieldRuntimeText $ do
uri <- lift $ with' lens getFocus
return $ fromMaybe "" uri
+
-------------------------------------------------------------------------------
-- |
+addNavTrailSplices :: Snaplet (Heist b) -> Initializer b (NavTrail b) ()
addNavTrailSplices heist = do
lens <- getLens
addConfig heist $
View
38 src/Snap/Extras/Tabs.hs
@@ -21,10 +21,9 @@ module Snap.Extras.Tabs
) where
-------------------------------------------------------------------------------
-import Blaze.ByteString.Builder
+import Control.Error
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
@@ -60,10 +59,10 @@ initTabs h = do
tabsCSplice :: MonadSnap m => C.Splice m
tabsCSplice = do
n <- getParamNode
- let getContext = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest
- splices = [("tab", C.defer tabCSplice getContext)]
+ let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest
+ splices = [("tab", C.defer tabCSplice getCtx)]
case n of
- Element t attrs ch -> C.withLocalSplices splices [] $
+ Element _ attrs ch -> C.withLocalSplices splices [] $
C.runNode $ X.Element "ul" attrs ch
_ -> error "tabs tag has to be an Element"
@@ -73,11 +72,11 @@ tabsCSplice = do
-- attributes in order to get ${} splice substitution.
tabCSplice :: Monad m => C.Promise Text -> C.Splice m
tabCSplice promise = do
- n@(Element _ attrs ch) <- getParamNode
+ (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 <- 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
@@ -90,9 +89,9 @@ tabCSplice promise = do
as <- attrsAction
let res = case ps as ctx of
Left e -> error $ "Tab error: " ++ e
- Right (url, ch, match) ->
+ Right (url, c, match) ->
let attr' = if match then ("class", "active") : as else as
- a = X.Element "a" (("href", url) : as) ch
+ a = X.Element "a" (("href", url) : as) c
in X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]]
return res
@@ -101,14 +100,14 @@ tabSpliceWorker :: Node -> Text -> [Node]
tabSpliceWorker n@(Element _ attrs ch) context =
case ps of
Left e -> error $ "Tab error: " ++ e
- Right (url, ch, match) ->
+ Right (url, c, match) ->
let attr' = if match then ("class", "active") : attrs else attrs
- a = X.Element "a" (("href", url) : attrs) ch
+ a = X.Element "a" (("href", url) : attrs) c
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 <- note "tab must specify a 'match' attribute" $ lookup "match" attrs
+ url <- note "tabs must specify a 'url' attribute" $ getAttribute "url" n
m' <- case m of
"Exact" -> Right $ url == context
"Prefix" -> Right $ url `T.isPrefixOf` context
@@ -116,6 +115,7 @@ tabSpliceWorker n@(Element _ attrs ch) context =
"None" -> Right $ False
_ -> Left "Unknown match type"
return (url, ch, m')
+tabSpliceWorker _ _ = []
-------------------------------------------------------------------------------
@@ -125,7 +125,7 @@ tabsSplice = do
let bind = bindSplices [("tab", tabSplice context)]
n <- getParamNode
case n of
- Element t attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]
+ Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]
_ -> error "tabs tag has to be an Element"
@@ -137,9 +137,6 @@ tabSplice context = do
return $ tabSpliceWorker n context
--------------------------------------------------------------------------------
-wErr err m = maybe (Left err) Right m
-
--------------------
-- Haskell-Driven --
@@ -220,8 +217,3 @@ tab url text attr md context = X.Element "li" attr' [tlink url text]
-------------------------------------------------------------------------------
tlink :: Text -> Text -> Node
tlink target text = X.Element "a" [("href", target)] [X.TextNode text]
-
-
--------------------------------------------------------------------------------
-link :: Text -> [Node] -> Node
-link target ch = X.Element "a" [("href", target)] ch
View
3 src/Snap/Extras/TextUtils.hs
@@ -34,9 +34,6 @@ readT = readNote "Can't read value in readT" . T.unpack
readBS :: (Read a) => ByteString -> a
readBS = readNote "Can't read value in readBS" . B.unpack
-maybeEither (Left e) = Nothing
-maybeEither (Right x) = Just x
-
titleCase :: Text -> Text
titleCase = T.unwords . map upFirst . T.words

0 comments on commit 10d706a

Please sign in to comment.
Something went wrong with that request. Please try again.