Refactor so the Heist snaplet doesn't import stuff from Internal.

examples/App.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 module Main where
 
-import Data.Lens.Lazy
 import Data.Lens.Template
 import qualified Data.Text as T
 import Snap.Core

src/Snap/Snaplet.hs

@@ -43,9 +43,11 @@ module Snap.Snaplet
   -- * Snaplet
   -- $snapletDoc
     Snaplet
+  , SnapletConfig
 
   -- * Snaplet Helper Functions
   -- $snapletHelpers
+  , snapletConfig
   , snapletValue
   , subSnaplet
 
@@ -55,6 +57,18 @@ module Snap.Snaplet
   -- * MonadSnaplet
   -- $monadSnaplet
   , MonadSnaplet(..)
+  , getSnapletAncestry
+  , getSnapletFilePath
+  , getSnapletName
+  , getSnapletDescription
+  , getSnapletUserConfig
+  , getSnapletRootURL
+
+  , getSnapletState
+  , putSnapletState
+  , modifySnapletState
+  , getsSnapletState
+
 --  , wrap
 --  , wrapTop
 

src/Snap/Snaplet/HeistNoClass.hs

@@ -55,8 +55,6 @@ import           Text.Templating.Heist
 import           Text.Templating.Heist.Splices.Cache
 
 import           Snap.Snaplet
--- TODO: It shouldn't be necessary to import this internal module.
-import           Snap.Snaplet.Internal.Types
 import           Snap.Core
 import           Snap.Util.FileServe
 
@@ -149,18 +147,12 @@ liftWith l = liftHandler . withTop' l
 instance MonadState v (SnapletHeist b v) where
     get = do
         l <- ask
-        b <- liftHandler lhGet
-        return $ _value $ getL l b
+        b <- liftHandler get
+        return $ getL (snapletValue . l) b
     put s = do
         l <- ask
-        b <- liftHandler lhGet
-        liftHandler $ lhPut $ setL l (b { _value = s}) b
-
-
-sConfig = do
-    l <- ask
-    b <- liftHandler lhGet
-    return $ _snapletConfig $ getL l b
+        b <- liftHandler get
+        liftHandler $ put $ setL (snapletValue . l) s b
 
 
 ------------------------------------------------------------------------------
@@ -170,12 +162,10 @@ instance MonadSnaplet SnapletHeist where
     getLens = ask
     with' l = withSS (l .)
     withTop' l = withSS (const id) . with' l
-    getSnapletAncestry = liftM _scAncestry sConfig
-    getSnapletFilePath = liftM _scFilePath sConfig
-    getSnapletName = liftM _scId sConfig
-    getSnapletDescription = liftM _scDescription sConfig
-    getSnapletConfig = liftM _scUserConfig sConfig
-    getSnapletRootURL = liftM getRootURL sConfig
+    getConfig = do
+        l <- ask
+        b <- liftHandler get
+        return $ getL (snapletConfig . l) b
 
 
 ------------------------------------------------------------------------------
@@ -249,7 +239,7 @@ renderHelper :: Maybe MIMEType
              -> ByteString
              -> Handler b (Heist b) ()
 renderHelper c t = do
-    (Heist ts _) <- get
+    (Heist ts _) <- getSnapletState
     withTop' id $ renderTemplate ts t >>= maybe pass serve
   where
     serve (b, mime) = do
@@ -287,10 +277,10 @@ heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))
             -> Handler b v a
             -> Handler b v a
 heistLocal' heist f m = do
-    hs  <- withTop' heist $ get
-    withTop' heist $ modify $ changeTS f
+    hs  <- withTop' heist $ getSnapletState
+    withTop' heist $ modifySnapletState $ changeTS f
     res <- m
-    withTop' heist $ put hs
+    withTop' heist $ putSnapletState hs
     return res
 
 

src/Snap/Snaplet/Internal/Lensed.hs

@@ -7,14 +7,13 @@ import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans
 import Data.Lens.Strict
-import Data.Functor
 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.Types
+import Snap.Core
 
 
 ------------------------------------------------------------------------------

src/Snap/Snaplet/Internal/RST.hs

@@ -12,7 +12,6 @@ import           Control.Applicative
 import           Control.Category
 import           Control.Monad.CatchIO
 import           Control.Monad.Reader
-import           Control.Monad.Reader.Class
 import           Control.Monad.State.Class
 import           Prelude hiding ((.), id, catch)
 import           Snap.Core

src/Snap/Snaplet/Internal/Types.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE FlexibleContexts           #-}
 
 module Snap.Snaplet.Internal.Types where
 
