From a04adff1d2041206e576dc3ee5d687afb1fb3889 Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Tue, 10 Mar 2020 22:55:16 +0100
Subject: [PATCH] Prepare real instance of Box using renderText

---
 src/PDF/Content/Text.hs | 56 +++++++++++++++++++++++++----------------
 1 file changed, 34 insertions(+), 22 deletions(-)

diff --git a/src/PDF/Content/Text.hs b/src/PDF/Content/Text.hs
index fdaf2dd..63d459a 100644
--- a/src/PDF/Content/Text.hs
+++ b/src/PDF/Content/Text.hs
@@ -6,7 +6,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module PDF.Content.Text (
-      format
+      Chunks(..)
+    , format
     , renderText
   ) where
 
@@ -15,6 +16,7 @@ import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.Reader (MonadReader(..), asks, runReaderT)
 import Control.Monad.State (MonadState(..), evalStateT)
 import Data.Map ((!))
+import qualified Data.Map as Map (empty, fromList, singleton)
 import Data.Text (Text, breakOn)
 import qualified Data.Text as Text (drop)
 import PDF.Box (Box(..))
@@ -27,7 +29,6 @@ import PDF.Content.Operator (Instruction, Operator(..))
 import PDF.Content.Operator.Text (Operator(..))
 import PDF.Font (Font(..), FontSet, emptyFont)
 import PDF.Object (DirectObject(..), StringObject(..), toByteString)
-import PDF.Pages (Page(..))
 import Prelude hiding (fail)
 
 data ROContext = ROContext {
@@ -45,52 +46,63 @@ decodeString input = do
 
 data Chunks = Chunks
 
-instance Monad m => Box m Chunks Content (Indexed Text)
+instance Monad m => Box m Chunks Content (Indexed Text) where
+  r Chunks _ = return $ Map.fromList [(Id 17, "Test")]
 
-renderText :: MonadFail m => FontSet -> Content -> m [Text]
+{-
+instance (MonadReader FontSet m, MonadFail m) => Box m Chunks Content (Indexed Text) where
+  r Chunks content = do
+    fontSet <- ask
+    renderText fontSet content
+-}
+
+
+renderText :: MonadFail m => FontSet -> Content -> m (Indexed Text)
 renderText fontSet (Content.Content {contentUnits, Content.indexedInstructions}) =
-  runReaderT (concat <$> mapM renderContentUnit contentUnits) roContext
+  runReaderT (mconcat <$> mapM renderContentUnit contentUnits) roContext
   where
     roContext = ROContext {indexedInstructions, fontSet}
 
-renderContentUnit :: TextContent m => ContentUnit -> m [Text]
+renderContentUnit :: TextContent m => ContentUnit -> m (Indexed Text)
 renderContentUnit (GraphicContext graphicContextUnits) =
-  concat <$> mapM renderGraphicContextUnit graphicContextUnits
+  mconcat <$> mapM renderGraphicContextUnit graphicContextUnits
 renderContentUnit (TextContext instructionIds) =
-  evalStateT (concat <$> mapM renderInstructionId instructionIds) emptyFont
+  evalStateT (mconcat <$> mapM renderInstructionId instructionIds) emptyFont
 
-renderGraphicContextUnit :: TextContent m => GraphicContextUnit -> m [Text]
-renderGraphicContextUnit (GraphicInstruction _) = return []
+renderGraphicContextUnit :: TextContent m => GraphicContextUnit -> m (Indexed Text)
+renderGraphicContextUnit (GraphicInstruction _) = return Map.empty
 renderGraphicContextUnit (ContentUnit contentUnit) =
   renderContentUnit contentUnit
 
-renderInstructionId :: FontContext m => Id Instruction -> m [Text]
-renderInstructionId instructionId =
-  asks ((! instructionId) . indexedInstructions) >>= renderInstruction
+renderInstructionId :: FontContext m => Id Instruction -> m (Indexed Text)
+renderInstructionId instructionId@(Id n) = toMap <$>
+  (asks ((! instructionId) . indexedInstructions) >>= renderInstruction)
+  where
+    toMap = maybe Map.empty (Map.singleton (Id n))
 
-renderInstruction :: FontContext m => Instruction -> m [Text]
+renderInstruction :: FontContext m => Instruction -> m (Maybe Text)
 renderInstruction (Text Tf, [NameObject fontName, _]) =
-  asks ((! fontName) . fontSet) >>= put >> return []
+  asks ((! fontName) . fontSet) >>= put >> return Nothing
 
-renderInstruction (Text Tstar, []) = return ["\n"]
+renderInstruction (Text Tstar, []) = return $ Just "\n"
 
 renderInstruction (Text TJ, [Array arrayObject]) =
-  replicate 1 <$> foldM appendText "" arrayObject
+  Just <$> foldM appendText "" arrayObject
   where
     appendText t (StringObject outputString) =
       mappend t <$> decodeString outputString
     appendText t _ = return t
 
 renderInstruction (Text Tj, [StringObject outputString]) =
-  replicate 1 <$> decodeString outputString
+  Just <$> decodeString outputString
 
 renderInstruction (Text Quote, [StringObject outputString]) =
-  (\t -> ["\n", t]) <$> decodeString outputString
+  (Just . mappend "\n") <$> decodeString outputString
 
-renderInstruction (Text DQuote, [StringObject outputString]) =
-  (\t -> ["\n", t]) <$> decodeString outputString
+renderInstruction (Text DQuote, [_, _, StringObject outputString]) =
+  (Just . mappend "\n") <$> decodeString outputString
 
-renderInstruction _ = return []
+renderInstruction _ = return Nothing
 
 format :: (MonadFail m, MonadReader Font m) => Text -> m [Instruction]
 format input =