Use plain Haskell functions instead of StateT

Author: Libby

src/Web/Larceny.hs

@@ -130,7 +130,7 @@ renderWith l sub s = renderRelative l sub s []
 renderRelative :: Library s -> Substitutions s -> s -> Path -> Path -> IO (Maybe Text)
 renderRelative l sub s givenPath targetPath =
   case findTemplate l givenPath targetPath of
-    (pth, Just (Template run)) -> Just <$> evalStateT (run pth sub l) s
+    (pth, Just (Template run)) -> Just <$> fst <$> run pth sub l s
     (_, Nothing) -> return Nothing
 
 -- | Load all the templates in some directory into a Library.

src/Web/Larceny/Fills.hs

@@ -17,7 +17,8 @@ module Web.Larceny.Fills ( textFill
                          , (%)) where
 
 import           Control.Exception
-import           Control.Monad.State (StateT)
+import           Control.Monad       (foldM)
+import           Control.Monad.State (StateT, runStateT)
 import qualified Data.Map            as M
 import           Data.Maybe          (fromMaybe)
 import           Data.Text           (Text)
@@ -100,7 +101,9 @@ rawTextFill t = rawTextFill' (return t)
 -- textFill' getTextFromDatabase
 -- @
 textFill' :: StateT s IO Text -> Fill s