@@ -68,24 +69,18 @@ getRootURL sc = buildPath $ _scRouteContext sc
 --   the snaplet's root URL, and so on.
 data Snaplet s = Snaplet
     { _snapletConfig :: SnapletConfig
-    , _value         :: s
+    , _snapletValue  :: s
     }
 
 
 makeLenses [''SnapletConfig, ''Snaplet]
 
 
-------------------------------------------------------------------------------
--- | A lens to get the user defined state out of a Snaplet.
-snapletValue :: Lens (Snaplet a) a
-snapletValue = value
-
-
 ------------------------------------------------------------------------------
 -- | 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 = (. value)
+subSnaplet = (. snapletValue)
 
 
 ------------------------------------------------------------------------------
@@ -137,25 +132,35 @@ class MonadSnaplet m where
     -- | Gets the lens for the current snaplet.
     getLens :: m b v (Lens (Snaplet b) (Snaplet v))
 
-    -- | Gets a list of the names of snaplets that are direct ancestors of the
-    -- current snaplet.
-    getSnapletAncestry :: m b v [Text]
+    -- | Gets the current snaplet's config.
+    getConfig :: m b v SnapletConfig
 
-    -- | Gets the snaplet's path on the filesystem.
-    getSnapletFilePath :: m b v FilePath
 
-    -- | Gets the current snaple's name.
-    getSnapletName :: m b v (Maybe Text)
+-- | Gets a list of the names of snaplets that are direct ancestors of the
+-- current snaplet.
+getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text]
+getSnapletAncestry = return . _scAncestry =<< getConfig
 
-    -- | Gets the current snaple's name.
-    getSnapletDescription :: m b v Text
+-- | Gets the snaplet's path on the filesystem.
+getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath
+getSnapletFilePath = return . _scFilePath =<< getConfig
 
-    -- | Gets the config data structure for the current snaplet.
-    getSnapletConfig :: m b v Config
+-- | Gets the current snaple's name.
+getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text)
+getSnapletName = return . _scId =<< getConfig
 
-    -- | Gets the base URL for the current snaplet.  Directories get added to
-    -- the current snaplet path by calls to 'nestSnaplet'.
-    getSnapletRootURL :: m b v ByteString
+-- | Gets the current snaple's name.
+getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text
+getSnapletDescription = return . _scDescription =<< getConfig
+
+-- | Gets the config data structure for the current snaplet.
+getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config
+getSnapletUserConfig = return . _scUserConfig =<< getConfig
+
+-- | Gets the base URL for the current snaplet.  Directories get added to
+-- the current snaplet path by calls to 'nestSnaplet'.
+getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString
+getSnapletRootURL = liftM getRootURL getConfig
 
 
 -- Do we really need this stuff?
@@ -200,27 +205,48 @@ newtype Handler b v a =
            , MonadSnap)
 
 
-hConfig :: Handler b v SnapletConfig
-hConfig = Handler $ gets _snapletConfig
+------------------------------------------------------------------------------
+instance MonadState (Snaplet v) (Handler b v) where
+    get = Handler get
+    put = Handler . put
+
+
+------------------------------------------------------------------------------
+-- | Gets the current snaplet's state.
+getSnapletState :: MonadState (Snaplet a) m => m a
+getSnapletState = liftM _snapletValue get
+
+
+------------------------------------------------------------------------------
+-- | Modifies the current snaplet's state.
+modifySnapletState :: MonadState (Snaplet a) m => (a -> a) -> m ()
+modifySnapletState f = modify (modL snapletValue f)
+
+
+------------------------------------------------------------------------------
+-- | Puts the current snaplet's state.
+putSnapletState :: MonadState (Snaplet a) m => a -> m ()
+putSnapletState s = modifySnapletState (const s)
+
+
+------------------------------------------------------------------------------
+-- | Gets the current snaplet's state.
+getsSnapletState :: MonadState (Snaplet a) m => (a -> b) -> m b
+getsSnapletState f = liftM (f . _snapletValue) get
 
 
 instance MonadSnaplet Handler where
     getLens = Handler ask
     with' !l (Handler !m) = Handler $ L.with l m
     withTop' !l (Handler m) = Handler $ L.withTop l m
-    getSnapletAncestry = return . _scAncestry =<< hConfig
-    getSnapletFilePath = return . _scFilePath =<< hConfig
-    getSnapletName = return . _scId =<< hConfig
-    getSnapletDescription = return . _scDescription =<< hConfig
-    getSnapletConfig = return . _scUserConfig =<< hConfig
-    getSnapletRootURL = liftM getRootURL hConfig
+    getConfig = Handler $ gets _snapletConfig
 
 
 ------------------------------------------------------------------------------
 -- | Handler that reloads the site.
 reloadSite :: Handler b v ()
 reloadSite = failIfNotLocal $ do
