Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge 0.10 into snaplet-test

  • Loading branch information...
commit 2e136c3c36551577a1e5fbd503f6ca95c0da5bf6 2 parents 9e9f11b + 0388a5f
Your Name authored
Showing with 442 additions and 214 deletions.
  1. +1 −2  project_template/default/foo.cabal
  2. +2 −2 project_template/default/src/Application.hs
  3. +2 −0  project_template/tutorial/src/Part2.lhs
  4. +1 −1  project_template/tutorial/src/Tutorial.lhs
  5. +4 −2 snap.cabal
  6. +233 −0 snap.cabal.orig
  7. +2 −4 src/Snap.hs
  8. +3 −0  src/Snap/Snaplet.hs
  9. +1 −2  src/Snap/Snaplet/Auth/AuthManager.hs
  10. +1 −2  src/Snap/Snaplet/Auth/Backends/JsonFile.hs
  11. +1 −2  src/Snap/Snaplet/Auth/Handlers.hs
  12. +8 −9 src/Snap/Snaplet/Auth/SpliceHelpers.hs
  13. +11 −10 src/Snap/Snaplet/Heist.hs
  14. +12 −13 src/Snap/Snaplet/HeistNoClass.hs
  15. +34 −34 src/Snap/Snaplet/Internal/Initializer.hs
  16. +19 −27 src/Snap/Snaplet/Internal/LensT.hs
  17. +40 −39 src/Snap/Snaplet/Internal/Lensed.hs
  18. +25 −20 src/Snap/Snaplet/Internal/Types.hs
  19. +1 −2  src/Snap/Snaplet/Session.hs
  20. +4 −7 test/snap-testsuite.cabal
  21. +2 −2 test/suite/Blackbox/App.hs
  22. +4 −5 test/suite/Blackbox/BarSnaplet.hs
  23. +2 −2 test/suite/Blackbox/Common.hs
  24. +3 −4 test/suite/Blackbox/EmbeddedSnaplet.hs
  25. +2 −2 test/suite/Blackbox/Types.hs
  26. +4 −5 test/suite/NestTest.hs
  27. +9 −7 test/suite/Snap/Snaplet/Internal/LensT/Tests.hs
  28. +9 −7 test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs
  29. +2 −2 test/suite/Snap/Snaplet/Internal/Tests.hs
