HPDF-1.2: 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(
-- * Types
-- ** Boxes
Box(..)
, DisplayableBox(..)
, Letter(..)
, BoxDimension
-- ** Styles
, Style(..)
, TextStyle(..)
, StyleFunction(..)
, ParagraphStyle(..)
, MonadStyle(..)
, ComparableStyle(..)
-- ** Typesetting monads
, Para
, TM
-- ** Containers
, VBox
, VerState(..)
, Container
, Justification(..)
-- * Functions
-- ** Text display
, displayFormattedText
-- ** Text construction operators
, forceNewLine
, txt
, paragraph
-- ** Paragraph construction operators
, kern
, addPenalty
, mkLetter
, mkDrawBox
-- ** Functions useful to change the paragraph style
, getParaStyle
, setParaStyle
-- ** Container
, mkContainer
, fillContainer
, defaultVerState
, getBoxes
, containerX
, containerY
, containerWidth
, containerHeight
, containerContentHeight
, containerContentRightBorder
, containerContentLeftBorder
, containerCurrentHeight
, containerContentRectangle
-- * Settings (similar to TeX ones)
-- ** Line breaking settings
, setFirstPassTolerance
, setSecondPassTolerance
, setHyphenPenaltyValue
, setFitnessDemerit
, setHyphenDemerit
, setLinePenalty
, getFirstPassTolerance
, getSecondPassTolerance
, getHyphenPenaltyValue
, getFitnessDemerit
, getHyphenDemerit
, getLinePenalty
, setJustification
-- ** Vertical mode settings
, setBaseLineSkip
, setLineSkipLimit
, setLineSkip
, getBaseLineSkip
, getLineSkipLimit
, getLineSkip
, module Graphics.PDF.Typesetting.StandardStyle
) 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.Layout
import Graphics.PDF.Typesetting.Box
import Graphics.PDF.Typesetting.StandardStyle
-- | 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 :: (ParagraphStyle ps s) => Rectangle -- ^ Text area
-> ps -- ^ default vertical style
-> s -- ^ Default horizontal style
-> TM ps s a -- ^ Typesetting monad
-> Draw a -- ^ Draw monad
displayFormattedText (Rectangle xa ya xb yb) 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'} ) () (defaultTmState defaultVStyle defaultHStyle)
c = mkContainer xa yb (xb-xa) (yb-ya)
(d,_,_) = fillContainer (pageSettings s') c boxes
d
return a
-- | Return the list of Vboxes for a text
getBoxes :: (ParagraphStyle ps s) => ps -- ^ default vertical style
-> s -- ^ Default horizontal style
-> TM ps s a -- ^ Typesetting monad
-> [VBox ps s] -- ^ List of boxes
getBoxes defaultVStyle defaultHStyle t =
let (_, _ , boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) () (defaultTmState defaultVStyle defaultHStyle)
in boxes
-- | Add a penalty
addPenalty :: Int -> Para s ()
addPenalty f = tell $ [penalty f]
defaultTmState :: (ParagraphStyle ps s) => ps -> s -> TMState ps s
defaultTmState s' s = TMState { tmStyle = s
, paraSettings = defaultBreakingSettings
, pageSettings = defaultVerState s'
}
data TMState ps s = TMState { tmStyle :: !s
, paraSettings :: !BRState
, pageSettings :: !(VerState ps)
}
newtype TM ps s a = TM { unTM :: RWS () [VBox ps s] (TMState ps s) a}
#ifndef __HADDOCK__
deriving(Monad,MonadWriter [VBox ps s], MonadState (TMState ps s), Functor)
#else
instance Monad TM
instance MonadWriter [VBox ps s] TM
instance MonadState (TMState ps s) TM
instance Functor TM
#endif
newtype Para s a = Para { unPara :: RWS BRState [Letter s] s a}
#ifndef __HADDOCK__
deriving(Monad,MonadWriter [Letter s], MonadReader BRState, MonadState s, Functor)
#else
instance Monad Para
instance MonadWriter [Letter s] Para
instance MonadState s Para
instance Functor Para
instance MonadReader BRState Para
#endif
-- | A MonadStyle where some typesetting operators can be used
class (Style s, Monad m) => MonadStyle s m | m -> s where
-- | Set the current text style
setStyle :: s -> m ()
-- | Get the current text style
currentStyle :: m s
-- | 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 Style s => MonadStyle s (TM ps s) where
-- Set style of text
setStyle f = modifyStrict $ \s -> s {tmStyle = 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
tell $ [vglue (Just style) h y z 0 0]
-- Add a glue
unstyledGlue h y z = do
tell $ [vglue Nothing h y z 0 0]
instance Style s => MonadStyle s (Para s) where
-- Set style of text
setStyle f = put $! 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]
-- | For a newline and end the current paragraph
forceNewLine :: Style s => Para s ()
forceNewLine = do
endPara
startPara
-- | End the current paragraph with or without using the same style
endFullyJustified :: Style s => Bool -- ^ True if we use the same style to end a paragraph. false for an invisible style
-> Para s ()
endFullyJustified r = do
if r
then
glue 0 10000.0 0
else
tell $ [glueBox Nothing 0 10000.0 0]
addPenalty (-infinity)
endPara :: Style s => Para s ()
endPara = do
style <- ask
theStyle <- currentStyle
let w = spaceWidth theStyle
case centered style of
Centered -> do
addLetter (glueBox (Just theStyle) 0 (centeredDilatationFactor*w) 0)
addLetter (penalty (-infinity))
RightJustification -> addPenalty (-infinity)
_ -> endFullyJustified False
startPara :: Style s => Para s ()
startPara = do
style <- ask
theStyle <- currentStyle
let w = spaceWidth theStyle
case (centered style) of
Centered -> do
addLetter (kernBox (theStyle) 0)
addLetter $ penalty infinity
addLetter (glueBox (Just theStyle) 0 (centeredDilatationFactor*w) 0)
RightJustification -> do
addLetter (kernBox (theStyle) 0)
addLetter $ penalty infinity
addLetter (glueBox (Just theStyle) 0 (rightDilatationFactor*w) 0)
_ -> return ()
-- | Run a paragraph. Style changes are local to the paragraph
runPara :: Style s => Para s a -> TM ps s 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 0 boxes (Just style) settings]
return a
where
closedPara = do
startPara
x <- m
endPara
return x
-- | Get the current paragraph style
getParaStyle :: TM ps s ps
getParaStyle = gets pageSettings >>= TM . return . currentParagraphStyle
-- | Change the current paragraph style
setParaStyle :: ParagraphStyle ps s => ps -> TM ps s ()
setParaStyle style = do
modifyStrict $ \s -> s {pageSettings = (pageSettings s){currentParagraphStyle = style}}
-- | Add a letter to the paragraph
addLetter :: Letter s -> Para s ()
addLetter l = Para . tell $ [l]
-- | Add a new paragraph to the text
paragraph :: Style s => Para s a -> TM ps s a
paragraph = runPara
-- | Add a null char
--nullChar :: Para ()
--nullChar = Para . tell $ [nullLetter]
-- | Add a text line
txt :: Style s => String -> Para s ()
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 :: Style s => PDFFloat -> Para s ()
kern w = do
f <- currentStyle
tell $ [kernBox f w]
setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ps s ()
setBaseLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){baselineskip = (w,y,z)}}
getBaseLineSkip :: TM ps s (PDFFloat,PDFFloat,PDFFloat)
getBaseLineSkip = do
s <- gets pageSettings
return (baselineskip s)
setLineSkipLimit :: PDFFloat -> TM ps s ()
setLineSkipLimit l = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskiplimit=l}}
getLineSkipLimit :: TM ps s PDFFloat
getLineSkipLimit = gets pageSettings >>= return . lineskiplimit
setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ps s ()
setLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskip = (w,y,z)}}
getLineSkip :: TM ps s (PDFFloat,PDFFloat,PDFFloat)
getLineSkip = gets pageSettings >>= return . lineskip
setFirstPassTolerance :: PDFFloat -> TM ps s ()
setFirstPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){firstPassTolerance = x}}
getFirstPassTolerance :: TM ps s PDFFloat
getFirstPassTolerance = gets paraSettings >>= return . firstPassTolerance
setSecondPassTolerance :: PDFFloat -> TM ps s ()
setSecondPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){secondPassTolerance = x}}
getSecondPassTolerance :: TM ps s PDFFloat
getSecondPassTolerance = gets paraSettings >>= return . secondPassTolerance
setHyphenPenaltyValue :: Int -> TM ps s ()
setHyphenPenaltyValue x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){hyphenPenaltyValue = x}}
getHyphenPenaltyValue :: TM ps s Int
getHyphenPenaltyValue = gets paraSettings >>= return . hyphenPenaltyValue
setFitnessDemerit :: PDFFloat -> TM ps s ()
setFitnessDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){fitness_demerit = x}}
getFitnessDemerit :: TM ps s PDFFloat
getFitnessDemerit = gets paraSettings >>= return . fitness_demerit
setHyphenDemerit :: PDFFloat -> TM ps s ()
setHyphenDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){flagged_demerit = x}}
getHyphenDemerit :: TM ps s PDFFloat
getHyphenDemerit = gets paraSettings >>= return . flagged_demerit
setLinePenalty :: PDFFloat -> TM ps s ()
setLinePenalty x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){line_penalty = x}}
getLinePenalty :: TM ps s PDFFloat
getLinePenalty = gets paraSettings >>= return . line_penalty
setJustification :: Justification -- ^ Centered, left or fully justified
-> TM ps s ()
setJustification j = modifyStrict $ \s -> s {paraSettings = (paraSettings s){centered = j}}