-textFill' t = Fill $ \_m _t _l -> HE.text <$> t
+textFill' t = Fill $ \_m _t _l st -> do
+   (t, st') <- runStateT t st
+   return (HE.text t, st')
 
 -- | Use state or IO, then fill in some text.
 --
@@ -109,7 +112,7 @@ textFill' t = Fill $ \_m _t _l -> HE.text <$> t
 -- textFill' getTextFromDatabase
 -- @
 rawTextFill' :: StateT s IO Text -> Fill s
-rawTextFill' t = Fill $ \_m _t _l -> t
+rawTextFill' t = Fill $ \_m _t _l -> runStateT t
 
 -- | Create substitutions for each element in a list and fill the child nodes
 -- with those substitutions.
@@ -124,17 +127,26 @@ rawTextFill' t = Fill $ \_m _t _l -> t
 mapSubs :: (a -> Substitutions s)
         -> [a]
         -> Fill s
-mapSubs f xs = Fill $ \_attrs (pth, tpl) lib ->
-    T.concat <$>  mapM (\n -> runTemplate tpl pth (f n) lib) xs
+mapSubs f xs = Fill $ \_attrs (pth, tpl) lib st ->
+  foldM
+    (\(text, st) item -> do
+      (t , st') <- runTemplate tpl pth (f item) lib st
+      return (text <> t, st'))
+    ("", st)
+    xs
 
 -- | Create substitutions for each element in a list (using IO/state if
 -- needed) and fill the child nodes with those substitutions.
 mapSubs' :: (a -> StateT s IO (Substitutions s)) -> [a] -> Fill s
 mapSubs' f xs = Fill $
-  \_m (pth, tpl) lib ->
-    T.concat <$>  mapM (\x -> do
-                           s' <- f x
-                           runTemplate tpl pth s' lib) xs
+  \_m (pth, tpl) lib st ->
+    foldM
+      (\(text, st) item -> do
+        (s', st' ) <- runStateT (f item) st
+        (t , st'') <- runTemplate tpl pth s' lib st'
+        return (text <> t, st''))
+      ("", st)
+      xs
 
 -- | Fill in the child nodes of the blank with substitutions already
 -- available.
@@ -198,11 +210,11 @@ maybeFillChildrenWith (Just s) = Fill $ \_s (pth, Template tpl) l ->
 --
 -- > Bonnie Thunders
 maybeFillChildrenWith' :: StateT s IO (Maybe (Substitutions s)) -> Fill s
-maybeFillChildrenWith' sMSubs = Fill $ \_s (pth, Template tpl) l -> do
-  mSubs <- sMSubs
+maybeFillChildrenWith' sMSubs = Fill $ \_s (pth, Template tpl) l st -> do
+  (mSubs, newState) <- runStateT sMSubs st
   case mSubs of
-    Nothing -> return ""
-    Just s  -> tpl pth s l
+    Nothing -> return ("", newState)
+    Just s  -> tpl pth s l newState
 
 -- | Use attributes from the the blank as arguments to the fill.
 --

src/Web/Larceny/Internal.hs

@@ -96,22 +96,23 @@ toLarcenyNode _ (X.NodeInstruction _) = NodeContent ""
 mk :: Overrides -> [Node] -> Template s
 mk o = f
   where f nodes =
-          Template $ \pth m l ->
+          Template $ \pth m l st ->
                       let pc = ProcessContext pth m l o f nodes in
-                      do s <- get
-                         T.concat <$> toUserState (pc s) (process nodes)
+                      do (textList, st') <- toUserState (pc st) (process nodes)
+                         return (T.concat textList, st')
 
-toProcessState :: StateT s IO a -> StateT (ProcessContext s) IO a
+
+toProcessState :: (s -> IO (a, s)) -> StateT (ProcessContext s) IO a
 toProcessState f =
   do pc <- get
-     (result, s') <- liftIO $ runStateT f (_pcState pc)
+     (result, s') <- liftIO $ f (_pcState pc)
      pcState .= s'
      return result
 
-toUserState :: ProcessContext s -> StateT (ProcessContext s) IO a -> StateT s IO a
-toUserState pc f =
-  do s <- get
-     liftIO $ evalStateT f (pc { _pcState = s })
+toUserState :: ProcessContext s -> StateT (ProcessContext s) IO a -> IO (a, s)
+toUserState pc f = 
+  do (a, st) <- runStateT f pc
+     return (a, _pcState st)
 
 fillIn :: Blank -> Substitutions s -> Fill s
 fillIn tn m = fromMaybe (fallbackFill tn m) (M.lookup tn m)
@@ -120,9 +121,9 @@ fallbackFill :: Blank -> Substitutions s -> Fill s
 fallbackFill FallbackBlank m =  fromMaybe (textFill "") (M.lookup FallbackBlank m)
 fallbackFill (Blank tn) m =
   let fallback = fromMaybe (textFill "") (M.lookup FallbackBlank m) in
-  Fill $ \attr (pth, tpl) lib ->
-    do liftIO $ putStrLn ("Larceny: Missing fill for blank " <> show tn <> " in template " <> show pth)
-       unFill fallback attr (pth, tpl) lib
+  Fill $ \attr (pth, tpl) lib st ->
+    do putStrLn ("Larceny: Missing fill for blank " <> show tn <> " in template " <> show pth)
+       unFill fallback attr (pth, tpl) lib st
 
 data ProcessContext s = ProcessContext { _pcPath          :: Path
                                        , _pcSubs          :: Substitutions s
@@ -227,11 +228,11 @@ fillAttrs attrs =  M.fromList <$> mapM fill (M.toList attrs)
 
 fillAttr :: Either Text Blank -> StateT (ProcessContext s) IO Text
 fillAttr eBlankText =
-  do (ProcessContext pth m l _ mko _ _) <- get
+  do pc@(ProcessContext pth m l _ mko _ _) <- get
      toProcessState $
        case eBlankText of
          Right hole -> unFill (fillIn hole m) mempty (pth, mko []) l
-         Left text -> return text
+         Left text -> \s -> return (text, s)
 
 -- Look up the Fill for the hole.  Apply the Fill to a map of
 -- attributes, a Template made from the child nodes (adding in the

src/Web/Larceny/Types.hs

@@ -43,6 +43,9 @@ instance Hashable Blank where
   hashWithSalt s (Blank tn) = s + hash tn
   hashWithSalt s FallbackBlank = s + hash ("FallbackBlank" :: Text)
 
+-- A transitional type
+type StateTsIOText s = IO (Text, s)
+
 -- | A  Fill is how to fill in a Blank.
 --
 -- In most cases, you can use helper functions like `textFill` or
@@ -69,7 +72,8 @@ instance Hashable Blank where
 newtype Fill s = Fill { unFill :: Attributes
                                -> (Path, Template s)
                                -> Library s
-                               -> StateT s IO Text }
+                               -> s
+                               -> StateTsIOText s }
 
 -- | The Blank's attributes, a map from the attribute name to
 -- it's value.
@@ -118,7 +122,8 @@ fallbackSub fill = M.fromList [(FallbackBlank, fill)]
 newtype Template s = Template { runTemplate :: Path
                                             -> Substitutions s
                                             -> Library s
-                                            -> StateT s IO Text }
+                                            -> s
+                                            -> StateTsIOText s }
 
 -- | The path to a template.
 type Path = [Text]

test/Examples.hs

@@ -64,10 +64,10 @@ subst = subs [ ("site-title", textFill "Gotham Girls roster")
 
 modifyInnerText :: (Text -> Text) -> Fill ()
 modifyInnerText f = Fill $
-  \_attrs (_pth, tpl) _l ->
+  \_attrs (_pth, tpl) _l st ->
     liftIO $ do
-      t' <- evalStateT (runTemplate tpl ["default"] mempty mempty) ()
-      return $ f t'
+      (t', st') <- runTemplate tpl ["default"] mempty mempty st
+      return $ (f t', st')
 
 tplLib :: Library ()
 tplLib = M.fromList [(["skater"], parse "Beyonslay")]

test/Spec.hs

@@ -116,7 +116,8 @@ renderM :: Text -> LarcenyHspecM Text
 renderM templateText = do
   (LarcenyHspecState _ (LarcenyState p s l o)) <- S.get
   let tpl = parseWithOverrides o (LT.fromStrict templateText)
-  liftIO $ evalStateT (runTemplate tpl p s l) ()
+  (a, s) <- liftIO $ runTemplate tpl p s l ()
+  return a
 
 shouldRenderM :: Text -> Text -> LarcenyHspecM ()
 shouldRenderM templateText output = do
@@ -325,19 +326,19 @@ spec = hspec $ do
       it "should allow you to write functions for fills" $ do
         let subs' =
               subs [("desc",
-                     Fill $ \m _t _l -> return $ T.take (read $ T.unpack (m M.! "length"))
-                                        "A really long description"
-                                        <> "...")]
+                     Fill $ \m _t _l s -> return (T.take (read $ T.unpack (m M.! "length"))
+                                           "A really long description"
+                                            <> "...", s))]
         hLarcenyState.lSubs .= subs'
         "<l:desc length=\"10\" />" `shouldRenderM` "A really l..."
 
       it "should allow you to use IO in fills" $ do
         let subs' =
               subs [("desc", Fill $
-                          \m _t _l -> do liftIO $ putStrLn "***********\nHello World\n***********"
-                                         return $ T.take (read $ T.unpack (m M.! "length"))
-                                           "A really long description"
-                                           <> "...")]
+                          \m _t _l s -> do putStrLn "***********\nHello World\n***********"
+                                           return (T.take (read $ T.unpack (m M.! "length"))
+                                             "A really long description"
+                                             <> "...", s))]
         hLarcenyState.lSubs .= subs'
         "<l:desc length=\"10\" />" `shouldRenderM` "A really l..."
 
@@ -383,7 +384,7 @@ spec = hspec $ do
            `shouldRenderM` "<p class=\"lots of space\"></p>"
 
       it "should know what the template path is" $ do
-        let fill = Fill $ \_ (p, _) _ -> return (head p)
+        let fill = Fill $ \_ (p, _) _ s -> return (head p, s)
         hLarcenyState.lSubs .= subs [("template", fill)]
         "<p class=\"${template}\"></p>"
           `shouldRenderM` "<p class=\"default\"></p>"
@@ -453,10 +454,9 @@ statefulTests =
   describe "statefulness" $ do
       it "a fill should be able to affect subsequent fills" $ do
          renderWith (M.fromList [(["default"], parse "<x/><x/>")])
-                    (subs [("x", Fill $ \_ _ _ ->
-                                   do modify ((+1) :: Int -> Int)
-                                      s <- get
-                                      return (T.pack (show s)))])
+                    (subs [("x", Fill $ \_ _ _ s ->
+                                    do let s' = s + 1
+                                       return (T.pack (show s'), s'))])
                     0
                     ["default"]
          `shouldReturn` Just "12"
@@ -471,10 +471,9 @@ statefulTests =
                  \<bind tag=\"test2\">test2</bind>\
                  \<x/><x/>"
        renderWith (M.fromList [(["default"], parse tpl)])
-                    (subs [("x", Fill $ \_ _ _ ->
-                                   do modify ((+1) :: Int -> Int)
-                                      s <- get
-                                      return (T.pack (show s)))])
+                    (subs [("x", Fill $ \_ _ _ s ->
+                                   do let s' = s + 1
+                                      return (T.pack (show s'), s'))])
                     0
                     ["default"]
          `shouldReturn` Just "12"
@@ -641,9 +640,9 @@ attrTests =
       it "should allow you use child elements" $ do
         let descTplFill =
               useAttrs (a"length")
-                       (\n -> Fill $ \_attrs (_pth, tpl) _l -> liftIO $ do
-                           t' <- evalStateT (runTemplate tpl ["default"] mempty mempty) ()
-                           return $ T.take n t' <> "...")
+                       (\n -> Fill $ \_attrs (_pth, tpl) _l st -> liftIO $ do
+                           (t', st') <- runTemplate tpl ["default"] mempty mempty st
+                           return (T.take n t' <> "...", st'))
         hLarcenyState.lSubs .= subs [ ("adverb", textFill "really")
                                     , ("desc", descTplFill)]
         "<l:desc length=\"10\">A <adverb /> long description</desc>"
@@ -681,8 +680,8 @@ attrTests =
         descFunc :: Int -> Maybe Text -> Fill ()
         descFunc n e = Fill $
           do let ending = fromMaybe "..."  e
-             \_attrs (_pth, tpl) _l -> liftIO $ do
-               renderedText <- evalStateT (runTemplate tpl ["default"] mempty mempty) ()
-               return $ T.take n renderedText <> ending
+             \_attrs (_pth, tpl) _l st -> liftIO $ do
+               (renderedText, st') <- runTemplate tpl ["default"] mempty mempty st
+               return (T.take n renderedText <> ending, st')
 
 {-# ANN module ("HLint: ignore Redundant do" :: String) #-}