-    cfg <- hConfig
+    cfg <- getConfig
     !res <- liftIO $ _reloader cfg
     either bad good res
   where
@@ -280,21 +306,11 @@ newtype Initializer b v a =
 makeLenses [''InitializerState]
 
 
-iConfig :: Initializer b v SnapletConfig
-iConfig = Initializer $ liftM _curConfig LT.getBase
-
-
 instance MonadSnaplet Initializer where
     getLens = Initializer ask
     with' !l (Initializer !m) = Initializer $ LT.with l m
     withTop' !l (Initializer m) = Initializer $ LT.withTop l m
-
-    getSnapletAncestry = return . _scAncestry =<< iConfig
-    getSnapletFilePath = return . _scFilePath =<< iConfig
-    getSnapletName = return . _scId =<< iConfig
-    getSnapletDescription = return . _scDescription =<< iConfig
-    getSnapletConfig = return . _scUserConfig =<< iConfig
-    getSnapletRootURL = liftM getRootURL iConfig
+    getConfig = Initializer $ liftM _curConfig LT.getBase
 
 
 ------------------------------------------------------------------------------
@@ -312,19 +328,3 @@ data ReloadInfo b = ReloadInfo
     , riAction  :: Initializer b b b
     }
 
-
-------------------------------------------------------------------------------
-instance MonadState v (Handler b v) where
-    get = liftM _value lhGet
-    put v = do
-        s <- lhGet
-        lhPut $ s { _value = v }
-
-lhGet :: Handler b v (Snaplet v)
-lhGet = Handler get
-{-# INLINE lhGet #-}
-
-lhPut :: Snaplet v -> Handler b v ()
-lhPut = Handler . put
-{-# INLINE lhPut #-}
-

src/Snap/Snaplet/Session.hs

@@ -56,7 +56,7 @@ setInSession :: Text -> Text -> Handler b SessionManager ()
 setInSession k v = do
   SessionManager r <- loadSession
   let r' = SM.insert k v r
-  put $ SessionManager r'
+  putSnapletState $ SessionManager r'
 
 
 -- | Get a key from the current session
@@ -71,14 +71,14 @@ deleteFromSession :: Text -> Handler b SessionManager ()
 deleteFromSession k = do
   SessionManager r <- loadSession
   let r' = SM.delete k r
-  put $ SessionManager r'
+  putSnapletState $ SessionManager r'
 
 
 -- | Returns a CSRF Token unique to the current session
 csrfToken :: Handler b SessionManager Text
 csrfToken = do
   mgr@(SessionManager r) <- loadSession
-  put mgr
+  putSnapletState mgr
   return $ SM.csrf r
 
 
@@ -94,21 +94,21 @@ resetSession :: Handler b SessionManager ()
 resetSession = do
   SessionManager r <- loadSession
   r' <- liftSnap $ SM.reset r
-  put $ SessionManager r'
+  putSnapletState $ SessionManager r'
 
 
 -- | Touch the session so the timeout gets refreshed
 touchSession :: Handler b SessionManager ()
 touchSession = do
   SessionManager r <- loadSession
   let r' = SM.touch r
-  put $ SessionManager r'
+  putSnapletState $ SessionManager r'
 
 
 -- | Load the session into the manager
 loadSession :: Handler b SessionManager SessionManager
 loadSession = do
-  SessionManager r <- get
+  SessionManager r <- getSnapletState
   r' <- liftSnap $ load r 
   return $ SessionManager r'
 

test/suite/Blackbox/App.hs

@@ -38,7 +38,7 @@ routeWithSplice = do
 
 routeWithConfig :: Handler App App ()
 routeWithConfig = do
-    cfg <- getSnapletConfig
+    cfg <- getSnapletUserConfig
     val <- liftIO $ lookup cfg "topConfigField"
     writeText $ "routeWithConfig: " `T.append` fromJust val
 

test/suite/Blackbox/BarSnaplet.hs

@@ -36,7 +36,7 @@ barInit :: HasHeist b
         => Lens b (Snaplet FooSnaplet)
         -> SnapletInit b (BarSnaplet b)
 barInit l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do
-    config <- getSnapletConfig
+    config <- getSnapletUserConfig
     addTemplates ""
     rootUrl <- getSnapletRootURL
     addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust)