Store Larceny state in monad transformer stack

larceny.cabal

@@ -23,6 +23,7 @@ library
                      , Web.Larceny.Internal
                      , Web.Larceny.Types
                      , Web.Larceny.Fills
+                     , Web.Larceny.Legacy
   other-extensions:    OverloadedStrings
   build-depends:       base >=4.8 && <5
                      , containers >=0.5 && <0.6

src/Web/Larceny.hs

@@ -81,7 +81,8 @@ module Web.Larceny ( Blank(..)
                    , a
                    , (%)
                    , parse
-                   , parseWithOverrides) where
+                   , parseWithOverrides
+                   , LarcenyState(..)) where
 
 import           Control.Monad        (filterM)
 import           Control.Monad.State  (evalStateT)
@@ -130,7 +131,9 @@ 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)) ->
+      let larcenyState = LarcenyState pth sub l defaultOverrides print s in
+        Just <$> evalStateT (run sub) larcenyState
     (_, 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.State (StateT, get)
+import           Control.Monad.Trans (liftIO)
 import qualified Data.Map            as M
 import           Data.Maybe          (fromMaybe)
 import           Data.Text           (Text)
@@ -100,16 +101,15 @@ 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 $ \_a _t -> HE.text <$> toLarcenyState t 
 -- | 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 -> t
+rawTextFill' t = Fill $ \_a _t -> toLarcenyState t
 
 -- | Create substitutions for each element in a list and fill the child nodes
 -- with those substitutions.
@@ -124,17 +124,17 @@ 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 tpl -> do
+    T.concat <$>  mapM (\n -> runTemplate tpl (f n)) 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 ->
+  \_m tpl -> do
     T.concat <$>  mapM (\x -> do
-                           s' <- f x
-                           runTemplate tpl pth s' lib) xs
+                           s' <- toLarcenyState $ f x
+                           runTemplate tpl s') xs
 
 -- | Fill in the child nodes of the blank with substitutions already
 -- available.
@@ -182,8 +182,8 @@ fillChildrenWith' m = maybeFillChildrenWith' (Just <$> m)
 -- > Bonnie Thunders
 maybeFillChildrenWith :: Maybe (Substitutions s) -> Fill s
 maybeFillChildrenWith Nothing = textFill ""
-maybeFillChildrenWith (Just s) = Fill $ \_s (pth, Template tpl) l ->
-  tpl pth s l
+maybeFillChildrenWith (Just s) = Fill $ \_attrs tpl -> do
+  runTemplate tpl s
 
 -- | Use state and IO and maybe fill in with some substitutions.
 --
@@ -198,11 +198,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 (Template tpl) -> do
+  mSubs <- toLarcenyState sMSubs
   case mSubs of
     Nothing -> return ""
-    Just s  -> tpl pth s l
+    Just s  -> tpl s
 
 -- | Use attributes from the the blank as arguments to the fill.
 --
@@ -223,8 +223,8 @@ maybeFillChildrenWith' sMSubs = Fill $ \_s (pth, Template tpl) l -> do
 useAttrs :: (Attributes -> k -> Fill s)
          ->  k
          ->  Fill s
-useAttrs k fill= Fill $ \atrs (pth, tpl) lib ->
-  unFill (k atrs fill) atrs (pth, tpl) lib
+useAttrs k fill= Fill $ \atrs tpl ->
+  unFill (k atrs fill) atrs tpl
 
 -- | Prepend `a` to the name of an attribute to pass the value of that
 -- attribute to the fill.

src/Web/Larceny/Internal.hs

@@ -1,13 +1,13 @@
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Web.Larceny.Internal ( findTemplate
                             , parse
                             , parseWithOverrides) where
 
 import           Control.Exception
-import           Lens.Micro
+import           Lens.Micro          ((.~))
+import           Control.Monad.State (MonadState, modify, get)
 import           Control.Monad.Trans (liftIO)
-import           Control.Monad.State (MonadState, StateT, evalStateT, runStateT, get, modify)
 import qualified Data.HashSet        as HS
 import qualified Data.Map            as M
 import           Data.Maybe          (fromMaybe)
@@ -18,27 +18,17 @@ import qualified Data.Text.Lazy      as LT
 import qualified Text.HTML.DOM       as D
 import qualified Text.XML            as X
 ------------
-import           Web.Larceny.Types
 import           Web.Larceny.Fills
 import           Web.Larceny.Html    (html5Nodes, html5SelfClosingNodes)
 import           Web.Larceny.Svg     (svgNodes)
-
--- | Turn lazy text into templates.
-parse :: LT.Text -> Template s
-parse = parseWithOverrides defaultOverrides
-
--- | Use overrides when parsing a template.
-parseWithOverrides :: Overrides -> LT.Text -> Template s
-parseWithOverrides o t =
-  let textWithoutDoctype = LT.replace "<!DOCTYPE html>" "<doctype />" t
-      (X.Document _ (X.Element _ _ nodes) _) = D.parseLT ("<div>" <> textWithoutDoctype <> "</div>")
-  in mk o $! map (toLarcenyNode o) nodes
+import           Web.Larceny.Types
 
 -- | Phases of the template parsing/rendering process: 1. Parse the document
 --     into HTML (or really, XML) nodes 2. Turn those nodes into Larceny nodes,
 --     which encodes more information about the elements, including prefix and
 --     whether the node is a regular HTML node, a special Larceny element, or a
 --     Larceny blank. 3. Render each node into Text according to its node type.
+
 data Node = NodeElement Element
           | NodeContent Text
           | NodeComment Text
@@ -49,6 +39,18 @@ data Element = PlainElement Name Attributes [Node]
              | BlankElement Name Attributes [Node]
              | DoctypeElement
 
+-- | Turn lazy text into templates.
+parse :: LT.Text -> Template s
+parse = parseWithOverrides defaultOverrides
+
+-- | Use overrides when parsing a template.
+parseWithOverrides :: Overrides -> LT.Text -> Template s
+parseWithOverrides o t =
+  let textWithoutDoctype = LT.replace "<!DOCTYPE html>" "<doctype />" t
+      (X.Document _ (X.Element _ _ nodes) _) = D.parseLT ("<div>" <> textWithoutDoctype <> "</div>")
+  in mk $! map (toLarcenyNode o) nodes
+
+
 toLarcenyName :: X.Name -> Name
 toLarcenyName (X.Name tn _ _) =
   case T.stripPrefix "l:" tn of
@@ -93,25 +95,13 @@ toLarcenyNode _ (X.NodeComment c) = NodeComment c
 toLarcenyNode _ (X.NodeInstruction _) = NodeContent ""
 
 -- | Turn HTML nodes and overrides into templates.
-mk :: Overrides -> [Node] -> Template s
-mk o = f
+mk :: [Node] -> Template s
+mk = f
   where f nodes =
-          Template $ \pth m l ->
-                      let pc = ProcessContext pth m l o f nodes in
-                      do s <- get
-                         T.concat <$> toUserState (pc s) (process nodes)
-
-toProcessState :: StateT s IO a -> StateT (ProcessContext s) IO a
-toProcessState f =
-  do pc <- get
-     (result, s') <- liftIO $ runStateT 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 })
+          Template $ \m ->
+                      do modify (lSubs .~ m)
+                         -- lPath .= pth
+                         T.concat <$> process nodes
 
 fillIn :: Blank -> Substitutions s -> Fill s
 fillIn tn m = fromMaybe (fallbackFill tn m) (M.lookup tn m)
@@ -120,45 +110,21 @@ 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
-
-data ProcessContext s = ProcessContext { _pcPath          :: Path
-                                       , _pcSubs          :: Substitutions s
-                                       , _pcLib           :: Library s
-                                       , _pcOverrides     :: Overrides
-                                       , _pcMk            :: [Node] -> Template s
-                                       , _pcNodes         :: [Node]
-                                       , _pcState         :: s }
-
-infix  4 .=
-(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
-l .= b = modify (l .~ b)
-{-# INLINE (.=) #-}
-
-pcSubs :: Lens' (ProcessContext s) (Substitutions s)
-pcSubs = lens _pcSubs (\pc s -> pc { _pcSubs = s })
-
-pcNodes :: Lens' (ProcessContext s) [Node]
-pcNodes  = lens _pcNodes (\pc n -> pc { _pcNodes = n })
-
-pcState :: Lens' (ProcessContext s) s
-pcState = lens _pcState (\pc s -> pc { _pcState = s })
-
-type ProcessT s = StateT (ProcessContext s) IO [Text]
+  Fill $ \attr tpl ->
+    do st <- get
+       let pth = _lPath st
+       liftIO $ putStrLn ("Larceny: Missing fill for blank " <> show tn <> " in template " <> show pth)
+       unFill fallback attr tpl
 
 add :: Substitutions s -> Template s -> Template s
 add mouter tpl =
-  Template (\pth minner l -> runTemplate tpl pth (minner `M.union` mouter) l)
+  Template (\minner -> runTemplate tpl (minner `M.union` mouter))
 
-process :: [Node] -> ProcessT s
+process :: [Node] -> LarcenyM s [Text]
 process [] = return []
 process (NodeElement (BindElement atr kids):nextNodes) = do
-  pcNodes .= nextNodes
-  processBind atr kids
+  processBind atr kids nextNodes
 process (currentNode:nextNodes) = do
-  pcNodes .= nextNodes
   processedNode <-
     case currentNode of
       NodeElement DoctypeElement  -> return ["<!DOCTYPE html>"]
@@ -182,12 +148,12 @@ process (currentNode:nextNodes) = do
 processPlain :: Name ->
                 Attributes ->
                 [Node] ->
-                ProcessT s
+                LarcenyM s [Text]
 processPlain tagName atr kids = do
   pc <- get
   atrs <- attrsToText atr
   processed <- process kids
-  return $ tagToText (_pcOverrides pc) tagName atrs processed
+  return $ tagToText (_lOverrides pc) tagName atrs processed
 
 selfClosing :: Overrides -> HS.HashSet Text
 selfClosing (Overrides _ _ sc) =
@@ -206,7 +172,7 @@ tagToText overrides (Name mPf name) atrs processed =
            ++ processed
            ++ ["</" <> prefix <> name <> ">"]
 
-attrsToText :: Attributes -> StateT (ProcessContext s) IO Text
+attrsToText :: Attributes -> LarcenyM s Text
 attrsToText attrs =
   T.concat <$> mapM attrToText (M.toList attrs)
   where attrToText (k,v) = do
@@ -217,20 +183,19 @@ attrsToText attrs =
         toText (k, "") = " " <> k
         toText (k, v) = " " <> k <> "=\"" <> T.strip v <> "\""
 
-fillAttrs :: Attributes -> StateT (ProcessContext s) IO Attributes
+fillAttrs :: Attributes -> LarcenyM s Attributes
 fillAttrs attrs =  M.fromList <$> mapM fill (M.toList attrs)
   where fill p = do
           let (unboundKeys, unboundValues) = eUnboundAttrs p
           keys <- T.concat <$> mapM fillAttr unboundKeys
           vals <- T.concat <$> mapM fillAttr unboundValues
           return (keys, vals)
 
-fillAttr :: Either Text Blank -> StateT (ProcessContext s) IO Text
+fillAttr :: Either Text Blank -> LarcenyM s Text
 fillAttr eBlankText =
-  do (ProcessContext pth m l _ mko _ _) <- get
-     toProcessState $
-       case eBlankText of
-         Right hole -> unFill (fillIn hole m) mempty (pth, mko []) l
+  do m <- _lSubs <$> get
+     case eBlankText of
+         Right hole -> unFill (fillIn hole m) mempty (mk [])
          Left text -> return text
 
 -- Look up the Fill for the hole.  Apply the Fill to a map of
@@ -239,40 +204,42 @@ fillAttr eBlankText =
 processBlank :: Text ->
                 Attributes ->
                 [Node] ->
-                ProcessT s
+                LarcenyM s [Text]
 processBlank tagName atr kids = do
-  (ProcessContext pth m l _ mko _ _) <- get
+  m <- _lSubs <$> get
   filled <- fillAttrs atr
-  sequence [ toProcessState $ unFill (fillIn (Blank tagName) m)
+  sequence [ unFill (fillIn (Blank tagName) m)
                     filled
-                    (pth, add m (mko kids)) l]
+                    (add m (mk kids))]
 
 processBind :: Attributes ->
                [Node] ->
-               ProcessT s
-processBind atr kids = do
-  (ProcessContext pth m l _ mko nodes _) <- get
+               [Node] ->
+               LarcenyM s [Text]
+processBind atr kids nextNodes = do
+  m <- _lSubs <$> get
   let tagName = atr M.! "tag"
-      newSubs = subs [(tagName, Fill $ \_a _t _l ->
-                                       runTemplate (mko kids) pth m l)]
-  pcSubs .= newSubs `M.union` m
-  process nodes
+      newSubs = subs [(tagName, Fill $ \_a _t ->do
+                                  runTemplate (mk kids) m)]
+  modify (lSubs .~ newSubs `M.union` m)
+  process nextNodes
 
 -- Look up the template that's supposed to be applied in the library,
 -- create a substitution for the content hole using the child elements
 -- of the apply tag, then run the template with that substitution
 -- combined with outer substitution and the library.
 processApply :: Attributes ->
                 [Node] ->
-                ProcessT s
+                LarcenyM s [Text]
 processApply atr kids = do
-  (ProcessContext pth m l _ mko _ _) <- get
+  (LarcenyState pth m l _ _ _) <- get
   filledAttrs <- fillAttrs atr
   let (absolutePath, tplToApply) = findTemplateFromAttrs pth l filledAttrs
-  contentTpl <- toProcessState $ runTemplate (mko kids) pth m l
+  contentTpl <- runTemplate (mk kids) m
   let contentSub = subs [("apply-content",
                          rawTextFill contentTpl)]
-  sequence [ toProcessState $ runTemplate tplToApply absolutePath (contentSub `M.union` m) l ]
+  modify (lPath .~ absolutePath)
+  sequence [ runTemplate tplToApply (contentSub `M.union` m) ]
 
 findTemplateFromAttrs :: Path ->
                          Library s ->