From d48a95a40e20ad76dcb9963cdc0f70ab49ebb1b7 Mon Sep 17 00:00:00 2001
From: Libby <Libby Horacek>
Date: Mon, 8 Apr 2019 21:47:45 -0400
Subject: [PATCH 1/2] Use plain Haskell functions instead of StateT

---
 src/Web/Larceny.hs          |  2 +-
 src/Web/Larceny/Fills.hs    | 38 ++++++++++++++++++++-----------
 src/Web/Larceny/Internal.hs | 29 ++++++++++++------------
 src/Web/Larceny/Types.hs    |  9 ++++++--
 test/Examples.hs            |  6 ++---
 test/Spec.hs                | 45 ++++++++++++++++++-------------------
 6 files changed, 73 insertions(+), 56 deletions(-)

diff --git a/src/Web/Larceny.hs b/src/Web/Larceny.hs
index 9742f4d..70ba914 100644
--- a/src/Web/Larceny.hs
+++ b/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.
diff --git a/src/Web/Larceny/Fills.hs b/src/Web/Larceny/Fills.hs
index 107339b..ae35a1b 100644
--- a/src/Web/Larceny/Fills.hs
+++ b/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.
 --
diff --git a/src/Web/Larceny/Internal.hs b/src/Web/Larceny/Internal.hs
index f71cbe5..5cf3e07 100644
--- a/src/Web/Larceny/Internal.hs
+++ b/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
diff --git a/src/Web/Larceny/Types.hs b/src/Web/Larceny/Types.hs
index 4fb1ad7..897704a 100644
--- a/src/Web/Larceny/Types.hs
+++ b/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]
diff --git a/test/Examples.hs b/test/Examples.hs
index 0b1c4e0..edae515 100644
--- a/test/Examples.hs
+++ b/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")]
diff --git a/test/Spec.hs b/test/Spec.hs
index 94eae1e..9d66e72 100644
--- a/test/Spec.hs
+++ b/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) #-}

From 87415eb6adef7bb004b7e533e7613de5d1a86924 Mon Sep 17 00:00:00 2001
From: Libby <Libby Horacek>
Date: Mon, 8 Apr 2019 22:17:42 -0400
Subject: [PATCH 2/2] Add Legacy module with old arguments

---
 src/Web/Larceny/Legacy.hs | 98 +++++++++++++++++++++++++++++++++++++++
 test/Spec.hs              | 15 ++++++
 2 files changed, 113 insertions(+)
 create mode 100644 src/Web/Larceny/Legacy.hs

diff --git a/src/Web/Larceny/Legacy.hs b/src/Web/Larceny/Legacy.hs
new file mode 100644
index 0000000..dc19e05
--- /dev/null
+++ b/src/Web/Larceny/Legacy.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Web.Larceny.Legacy ( textFill
+                          , textFill'
+                          , rawTextFill
+                          , rawTextFill'
+                          , mapSubs
+                          , mapSubs'
+                          , fillChildren
+                          , fillChildrenWith
+                          , fillChildrenWith'
+                          , maybeFillChildrenWith
+                          , maybeFillChildrenWith'
+                          , ifFill
+                          , useAttrs
+                          , a
+                          , (%)
+                          , fill ) where
+
+import           Control.Exception
+import           Control.Monad       (foldM)
+import           Control.Monad.State (StateT, runStateT)
+import qualified Data.Map            as M
+import           Data.Maybe          (fromMaybe)
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+import qualified HTMLEntities.Text   as HE
+------------
+import           Web.Larceny.Types
+import           Web.Larceny.Fills hiding (textFill', rawTextFill', mapSubs', fillChildrenWith', maybeFillChildrenWith')
+
+
+fill :: (Attributes -> (Path, Template s) -> Library s -> StateT s IO Text) -> Fill s
+fill f = Fill $ \attrs t lib st -> runStateT (f attrs t lib) st
+
+-- | Use state or IO, then fill in some text.
+--
+-- @
+-- -- getTextFromDatabase :: StateT () IO Text
+-- textFill' getTextFromDatabase
+-- @
+textFill' :: StateT s IO Text -> Fill s
+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.
+--
+-- @
+-- -- getTextFromDatabase :: StateT () IO Text
+-- textFill' getTextFromDatabase
+-- @
+rawTextFill' :: StateT s IO Text -> Fill s
+rawTextFill' t = Fill $ \_m _t _l -> runStateT t
+
+-- | 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 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
+
+-- | Use substitutions with State and IO.
+--
+-- @
+-- \<changeTheWorld>\<results \/>\<\/changeTheWorld>
+-- -- doABunchOfStuffAndGetSubstitutions :: StateT () IO (Substitutions ())
+-- ("changeTheWorld", fillChildrenWith' doStuffAndGetSubstitutions)
+-- @
+--
+-- > This template did IO!
+fillChildrenWith' :: StateT s IO (Substitutions s) -> Fill s
+fillChildrenWith' m = maybeFillChildrenWith' (Just <$> m)
+
+-- | Use state and IO and maybe fill in with some substitutions.
+--
+-- @
+-- \<ifLoggedIn>Logged in as \<userName \/>\<\/ifLoggedIn>
+-- ("ifLoggedIn", maybeFillChildrenWith' $ do
+--                  mUser <- getLoggedInUser -- returns (Just "Bonnie Thunders")
+--                  case mUser of
+--                    Just user -> Just $ subs' ("userName", textFill user)
+--                    Nothing   -> Nothing)
+-- @
+--
+-- > Bonnie Thunders
+maybeFillChildrenWith' :: StateT s IO (Maybe (Substitutions s)) -> Fill s
+maybeFillChildrenWith' sMSubs = Fill $ \_s (pth, Template tpl) l st -> do
+  (mSubs, newState) <- runStateT sMSubs st
+  case mSubs of
+    Nothing -> return ("", newState)
+    Just s  -> tpl pth s l newState
\ No newline at end of file
diff --git a/test/Spec.hs b/test/Spec.hs
index 9d66e72..79728fd 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -25,6 +25,7 @@ import           Examples
 import           Test.Hspec
 import qualified Test.Hspec.Core.Spec    as H
 import           Web.Larceny
+import qualified Web.Larceny.Legacy       as Legacy
 
 infix  4 .=
 (.=) :: S.MonadState s m => ASetter s s a b -> b -> m ()
@@ -428,6 +429,7 @@ spec = hspec $ do
     doctypeTests
     conditionalTests
     namespaceTests
+  legacyTests
   statefulTests
 
 namespaceTests :: SpecWith LarcenyHspecState
@@ -489,6 +491,19 @@ doctypeTests = do
       "<!DOCTYPE html><html><p>Hello world</p></html>"
       `shouldRenderM` "<!DOCTYPE html><html><p>Hello world</p></html>"
 
+legacyTests :: SpecWith ()
+legacyTests = do
+  describe "legacy functions" $ do
+    it "should have the same arguments as old Fill" $ do
+       renderWith (M.fromList [(["default"], parse "<x/><x/>")])
+                  (subs [("x", Legacy.fill $ \_ _ _ ->
+                                 do modify ((+1) :: Int -> Int)
+                                    s <- get
+                                    return (T.pack (show s)))])
+                  0
+                  ["default"]
+          `shouldReturn` Just "12"
+
 conditionalTests :: SpecWith LarcenyHspecState
 conditionalTests = do
   describe "conditionals" $ do