---------------------------------------------------------
-- |
-- 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