HPDF-1.1: Graphics/PDF/Typesetting.hs
---------------------------------------------------------
-- |
-- Copyright : (c) alpha 2007
-- License : BSD-style
--
-- Maintainer : misc@NOSPAMalpheccar.org
-- Stability : experimental
-- Portability : portable
--
-- Experimental typesetting. It is a work in progress
---------------------------------------------------------
module Graphics.PDF.Typesetting(
-- * Typesetting
-- ** Types
Box(..)
, DisplayableBox(..)
, Style(..)
, TextStyle(..)
, StyleFunction(..)
, AnyStyle
, ParagraphStyle(..)
, AnyParagraphStyle
, MonadStyle(..)
, Letter(..)
, BoxDimension
-- * Functions
-- ** Text display
, displayFormattedText
-- ** Text construction operators
, endParagraph
, txt
, paragraph
-- * Paragraph construction operators
, kern
, addPenalty
-- , nullChar
, mkLetter
-- * Misc
, mkDrawBox
-- * Settings (similar to TeX ones)
-- ** Line breaking settings
, setFirstPassTolerance
, setSecondPassTolerance
, setHyphenPenaltyValue
, setFitnessDemerit
, setHyphenDemerit
, setLinePenalty
, getFirstPassTolerance
, getSecondPassTolerance
, getHyphenPenaltyValue
, getFitnessDemerit
, getHyphenDemerit
, getLinePenalty
-- ** Vertical mode settings
, setBaseLineSkip
, setLineSkipLimit
, setLineSkip
, getBaseLineSkip
, getLineSkipLimit
, getLineSkip
-- * Styles
-- ** Functions useful to change the paragraph style
, getParaStyle
, setParaStyle
, getTextArea
) where
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Text
import Graphics.PDF.Draw
import Graphics.PDF.Shapes
import Control.Monad.RWS
import Graphics.PDF.Typesetting.Breaking
import Graphics.PDF.Typesetting.Vertical
import Graphics.PDF.Typesetting.Box
-- | Display a formatted text in a given bounding rectangle with a given default paragraph style, a given default text style. No clipping
-- is taking place. Drawing stop when the last line is crossing the bounding rectangle in vertical direction
displayFormattedText :: (Style s, ParagraphStyle s') => Rectangle -- ^ Text area
-> s' -- ^ default vertical style
-> s -- ^ Default horizontal style
-> TM a -- ^ Typesetting monad
-> Draw a -- ^ Draw monad
displayFormattedText area@(Rectangle xa y' _ y'') defaultVStyle defaultHStyle t =
do
--withNewContext $ do
-- addShape $ Rectangle (xa-1) y' (xb+1) y''
-- closePath
-- setAsClipPath
let (a, s', boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) area (defaultTmState defaultVStyle defaultHStyle)
strokeVBoxes (verticalPostProcess (pageSettings s') 0 area boxes) (xa,y',y'')
return a
--endParagraphBoxes :: [Letter]
--endParagraphBoxes = [glueBox Nothing 0 10000.0 0,penalty (-infinity)]
-- | Add a penalty
addPenalty :: Int -> Para()
addPenalty f = tell $ [penalty f]
-- | End the current paragraph with or without using the same style
endParagraph :: Bool -- ^ True if we use the same style to end a paragraph. false for an invisible style
-> Para ()
endParagraph r = do
if r
then
glue 0 10000.0 0
else
tell $ [glueBox Nothing 0 10000.0 0]
addPenalty (-infinity)
-- | Get the bounding rectangle containing the text
getTextArea :: TM Rectangle
getTextArea = ask
defaultTmState :: (Style s, ParagraphStyle s') => s' -> s -> TMState
defaultTmState s' s = TMState { tmStyle = AnyStyle s
, paraSettings = defaultBreakingSettings
, pageSettings = defaultVerState s'
}
data TMState = TMState { tmStyle :: !AnyStyle
, paraSettings :: !BRState
, pageSettings :: !VerState
}
newtype TM a = TM { unTM :: RWS Rectangle [VBox] TMState a}
#ifndef __HADDOCK__
deriving(Monad,MonadWriter [VBox], MonadState TMState, MonadReader Rectangle, Functor)
#else
instance Monad TM
instance MonadWriter [VBox] TM
instance MonadState TMState TM
instance Functor TM
instance MonadReader Rectangle TM
#endif
newtype Para a = Para { unPara :: RWS BRState [Letter] AnyStyle a}
#ifndef __HADDOCK__
deriving(Monad,MonadWriter [Letter], MonadReader BRState, MonadState AnyStyle, Functor)
#else
instance Monad Para
instance MonadWriter [Letter] Para
instance MonadState AnyStyle Para
instance Functor Para
instance MonadReader BRState Para
#endif
-- | A MonadStyle where some typesetting operators can be used
class Monad m => MonadStyle m where
-- | Set the current text style
setStyle :: Style a => a -> m ()
-- | Get the current text style
currentStyle :: m AnyStyle
-- | Add a box using the current mode (horizontal or vertical. The current style is always applied to the added box)
addBox :: (Show a, DisplayableBox a, Box a) => a
-> PDFFloat -- ^ Width
-> PDFFloat -- ^ Height
-> PDFFloat -- ^ Descent
-> m ()
-- | Add a glue using the current style
glue :: PDFFloat -- ^ Size of glue (width or height depending on the mode)
-> PDFFloat -- ^ Dilatation factor
-> PDFFloat -- ^ Compression factor
-> m ()
-- | Add a glue with no style (it is just a translation)
unstyledGlue :: PDFFloat -- ^ Size of glue (width or height depending on the mode)
-> PDFFloat -- ^ Dilatation factor
-> PDFFloat -- ^ Compression factor
-> m ()
instance MonadStyle TM where
-- Set style of text
setStyle f = modifyStrict $ \s -> s {tmStyle = AnyStyle f}
-- Get current text style
currentStyle = gets tmStyle
-- Add a box to the stream in vertical mode
addBox a w h d = do
style <- getParaStyle
tell $ ([SomeVBox 0 (w,h,d) (AnyBox a) (Just style)])
-- Add a glue
glue h y z = do
style <- getParaStyle
Rectangle xa _ xb _ <- getTextArea
tell $ [vglue (Just style) h y z (xb-xa) 0]
-- Add a glue
unstyledGlue h y z = do
Rectangle xa _ xb _ <- getTextArea
tell $ [vglue Nothing h y z (xb-xa) 0]
instance MonadStyle Para where
-- Set style of text
setStyle f = put $! AnyStyle f
-- Get current text style
currentStyle = get
-- Add a box to the stream in horizontal mode
addBox a w h d = do
f <- currentStyle
addLetter . mkLetter (w,h,d) (Just f) $ a
-- Add a glue
glue w y z = do
f <- currentStyle
tell $ [glueBox (Just f) w y z]
-- Add a glue
unstyledGlue w y z = do
tell $ [glueBox Nothing w y z]
-- | Run a paragraph. Style changes are local to the paragraph
runPara :: Para a -> TM a
runPara m = do
TMState f settings pagesettings <- get
let (a, s', boxes) = (runRWS . unPara $ closedPara ) settings f
put $! TMState s' settings pagesettings
style <- getParaStyle
tell $ [Paragraph boxes (Just style) settings]
return a
where
closedPara = do
x <- m
endParagraph False
return x
-- | Get the current paragraph style
getParaStyle :: TM AnyParagraphStyle
getParaStyle = gets pageSettings >>= TM . return . paraStyle
-- | Change the current paragraph style
setParaStyle :: ParagraphStyle s => s -> TM ()
setParaStyle style = do
modifyStrict $ \s -> s {pageSettings = (pageSettings s){paraStyle = AnyParagraphStyle style}}
-- | Add a letter to the paragraph
addLetter :: Letter -> Para ()
addLetter l = Para . tell $ [l]
-- | Add a new paragraph to the text
paragraph :: Para a -> TM a
paragraph = runPara
-- | Add a null char
--nullChar :: Para ()
--nullChar = Para . tell $ [nullLetter]
-- | Add a text line
txt :: String -> Para ()
txt t = do
f <- currentStyle
settings <- ask
tell $ splitText settings f (toPDFString t)
-- | add a kern (space that can be dilated or compressed and on which no line breaking can occur)
kern :: PDFFloat -> Para()
kern w = do
f <- currentStyle
tell $ [kernBox f w]
setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()
setBaseLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){baselineskip = (w,y,z)}}
getBaseLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)
getBaseLineSkip = do
s <- gets pageSettings
return (baselineskip s)
setLineSkipLimit :: PDFFloat -> TM ()
setLineSkipLimit l = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskiplimit=l}}
getLineSkipLimit :: TM PDFFloat
getLineSkipLimit = gets pageSettings >>= return . lineskiplimit
setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()
setLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskip = (w,y,z)}}
getLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)
getLineSkip = gets pageSettings >>= return . lineskip
setFirstPassTolerance :: PDFFloat -> TM ()
setFirstPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){firstPassTolerance = x}}
getFirstPassTolerance :: TM PDFFloat
getFirstPassTolerance = gets paraSettings >>= return . firstPassTolerance
setSecondPassTolerance :: PDFFloat -> TM ()
setSecondPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){secondPassTolerance = x}}
getSecondPassTolerance :: TM PDFFloat
getSecondPassTolerance = gets paraSettings >>= return . secondPassTolerance
setHyphenPenaltyValue :: Int -> TM ()
setHyphenPenaltyValue x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){hyphenPenaltyValue = x}}
getHyphenPenaltyValue :: TM Int
getHyphenPenaltyValue = gets paraSettings >>= return . hyphenPenaltyValue
setFitnessDemerit :: PDFFloat -> TM ()
setFitnessDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){fitness_demerit = x}}
getFitnessDemerit :: TM PDFFloat
getFitnessDemerit = gets paraSettings >>= return . fitness_demerit
setHyphenDemerit :: PDFFloat -> TM ()
setHyphenDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){flagged_demerit = x}}
getHyphenDemerit :: TM PDFFloat
getHyphenDemerit = gets paraSettings >>= return . flagged_demerit
setLinePenalty :: PDFFloat -> TM ()
setLinePenalty x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){line_penalty = x}}
getLinePenalty :: TM PDFFloat
getLinePenalty = gets paraSettings >>= return . line_penalty