View
3  project_template/default/foo.cabal
@@ -21,9 +21,8 @@ Executable projname
Build-depends:
base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.11,
- data-lens >= 2.0.1 && < 2.11,
- data-lens-template >= 2.1 && < 2.2,
heist >= 0.10 && < 0.11,
+ lens >= 3.2 && < 3.3,
MonadCatchIO-transformers >= 0.2.1 && < 0.4,
mtl >= 2 && < 3,
snap >= 0.10 && < 0.11,
View
4 project_template/default/src/Application.hs
@@ -6,7 +6,7 @@
module Application where
------------------------------------------------------------------------------
-import Data.Lens.Template
+import Control.Lens
import Snap.Snaplet
import Snap.Snaplet.Heist
import Snap.Snaplet.Auth
@@ -19,7 +19,7 @@ data App = App
, _auth :: Snaplet (AuthManager App)
}
-makeLens ''App
+makeLenses ''App
instance HasHeist App where
heistLens = subSnaplet heist
View
2  project_template/tutorial/src/Part2.lhs
@@ -7,8 +7,10 @@
>
> data Bar = Bar
>
+> fooInit :: SnapletInit b Foo
> fooInit = makeSnaplet "foo" "Foo snaplet" Nothing $ do
> return Foo
>
+> barInit :: SnapletLens b Foo -> SnapletInit b Bar
> barInit h = makeSnaplet "bar" "Bar snaplet" Nothing $ do
> return Bar
View
2  project_template/tutorial/src/Tutorial.lhs
@@ -83,7 +83,7 @@ by our application as well as any other state we might want.
> , _companyName :: IORef B.ByteString
> }
>
-> makeLenses [''App]
+> makeLenses ''App
The field names begin with an underscore because of some more complicated
things going on under the hood. However, all you need to know right now is
View
6 snap.cabal
@@ -147,14 +147,16 @@ Library
containers >= 0.3 && < 0.6,
directory >= 1.0 && < 1.3,
directory-tree >= 0.10 && < 0.12,
- data-lens >= 2.0.1 && < 2.11,
- data-lens-template >= 2.1 && < 2.2,
dlist >= 0.5 && < 0.6,
errors >= 1.3 && < 1.4,
filepath >= 1.1 && < 1.4,
hashable >= 1.1 && < 1.2,
heist >= 0.10 && < 0.11,
+<<<<<<< HEAD
HUnit >= 1.2 && < 2,
+=======
+ lens >= 3.2 && < 3.3,
+>>>>>>> upstream/0.10
logict >= 0.4.2 && < 0.6,
mtl > 2.0 && < 2.2,
mwc-random >= 0.8 && < 0.13,
View
233 snap.cabal.orig
@@ -0,0 +1,233 @@
+name: snap
+version: 0.10.0
+synopsis: Top-level package for the Snap Web Framework
+description:
+ This is the top-level package for the official Snap Framework libraries.
+ It includes:
+ .
+ * The Snaplets API
+ .
+ * The \"snap\" executable program for generating starter projects
+ .
+ * Snaplets for sessions, authentication, and templates
+ .
+ To get started, issue the following sequence of commands:
+ .
+ @$ cabal install snap
+ $ mkdir myproject
+ $ cd myproject
+ $ snap init@
+ .
+ If you have trouble or any questions, see our FAQ page
+ (<http://snapframework.com/faq>) or the documentation
+ (<http://snapframework.com/docs>).
+
+license: BSD3
+license-file: LICENSE
+author: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith
+maintainer: snap@snapframework.com
+build-type: Simple
+cabal-version: >= 1.8
+homepage: http://snapframework.com/
+category: Web, Snap
+
+extra-source-files:
+ CONTRIBUTORS,
+ LICENSE,
+ README.md,
+ README.SNAP.md,
+ project_template/barebones/.ghci,
+ project_template/barebones/foo.cabal,
+ project_template/barebones/log/access.log,
+ project_template/barebones/src/Main.hs,
+ project_template/default/.ghci,
+ project_template/default/foo.cabal,
+ project_template/default/log/access.log,
+ project_template/default/log/error.log,
+ project_template/default/static/screen.css,
+ project_template/default/snaplets/heist/templates/base.tpl,
+ project_template/default/snaplets/heist/templates/index.tpl,
+ project_template/default/snaplets/heist/templates/_login.tpl,
+ project_template/default/snaplets/heist/templates/login.tpl,
+ project_template/default/snaplets/heist/templates/_new_user.tpl,
+ project_template/default/snaplets/heist/templates/new_user.tpl,
+ project_template/default/snaplets/heist/templates/userform.tpl,
+ project_template/default/src/Application.hs,
+ project_template/default/src/Main.hs,
+ project_template/default/src/Site.hs,
+ project_template/tutorial/.ghci,
+ project_template/tutorial/foo.cabal,
+ project_template/tutorial/log/placeholder,
+ project_template/tutorial/src/Part2.lhs,
+ project_template/tutorial/src/Tutorial.lhs,
+ extra/hscolour.css,
+ extra/haddock.css,
+ extra/logo.gif,
+ test/snap-testsuite.cabal,
+ test/runTestsAndCoverage.sh,
+ test/suite/TestSuite.hs,
+ test/suite/NestTest.hs,
+ test/suite/Snap/TestCommon.hs,
+ test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs,
+ test/suite/Snap/Snaplet/Internal/RST/Tests.hs,
+ test/suite/Snap/Snaplet/Internal/Tests.hs,
+ test/suite/Snap/Snaplet/Internal/LensT/Tests.hs,
+ test/suite/Blackbox/Types.hs,
+ test/suite/Blackbox/FooSnaplet.hs,
+ test/suite/Blackbox/BarSnaplet.hs,
+ test/suite/Blackbox/Common.hs,
+ test/suite/Blackbox/EmbeddedSnaplet.hs,
+ test/suite/Blackbox/Tests.hs,
+ test/suite/Blackbox/App.hs,
+ test/suite/SafeCWD.hs,
+ test/suite/AppMain.hs,
+ test/non-cabal-appdir/db.cfg,
+ test/non-cabal-appdir/bad.tpl,
+ test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl,
+ test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,
+ test/non-cabal-appdir/snaplets/baz/devel.cfg,
+ test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl,
+ test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,
+ test/non-cabal-appdir/snaplets/heist/templates/index.tpl,
+ test/non-cabal-appdir/snaplets/heist/templates/session.tpl,
+ test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl,
+ test/non-cabal-appdir/snaplets/heist/templates/page.tpl,
+ test/non-cabal-appdir/good.tpl,
+ test/non-cabal-appdir/log/placeholder,
+ test/non-cabal-appdir/devel.cfg,
+ test/foosnaplet/templates/foopage.tpl,
+ test/foosnaplet/devel.cfg
+
+Library
+ hs-source-dirs: src
+
+ exposed-modules:
+ Snap,
+ Snap.Snaplet
+ Snap.Snaplet.Heist
+ Snap.Snaplet.HeistNoClass
+ Snap.Snaplet.Auth
+ Snap.Snaplet.Auth.Backends.JsonFile
+ Snap.Snaplet.Config
+ Snap.Snaplet.Session
+ Snap.Snaplet.Session.Common
+ Snap.Snaplet.Session.SessionManager
+ Snap.Snaplet.Session.Backends.CookieSession
+ Snap.Snaplet.Test
+
+ other-modules:
+ Control.Access.RoleBased.Checker
+ Control.Access.RoleBased.Role
+ Control.Access.RoleBased.Types
+ Control.Access.RoleBased.Internal.Role
+ Control.Access.RoleBased.Internal.RoleMap
+ Control.Access.RoleBased.Internal.Rule
+ Control.Access.RoleBased.Internal.Types
+ Snap.Snaplet.Auth.AuthManager
+ Snap.Snaplet.Auth.Types
+ Snap.Snaplet.Auth.Handlers
+ Snap.Snaplet.Auth.SpliceHelpers
+ Snap.Snaplet.Internal.Initializer
+ Snap.Snaplet.Internal.LensT
+ Snap.Snaplet.Internal.Lensed
+ Snap.Snaplet.Internal.RST
+ Snap.Snaplet.Internal.Types
+ Snap.Snaplet.Session.SecureCookie
+
+ build-depends:
+ MonadCatchIO-transformers >= 0.2 && < 0.4,
+ aeson >= 0.6 && < 0.7,
+ attoparsec >= 0.10 && < 0.11,
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.11,
+ cereal >= 0.3 && < 0.4,
+ clientsession >= 0.8 && < 0.9,
+ configurator >= 0.1 && < 0.3,
+ comonad >= 1.1 && < 3.1,
+ containers >= 0.3 && < 0.6,
+ directory >= 1.0 && < 1.3,
+ directory-tree >= 0.10 && < 0.12,
+ dlist >= 0.5 && < 0.6,
+ errors >= 1.3 && < 1.4,
+ filepath >= 1.1 && < 1.4,
+ hashable >= 1.1 && < 1.2,
+ heist >= 0.10 && < 0.11,
+<<<<<<< HEAD
+ HUnit >= 1.2 && < 2,
+=======
+ lens >= 3.2 && < 3.3,
+>>>>>>> upstream/0.10
+ logict >= 0.4.2 && < 0.6,
+ mtl > 2.0 && < 2.2,
+ mwc-random >= 0.8 && < 0.13,
+ pwstore-fast >= 2.2 && < 2.4,
+ regex-posix >= 0.95 && < 1,
+ snap-core >= 0.9.2 && < 0.10,
+ snap-server >= 0.9.2 && < 0.10,
+ stm >= 2.2 && < 2.5,
+ syb >= 0.1 && < 0.4,
+ text >= 0.11 && < 0.12,
+ time >= 1.1 && < 1.5,
+ transformers >= 0.2 && < 0.4,
+ unordered-containers >= 0.1.4 && < 0.3,
+ vector >= 0.7.1 && < 0.11,
+ vector-algorithms >= 0.4 && < 0.6,
+ xmlhtml >= 0.1 && < 0.3
+
+ extensions:
+ BangPatterns,
+ CPP,
+ DeriveDataTypeable,
+ ExistentialQuantification,
+ FlexibleContexts,
+ FlexibleInstances,
+ GeneralizedNewtypeDeriving,
+ MultiParamTypeClasses,
+ NoMonomorphismRestriction,
+ OverloadedStrings,
+ PackageImports,
+ Rank2Types,
+ RecordWildCards,
+ ScopedTypeVariables,
+ TemplateHaskell,
+ TypeFamilies,
+ TypeOperators,
+ TypeSynonymInstances
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans -fno-warn-unused-do-bind
+ else
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans
+
+Executable snap
+ hs-source-dirs: src
+ main-is: Snap/Starter.hs
+
+ other-modules: Snap.StarterTH
+
+ build-depends:
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.11,
+ containers >= 0.3 && < 0.6,
+ directory >= 1.0 && < 1.3,
+ directory-tree >= 0.10 && < 0.12,
+ filepath >= 1.1 && < 1.4,
+ old-time >= 1.0 && < 1.2,
+ snap-server >= 0.9.1 && < 0.10,
+ template-haskell >= 2.2 && < 2.9,
+ text >= 0.11 && < 0.12
+
+ ghc-prof-options: -prof -auto-all
+
+ if impl(ghc >= 6.12.0)
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans -fno-warn-unused-do-bind
+ else
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans
+
+source-repository head
+ type: git
+ location: https://github.com/snapframework/snap.git
View
6 src/Snap.hs
@@ -8,18 +8,16 @@ see "Snap.Snaplet". For the core web server API, see "Snap.Core".
module Snap
( module Control.Applicative
+ , module Control.Lens
, module Control.Monad.State
- , module Data.Lens.Common
- , module Data.Lens.Template
, module Snap.Core
, module Snap.Http.Server
, module Snap.Snaplet
) where
import Control.Applicative
+import Control.Lens
import Control.Monad.State
-import Data.Lens.Common
-import Data.Lens.Template
import Snap.Core
import Snap.Http.Server
import Snap.Snaplet
View
3  src/Snap/Snaplet.hs
@@ -106,6 +106,9 @@ module Snap.Snaplet
, runSnaplet
, combineConfig
, serveSnaplet
+
+ -- * Snaplet Lenses
+ , SnapletLens
) where
View
3  src/Snap/Snaplet/Auth/AuthManager.hs
@@ -20,7 +20,6 @@ module Snap.Snaplet.Auth.AuthManager
------------------------------------------------------------------------------
import Data.ByteString (ByteString)
-import Data.Lens.Lazy
import Data.Text (Text)
import Data.Time
import Web.ClientSession
@@ -70,7 +69,7 @@ data AuthManager b = forall r. IAuthBackend r => AuthManager {
backend :: r
-- ^ Storage back-end
- , session :: Lens b (Snaplet SessionManager)
+ , session :: SnapletLens b SessionManager
-- ^ A lens pointer to a SessionManager
, activeUser :: Maybe AuthUser
View
3  src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -22,7 +22,6 @@ import Data.Map (Map)
import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Lens.Lazy
import Data.Time
import Web.ClientSession
import System.Directory
@@ -38,7 +37,7 @@ import Snap.Snaplet.Session
-- | Initialize a JSON file backed 'AuthManager'
initJsonFileAuthManager :: AuthSettings
-- ^ Authentication settings for your app
- -> Lens b (Snaplet SessionManager)
+ -> SnapletLens b SessionManager
-- ^ Lens into a 'SessionManager' auth snaplet will
-- use
-> FilePath
View
3  src/Snap/Snaplet/Auth/Handlers.hs
@@ -14,7 +14,6 @@ import Control.Applicative
import Control.Error
import Control.Monad.State
import Data.ByteString (ByteString)
-import Data.Lens.Lazy
import Data.Serialize hiding (get)
import Data.Time
import Data.Text.Encoding (decodeUtf8)
@@ -469,7 +468,7 @@ logoutUser target = logout >> target
-- This function has no DB cost - only checks to see if a user_id is present
-- in the current session.
--
-requireUser :: Lens b (Snaplet (AuthManager b))
+requireUser :: SnapletLens b (AuthManager b)
-- ^ Lens reference to an "AuthManager"
-> Handler b v a
-- ^ Do this if no authenticated user is present.
View
17 src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -23,7 +23,6 @@ module Snap.Snaplet.Auth.SpliceHelpers
) where
import Control.Monad.Trans
-import Data.Lens.Lazy
import Data.Monoid
import Data.Text (Text)
import qualified Text.XmlHtml as X
@@ -47,7 +46,7 @@ import Snap.Snaplet.Heist
-- \<loggedInUser\>
addAuthSplices
:: HasHeist b
- => Lens b (Snaplet (AuthManager b))
+ => SnapletLens b (AuthManager b)
-- ^ A lens reference to 'AuthManager'
-> Initializer b v ()
addAuthSplices auth = addSplices
@@ -57,7 +56,7 @@ addAuthSplices auth = addSplices
]
-compiledAuthSplices :: Lens b (Snaplet (AuthManager b))
+compiledAuthSplices :: SnapletLens b (AuthManager b)
-> [(Text, SnapletCSplice b)]
compiledAuthSplices auth =
[ ("ifLoggedIn", cIfLoggedIn auth)
@@ -71,7 +70,7 @@ compiledAuthSplices auth =
-- present, this will run the contents of the node.
--
-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
-ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b
+ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b
ifLoggedIn auth = do
chk <- lift $ withTop auth isLoggedIn
case chk of
@@ -84,7 +83,7 @@ ifLoggedIn auth = do
-- present, this will run the contents of the node.
--
-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
-cIfLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b
+cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedIn auth = do
children <- C.promiseChildren
return $ C.yieldRuntime $ do
@@ -99,7 +98,7 @@ cIfLoggedIn auth = do
-- not present, this will run the contents of the node.
--
-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
-ifLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b
+ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b
ifLoggedOut auth = do
chk <- lift $ withTop auth isLoggedIn
case chk of
@@ -112,7 +111,7 @@ ifLoggedOut auth = do
-- not present, this will run the contents of the node.
--
-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
-cIfLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b
+cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedOut auth = do
children <- C.promiseChildren
return $ C.yieldRuntime $ do
@@ -125,7 +124,7 @@ cIfLoggedOut auth = do
-------------------------------------------------------------------------------
-- | A splice that will simply print the current user's login, if
-- there is one.
-loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b
+loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b
loggedInUser auth = do
u <- lift $ withTop auth currentUser
maybe (return []) (I.textSplice . userLogin) u
@@ -134,7 +133,7 @@ loggedInUser auth = do
-------------------------------------------------------------------------------
-- | A splice that will simply print the current user's login, if
-- there is one.
-cLoggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b
+cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cLoggedInUser auth =
return $ C.yieldRuntimeText $ do
u <- lift $ withTop auth currentUser
View
21 src/Snap/Snaplet/Heist.hs
@@ -47,7 +47,6 @@ module Snap.Snaplet.Heist
------------------------------------------------------------------------------
import Prelude hiding (id, (.))
import Data.ByteString (ByteString)
-import Data.Lens.Lazy
import Data.Text (Text)
import Heist
------------------------------------------------------------------------------
@@ -78,7 +77,7 @@ import Snap.Snaplet.HeistNoClass ( Heist
class HasHeist b where
-- | A lens to the Heist snaplet. The b parameter to Heist will
-- typically be the base state of your application.
- heistLens :: Lens (Snaplet b) (Snaplet (Heist b))
+ heistLens :: SnapletLens (Snaplet b) (Heist b)
-- $initializerSection
@@ -200,19 +199,21 @@ cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t)
------------------------------------------------------------------------------
--- | Analogous to 'fileServe'. If the template specified in the request path
--- is not found, it returns 'empty'. Also, this function does not serve any
--- templates beginning with an underscore. This gives you a way to prevent
--- some templates from being served. For example, you might have a template
--- that contains only the navbar of your pages, and you wouldn't want that
--- template to be visible to the user as a standalone template.
+-- | A handler that serves all the templates (similar to 'fileServe'). If the
+-- template specified in the request path is not found, it returns 'empty'.
+-- Also, this function does not serve any templates beginning with an
+-- underscore. This gives you a way to prevent some templates from being
+-- served. For example, you might have a template that contains only the
+-- navbar of your pages, and you probably wouldn't want that template to be
+-- visible to the user as a standalone template. So if you put it in a file
+-- called \"_nav.tpl\", this function won't serve it.
heistServe :: HasHeist b => Handler b v ()
heistServe = withTop' heistLens Unclassed.heistServe
------------------------------------------------------------------------------
--- | Analogous to 'fileServeSingle'. If the given template is not found,
--- this throws an error.
+-- | Handler for serving a single template (similar to 'fileServeSingle'). If
+-- the given template is not found, this throws an error.
heistServeSingle :: HasHeist b
=> ByteString
-- ^ Template name
View
25 src/Snap/Snaplet/HeistNoClass.hs
@@ -66,7 +66,6 @@ import qualified Data.HashMap.Strict as Map
import Data.IORef
import Data.List
import Data.Monoid
-import Data.Lens.Lazy
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
@@ -244,7 +243,7 @@ addTemplatesAt h urlPrefix templateDir = do
------------------------------------------------------------------------------
-modifyHeistState' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+modifyHeistState' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Initializer b v ()
modifyHeistState' heist f = do
@@ -252,14 +251,14 @@ modifyHeistState' heist f = do
------------------------------------------------------------------------------
-modifyHeistState :: (Lens b (Snaplet (Heist b)))
+modifyHeistState :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Initializer b v ()
modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f
------------------------------------------------------------------------------
-withHeistState' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+withHeistState' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> a)
-> Handler b v a
withHeistState' heist f = do
@@ -268,7 +267,7 @@ withHeistState' heist f = do
------------------------------------------------------------------------------
-withHeistState :: (Lens b (Snaplet (Heist b)))
+withHeistState :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> a)
-> Handler b v a
withHeistState heist f = withHeistState' (subSnaplet heist) f
@@ -290,7 +289,7 @@ addConfig h hc = case extract h of
------------------------------------------------------------------------------
-addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+addSplices' :: SnapletLens (Snaplet b) (Heist b)
-> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices' heist splices = do
@@ -299,7 +298,7 @@ addSplices' heist splices = do
------------------------------------------------------------------------------
-addSplices :: (Lens b (Snaplet (Heist b)))
+addSplices :: SnapletLens b (Heist b)
-> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
@@ -403,7 +402,7 @@ cHeistServeSingle t =
------------------------------------------------------------------------------
-heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+heistLocal' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Handler b v a
-> Handler b v a
@@ -416,7 +415,7 @@ heistLocal' heist f m = do
------------------------------------------------------------------------------
-heistLocal :: (Lens b (Snaplet (Heist b)))
+heistLocal :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Handler b v a
-> Handler b v a
@@ -424,7 +423,7 @@ heistLocal heist f m = heistLocal' (subSnaplet heist) f m
------------------------------------------------------------------------------
-withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+withSplices' :: SnapletLens (Snaplet b) (Heist b)
-> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
@@ -433,7 +432,7 @@ withSplices' heist splices m = do
------------------------------------------------------------------------------
-withSplices :: (Lens b (Snaplet (Heist b)))
+withSplices :: SnapletLens b (Heist b)
-> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
@@ -441,7 +440,7 @@ withSplices heist splices m = withSplices' (subSnaplet heist) splices m
------------------------------------------------------------------------------
-renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+renderWithSplices' :: SnapletLens (Snaplet b) (Heist b)
-> ByteString
-> [(Text, SnapletISplice b)]
-> Handler b v ()
@@ -450,7 +449,7 @@ renderWithSplices' heist t splices =
------------------------------------------------------------------------------
-renderWithSplices :: (Lens b (Snaplet (Heist b)))
+renderWithSplices :: SnapletLens b (Heist b)
-> ByteString
-> [(Text, SnapletISplice b)]
-> Handler b v ()
View
68 src/Snap/Snaplet/Internal/Initializer.hs
@@ -21,11 +21,11 @@ module Snap.Snaplet.Internal.Initializer
, printInfo
) where
-import Prelude hiding ((.), id, catch)
-import Control.Category
+import Prelude hiding (catch)
import Control.Concurrent.MVar
import Control.Error
import Control.Exception (SomeException)
+import Control.Lens hiding (right)
import Control.Monad
import Control.Monad.CatchIO hiding (Handler)
import Control.Monad.Reader
@@ -36,7 +36,6 @@ import qualified Data.ByteString.Char8 as B
import Data.Configurator
import Data.IORef
import Data.Maybe
-import Data.Lens.Lazy
import Data.Text (Text)
import qualified Data.Text as T
import Snap.Http.Server
@@ -122,16 +121,16 @@ upHook h = Initializer $ do
------------------------------------------------------------------------------
-- | Helper function for transforming hooks.
-upHook' :: Monad m => Lens b a -> (a -> m a) -> b -> m b
+upHook' :: Monad m => SimpleLoupe b a -> (a -> m a) -> b -> m b
upHook' l h b = do
- v <- h (getL l b)
- return $ setL l v b
+ v <- h (b ^# l)
+ return $ storing l v b
------------------------------------------------------------------------------
-- | Modifies the Initializer's SnapletConfig.
modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()
-modifyCfg f = iModify $ modL curConfig $ \c -> f c
+modifyCfg f = iModify $ over curConfig $ \c -> f c
------------------------------------------------------------------------------
@@ -156,10 +155,10 @@ setupFilesystem (Just getSnapletDataDir) targetDir = do
where
doCopy srcRoot targetRoot filename = do
createDirectoryIfMissing True directory
- copyFile filename to
+ copyFile filename toDir
where
- to = targetRoot </> makeRelative srcRoot filename
- directory = dropFileName to
+ toDir = targetRoot </> makeRelative srcRoot filename
+ directory = dropFileName toDir
------------------------------------------------------------------------------
@@ -198,15 +197,15 @@ makeSnaplet :: Text
-> SnapletInit b v
makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do
modifyCfg $ \c -> if isNothing $ _scId c
- then setL scId (Just snapletId) c else c
+ then set scId (Just snapletId) c else c
sid <- iGets (T.unpack . fromJust . _scId . _curConfig)
topLevel <- iGets _isTopLevel
unless topLevel $ do
- modifyCfg $ modL scUserConfig (subconfig (T.pack sid))
- modifyCfg $ \c -> setL scFilePath
+ modifyCfg $ over scUserConfig (subconfig (T.pack sid))
+ modifyCfg $ \c -> set scFilePath
(_scFilePath c </> "snaplets" </> sid) c
- iModify (setL isTopLevel False)
- modifyCfg $ setL scDescription desc
+ iModify (set isTopLevel False)
+ modifyCfg $ set scDescription desc
cfg <- iGets _curConfig
printInfo $ T.pack $ concat
["Initializing "
@@ -243,7 +242,7 @@ bracketInit :: Initializer b v a -> Initializer b v a
bracketInit m = do
s <- iGet
res <- m
- iModify (setL curConfig (_curConfig s))
+ iModify (set curConfig (_curConfig s))
return res
@@ -253,9 +252,9 @@ bracketInit m = do
setupSnapletCall :: ByteString -> Initializer b v ()
setupSnapletCall rte = do
curId <- iGets (fromJust . _scId . _curConfig)
- modifyCfg (modL scAncestry (curId:))
- modifyCfg (modL scId (const Nothing))
- unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:))
+ modifyCfg (over scAncestry (curId:))
+ modifyCfg (over scId (const Nothing))
+ unless (B.null rte) $ modifyCfg (over scRouteContext (rte:))
------------------------------------------------------------------------------
@@ -268,14 +267,15 @@ nestSnaplet :: ByteString
-- ^ The root url for all the snaplet's routes. An empty
-- string gives the routes the same root as the parent
-- snaplet's routes.
- -> (Lens v (Snaplet v1))
+ -> SnapletLens v v1
-- ^ Lens identifying the snaplet
-> SnapletInit b v1
-- ^ The initializer function for the subsnaplet.
-> Initializer b v (Snaplet v1)
-nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do
- setupSnapletCall rte
- snaplet
+nestSnaplet rte l (SnapletInit snaplet) =
+ with l $ bracketInit $ do
+ setupSnapletCall rte
+ snaplet
------------------------------------------------------------------------------
@@ -295,7 +295,7 @@ embedSnaplet :: ByteString
-- NOTE: Because of the stronger isolation provided by
-- embedSnaplet, you should be more careful about using an
-- empty string here.
- -> (Lens v (Snaplet v1))
+ -> SnapletLens v v1
-- ^ Lens identifying the snaplet
-> SnapletInit v1 v1
-- ^ The initializer function for the subsnaplet.
@@ -303,13 +303,13 @@ embedSnaplet :: ByteString
embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do
curLens <- getLens
setupSnapletCall ""
- chroot rte (subSnaplet l . curLens) snaplet
+ chroot rte (cloneLens curLens . subSnaplet l) snaplet
------------------------------------------------------------------------------
-- | Changes the base state of an initializer.
chroot :: ByteString
- -> (Lens (Snaplet b) (Snaplet v1))
+ -> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot rte l (Initializer m) = do
@@ -320,20 +320,20 @@ chroot rte l (Initializer m) = do
_hFilter = id
}
let handler = chrootHandler l $ _hFilter s $ route $ _handlers s
- iModify $ modL handlers (++[(rte,handler)])
- . setL cleanup (_cleanup s)
+ iModify $ over handlers (++[(rte,handler)])
+ . set cleanup (_cleanup s)
addPostInitHookBase $ upHook' l hook
return a
------------------------------------------------------------------------------
-- | Changes the base state of a handler.
-chrootHandler :: (Lens (Snaplet v) (Snaplet b'))
+chrootHandler :: SnapletLens (Snaplet v) b'
-> Handler b' b' a -> Handler b v a
chrootHandler l (Handler h) = Handler $ do
s <- get
- (a, s') <- liftSnap $ L.runLensed h id (getL l s)
- modify $ setL l s'
+ (a, s') <- liftSnap $ L.runLensed h id (s ^# l)
+ modify $ storing l s'
return a
@@ -351,7 +351,7 @@ nameSnaplet :: Text
-- ^ The snaplet initializer function
-> SnapletInit b v
nameSnaplet nm (SnapletInit m) = SnapletInit $
- modifyCfg (setL scId (Just nm)) >> m
+ modifyCfg (set scId (Just nm)) >> m
------------------------------------------------------------------------------
@@ -366,7 +366,7 @@ addRoutes rs = do
let modRoute (r,h) = ( buildPath (r:ctx)
, setPattern r >> withTop' l h)
let rs' = map modRoute rs
- iModify (\v -> modL handlers (++rs') v)
+ iModify (\v -> over handlers (++rs') v)
where
setPattern r = do
p <- getRoutePattern
@@ -387,7 +387,7 @@ wrapSite :: (Handler b v () -> Handler b v ())
-> Initializer b v ()
wrapSite f0 = do
f <- mungeFilter f0
- iModify (\v -> modL hFilter (f.) v)
+ iModify (\v -> over hFilter (f.) v)
------------------------------------------------------------------------------
View
46 src/Snap/Snaplet/Internal/LensT.hs
@@ -7,17 +7,18 @@ module Snap.Snaplet.Internal.LensT where
import Control.Applicative
import Control.Category
+import Control.Lens (cloneLens)
+import Control.Lens.Loupe
import Control.Monad.CatchIO
import Control.Monad.Reader
import Control.Monad.State.Class
-import Data.Lens.Lazy
import Prelude hiding ((.), id, catch)
import Snap.Core
import Snap.Snaplet.Internal.RST
-newtype LensT b v s m a = LensT (RST (Lens b v) s m a)
+newtype LensT b v s m a = LensT (RST (SimpleLoupe b v) s m a)
deriving ( Monad
, MonadTrans
, Functor
@@ -26,59 +27,55 @@ newtype LensT b v s m a = LensT (RST (Lens b v) s m a)
, MonadPlus
, MonadCatchIO
, Alternative
- , MonadReader (Lens b v)
+ , MonadReader (SimpleLoupe b v)
, MonadSnap )
------------------------------------------------------------------------------
-instance (Monad m) => MonadState v (LensT b v b m) where
+instance Monad m => MonadState v (LensT b v b m) where
get = lGet
put = lPut
------------------------------------------------------------------------------
-getBase :: (Monad m) => LensT b v s m s
+getBase :: Monad m => LensT b v s m s
getBase = LensT get
{-# INLINE getBase #-}
------------------------------------------------------------------------------
-putBase :: (Monad m) => s -> LensT b v s m ()
+putBase :: Monad m => s -> LensT b v s m ()
putBase = LensT . put
{-# INLINE putBase #-}
------------------------------------------------------------------------------
-lGet :: (Monad m) => LensT b v b m v
+lGet :: Monad m => LensT b v b m v
lGet = LensT $ do
!l <- ask
!b <- get
- return $! l ^$ b
+ return $! b ^# l
{-# INLINE lGet #-}
------------------------------------------------------------------------------
-lPut :: (Monad m) => v -> LensT b v b m ()
+lPut :: Monad m => v -> LensT b v b m ()
lPut v = LensT $ do
!l <- ask
!b <- get
- put $! (l ^!= v) b
+ put $! storing l v b
{-# INLINE lPut #-}
------------------------------------------------------------------------------
-runLensT :: (Monad m) =>
- LensT b v s m a
- -> Lens b v
- -> s
- -> m (a, s)
-runLensT (LensT m) = runRST m
+runLensT :: Monad m => LensT b v s m a -> SimpleLoupe b v -> s -> m (a, s)
+runLensT (LensT m) l = runRST m l
{-# INLINE runLensT #-}
------------------------------------------------------------------------------
-withLensT :: Monad m =>
- ((Lens b' v') -> (Lens b v))
+withLensT :: Monad m
+ => (SimpleLoupe b' v' -> SimpleLoupe b v)
-> LensT b v s m a
-> LensT b' v' s m a
withLensT f (LensT m) = LensT $ withRST f m
@@ -87,19 +84,14 @@ withLensT f (LensT m) = LensT $ withRST f m
------------------------------------------------------------------------------
withTop :: Monad m
- => (Lens b v')
+ => SimpleLoupe b v'
-> LensT b v' s m a
-> LensT b v s m a
-withTop !subLens = withLensT (const subLens)
+withTop subLens = withLensT (const subLens)
{-# INLINE withTop #-}
------------------------------------------------------------------------------
-with :: Monad m
- => (Lens v v')
- -> LensT b v' s m a
- -> LensT b v s m a
-with !subLens = withLensT (subLens .)
-{-# INLINE with #-}
-
+with :: Monad m => SimpleLoupe v v' -> LensT b v' s m a -> LensT b v s m a
+with subLens = withLensT (\l -> cloneLens l . subLens)
View
79 src/Snap/Snaplet/Internal/Lensed.hs
@@ -1,24 +1,25 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
module Snap.Snaplet.Internal.Lensed where
import Control.Applicative
+import Control.Lens (cloneLens)
+import Control.Lens.Loupe
import Control.Monad
+import Control.Monad.Reader.Class
import Control.Monad.Trans
-import Data.Lens.Strict
import Control.Monad.CatchIO
-import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.State.Strict
import Control.Category
import Prelude hiding (catch, id, (.))
import Snap.Core
-
------------------------------------------------------------------------------
newtype Lensed b v m a = Lensed
- { unlensed :: Lens b v -> v -> b -> m (a, v, b) }
+ { unlensed :: SimpleLoupe b v -> v -> b -> m (a, v, b) }
------------------------------------------------------------------------------
@@ -49,20 +50,21 @@ instance Monad m => MonadState v (Lensed b v m) where
put v' = Lensed $ \_ _ s -> return ((), v', s)
-------------------------------------------------------------------------------
-instance Monad m => MonadReader (Lens b v) (Lensed b v m) where
- ask = Lensed $ \l v s -> return (l, v, s)
- local f g = do
- l' <- asks f
- withTop l' g
+instance Monad m => MonadReader (SimpleLoupe b v) (Lensed b v m) where
+ ask = Lensed $ \l v s -> return (l, v, s)
+ local = lensedLocal
+------------------------------------------------------------------------------
+lensedLocal :: Monad m => (SimpleLoupe b v -> SimpleLoupe b v') -> Lensed b v' m a -> Lensed b v m a
+lensedLocal f g = do
+ l <- ask
+ withTop (f l) g
------------------------------------------------------------------------------
instance MonadTrans (Lensed b v) where
lift m = Lensed $ \_ v b -> do
- res <- m
- return (res, v, b)
-
+ res <- m
+ return (res, v, b)
------------------------------------------------------------------------------
instance MonadIO m => MonadIO (Lensed b v m) where
@@ -73,7 +75,7 @@ instance MonadIO m => MonadIO (Lensed b v m) where
instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where
catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b
where
- handler l v b e = let (Lensed h) = f e
+ handler l v b e = let Lensed h = f e
in h l v b
block (Lensed m) = Lensed $ \l v b -> block (m l v b)
@@ -90,7 +92,7 @@ instance MonadPlus m => MonadPlus (Lensed b v m) where
------------------------------------------------------------------------------
instance (Monad m, Alternative m) => Alternative (Lensed b v m) where
empty = lift empty
- (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b
+ Lensed m <|> Lensed n = Lensed $ \l v b -> m l v b <|> n l v b
------------------------------------------------------------------------------
@@ -99,53 +101,52 @@ instance MonadSnap m => MonadSnap (Lensed b v m) where
------------------------------------------------------------------------------
+globally :: Monad m => StateT b m a -> Lensed b v m a
+globally (StateT f) = Lensed $ \l v s ->
+ liftM (\(a, s') -> (a, s' ^# l, s')) $ f (storing l v s)
+
+
+------------------------------------------------------------------------------
+lensedAsState :: Monad m => Lensed b v m a -> SimpleLoupe b v -> StateT b m a
+lensedAsState (Lensed f) l = StateT $ \s -> do
+ (a, v', s') <- f l (s ^# l) s
+ return (a, storing l v' s')
+
+
+------------------------------------------------------------------------------
getBase :: Monad m => Lensed b v m b
getBase = Lensed $ \_ v b -> return (b, v, b)
------------------------------------------------------------------------------
-withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a
+withTop :: Monad m => SimpleLoupe b v' -> Lensed b v' m a -> Lensed b v m a
withTop l m = globally $ lensedAsState m l
------------------------------------------------------------------------------
-with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a
+with :: Monad m => SimpleLoupe v v' -> Lensed b v' m a -> Lensed b v m a
with l g = do
- l' <- asks (l .)
- withTop l' g
+ l' <- ask
+ withTop (cloneLens l' . l) g
------------------------------------------------------------------------------
-embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a
+embed :: Monad m => SimpleLoupe v v' -> Lensed v v' m a -> Lensed b v m a
embed l m = locally $ lensedAsState m l
------------------------------------------------------------------------------
-globally :: Monad m => StateT b m a -> Lensed b v m a
-globally (StateT f) = Lensed $ \l v s ->
- liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s)
-
-
-------------------------------------------------------------------------------
locally :: Monad m => StateT v m a -> Lensed b v m a
locally (StateT f) = Lensed $ \_ v s ->
liftM (\(a, v') -> (a, v', s)) $ f v
------------------------------------------------------------------------------
-lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a
-lensedAsState (Lensed f) l = StateT $ \s -> do
- (a, v', s') <- f l (l ^$ s) s
- return (a, l ^= v' $ s')
-
-
-------------------------------------------------------------------------------
runLensed :: Monad m
=> Lensed t1 b m t
- -> Lens t1 b
+ -> SimpleLoupe t1 b
-> t1
-> m (t, t1)
runLensed (Lensed f) l s = do
- (a, v', s') <- f l (l ^$ s) s
- return (a, l ^= v' $ s')
-
+ (a, v', s') <- f l (s ^# l) s
+ return (a, storing l v' s')
View
45 src/Snap/Snaplet/Internal/Types.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -12,11 +13,10 @@
module Snap.Snaplet.Internal.Types where
-import Prelude hiding ((.), id)
import Control.Applicative
-import Control.Category ((.), id)
import Control.Comonad
import Control.Error
+import Control.Lens
import Control.Monad.CatchIO hiding (Handler)
import Control.Monad.Reader
import Control.Monad.State.Class
@@ -26,11 +26,8 @@ import qualified Data.ByteString.Char8 as B
import Data.Configurator.Types
import Data.IORef
import Data.Monoid
-import Data.Lens.Lazy
-import Data.Lens.Template
import Data.Text (Text)
import Data.Foldable (Foldable(..))
-import Data.Traversable
import Snap.Core
import qualified Snap.Snaplet.Internal.LensT as LT
@@ -55,6 +52,8 @@ data SnapletConfig = SnapletConfig
, _reloader :: IO (Either Text Text) -- might change
}
+makeLenses ''SnapletConfig
+
------------------------------------------------------------------------------
-- | Joins a reversed list of directories into a path.
@@ -82,7 +81,7 @@ data Snaplet s = Snaplet
, _snapletValue :: s
}
-makeLenses [''SnapletConfig, ''Snaplet]
+makeLenses ''Snaplet
instance Functor Snaplet where
fmap f (Snaplet c a) = Snaplet c (f a)
@@ -105,19 +104,22 @@ instance Extend Snaplet where
------------------------------------------------------------------------------
-- | A lens referencing the opaque SnapletConfig data type held inside
-- Snaplet.
-snapletConfig :: Lens (Snaplet a) SnapletConfig
+snapletConfig :: SimpleLens (Snaplet a) SnapletConfig
------------------------------------------------------------------------------
-- | A lens referencing the user-defined state type wrapped by a Snaplet.
-snapletValue :: Lens (Snaplet a) a
+snapletValue :: SimpleLens (Snaplet a) a
-}
+type SnapletLens s a = SimpleLoupe s (Snaplet a)
+
------------------------------------------------------------------------------
-- | Transforms a lens of the type you get from makeLenses to an similar lens
-- that is more suitable for internal use.
-subSnaplet :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b))
-subSnaplet = (. snapletValue)
+subSnaplet :: SnapletLens a b
+ -> SnapletLens (Snaplet a) b
+subSnaplet l = snapletValue . l
------------------------------------------------------------------------------
@@ -134,18 +136,18 @@ class MonadSnaplet m where
-- think about snaplet lenses using a filesystem path metaphor, the lens
-- supplied to this snaplet must be a relative path. In other words, the
-- lens's base state must be the same as the current snaplet.
- with :: (Lens v (Snaplet v'))
+ with :: SnapletLens v v'
-- ^ A relative lens identifying a snaplet
-> m b v' a
-- ^ Action from the lense's snaplet
-> m b v a
- with = with' . subSnaplet
+ with l = with' (subSnaplet l)
-- | Like 'with' but doesn't impose the requirement that the action
-- being run be a descendant of the current snaplet. Using our filesystem
-- metaphor again, the lens for this function must be an absolute
-- path--it's base must be the same as the current base.
- withTop :: (Lens b (Snaplet v'))
+ withTop :: SnapletLens b v'
-- ^ An \"absolute\" lens identifying a snaplet
-> m b v' a
-- ^ Action from the lense's snaplet
@@ -159,7 +161,8 @@ class MonadSnaplet m where
-- however the lens returned by 'getLens' will.
--
-- @with = with' . subSnaplet@
- with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a
+ with' :: SnapletLens (Snaplet v) v'
+ -> m b v' a -> m b v a
-- Not providing a definition for this function in terms of withTop'
-- allows us to avoid extra Monad type class constraints, making the type
@@ -167,10 +170,11 @@ class MonadSnaplet m where
-- with' l m = flip withTop m . (l .) =<< getLens
-- | The absolute version of 'with''
- withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a
+ withTop' :: SnapletLens (Snaplet b) v'
+ -> m b v' a -> m b v a
-- | Gets the lens for the current snaplet.
- getLens :: m b v (Lens (Snaplet b) (Snaplet v))
+ getLens :: m b v (SnapletLens (Snaplet b) v)
-- | Gets the current snaplet's opaque config data type. You'll only use
-- this function when writing MonadSnaplet instances.
@@ -270,7 +274,7 @@ getsSnapletState f = do
-- | The MonadState instance gives you access to the current snaplet's state.
instance MonadState v (Handler b v) where
get = getsSnapletState _snapletValue
- put v = modifySnapletState (setL snapletValue v)
+ put v = modifySnapletState (set snapletValue v)
instance MonadSnaplet Handler where
@@ -292,7 +296,8 @@ runPureBase (Handler m) b = do
-- | Gets the route pattern that matched for the handler. This lets you find
-- out exactly which of the strings you used in addRoutes matched.
getRoutePattern :: Handler b v (Maybe ByteString)
-getRoutePattern = withTop' id $ liftM _scRoutePattern getOpaqueConfig
+getRoutePattern =
+ withTop' id $ liftM _scRoutePattern getOpaqueConfig
------------------------------------------------------------------------------
@@ -301,7 +306,7 @@ getRoutePattern = withTop' id $ liftM _scRoutePattern getOpaqueConfig
-- addRoutes.
setRoutePattern :: ByteString -> Handler b v ()
setRoutePattern p = withTop' id $
- modifySnapletState (setL (scRoutePattern . snapletConfig) (Just p))
+ modifySnapletState (set (snapletConfig . scRoutePattern) (Just p))
------------------------------------------------------------------------------
@@ -391,7 +396,7 @@ newtype Initializer b v a =
a)
deriving (Applicative, Functor, Monad, MonadIO)
-makeLenses [''InitializerState]
+makeLenses ''InitializerState
instance MonadSnaplet Initializer where
View
3  src/Snap/Snaplet/Session.hs
@@ -17,7 +17,6 @@ module Snap.Snaplet.Session
------------------------------------------------------------------------------
import Control.Monad.State
-import Data.Lens.Lazy
import Data.Text (Text)
import Snap.Core
------------------------------------------------------------------------------
@@ -33,7 +32,7 @@ import qualified Snap.Snaplet.Session.SessionManager as SM
------------------------------------------------------------------------------
-- | Wrap around a handler, committing any changes in the session at the end
--
-withSession :: Lens b (Snaplet SessionManager)
+withSession :: SnapletLens b SessionManager
-> Handler b v a
-> Handler b v a
withSession l h = do
View
11 test/snap-testsuite.cabal
@@ -21,9 +21,7 @@ Executable snap-testsuite
comonad >= 3.0 && < 3.1,
configurator >= 0.1 && < 0.3,
containers >= 0.3,
- data-lens >= 2.0.1 && < 2.11,
- data-lens-template >= 2.1.1 && < 2.2,
- directory,
+ directory >= 1.0 && < 1.3,
directory-tree >= 0.10 && < 0.12,
dlist >= 0.5 && < 0.6,
errors >= 1.3.1 && < 1.4,
@@ -32,6 +30,7 @@ Executable snap-testsuite
heist >= 0.10 && < 0.11,
http-conduit >= 1.4 && < 1.7,
http-types >= 0.6 && < 0.8,
+ lens >= 3.2 && < 3.3,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
@@ -89,8 +88,6 @@ Executable app
comonad >= 3.0 && < 3.1,
configurator >= 0.1 && < 0.3,
containers >= 0.3,
- data-lens >= 2.0.1 && < 2.11,
- data-lens-template >= 2.1.1 && < 2.2,
directory,
directory-tree >= 0.10 && < 0.12,
dlist >= 0.5 && < 0.6,
@@ -98,6 +95,7 @@ Executable app
filepath,
hashable >= 1.1,
heist >= 0.10 && < 0.11,
+ lens >= 3.2 && < 3.3,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
@@ -150,8 +148,6 @@ Executable nesttest
comonad >= 3.0 && < 3.1,
configurator >= 0.1 && < 0.3,
containers >= 0.3,
- data-lens >= 2.0.1 && < 2.11,
- data-lens-template >= 2.1.1 && < 2.2,
directory,
directory-tree >= 0.10 && < 0.12,
dlist >= 0.5 && < 0.6,
@@ -161,6 +157,7 @@ Executable nesttest
heist >= 0.10 && < 0.11,
http-conduit >= 1.4 && < 1.7,
http-types >= 0.6 && < 0.8,
+ lens >= 3.2 && < 3.3,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
View
4 test/suite/Blackbox/App.hs
@@ -12,8 +12,8 @@ import Prelude hiding (lookup)
------------------------------------------------------------------------------
import Control.Applicative
+import Control.Lens
import Control.Monad.Trans
-import Data.Lens.Lazy
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -63,7 +63,7 @@ app = makeSnaplet "app" "Test application" Nothing $ do
, ("/sessionTest", sessionTest)
]
wrapSite (<|> heistServe)
- return $ App hs (modL snapletValue fooMod fs) bs sm ns
+ return $ App hs (over snapletValue fooMod fs) bs sm ns
-------------------------------------------------------------------------------
View
9 test/suite/Blackbox/BarSnaplet.hs
@@ -7,11 +7,10 @@ module Blackbox.BarSnaplet where
import Prelude hiding (lookup)
+import Control.Lens
import Control.Monad.State
import qualified Data.ByteString as B
import Data.Configurator
-import Data.Lens.Lazy
-import Data.Lens.Template
import Data.Maybe
import Data.Text (Text)
import Snap.Snaplet
@@ -24,17 +23,17 @@ import Blackbox.FooSnaplet
data BarSnaplet b = BarSnaplet
{ _barField :: String
- , fooLens :: Lens b (Snaplet FooSnaplet)
+ , fooLens :: SnapletLens b FooSnaplet
}
-makeLens ''BarSnaplet
+makeLenses ''BarSnaplet
barsplice :: [(Text, SnapletISplice b)]
barsplice = [("barsplice", textSplice "contents of the bar splice")]
barInit :: HasHeist b
=> Snaplet (Heist b)
- -> Lens b (Snaplet FooSnaplet)
+ -> SnapletLens b FooSnaplet
-> SnapletInit b (BarSnaplet b)
barInit h l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do
config <- getSnapletUserConfig
View
4 test/suite/Blackbox/Common.hs
@@ -1,7 +1,7 @@
module Blackbox.Common where
+import Control.Lens
import Control.Monad.Trans
-import Data.Lens.Lazy
import qualified Data.Text as T
import Snap.Core
import Snap.Snaplet
@@ -20,6 +20,6 @@ genericConfigString = do
handlerConfig :: Handler b v ()
handlerConfig = writeText =<< genericConfigString
-shConfigSplice :: Lens (Snaplet b) (Snaplet v) -> SnapletISplice b
+shConfigSplice :: SnapletLens (Snaplet b) v -> SnapletISplice b
shConfigSplice _lens = textSplice =<< lift (with' _lens genericConfigString)
View
7 test/suite/Blackbox/EmbeddedSnaplet.hs
@@ -11,9 +11,8 @@
module Blackbox.EmbeddedSnaplet where
import Prelude hiding ((.))
+import Control.Lens
import Control.Monad.State
-import Data.Lens.Lazy
-import Data.Lens.Template
import qualified Data.Text as T
import System.FilePath.Posix
@@ -28,7 +27,7 @@ data EmbeddedSnaplet = EmbeddedSnaplet
, _embeddedVal :: Int
}
-makeLenses [''EmbeddedSnaplet]
+makeLenses ''EmbeddedSnaplet
instance HasHeist EmbeddedSnaplet where
heistLens = subSnaplet embeddedHeist
@@ -50,7 +49,7 @@ embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do
return $ EmbeddedSnaplet hs 42
-embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet))
+embeddedSplice :: (SnapletLens (Snaplet b) EmbeddedSnaplet)
-> SnapletISplice b
embeddedSplice embeddedLens = do
val <- lift $ with' embeddedLens $ gets _embeddedVal
View
4 test/suite/Blackbox/Types.hs
@@ -7,7 +7,7 @@
module Blackbox.Types where
-import Data.Lens.Template
+import Control.Lens
import Snap.Snaplet
import Snap.Snaplet.Heist
@@ -26,7 +26,7 @@ data App = App
, _embedded :: Snaplet EmbeddedSnaplet
}
-makeLenses [''App]
+makeLenses ''App
instance HasHeist App where heistLens = subSnaplet heist
View
9 test/suite/NestTest.hs
@@ -11,9 +11,8 @@
module Main where
import Prelude hiding ((.))
+import Control.Lens
import Control.Monad.State
-import Data.Lens.Lazy
-import Data.Lens.Template
import qualified Data.Text as T
import Snap.Http.Server.Config
import Snap.Core
@@ -30,7 +29,7 @@ data FooSnaplet = FooSnaplet
, _fooVal :: Int
}
-makeLenses [''FooSnaplet]
+makeLenses ''FooSnaplet
instance HasHeist FooSnaplet where
heistLens = subSnaplet fooHeist
@@ -51,7 +50,7 @@ fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do
--fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b)))
-- -> SnapletSplice (Handler b b)
-fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet))
+fooSplice :: (SnapletLens (Snaplet b) FooSnaplet)
-> SnapletISplice b
fooSplice fooLens = do
val <- lift $ with' fooLens $ gets _fooVal
@@ -63,7 +62,7 @@ data App = App
{ _foo :: Snaplet (FooSnaplet)
}
-makeLenses [''App]
+makeLenses ''App
app :: SnapletInit App App
app = makeSnaplet "app" "nested snaplet application" Nothing $ do
View
16 test/suite/Snap/Snaplet/Internal/LensT/Tests.hs
@@ -2,11 +2,11 @@
module Snap.Snaplet.Internal.LensT.Tests (tests) where
+import Control.Lens
import Control.Applicative
import Control.Category
import Control.Monad.Identity
import Control.Monad.State.Strict
-import Data.Lens.Template
import Prelude hiding (catch, (.))
import Test.Framework
import Test.Framework.Providers.HUnit
@@ -33,7 +33,9 @@ data TestBotType = TestBotType {
_bot0 :: Int
} deriving (Show)
-makeLenses [''TestType, ''TestSubType, ''TestBotType]
+makeLenses ''TestType
+makeLenses ''TestSubType
+makeLenses ''TestBotType
------------------------------------------------------------------------------
@@ -54,10 +56,10 @@ tests = testGroup "Snap.Snaplet.Internal.LensT"
testfmap :: Test
testfmap = testCase "lensed/fmap" $ do
-- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState
- let x = fst $ runIdentity (runLensT (fmap (*2) three) (bot . sub) defaultState)
+ let x = fst $ runIdentity (runLensT (fmap (*2) three) (sub . bot) defaultState)
assertEqual "fmap" 6 x
- let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)
+ let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)
assertEqual "fmap2" (12 :: Int) y
assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'
@@ -76,10 +78,10 @@ testfmap = testCase "lensed/fmap" $ do
testApplicative :: Test
testApplicative = testCase "lensed/applicative" $ do
-- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState
- let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (bot . sub) defaultState)
+ let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (sub . bot) defaultState)
assertEqual "fmap" 6 x
- let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)
+ let (y,s') = runIdentity (runLensT twiddle (sub . bot) defaultState)
assertEqual "fmap2" (12::Int) y
assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'
@@ -98,7 +100,7 @@ testApplicative = testCase "lensed/applicative" $ do
testMonadState :: Test
testMonadState = testCase "lens/MonadState" $ do
-- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState
- let s = snd $ runIdentity (runLensT go (bot0 . bot . sub) defaultState)
+ let s = snd $ runIdentity (runLensT go (sub . bot . bot0) defaultState)
assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s
assertEqual "sub0" 3 $ _sub0 $ _sub s
View
16 test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs
@@ -5,8 +5,8 @@ module Snap.Snaplet.Internal.Lensed.Tests (tests) where
import Control.Applicative
import Control.Category
import Control.Exception
+import Control.Lens
import Control.Monad.State.Strict
-import Data.Lens.Template
import Prelude hiding (catch, (.))
import Test.Framework
import Test.Framework.Providers.HUnit
@@ -33,7 +33,9 @@ data TestBotType = TestBotType {
_bot0 :: Int
} deriving (Show)
-makeLenses [''TestType, ''TestSubType, ''TestBotType]
+makeLenses ''TestType
+makeLenses ''TestSubType
+makeLenses ''TestBotType
------------------------------------------------------------------------------
@@ -52,10 +54,10 @@ tests = testGroup "Snap.Snaplet.Internal.Lensed"
------------------------------------------------------------------------------
testfmap :: Test
testfmap = testCase "lensed/fmap" $ do
- x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState
+ x <- evalStateT (lensedAsState (fmap (*2) three) (sub . bot)) defaultState
assertEqual "fmap" 6 x
- (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState
+ (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState
assertEqual "fmap2" 12 y
assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'
@@ -73,10 +75,10 @@ testfmap = testCase "lensed/fmap" $ do
------------------------------------------------------------------------------
testApplicative :: Test
testApplicative = testCase "lensed/applicative" $ do
- x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState
+ x <- evalStateT (lensedAsState (pure (*2) <*> three) (sub . bot)) defaultState
assertEqual "fmap" 6 x
- (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState
+ (y,s') <- runStateT (lensedAsState twiddle (sub . bot)) defaultState
assertEqual "fmap2" (12::Int) y
assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'
@@ -94,7 +96,7 @@ testApplicative = testCase "lensed/applicative" $ do
------------------------------------------------------------------------------
testMonadState :: Test
testMonadState = testCase "lens/MonadState" $ do
- s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState
+ s <- execStateT (lensedAsState go (sub . bot . bot0)) defaultState
assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s
assertEqual "sub0" 3 $ _sub0 $ _sub s
View
4 test/suite/Snap/Snaplet/Internal/Tests.hs
@@ -7,10 +7,10 @@ module Snap.Snaplet.Internal.Tests
( tests, initTest ) where
------------------------------------------------------------------------------
+import Control.Lens
import Control.Monad
import Control.Monad.Trans
import Data.ByteString (ByteString)
-import Data.Lens.Template
import Data.List
import Data.Text
import Prelude hiding (catch, (.))
@@ -39,7 +39,7 @@ data App = App
, _bar :: Snaplet Bar
}
-makeLens ''App
+makeLenses ''App
--showConfig :: SnapletConfig -> IO ()
--showConfig c = do
Please sign in to comment.
Something went wrong with that request. Please try again.