Permalink
Browse files

Working on switching to lens

  • Loading branch information...
1 parent ecc0dc2 commit 346fdc4cc142b0f759eb49ce1556c00877c2b7a6 @mightybyte mightybyte committed Oct 29, 2012
View
@@ -147,13 +147,12 @@ 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,
+ lens >= 3.0.1 && < 3.1,
logict >= 0.4.2 && < 0.6,
mtl > 2.0 && < 2.2,
mwc-random >= 0.8 && < 0.13,
View
@@ -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
@@ -19,8 +19,8 @@ module Snap.Snaplet.Auth.AuthManager
) where
------------------------------------------------------------------------------
+import Control.Lens
import Data.ByteString (ByteString)
-import Data.Lens.Lazy
import Data.Text (Text)
import Data.Time
import Web.ClientSession
@@ -13,6 +13,7 @@ module Snap.Snaplet.Auth.Backends.JsonFile
import Control.Applicative
import Control.Monad.State
import Control.Concurrent.STM
+import Control.Lens
import Data.Aeson
import qualified Data.Attoparsec as Atto
import qualified Data.ByteString.Lazy as LB
@@ -22,7 +23,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
@@ -12,9 +12,9 @@ module Snap.Snaplet.Auth.Handlers where
------------------------------------------------------------------------------
import Control.Applicative
import Control.Error
+import Control.Lens
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)
@@ -22,8 +22,8 @@ module Snap.Snaplet.Auth.SpliceHelpers
, cLoggedInUser
) where
+import Control.Lens
import Control.Monad.Trans
-import Data.Lens.Lazy
import Data.Monoid
import Data.Text (Text)
import qualified Text.XmlHtml as X
@@ -46,8 +46,8 @@ module Snap.Snaplet.Heist
------------------------------------------------------------------------------
import Prelude hiding (id, (.))
+import Control.Lens
import Data.ByteString (ByteString)
-import Data.Lens.Lazy
import Data.Text (Text)
import Heist
------------------------------------------------------------------------------
@@ -57,6 +57,7 @@ import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Error
+import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString (ByteString)
@@ -66,7 +67,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
@@ -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 => SimpleLens 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 (view (reflectLens l) b)
+ return $ set (reflectLens 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
------------------------------------------------------------------------------
@@ -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))
+ -> (SimpleLens v (Snaplet 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,21 +295,21 @@ 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))
+ -> (SimpleLens v (Snaplet v1))
-- ^ Lens identifying the snaplet
-> SnapletInit v1 v1
-- ^ The initializer function for the subsnaplet.
-> Initializer b v (Snaplet v1)
embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do
curLens <- getLens
setupSnapletCall ""
- chroot rte (subSnaplet l . curLens) snaplet
+ chroot rte (ReifyLens (reflectLens curLens . (reflectLens $ subSnaplet l))) snaplet
------------------------------------------------------------------------------
-- | Changes the base state of an initializer.
chroot :: ByteString
- -> (Lens (Snaplet b) (Snaplet v1))
+ -> (SimpleLens (Snaplet b) (Snaplet 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 :: (SimpleLens (Snaplet v) (Snaplet 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 (view (reflectLens l) s)
+ modify $ set (reflectLens 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)
------------------------------------------------------------------------------
@@ -7,17 +7,17 @@ module Snap.Snaplet.Internal.LensT where
import Control.Applicative
import Control.Category
+import Control.Lens
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 (SimpleReifiedLens b v) s m a)
deriving ( Monad
, MonadTrans
, Functor
@@ -26,7 +26,7 @@ newtype LensT b v s m a = LensT (RST (Lens b v) s m a)
, MonadPlus
, MonadCatchIO
, Alternative
- , MonadReader (Lens b v)
+ , MonadReader (SimpleReifiedLens b v)
, MonadSnap )
@@ -53,7 +53,7 @@ lGet :: (Monad m) => LensT b v b m v
lGet = LensT $ do
!l <- ask
!b <- get
- return $! l ^$ b
+ return $! b ^. reflectLens l
{-# INLINE lGet #-}
@@ -62,23 +62,19 @@ lPut :: (Monad m) => v -> LensT b v b m ()
lPut v = LensT $ do
!l <- ask
!b <- get
- put $! (l ^!= v) b
+ put $! set (reflectLens 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 -> SimpleLens b v -> s -> m (a, s)
+runLensT (LensT m) l = runRST m (ReifyLens l)
{-# INLINE runLensT #-}
------------------------------------------------------------------------------
-withLensT :: Monad m =>
- ((Lens b' v') -> (Lens b v))
+withLensT :: Monad m
+ => ((SimpleReifiedLens b' v') -> (SimpleReifiedLens b v))
-> LensT b v s m a
-> LensT b' v' s m a
withLensT f (LensT m) = LensT $ withRST f m
@@ -87,19 +83,14 @@ withLensT f (LensT m) = LensT $ withRST f m
------------------------------------------------------------------------------
withTop :: Monad m
- => (Lens b v')
+ => (SimpleLens b v')
-> LensT b v' s m a
-> LensT b v s m a
-withTop !subLens = withLensT (const subLens)
+withTop subLens = withLensT (const (ReifyLens 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 => SimpleLens v v' -> LensT b v' s m a -> LensT b v s m a
+with subLens = withLensT (\l -> ReifyLens $ reflectLens l . subLens)
Oops, something went wrong.

0 comments on commit 346fdc4

Please sign in to comment.