Tissevert/Hufflepdf
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Try replacing general monadic type constraint by a definite monad stack

Browse source
This commit is contained in:
Tissevert 2020-03-11 22:35:19 +01:00
parent 5b8d951516
commit 5bf2b08fa9
1 changed files with 9 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
src/PDF/Content/Text.hs
View file

@ -13,8 +13,8 @@ module PDF.Content.Text (
import Control.Monad (foldM) import Control.Monad (foldM)
import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Fail (MonadFail(..))
import Control.Monad.Reader (MonadReader(..), asks, runReaderT) import Control.Monad.Reader (MonadReader(..), ReaderT, asks, runReaderT)
import Control.Monad.State (MonadState(..), evalStateT) import Control.Monad.State (MonadState(..), StateT, evalStateT)
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Map as Map (empty, fromList, singleton) import qualified Data.Map as Map (empty, fromList, singleton)
import Data.Text (Text, breakOn) import Data.Text (Text, breakOn)
@ -36,10 +36,10 @@ data ROContext = ROContext {
, fontSet :: FontSet , fontSet :: FontSet
} }
type TextContent m = (MonadReader ROContext m, MonadFail m) type TextContent m = ReaderT ROContext m
type FontContext m = (MonadState Font m, TextContent m) type FontContext m = StateT Font (TextContent m)
decodeString :: FontContext m => StringObject -> m Text decodeString :: MonadFail m => StringObject -> FontContext m Text
decodeString input = do decodeString input = do
Font {decode} <- get Font {decode} <- get
either fail return . decode $ toByteString input either fail return . decode $ toByteString input
@ -57,24 +57,24 @@ renderText fontSet (Content.Content {contentUnits, Content.indexedInstructions})
where where
roContext = ROContext {indexedInstructions, fontSet} roContext = ROContext {indexedInstructions, fontSet}
renderContentUnit :: TextContent m => ContentUnit -> m (Indexed Text) renderContentUnit :: MonadFail m => ContentUnit -> TextContent m (Indexed Text)
renderContentUnit (GraphicContext graphicContextUnits) = renderContentUnit (GraphicContext graphicContextUnits) =
mconcat <$> mapM renderGraphicContextUnit graphicContextUnits mconcat <$> mapM renderGraphicContextUnit graphicContextUnits
renderContentUnit (TextContext instructionIds) = renderContentUnit (TextContext instructionIds) =
evalStateT (mconcat <$> mapM renderInstructionId instructionIds) emptyFont evalStateT (mconcat <$> mapM renderInstructionId instructionIds) emptyFont
renderGraphicContextUnit :: TextContent m => GraphicContextUnit -> m (Indexed Text) renderGraphicContextUnit :: MonadFail m => GraphicContextUnit -> TextContent m (Indexed Text)
renderGraphicContextUnit (GraphicInstruction _) = return Map.empty renderGraphicContextUnit (GraphicInstruction _) = return Map.empty
renderGraphicContextUnit (ContentUnit contentUnit) = renderGraphicContextUnit (ContentUnit contentUnit) =
renderContentUnit contentUnit renderContentUnit contentUnit
renderInstructionId :: FontContext m => Id Instruction -> m (Indexed Text) renderInstructionId :: MonadFail m => Id Instruction -> FontContext m (Indexed Text)
renderInstructionId instructionId@(Id n) = toMap <$> renderInstructionId instructionId@(Id n) = toMap <$>
(asks ((! instructionId) . indexedInstructions) >>= renderInstruction) (asks ((! instructionId) . indexedInstructions) >>= renderInstruction)
where where
toMap = maybe Map.empty (Map.singleton (Id n)) toMap = maybe Map.empty (Map.singleton (Id n))
renderInstruction :: FontContext m => Instruction -> m (Maybe Text) renderInstruction :: MonadFail m => Instruction -> FontContext m (Maybe Text)
renderInstruction (Text Tf, [NameObject fontName, _]) = renderInstruction (Text Tf, [NameObject fontName, _]) =
asks ((! fontName) . fontSet) >>= put >> return Nothing asks ((! fontName) . fontSet) >>= put >> return Nothing