Implement 'w' for Box m Chunks Content (Indexed Text)

src/PDF/Content/Text.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module PDF.Content.Text (
       Chunks(..)
+    , chunk
     , format
     , renderText
   ) where
@@ -14,8 +15,12 @@ module PDF.Content.Text (
 import Control.Monad (foldM)
 import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.Reader (MonadReader(..), ReaderT, asks, runReaderT)
-import Control.Monad.State (MonadState(..), StateT, evalStateT)
+import Control.Monad.State (
+    MonadState(..), StateT, evalStateT, gets, modify, runStateT
+  )
+import Control.Monad.Trans (lift)
 import Data.Id (Id(..), Indexed, at, empty, singleton)
+import qualified Data.Id as Id (delete, lookup, register)
 import Data.Map ((!))
 import Data.Text (Text, breakOn)
 import qualified Data.Text as Text (drop)
@@ -38,6 +43,9 @@ data ROContext = ROContext {
 type TextContent m = ReaderT ROContext m
 type FontContext m = StateT Font (TextContent m)
 
+type Updater m = StateT (Indexed Instruction) (ReaderT (Indexed Text) (ReaderT FontSet m))
+type TextUpdater m = StateT Font (Updater m)
+
 decodeString :: MonadFail m => StringObject -> FontContext m Text
 decodeString input = do
   Font {decode} <- get
@@ -45,11 +53,19 @@ decodeString input = do
 
 data Chunks = Chunks
 
+chunk :: Int -> Id Text
+chunk = Id
+
 instance MonadFail m => Box (ReaderT FontSet m) Chunks Content (Indexed Text) where
   r Chunks content = do
     fontSet <- ask
     renderText fontSet content
 
+  w Chunks indexedText (Content.Content {contentUnits, Content.indexedInstructions}) =
+    uncurry Content.Content <$> runReaderT (
+        runStateT (mapM updateContentUnit contentUnits) indexedInstructions
+      ) indexedText
+
 renderText :: MonadFail m => FontSet -> Content -> m (Indexed Text)
 renderText fontSet (Content.Content {contentUnits, Content.indexedInstructions}) =
   runReaderT (mconcat <$> mapM renderContentUnit contentUnits) roContext
@@ -62,17 +78,32 @@ renderContentUnit (GraphicContext graphicContextUnits) =
 renderContentUnit (TextContext instructionIds) =
   evalStateT (mconcat <$> mapM renderInstructionId instructionIds) emptyFont
 
+updateContentUnit :: MonadFail m => ContentUnit -> Updater m ContentUnit
+updateContentUnit (GraphicContext graphicContextUnits) = GraphicContext <$>
+  mapM updateGraphicContextUnit graphicContextUnits
+updateContentUnit (TextContext instructionIds) = TextContext . concat <$>
+  evalStateT (mapM updateInstructionId instructionIds) emptyFont
+
 renderGraphicContextUnit :: MonadFail m => GraphicContextUnit -> TextContent m (Indexed Text)
 renderGraphicContextUnit (GraphicInstruction _) = return empty
 renderGraphicContextUnit (ContentUnit contentUnit) =
   renderContentUnit contentUnit
 
+updateGraphicContextUnit :: MonadFail m => GraphicContextUnit -> Updater m GraphicContextUnit
+updateGraphicContextUnit gI@(GraphicInstruction _) = return gI
+updateGraphicContextUnit (ContentUnit contentUnit) =
+  ContentUnit <$> updateContentUnit contentUnit
+
 renderInstructionId :: MonadFail m => Id Instruction -> FontContext m (Indexed Text)
 renderInstructionId instructionId@(Id n) = toMap <$>
   (asks ((`at` instructionId) . indexedInstructions) >>= renderInstruction)
   where
     toMap = maybe empty (singleton (Id n))
 
+updateInstructionId :: MonadFail m => Id Instruction -> TextUpdater m [Id Instruction]
+updateInstructionId instructionId =
+  lift (gets (`at` instructionId)) >>= updateInstruction instructionId
+
 renderInstruction :: MonadFail m => Instruction -> FontContext m (Maybe Text)
 renderInstruction (Text Tf, [NameObject fontName, _]) =
   asks ((! fontName) . fontSet) >>= put >> return Nothing
@@ -97,13 +128,32 @@ renderInstruction (Text DQuote, [_, _, StringObject outputString]) =
 
 renderInstruction _ = return Nothing
 
-format :: (MonadFail m, MonadReader Font m) => Text -> m [Instruction]
-format input =
+updateInstruction :: MonadFail m => Id Instruction -> Instruction -> TextUpdater m [Id Instruction]
+updateInstruction instructionId (Text Tf, [NameObject fontName, _]) =
+  (lift . lift . lift $ asks (!fontName)) >>= put >> return [instructionId]
+
+updateInstruction instructionId@(Id n) instruction = do
+  if emitsText $ fst instruction
+  then asks (Id.lookup (Id n)) >>= replaceText
+  else return [instructionId]
+  where
+    emitsText (Text Tstar) = True
+    emitsText (Text TJ) = True
+    emitsText (Text Tj) = True
+    emitsText (Text Quote) = True
+    emitsText (Text DQuote) = True
+    emitsText _ = False
+    replaceText = maybe (return []) $ \text -> do
+      lift $ modify (Id.delete instructionId)
+      format text >>= mapM (lift . Id.register)
+
+format :: MonadFail m => Text -> StateT Font m [Instruction]
+format input = do
   case breakOn "\n" input of
     ("", "") -> return []
     ("", left) -> ((Text Tstar, []) :) <$> format (Text.drop 1 left)
     (line, left) -> (:) <$> tj line <*> format left
   where
     tj t = do
-      literal <- either fail (return . Literal) =<< asks (($t) . encode)
+      literal <- either fail (return . Literal) =<< gets (($t) . encode)
       return (Text Tj, [StringObject literal])