{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}

-- | This module exposes the implementation details of
-- "Graphics.EasyRender". Most user code should not need to import
-- this; they should import "Graphics.EasyRender" instead. 
-- 
-- This module provides efficient functions for rendering vector
-- graphics to a number of formats, including EPS, PostScript, and
-- PDF. It provides an abstraction for multi-page documents, as well
-- as a set of graphics primitives for page descriptions. 
-- 
-- The graphics model is similar to that of the PostScript and PDF
-- languages, but we only implement a subset of their functionality.
-- Care has been taken that graphics rendering is done efficiently and
-- as lazily as possible; documents are rendered \"on the fly\",
-- without the need to store the whole document in memory.
-- 
-- The provided document description model consists of two separate
-- layers of abstraction:
-- 
-- * /drawing/ is concerned with placing marks on a fixed surface, and
-- takes place in the 'Draw' monad;
-- 
-- * /document structure/ is concerned with a sequence of pages, their
-- bounding boxes, and other meta-data. It takes place in the
-- 'Document' monad.

module Graphics.EasyRender.Internal where

import Graphics.EasyRender.Auxiliary

import Codec.Compression.Zlib
import Control.Monad.State
import qualified Data.ByteString.Lazy as ByteString
import Data.Char
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import System.IO
import Text.Printf

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

-- ----------------------------------------------------------------------
-- * Types

-- ----------------------------------------------------------------------
-- ** Coordinates

-- | The type of /x/-coordinates.
type X = Double

-- | The type of /y/-coordinates.
type Y = Double

-- ----------------------------------------------------------------------
-- ** Colors

-- | The type of colors.
data Color =
  Color_RGB Double Double Double -- ^ Red, green and blue components,
                                 -- in the range from 0.0 (dark) to
                                 -- 1.0 (bright).
  | Color_Gray Double            -- ^ Gray value, in the range from
                                 -- 0.0 (black) to 1.0 (white).
  deriving (Show)

-- ----------------------------------------------------------------------
-- ** Fonts

-- | A enumeration type for base fonts. For the time being, we only
-- offer TimesRoman and Helvetica.
data Basefont = TimesRoman | Helvetica
  deriving (Show)

-- | A type representing font metrics for a given base font. The first
-- component is the default width of characters; the second component
-- is a map from characters to widths.
type Fontmetric = (Double, Map Char Double)

-- | Define a font metric for each base font.
metric :: Basefont -> Fontmetric
metric TimesRoman = metric_timesroman
metric Helvetica = metric_helvetica

-- | Font metrics for TimesRoman.
metric_timesroman :: Fontmetric
metric_timesroman = (0.5, m) where
  m = Map.fromList $ map (\(n,w) -> (chr n, w))
      [(32,0.25), (33,0.332031), (34,0.40625), (37,0.832031), (38,0.777344),
       (39,0.332031), (40,0.332031), (41,0.332031), (44,0.25), (45,0.332031),
       (46,0.25), (47,0.277344), (58,0.277344), (59,0.277344), (63,0.441406),
       (64,0.917969), (65,0.71875), (66,0.664062), (67,0.664062), (68,0.71875),
       (69,0.609375), (71,0.71875), (72,0.71875), (73,0.332031), (74,0.386719),
       (75,0.71875), (76,0.609375), (77,0.886719), (78,0.71875), (79,0.71875),
       (81,0.71875), (82,0.664062), (84,0.609375), (85,0.71875), (86,0.71875),
       (87,0.941406), (88,0.71875), (89,0.71875), (90,0.609375), (91,0.332031),
       (92,0.277344), (93,0.332031), (94,0.46875), (96,0.332031),
       (97,0.441406), (99,0.441406), (101,0.441406), (102,0.332031),
       (105,0.277344), (106,0.277344), (108,0.277344), (109,0.777344),
       (114,0.332031), (115,0.386719), (116,0.277344), (119,0.71875),
       (122,0.441406), (123,0.476562), (124,0.199219), (125,0.476562),
       (161,0.332031), (164,0.164062), (169,0.179688), (170,0.441406),
       (172,0.332031), (173,0.332031), (180,0.25), (182,0.449219),
       (183,0.347656), (184,0.332031), (185,0.441406), (186,0.441406),
       (188,1.0), (189,1.0), (191,0.441406), (193,0.332031), (194,0.332031),
       (195,0.332031), (196,0.332031), (197,0.332031), (198,0.332031),
       (199,0.332031), (200,0.332031), (202,0.332031), (203,0.332031),
       (205,0.332031), (206,0.332031), (207,0.332031), (208,1.0),
       (225,0.886719), (227,0.273438), (232,0.609375), (233,0.71875),
       (234,0.886719), (241,0.664062), (245,0.277344), (248,0.277344),
       (250,0.71875)]

-- | Font metrics for Helvetica.
metric_helvetica :: Fontmetric
metric_helvetica = (0.277344, m) where
  m = Map.fromList $ map (\(n,w) -> (chr n, w))
      [(34,0.351562), (35,0.554688), (36,0.554688), (37,0.886719),
      (38,0.664062), (39,0.21875), (40,0.332031), (41,0.332031), (42,0.386719),
      (43,0.582031), (45,0.332031), (48,0.554688), (49,0.554688),
      (50,0.554688), (51,0.554688), (52,0.554688), (53,0.554688),
      (54,0.554688), (55,0.554688), (56,0.554688), (57,0.554688),
      (60,0.582031), (61,0.582031), (62,0.582031), (63,0.554688), (64,1.01172),
      (65,0.664062), (66,0.664062), (67,0.71875), (68,0.71875), (69,0.664062),
      (70,0.609375), (71,0.777344), (72,0.71875), (74,0.5), (75,0.664062),
      (76,0.554688), (77,0.832031), (78,0.71875), (79,0.777344), (80,0.664062),
      (81,0.777344), (82,0.71875), (83,0.664062), (84,0.609375), (85,0.71875),
      (86,0.664062), (87,0.941406), (88,0.664062), (89,0.664062),
      (90,0.609375), (94,0.46875), (95,0.554688), (96,0.21875), (97,0.554688),
      (98,0.554688), (99,0.5), (100,0.554688), (101,0.554688), (103,0.554688),
      (104,0.554688), (105,0.21875), (106,0.21875), (107,0.5), (108,0.21875),
      (109,0.832031), (110,0.554688), (111,0.554688), (112,0.554688),
      (113,0.554688), (114,0.332031), (115,0.5), (117,0.554688), (118,0.5),
      (119,0.71875), (120,0.5), (121,0.5), (122,0.5), (123,0.332031),
      (124,0.257812), (125,0.332031), (126,0.582031), (161,0.332031),
      (162,0.554688), (163,0.554688), (164,0.164062), (165,0.554688),
      (166,0.554688), (167,0.554688), (168,0.554688), (169,0.1875),
      (170,0.332031), (171,0.554688), (172,0.332031), (173,0.332031),
      (174,0.5), (175,0.5), (177,0.554688), (178,0.554688), (179,0.554688),
      (182,0.535156), (183,0.347656), (184,0.21875), (185,0.332031),
      (186,0.332031), (187,0.554688), (188,1.0), (189,1.0), (191,0.609375),
      (193,0.332031), (194,0.332031), (195,0.332031), (196,0.332031),
      (197,0.332031), (198,0.332031), (199,0.332031), (200,0.332031),
      (202,0.332031), (203,0.332031), (205,0.332031), (206,0.332031),
      (207,0.332031), (208,1.0), (225,1.0), (227,0.367188), (232,0.554688),
      (233,0.777344), (234,1.0), (235,0.363281), (241,0.886719), (248,0.21875),
      (249,0.609375), (250,0.941406), (251,0.609375)]

-- | Look up the width of a character in the given metric.
char_metric :: Fontmetric -> Char -> Double
char_metric (d, m) c = case Map.lookup c m of
  Nothing -> d
  Just w -> w
  
-- | Look up with width of a string in the given metric.
string_metric :: Fontmetric -> String -> Double
string_metric metric s = sum [ char_metric metric c | c <- s ]

-- | A data type describing a scaled font. This consists of a base
-- font and a point size.
data Font = Font Basefont Double
  deriving (Show)

-- | Return the nominal point size of a font.
nominalsize :: Font -> Double
nominalsize (Font basefont pointsize) = pointsize

-- | Return the width of the given string in the given font.
text_width :: Font -> String -> Double
text_width (Font basefont pointsize) s = pointsize * string_metric m s
  where
    m = metric basefont

-- ----------------------------------------------------------------------
-- ** Alignment

-- | A real number representing text alignment.  0 = left aligned, 0.5
-- = centered, 1 = right aligned. Intermediate values are also
-- possible. For example, an alignment value of 0.25 means one quarter
-- of the way between left aligned and right aligned.
type Alignment = Double

-- | Left alignment.
align_left :: Alignment
align_left = 0.0

-- | Centered alignment.
align_center :: Alignment
align_center = 0.5

-- | Right alignment.
align_right :: Alignment
align_right = 1.0

-- ----------------------------------------------------------------------
-- * The Document monad
  
-- $DOCUMENTMODEL 
-- 
-- Document description takes place in the 'Document' monad. A basic
-- multi-page document has the following structure:
-- 
-- > document :: Document ()
-- > document = do
-- >   newpage x y $ do
-- >     <<<drawing commands>>>
-- >   newpage x y $ do
-- >     <<<drawing commands>>>
-- >   ...
-- 
-- Here, each 'newpage' command describes one page of the
-- document. The parameters /x/ and /y/ specify the dimensions of the
-- page bounding box. They are expressed in units of PostScript
-- points, i.e., multiples of 1/72 inch.
-- 
-- Sometimes the bounding box for a page is not known until after the
-- page content has been generated. For this purpose, we also provide
-- the following alternative to the 'newpage' command:
-- 
-- >   newpage_defer $ do
-- >     <<<drawing commands>>>
-- >     endpage x y
-- 
-- It works just like the 'newpage' command, except that the bounding
-- box is given at the end.

-- | The Document monad.
data Document a =
  Document_Return a                       -- ^ Terminate with a result.
  | Document_Page X Y (Draw (Document a)) -- ^ Page with bounding box
                                          -- known at the beginning.
  | Document_Page_defer (Draw (X, Y, Document a)) 
                                          -- ^ Page with bounding box
                                          -- known at the end.

instance Monad Document where
  return a = Document_Return a
  f >>= g = case f of
    Document_Return a -> g a
    Document_Page x y draw -> Document_Page x y draw' where
      draw' = do
        f' <- draw
        return (f' >>= g)
    Document_Page_defer draw -> Document_Page_defer draw' where
      draw' = do
        (x, y, f') <- draw
        return (x, y, f' >>= g)
                     
instance Applicative Document where
  pure = return
  (<*>) = ap

instance Functor Document where
  fmap = liftM

-- ----------------------------------------------------------------------
-- ** A vacuous run function
        
-- | Skip document without rendering.        
document_skip :: Document a -> a
document_skip (Document_Return a) = a
document_skip (Document_Page x y draw) = document_skip a where
  a = draw_skip draw
document_skip (Document_Page_defer draw) = document_skip a where
  (x, y, a) = draw_skip draw

-- ----------------------------------------------------------------------
-- ** User-level document structuring commands

-- | Create a page of the given bounding box, containing the given
-- drawing.
newpage :: X -> Y -> Draw a -> Document a
newpage x y draw =
  Document_Page x y draw' where
    draw' = do
      a <- draw
      return (Document_Return a)
            
-- | Create a page containing the given drawing, with the bounding box
-- computed at the end of the drawing routines.
newpage_defer :: Draw (X, Y, a) -> Document a
newpage_defer draw =
  Document_Page_defer draw' where
    draw' = do
      (x, y, a) <- draw
      return (x, y, Document_Return a)

-- | End the page with the given bounding box.
endpage :: X -> Y -> Draw (X, Y, ())
endpage x y = do
  return (x, y, ())

-- ----------------------------------------------------------------------
-- * The Draw monad

-- $DRAWINGMODEL 
-- 
-- The description of the visible content of a page take place in the
-- 'Draw' monad. It takes the form of a sequence of drawing commands,
-- for example:
-- 
-- >     moveto 10 10
-- >     lineto 10 100
-- >     lineto 100 100
-- >     lineto 100 10
-- >     closepath
-- >     stroke
-- 
-- The graphics model is similar to that of the PostScript and PDF
-- languages. The basic concept is that of a /path/, which is a
-- sequence of straight and curved line segments. Paths are first
-- constructed using /path construction commands/, and then painted
-- using /painting commands/, depending on a set of current 
-- /graphics parameters/ and a current /coordinate system/.
-- 
-- We also provide block structure. Changes to the graphics state
-- (color, coordinate system, etc.) that are done within a block are
-- local to the block.
-- 
-- >     block $ do
-- >       <<drawing commands>>
  
-- ----------------------------------------------------------------------
-- ** Internal definition of the Draw monad

-- | An abstract data type describing individual drawing commands.
data DrawCommand =
  Newpath        -- ^ Set the current path to empty.
  | Moveto X Y   -- ^ Start a new subpath at the given coordinates.
  | Lineto X Y   -- ^ Append a straight line to the current subpath.
  | Curveto X Y X Y X Y -- ^ Append a Bezier curve segment.
  | Closepath    -- ^ Close the current subpath.
  | Clip         -- ^ Use the current path as a clipping path.
  | Stroke       -- ^ Stroke and clear the current path.
  | Fill Color   -- ^ Fill and clear the current path.
  | FillStroke Color -- ^ Fill and stroke and clear the current path.
  | TextBox Alignment Font Color X Y X Y Double String -- ^ Text.
  | SetLineWidth Double  -- ^ Set current line width.
  | SetColor Color -- ^ Set current color.
  | Translate X Y  -- ^ Translate current coordinate system.
  | Scale X Y      -- ^ Scale the current coordinate system.
  | Rotate Double  -- ^ Rotate the current coordinate system.
  | Comment String -- ^ A human-readable comment, not rendered
  | Subroutine (Draw ()) [CustomDef]
                 -- ^ A subroutine is a composite drawing command. In
                 -- addition to a default definition that works for
                 -- any backend, it can also have optional specialized
                 -- definitions for particular backends.
  deriving (Show)

-- $ In understanding how the 'Draw' monad works, it is useful to keep
-- in mind that there is an isomorphism
-- 
-- @Draw /a/@ ≅ @Draw ()@ ×. /a/,
-- 
-- where \"×.\" is left-strict product, i.e., if the left-hand-side is
-- undefined, then so is the entire expression.

-- | The Draw monad.
data Draw a = 
  Draw_Return a                     -- ^ Terminate with a result.
  | Draw_Write DrawCommand (Draw a) -- ^ Write a command and continue.
  | Draw_Block (Draw (Draw a))      -- ^ Block structure. Perform the
                                    -- commands of the outer 'Draw' in
                                    -- a temporary copy of the
                                    -- graphics state, then continue
                                    -- with the inner 'Draw' in the
                                    -- original graphics state.
    deriving (Show)
    
instance Monad Draw where
  return a = Draw_Return a
  f >>= g = case f of
    Draw_Return a -> g a
    Draw_Write cmd f' -> Draw_Write cmd (f' >>= g)
    Draw_Block draw -> Draw_Block draw' where
      draw' = do
        f' <- draw
        return (f' >>= g)

instance Applicative Draw where
  pure = return
  (<*>) = ap

instance Functor Draw where
  fmap = liftM

-- ----------------------------------------------------------------------
-- ** Low-level operations for the Draw monad

-- | Write the given command to the 'Draw' monad.
draw_write :: DrawCommand -> Draw ()
draw_write cmd = 
  Draw_Write cmd (Draw_Return ())  

-- | Create a new subroutine.
draw_subroutine :: [CustomDef] -> Draw () -> Draw ()
draw_subroutine alt draw =
  draw_write (Subroutine draw alt)

-- | Write a block to the 'Draw' monad.
draw_block :: Draw a -> Draw a
draw_block draw = 
  Draw_Block draw' where
    draw' = do
      a <- draw
      return (Draw_Return a)
      
-- ----------------------------------------------------------------------
-- ** A vacuous run function

-- | Skip draw actions without rendering.
draw_skip :: Draw a -> a
draw_skip (Draw_Return x) = x
draw_skip (Draw_Write cmd cont) = draw_skip cont
draw_skip (Draw_Block f) = draw_skip (draw_skip f)

-- ----------------------------------------------------------------------
-- ** User-level drawing commands

-- ----------------------------------------------------------------------
-- *** Path construction commands

-- $PATHCONSTRUCTION
--   
-- During path construction, there is a notion of /current path/ and
-- /current point/. A path may consist of zero or more connected
-- subpaths, and each subpath is either open or closed. 

-- | Set the current path to empty.
newpath :: Draw ()
newpath = draw_write (Newpath)

-- | Start a new subpath at (/x/,/y/). The point (/x/,/y/) becomes the
-- current point.
moveto :: X -> Y -> Draw ()
moveto x y = draw_write (Moveto x y)

-- | Extend the current subpath by a straight line segment from the
-- current point to (/x/,/y/). The point (/x/,/y/) becomes the current
-- point.
lineto :: X -> Y -> Draw ()
lineto x y = draw_write (Lineto x y)

-- | @'curveto' /x1/ /y1/ /x2/ /y2/ /x/ /y/@: Extend the current
-- subpath by a Bezier curve segment from the current point to
-- (/x/,/y/), with control points (/x1/,/y1/) and (/x2/,/y2/). The
-- point (/x/,/y/) becomes the current point.
curveto :: X -> Y -> X -> Y -> X -> Y -> Draw ()
curveto x1 y1 x2 y2 x y = draw_write (Curveto x1 y1 x2 y2 x y)

-- | Close the current subpath. If necessary, connect the subpath's
-- final and initial points by a straight line segment. Note that a
-- closed path is rendered differently than a non-closed path whose
-- initial and final points coincide, because in the latter case, the
-- endpoints are capped rather than mitered.
closepath :: Draw ()
closepath = draw_write (Closepath)

-- ----------------------------------------------------------------------
-- *** Clipping

-- | Use the current path as a clipping path. The non-zero winding
-- number determines which points lie \"inside\" the path. All
-- subsequent drawing operations only paint inside the clipping
-- path. This operation implicitly resets the curent path to empty.
-- There is no way to undo this operation, except by enclosing it in
-- the local block.
clip :: Draw ()
clip = draw_write (Clip)

-- ----------------------------------------------------------------------
-- *** Painting commands

-- | Stroke the current path, using the current line color, line
-- width, and other graphics parameters. This operation implicitly
-- resets the current path to empty.
stroke :: Draw ()
stroke = draw_write (Stroke)

-- | Fill the current path, using the given color. This operation
-- implicitly resets the current path to empty. 
fill :: Color -> Draw ()
fill color = draw_write (Fill color)

-- | Fill the current path, using the given color; also stroke the
-- path using the current line color. This operation implicitly resets
-- the current path to empty.
fillstroke :: Color -> Draw ()
fillstroke color = draw_write (FillStroke color)

-- ----------------------------------------------------------------------
-- *** Text

-- | @'textbox' /a/ /f/ /c/ /x0/ /y0/ /x1/ /y1/ /b/ /s/@: Write the
-- given string on an imaginary line from point (/x0/,/y0/) to
-- (/x1/,/y1/), using font /f/ and color /c/. If the text is too wide
-- to fit on the line, it is scaled down. Otherwise, it is aligned
-- according to the alignment parameter /a/. The parameter /b/
-- specifies an additional offset by which to lower the text, with
-- respect to the text's nominal size. For example, if /b/=0, then the
-- above-mentioned imaginary line from (/x0/,/y0/) to (/x1/,/y1/)
-- coincides with the text's usual baseline. If /b/=0.5, then this
-- line approximately goes through the center of each character.
-- 
-- \[image textbox.png]
textbox :: Alignment -> Font -> Color -> X -> Y -> X -> Y -> Double -> String -> Draw ()
textbox a f c x0 y0 x1 y1 b s = draw_write (TextBox a f c x0 y0 x1 y1 b s)

-- ----------------------------------------------------------------------
-- *** Graphics parameters

-- $GRAPHICSPARAMETERS
-- 
-- The painting commands rely on a set of graphics parameters. The
-- graphics parameters are initially set to default values, and can be
-- altered with the following commands.

-- | Set the line width. The initial line width is 1.
setlinewidth :: Double -> Draw ()
setlinewidth x = draw_write (SetLineWidth x)

-- | Set the current color for stroking. The initial stroke color is
-- black.
setcolor :: Color -> Draw ()
setcolor color = draw_write (SetColor color)

-- ----------------------------------------------------------------------
-- *** Coordinate system

-- $COORDINATESYSTEM
-- 
-- Coordinates, lengths, widths, etc, are all interpreted relative to
-- a /current coordinate system/. The initial coordinate system of
-- each page has the origin in the lower left corner, with each unit
-- equaling one PostScript point (1/72 inch). The following commands
-- can be used to change the current coordinate system.

-- | Translate the current coordinate system by (/x/,/y/).
translate :: X -> Y -> Draw ()
translate x y = draw_write (Translate x y)

-- | Scale the current coordinate system by (/s/,/t/). Here, /s/ is
-- the scaling factor in the /x/-direction, and /t/ is the scaling
-- factor in the /y/-direction.
scale :: X -> Y -> Draw ()
scale x y = draw_write (Scale x y)

-- | Rotate the current coordinate system by /angle/, measured
-- counterclockwise in degrees.
rotate :: Double -> Draw ()
rotate angle = draw_write (Rotate angle)

-- ----------------------------------------------------------------------
-- *** Comments

-- | Insert a human-readable comment in the content stream. This is
-- for information only, and is not rendered in the graphical output.
comment :: String -> Draw ()
comment s = draw_write (Comment s)

-- ----------------------------------------------------------------------
-- *** Block structure

-- $BLOCKSTRUCTURE 
-- 
-- Drawing operations can be grouped into blocks with the 'block'
-- operator. Changes to the graphics parameters and coordinate system
-- are local to the block. It is undefined whether changes to the
-- current path made within a block persist after the end of the block
-- (they do in PDF, but not in PostScript). Therefore, path
-- construction should not be broken up across end-of-block boundaries.

-- | Perform a block of commands in a local copy of the graphics
-- state. This is intended to be used like this:
-- 
-- >     block $ do
-- >       <<drawing commands>>
block :: Draw a -> Draw a
block = draw_block

-- ----------------------------------------------------------------------
-- *** Derived commands

-- $ PDF has no built-in command for drawing circular arcs, so we
-- define it here. Since PostScript does have such a command, we use
-- the 'draw_subroutine' mechanism.

-- | Start a new subpath consisting of a circular arc segment. The arc
-- segment is centered at (/x/,/y/), has radius /r/, and extends from
-- angle /a1/ to angle /a2/, measured in degrees, counterclockwise
-- from the /x/-axis. The arc is drawn counterclockwise if /a2/ ≥
-- /a1/, and clockwise otherwise. The final point becomes the new
-- current point.
arc :: X -> Y -> Double -> Double -> Double -> Draw ()
arc x y r a1 a2 = draw_subroutine alt $ do
  arc_internal False x y r r a1 a2
    where
      alt = [custom_ps $ printf "%f %f moveto\n" x0 y0 ++ printf "%f %f %f %f %f %s\n" x y r a1 a2 (if a1 <= a2 then "arc" else "arcn"),
             custom_ascii $ printf "Arc %f %f %f %f %f\n" x y r a1 a2]
      x0 = x + r * cos (pi/180 * a1)
      y0 = y + r * sin (pi/180 * a1)

-- | Like 'arc', except append to the current subpath. If necessary,
-- add a straight line segment from the current point to the starting
-- point of the arc.
arc_append :: X -> Y -> Double -> Double -> Double -> Draw ()
arc_append x y r a1 a2 = draw_subroutine alt $ do
  arc_internal True x y r r a1 a2
    where
      alt = [custom_ps $ printf "%f %f %f %f %f %s\n" x y r a1 a2 (if a1 <= a2 then "arc" else "arcn"),
             custom_ascii $ printf "Arc_append %f %f %f %f %f\n" x y r a1 a2]

-- | Append a new closed subpath consisting of an oval centered at
-- (/x/,/y/), with horizontal and vertical radii /rx/ and /ry/,
-- respectively.
oval :: X -> Y -> X -> Y -> Draw ()
oval x y rx ry = do
  arc_internal False x y rx ry 0 360
  closepath

-- | The common implementation of 'arc', 'arc_append', and 'oval'. The
-- first parameter is a boolean flag indicating whether to append to
-- an existing subpath or start a new subpath. The fourth and fifth
-- parameter are the horizontal and vertical radius.
arc_internal :: Bool -> X -> Y -> Double -> Double -> Double -> Double -> Draw ()
arc_internal connect x y rx ry a1 a2 = do
  if connect then lineto x0 y0 else moveto x0 y0
  -- We divide the arc into n segments of 90 degrees or less.
  sequence_ [ aux a | i <- [0..n-1], let a = a1 + (fromIntegral i)*phi ]
  where
    (x0, y0) = point rx ry a1
    n = int_ceiling (abs(a2 - a1) / 90)
    phi = if n > 0 then (a2 - a1) / (fromIntegral n) else 0
    alpha = 4/3 * c / (1+c)
    c = cos' (phi/2)
    point rx ry a = (x + rx * cos' a, y + ry * sin' a)
    cos' x = cos (pi/180 * x)
    sin' x = sin (pi/180 * x)
    along (x0,y0) (x1,y1) alpha = (x0 + alpha * (x1-x0), y0 + alpha * (y1-y0))
    aux a = curveto x1 y1 x2 y2 x3 y3
      where
        (x0, y0) = point rx ry a
        (x3, y3) = point rx ry (a + phi)
        (xp, yp) = point (rx/c) (ry/c) (a + phi/2)
        (x1, y1) = along (x0, y0) (xp, yp) alpha
        (x2, y2) = along (x3, y3) (xp, yp) alpha

-- | @'rectangle' /x/ /y/ /w/ /h/@: Draw a rectangle of width /w/ and
-- height /h/, starting from (/x/,/y/). If /w/ and /h/ are positive,
-- then (/x/,/y/) is the lower left corner.
rectangle :: X -> Y -> X -> Y -> Draw ()
rectangle x y w h = draw_subroutine alt def where
  def = do
    moveto x y
    lineto x (y+h)
    lineto (x+w) (y+h)
    lineto (x+w) y
    closepath
  alt = [
    custom_pdf $ printf "%f %f %f %f re\n" x y w h,
    custom_ascii $ printf "Rectangle %f %f %f %f\n" x y w h
    ]

-- ----------------------------------------------------------------------
-- * Customization

-- $CUSTOMIZATION
-- 
-- The document and drawing abstractions provided by this module are
-- purposely kept general-purpose, and do not include
-- application-specific features. However, we provide a mechanism by
-- which applications can provide customized drawing commands and
-- other custom features.

-- ** Custom drawing commands

-- $CUSTOMCOMMANDS
-- 
-- It is sometimes useful to use customized drawing commands. For
-- example, an application that draws many rectangles might like to
-- define a custom 'rectangle' function for appending a rectangle to
-- the current path. Of course this can be defined as an ordinary
-- Haskell function, using elementary drawing commands:
-- 
-- > my_rect :: X -> Y -> X -> Y -> Draw ()
-- > my_rect x0 y0 x1 y1 = do
-- >   moveto x0 y0
-- >   lineto x0 y1
-- >   lineto x1 y1
-- >   lineto x1 y0
-- >   closepath
-- 
-- However, sometimes it is nice to make use of specialized abilities
-- of individual backends. For example, PDF already has a built-in
-- rectangle drawing command, and PostScript has the ability to define
-- custom subroutines within the document text. Using these features
-- can decrease the size of the generated documents. 
-- 
-- We therefore provide a facility for defining new drawing commands
-- with backend-specific implementations. For example, a more general
-- version of the above 'my_rect' function can be defined as
-- follows:
-- 
-- > my_rect :: X -> Y -> X -> Y -> Draw ()
-- > my_rect x0 y0 x1 y1 = draw_subroutine alt $ do
-- >   moveto x0 y0
-- >   lineto x0 y1
-- >   lineto x1 y1
-- >   lineto x1 y0
-- >   closepath
-- >  where
-- >   alt = [
-- >     custom_ps $      printf "%f %f %f %f rect\n" x0 y0 x1 y1,
-- >     custom_pdf $     printf "%f %f %f %f re\n" x0 y0 (x1-x0) (y1-y0),
-- >     custom_ascii $   printf "My_rect %f %f %f %f\n" x0 y0 x1 y1
-- >     ]
-- 
-- The idea is to provide a default definition in terms of primitive
-- drawing commands, as well as a list of various backend specific
-- definitions. In the case of PostScript subroutines, the PostScript
-- file must then also be supplied with a definition for the /rect/
-- subroutine, which can be done with the command 'render_ps_custom':
-- 
-- > my_ps_defs = "/rect { ... } bind def\n"
-- >
-- > my_render_ps = render_ps_custom custom { ps_defs = my_ps_defs }
-- 
-- Note that the 'draw_subroutine' customization mechanism is entirely
-- optional. Its purpose is to generate shorter output for some
-- backends; if it is omitted, the file may be be longer but should
-- look the same.

-- | An enumeration of backend languages, for the purpose of defining
-- custom drawing commands. Note that several backends (e.g. EPS and
-- PostScript) may share the same language, and therefore they are
-- only represented once in this enumeration.
data Language =
  Language_PS      -- ^ PostScript (including EPS)
  | Language_PDF   -- ^ PDF
  | Language_ASCII -- ^ ASCII (for debugging)
  deriving (Show, Eq, Ord)

-- | The type of custom definitions, to be used with the
-- 'draw_subroutine' command.
data CustomDef = CustomDef Language String
  deriving (Show)

-- | Define a custom PostScript definition.
custom_ps :: String -> CustomDef
custom_ps s = CustomDef Language_PS s

-- | Define a custom PDF definition.
custom_pdf :: String -> CustomDef
custom_pdf s = CustomDef Language_PDF s

-- | Define a custom ASCII definition.
custom_ascii :: String -> CustomDef
custom_ascii s = CustomDef Language_ASCII s

-- | Look up an element in a list of 'CustomDef's.
custom_lookup :: Language -> [CustomDef] -> Maybe String
custom_lookup lang defs = 
  case find (\(CustomDef l _) -> l==lang) defs of
    Nothing -> Nothing
    Just (CustomDef l s) -> Just s

-- ----------------------------------------------------------------------
-- ** Customization interface

-- | A data structure that holds application-specific meta-data and
-- customization information.
data Custom = Custom { 
  creator :: String, -- ^ Name of the software that created the file.
                     -- Example: \"MyApp 1.0\". Note: this is intended
                     -- to hold the name of the software, not the
                     -- human user, that created the document.
  ps_defs :: String  -- ^ Definitions to go in the PostScript
                     -- preamble.
  }
              
-- | An empty customization structure. Customizations should be
-- specified by modifying 'custom', for example:
-- 
-- > custom { creator = "MyApp 1.0" }
custom :: Custom
custom = Custom {
  creator = "",
  ps_defs = ""
  }

-- ----------------------------------------------------------------------
-- * Generic string output

-- ----------------------------------------------------------------------
-- ** The WriterMonad class

-- | A 'WriterMonad' is any monad that one can output strings to.
-- 
-- Minimal complete definition: 'wPutChar' or 'wPutStr'.
class Monad m => WriterMonad m where
  -- | Write a character.
  wPutChar :: Char -> m ()
  wPutChar c = wPutStr [c]
  
  -- | Write a string.
  wPutStr :: String -> m ()
  wPutStr s = sequence_ [ wPutChar c | c <- s ]
  
-- | Like 'wPutStr', but adds a newline character.
wPutStrLn :: (WriterMonad m) => String -> m ()
wPutStrLn s = do
  wPutStr s
  wPutChar '\n'
  
-- | Write a value of any printable type, and add a newline.
wprint :: (WriterMonad m, Show a) => a -> m ()
wprint x = wPutStrLn (show x)
    
instance WriterMonad IO where
  wPutChar = putChar
  wPutStr = putStr

-- ----------------------------------------------------------------------
-- ** The Writer monad

-- | A generic 'WriterMonad'.
data Writer a =
  Writer_Return a                    -- ^ Terminate with a result.
  | Writer_PutChar Char (Writer a)   -- ^ Write a character.
  | Writer_PutStr String (Writer a)  -- ^ Write a string.

instance Monad Writer where
  return a = Writer_Return a
  f >>= g = case f of
    Writer_Return a -> g a
    Writer_PutChar c f' -> Writer_PutChar c (f' >>= g)
    Writer_PutStr s f' -> Writer_PutStr s (f' >>= g) 
    
instance Applicative Writer where
  pure = return
  (<*>) = ap

instance Functor Writer where
  fmap = liftM

instance WriterMonad Writer where
  wPutChar c = Writer_PutChar c (Writer_Return ())
  wPutStr s = Writer_PutStr s (Writer_Return ())
  
-- ----------------------------------------------------------------------
-- ** Isomorphism with (String, a)
  
-- | Isomorphically map a 'Writer' computation to a pair of a string
-- and a value.
-- 
-- Important usage note: the 'String' in the output is produced
-- lazily, and before /a/ is produced. To preserve laziness, do not
-- evaluate /a/ before the end of 'String' has been reached.
writer_to_pair :: Writer a -> (String, a)
writer_to_pair (Writer_Return a) = ("", a)
writer_to_pair (Writer_PutChar c cont) = (c:t, a) where
  (t, a) = writer_to_pair cont
writer_to_pair (Writer_PutStr s cont) = (s ++ t, a) where
  (t, a) = writer_to_pair cont

-- | The inverse of 'writer_to_pair'.
pair_to_writer :: (String, a) -> Writer a
pair_to_writer (s, a) = do
  wPutStr s
  return a

-- ----------------------------------------------------------------------
-- ** Run functions

-- | Run a 'Writer' computation in any 'WriterMonad'.
run_writer :: (WriterMonad m) => Writer a -> m a
run_writer (Writer_Return a) = return a
run_writer (Writer_PutChar c cont) = do
  wPutChar c
  run_writer cont
run_writer (Writer_PutStr s cont) = do
  wPutStr s
  run_writer cont

-- | Run a writer in the 'IO' monad by printing to a file.
writer_to_file :: Handle -> Writer a -> IO a
writer_to_file h (Writer_Return a) = return a
writer_to_file h (Writer_PutChar c cont) = do
  hPutChar h c
  writer_to_file h cont
writer_to_file h (Writer_PutStr s cont) = do
  hPutStr h s
  writer_to_file h cont

-- | Run a writer by printing to a string.
writer_to_string :: Writer a -> String
writer_to_string = fst . writer_to_pair

-- ----------------------------------------------------------------------
-- ** Boxed monads

-- | Create an identical \"boxed\" copy of a type constructor. This is
-- used for technical reasons, to allow the 'wprintf' operation to be
-- typed.
newtype Boxed m a = Boxed (m a)

-- | Unbox a boxed item.
unbox :: Boxed m a -> m a
unbox (Boxed x) = x

instance Monad m => Monad (Boxed m) where
  return a = Boxed (return a)
  f >>= g = Boxed (unbox f >>= (unbox . g))

instance Applicative m => Applicative (Boxed m) where
  pure a = Boxed (pure a)
  f <*> x = Boxed (unbox f <*> unbox x)

instance Functor m => Functor (Boxed m) where
  fmap f x = Boxed (fmap f (unbox x))

instance WriterMonad m => WriterMonad (Boxed m) where
  wPutChar c = Boxed (wPutChar c)
  wPutStr c = Boxed (wPutStr c)

instance MonadState s m => MonadState s (Boxed m) where
  get = Boxed get
  put s = Boxed (put s)

-- ----------------------------------------------------------------------
-- ** Currying in a boxed monad
  
-- | A class to curry/uncurry functions in any boxed monad. This
-- establishes an isomorphism
-- 
-- > @fun  ≅  args -> Boxed m res,@
-- 
-- where
-- 
-- > fun = a1 -> a2 -> ... -> an -> Boxed m res,
-- > args = (a1, (a2, (..., (an, ())))).
class Boxed_Curry fun args m res | fun -> args res m, args res m -> fun where
  boxed_curry :: (args -> Boxed m res) -> fun
  boxed_uncurry :: fun -> (args -> Boxed m res)

instance Boxed_Curry (Boxed m a) () m a where
  boxed_curry g = g ()
  boxed_uncurry x = const x
  
instance Boxed_Curry fun args m res => Boxed_Curry (a -> fun) (a, args) m res where
  boxed_curry g x = boxed_curry (\xs -> g (x,xs))
  boxed_uncurry f (x,xs) = boxed_uncurry (f x) xs

-- ----------------------------------------------------------------------  
-- ** Formatted printing
  
-- | Print a formatted value in the context of a boxed WriterMonad. Usage:
-- 
-- wprintf "%f %f" x y :: Boxed Writer
wprintf :: (Boxed_Curry fun args m (), WriterMonad m, Curry fun' args String, PrintfType fun') => String -> fun
wprintf fmt = g where
  g = boxed_curry g'
  g' args = wPutStr (f' args)
  f' = muncurry f
  f = printf fmt

-- | In any 'WriterMonad', introduce a block in which 'wprintf' can be
-- used. This has no computational overhead, i.e., is compiled to the
-- identity operation; it exists only to please the type system,
-- due to the fancy typing of 'wprintf'.
with_printf :: (WriterMonad m) => Boxed m a -> m a
with_printf = unbox

-- ----------------------------------------------------------------------
-- ** Filters

-- $ A filter is any function from strings to strings, but it should
-- usually be lazy. Typical examples are compression, encryption,
-- ASCII armoring, character encoding, and their inverses.
-- 
-- We provide a convenient operator for temporarily wrapping a filter
-- around the 'Writer' monad, as well as specific filters.

-- | Wrap a filter around a 'Writer' computation. This introduces a
-- local block within the 'Writer' monad; all text written within the
-- block is encoded through the given filter. Filters can be composed
-- and nested.
with_filter :: (WriterMonad m) => (String -> String) -> Writer a -> m a
with_filter encoding = run_writer . pair_to_writer . (\(x,y) -> (encoding x, y)) . writer_to_pair

-- | A filter for performing \"flate\" (also known as \"zlib\")
-- compression. 
-- 
-- Note: both the input and output strings are regarded as sequences
-- of bytes, not characters. Any characters outside the byte range are
-- truncated to 8 bits.
flate_filter :: String -> String
flate_filter = map chr . map fromIntegral . ByteString.unpack . compress . ByteString.pack . map fromIntegral . map ord

-- ----------------------------------------------------------------------
-- * Backends

-- ----------------------------------------------------------------------
-- ** Auxiliary functions

-- | Ensure that the last line of the string ends in a newline
-- character, adding one if necessary. An empty string is considered to contain zero lines, so no newline character needs to be added. 
ensure_nl :: String -> String
ensure_nl "" = ""
ensure_nl s = 
  if last s == '\n' then s else s++"\n"

-- ----------------------------------------------------------------------
-- * ASCII output

-- | Render draw actions as ASCII.
draw_to_ascii :: Draw a -> Writer a
draw_to_ascii (Draw_Return x) = return x
draw_to_ascii (Draw_Write cmd cont) = do
  command_to_ascii cmd
  draw_to_ascii cont
draw_to_ascii (Draw_Block f) = do
  wPutStrLn "begin"
  cont <- draw_to_ascii f
  wPutStrLn "end"
  draw_to_ascii cont
  
-- | Render drawing commands as ASCII.
command_to_ascii :: DrawCommand -> Writer ()
command_to_ascii (Subroutine draw alt) =
  case custom_lookup Language_ASCII alt of
    Just out -> wPutStr (ensure_nl out)
    Nothing -> draw_to_ascii draw
command_to_ascii cmd =
  wprint cmd

-- | Render a document as ASCII.
document_to_ascii :: Document a -> Writer a
document_to_ascii (Document_Return x) = return x
document_to_ascii (Document_Page x y draw) = do
  wPutStrLn $ "startpage " ++ show x ++ " " ++ show y
  cont <- draw_to_ascii draw
  wPutStrLn "endpage"
  document_to_ascii cont
document_to_ascii (Document_Page_defer draw) = do
  wPutStrLn "startpage (atend)"
  (x, y, cont) <- draw_to_ascii draw
  wPutStrLn $ "endpage " ++ show x ++ " " ++ show y
  document_to_ascii cont
  
-- | Render a document as ASCII. This is for debugging purposes only.
-- The output is a sequence of drawing commands, rather than a
-- graphical representation.
render_ascii :: Document a -> Writer a
render_ascii = document_to_ascii

-- ----------------------------------------------------------------------
-- * PostScript output
  
-- ----------------------------------------------------------------------
-- ** Auxiliary functions

-- | Escape special characters in a string literal.
ps_escape :: String -> String
ps_escape [] = []
ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t
ps_escape ('('  : t) = '\\' : '('  : ps_escape t
ps_escape (')'  : t) = '\\' : ')'  : ps_escape t
ps_escape (h : t)    = h : ps_escape t

-- | Remove newline characters in a string.
remove_nl :: String -> String
remove_nl = map f where
  f '\n' = ' '
  f '\r' = ' '
  f x = x

-- ----------------------------------------------------------------------
-- ** The PSWriter monad

-- $ For convenience, we wrap the 'Writer' monad in a custom state monad;
-- the latter keeps track of the current document bounding box (i.e.,
-- the smallest bounding box containing all pages) and the current
-- number of pages.

-- | The type of page numbers.
type Page = Integer

-- | A state to keep track of a current bounding box and page number.
data PS_State = PS_State !X !Y !Page

-- | The initial 'PS_State'.
ps_state_empty :: PS_State
ps_state_empty = PS_State 0 0 0 

-- | The 'PSWriter' monad. This is just a 'PS_State' wrapped around
-- the 'Writer' monad.
type PSWriter = Boxed (StateT PS_State Writer)

instance WriterMonad (StateT PS_State Writer) where
  wPutChar c = lift (wPutChar c)
  wPutStr s = lift (wPutStr s)

-- | Run function for the 'PSWriter' monad.
pswriter_run :: PSWriter a -> Writer a
pswriter_run f = evalStateT (unbox f) ps_state_empty

-- ----------------------------------------------------------------------
-- *** Access functions for the PSWriter monad

-- | Get the bounding box.
ps_get_bbox :: PSWriter (X, Y)
ps_get_bbox = do
  PS_State x y _ <- get
  return (x, y)
  
-- | Add to the bounding box.
ps_add_bbox :: X -> Y -> PSWriter ()
ps_add_bbox x y = do
  PS_State x' y' p <- get
  put (PS_State (x `max` x') (y `max` y') p)

-- | Get the page count.
ps_get_pagecount :: PSWriter Page
ps_get_pagecount = do
  PS_State _ _ p <- get
  return p
  
-- | Return the next page number.
ps_next_page :: PSWriter Page
ps_next_page = do
  PS_State x y p <- get
  put (PS_State x y (p+1))
  return (p+1)

-- ----------------------------------------------------------------------
-- ** Internal rendering to the PSWriter monad

-- | Render draw actions as PostScript.
draw_to_ps :: Draw a -> PSWriter a
draw_to_ps (Draw_Return x) = return x
draw_to_ps (Draw_Write cmd cont) = do
  command_to_ps cmd
  draw_to_ps cont
draw_to_ps (Draw_Block body) = do
  wPutStrLn "gsave"
  cont <- draw_to_ps body
  wPutStrLn "grestore"
  draw_to_ps cont
  
-- | Set the color.
color_to_ps :: Color -> PSWriter ()
color_to_ps (Color_RGB r g b) = do
  wprintf "%f %f %f setrgbcolor\n" r g b
color_to_ps (Color_Gray v) = do
  wprintf "%f setgray\n" v

-- | Set the font.
font_to_ps :: Font -> PSWriter ()
font_to_ps (Font TimesRoman pt) = do
  wprintf "/Times-Roman findfont %f scalefont setfont\n" pt
font_to_ps (Font Helvetica pt) = do
  wprintf "/Helvetica findfont %f scalefont setfont\n" pt

-- | Draw a single drawing command to PostScript.
command_to_ps :: DrawCommand -> PSWriter ()
command_to_ps (Newpath) = do
  wPutStrLn "newpath"
command_to_ps (Moveto x y) = do
  wprintf "%f %f moveto\n" x y
command_to_ps (Lineto x y) = do
  wprintf "%f %f lineto\n" x y
command_to_ps (Curveto x1 y1 x2 y2 x y) = do
  wprintf "%f %f %f %f %f %f curveto\n" x1 y1 x2 y2 x y
command_to_ps (Closepath) = do
  wPutStrLn "closepath"
command_to_ps (Stroke) = do
  wPutStrLn "stroke"
command_to_ps (Clip) = do
  wPutStrLn "clip"
  wPutStrLn "newpath"
command_to_ps (Fill color) = do
  wPutStrLn "gsave" 
  color_to_ps color
  wPutStrLn "fill" 
  wPutStrLn "grestore"
  wPutStrLn "newpath"
command_to_ps (FillStroke color) = do
  wPutStrLn "gsave"
  color_to_ps color
  wPutStrLn "fill"
  wPutStrLn "grestore"
  wPutStrLn "stroke"
command_to_ps (TextBox align font color x0 y0 x1 y1 b s) = do
  wPutStrLn "gsave"
  font_to_ps font
  color_to_ps color
  wprintf "(%s) %f %f %f %f %f %f textbox\n" (ps_escape s) x0 y0 x1 y1 align yshift
  wPutStrLn "grestore"
  where
    yshift = -b * nominalsize font
command_to_ps (SetLineWidth x) = do
  wprintf "%f setlinewidth\n" x
command_to_ps (SetColor color) = do
  color_to_ps color
command_to_ps (Translate x y) = do
  wprintf "%f %f translate\n" x y
command_to_ps (Scale x y) = do
  wprintf "%f %f scale\n" x y
command_to_ps (Rotate angle) = do
  wprintf "%f rotate\n" angle
command_to_ps (Comment s) = do
  wprintf "%% %s\n" (remove_nl s)
command_to_ps (Subroutine draw alt) = 
  case custom_lookup Language_PS alt of
    Just out -> wprintf "%s" (ensure_nl out)
    Nothing -> draw_to_ps draw

-- | Render a document as PostScript.
document_to_ps :: Custom -> Document a -> PSWriter a
document_to_ps custom document = do
  -- global header
  wPutStrLn "%!PS-Adobe-3.0"
  wPutStrLn "%%LanguageLevel: 2"
  when (creator custom /= "") $ do
    wprintf "%%%%Creator: %s\n" (creator custom)
  wPutStrLn "%%BoundingBox: (atend)"
  wPutStrLn "%%HiResBoundingBox: (atend)"
  wPutStrLn "%%Pages: (atend)"
  wPutStrLn "%%EndComments"
  wPutStrLn "%%BeginSetup"
  wprintf "%s" global_ps_defs
  when (ps_defs custom /= "") $ do
    wprintf "%s" (ensure_nl $ ps_defs custom)
  wPutStrLn "%%EndSetup"
  a <- pages_to_ps document
  (x, y) <- ps_get_bbox
  pagecount <- ps_get_pagecount
  wPutStrLn "%%Trailer"
  wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y)
  wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y
  wprintf "%%%%Pages: %d\n" pagecount
  wPutStrLn "%%EOF"
  return a

-- | Global PostScript definitions used by the rendering engine.
global_ps_defs :: String
global_ps_defs = "/textbox { /b exch def /align exch def /y1 exch def /x1 exch def /y0 exch def /x0 exch def /dx x1 x0 sub def /dy y1 y0 sub def /d dx dx mul dy dy mul add sqrt def dup stringwidth pop /w exch def /fontscale w d le {d} {w} ifelse def gsave [dx dy dy neg dx x0 y0] concat 1 fontscale div dup scale fontscale w sub align mul b moveto show grestore } bind def\n"
        
-- | Render pages as PostScript.
pages_to_ps :: Document a -> PSWriter a
pages_to_ps (Document_Return a) = return a
pages_to_ps (Document_Page x y draw) = do
  page <- ps_next_page
  ps_add_bbox x y
  wprintf "%%%%Page: %d %d\n" page page
  wprintf "%%%%PageBoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y)
  wprintf "%%%%PageHiResBoundingBox: 0 0 %f %f\n" x y
  wPutStrLn "save"
  cont <- draw_to_ps draw
  wPutStrLn "showpage"
  wPutStrLn "restore"
  pages_to_ps cont
pages_to_ps (Document_Page_defer draw) = do
  page <- ps_next_page
  wprintf "%%%%Page: %d %d\n" page page
  wPutStrLn "%%PageBoundingBox: (atend)"
  wPutStrLn "%%PageHiResBoundingBox: (atend)"
  (x, y, cont) <- draw_to_ps draw
  wPutStrLn "showpage"
  wPutStrLn "%%PageTrailer"
  wprintf "%%%%PageBoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y)
  wprintf "%%%%PageHiResBoundingBox: 0 0 %f %f\n" x y
  ps_add_bbox x y
  pages_to_ps cont

-- ----------------------------------------------------------------------
-- ** Rendering to the Writer monad

-- | Render document as PostScript. The first argument is a
-- customization data structure.
render_ps_custom :: Custom -> Document a -> Writer a
render_ps_custom custom doc = 
  pswriter_run (document_to_ps custom doc)

-- ----------------------------------------------------------------------
-- * EPS output

-- $ Encapsulated PostScript (EPS) output is slightly different from
-- normal PostScript output. EPS is limited to a single page, and
-- contains no \"showpage\" command. We permit the user to print a
-- single page from a multi-page document, by specifying the page
-- number.

-- | Render a document as EPS. Since EPS only permits a single page of
-- output, the 'Page' parameter is used to specify which page (of a
-- potential multi-page document) should be printed. An error will be
-- thrown if the page number was out of range.
-- 
-- Note: if the return value is not used, the remaining pages are
-- lazily skipped.
document_to_eps :: Custom -> Page -> Document a -> PSWriter a
document_to_eps custom page (Document_Return a) = 
  error "document_to_eps: requested page does not exist"
document_to_eps custom page (Document_Page x y draw)  
  | page == 1 = do
      -- EPS header
      wPutStrLn "%!PS-Adobe-3.0 EPSF-3.0"
      wPutStrLn "%%LanguageLevel: 2"
      when (creator custom /= "") $ do
        wprintf "%%%%Creator: %s\n" (creator custom)
      wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y)
      wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y
      wPutStrLn "%%Pages: 1"
      wPutStrLn "%%EndComments"
      wPutStrLn "%%Page: 1 1"
      wPutStrLn "save"
      wprintf "%s" global_ps_defs
      when (ps_defs custom /= "") $ do
        wprintf "%s" (ensure_nl $ ps_defs custom)
      cont <- draw_to_ps draw
      wPutStrLn "restore"
      wPutStrLn "%%EOF"
      let a = document_skip cont
      return a
  | otherwise = do
      let cont = draw_skip draw
      document_to_eps custom (page-1) cont
document_to_eps custom page (Document_Page_defer draw)  
  | page == 1 = do
      -- EPS header
      wPutStrLn "%!PS-Adobe-3.0 EPSF-3.0"
      wPutStrLn "%%LanguageLevel: 2"
      when (creator custom /= "") $ do
        wprintf "%%%%Creator: %s\n" (creator custom)
      wPutStrLn "%%BoundingBox: (atend)"
      wPutStrLn "%%HiResBoundingBox: (atend)"
      wPutStrLn "%%Pages: 1"
      wPutStrLn "%%EndComments"
      wPutStrLn "%%Page: 1 1"
      wPutStrLn "save"
      wprintf "%s" global_ps_defs
      when (ps_defs custom /= "") $ do
        wprintf "%s" (ensure_nl $ ps_defs custom)
      (x, y, cont) <- draw_to_ps draw
      wPutStrLn "restore"
      wPutStrLn "%%Trailer"
      wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y)
      wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y
      wPutStrLn "%%EOF"
      let a = document_skip cont
      return a
  | otherwise = do
      let (_, _, cont) = draw_skip draw
      document_to_eps custom (page-1) cont
        
-- | Render document as EPS. The first argument is a customization
-- data structure, and the second argument is the number of the page
-- to extract from the document.
render_eps_custom :: Custom -> Page -> Document a -> Writer a
render_eps_custom custom page doc = 
  pswriter_run (document_to_eps custom page doc)

-- ----------------------------------------------------------------------
-- * PDF output

-- ----------------------------------------------------------------------
-- ** Auxiliary functions

-- | Escape special characters in a string literal.
pdf_escape :: String -> String
pdf_escape [] = []
pdf_escape ('\\' : t) = '\\' : '\\' : pdf_escape t
pdf_escape ('('  : t) = '\\' : '('  : pdf_escape t
pdf_escape (')'  : t) = '\\' : ')'  : pdf_escape t
pdf_escape (h : t)    = h : pdf_escape t

-- ----------------------------------------------------------------------
-- ** The PDF state

-- $ Creating PDF files requires some state: we need to keep track of
-- the current file position, page numbering, and object numbering. 

-- | A position in a file. The first byte is 0.
type Filepos = Integer

-- | A PDF object reference.
type Object = Integer

-- | A state to keep track of PDF document structure: current
-- character count, current TOC, current page, etc.
data PDF_State = PDF_State {
  pdf_filepos :: !Filepos,              -- ^ Current position in file.
  pdf_obj :: !Object,                   -- ^ Object count.
  pdf_xref :: !(Map Object Filepos),    -- ^ Cross-reference table.
  pdf_page :: !Page,                    -- ^ Next available page number.
  pdf_pagetable :: !(Map Page Object),  -- ^ Page table.
  pdf_font :: !Integer,                 -- ^ Next available font number.
  pdf_fonttable :: !(Map String String) -- ^ Font table mapping each font's PostScript name to a local name.
  }
                 
-- | The initial 'PDF_State'.
pdf_state_empty :: PDF_State
pdf_state_empty = PDF_State {
  pdf_filepos = 0,
  pdf_obj = 0,
  pdf_xref = Map.empty,
  pdf_page = 0,
  pdf_pagetable = Map.empty,
  pdf_font = 0,
  pdf_fonttable = Map.empty
  }

-- ----------------------------------------------------------------------
-- ** The PDFWriter monad

-- | The 'RawPDFWriter' monad is just a 'PDF_State' wrapped around
-- the 'Writer' monad. Its 'wPutChar' and 'wPutStr' methods
-- automatically keep track of the file position.
type RawPDFWriter = StateT PDF_State Writer

instance WriterMonad RawPDFWriter where
  wPutChar c = do
    lift (wPutChar c)
    pdf_inc_filepos 1
  wPutStr s = do                 
    lift (wPutStr s)
    pdf_inc_filepos (toInteger $ length s)

-- | Boxed version of the 'RawPDFWriter' monad.
type PDFWriter = Boxed RawPDFWriter
  
-- | Run function for the 'PDFWriter' monad.
pdfwriter_run :: PDFWriter a -> Writer a
pdfwriter_run f = do
  evalStateT (unbox f) pdf_state_empty

-- ----------------------------------------------------------------------
-- *** Access functions for the PDFWriter monad

-- | Get the file position.
pdf_get_filepos :: PDFWriter Filepos
pdf_get_filepos = do
  s <- get
  return $ pdf_filepos s

-- | Add to the file position.
pdf_inc_filepos :: Integer -> RawPDFWriter ()
pdf_inc_filepos n = do
  s <- get
  let p = pdf_filepos s
  put s { pdf_filepos = p+n }

-- | Get the number of allocated objects. Note that objects are
-- allocated as 1, 2, ..., /n/; this function returns /n/.
pdf_get_objcount :: PDFWriter Object
pdf_get_objcount = do
  s <- get
  return $ pdf_obj s
  
-- | Allocate an unused object identifier.
pdf_next_object :: PDFWriter Object
pdf_next_object = do
  s <- get
  let o = pdf_obj s
  put s { pdf_obj = o+1 }  
  return $ o+1
  
-- | Add a cross reference to the cross reference table.
pdf_add_xref :: Object -> Filepos -> PDFWriter ()
pdf_add_xref obj pos = do
  s <- get
  let xref = pdf_xref s
  put s { pdf_xref = Map.insert obj pos xref }

-- | Retrieve the cross reference table.
pdf_get_xref :: PDFWriter (Map Object Filepos)
pdf_get_xref = do
  s <- get
  return $ pdf_xref s

-- | Get the page count.
pdf_get_pagecount :: PDFWriter Page
pdf_get_pagecount = do
  s <- get
  return $ pdf_page s
  
-- | Return the next page number.
pdf_next_page :: PDFWriter Page
pdf_next_page = do
  s <- get
  let p = pdf_page s
  put s { pdf_page = p+1 }
  return $ p+1

-- | Add a page to the page table.
pdf_add_pagetable :: Page -> Object -> PDFWriter ()
pdf_add_pagetable page obj = do
  s <- get
  let pagetable = pdf_pagetable s
  put s { pdf_pagetable = Map.insert page obj pagetable }

-- | Retrieve the page table.
pdf_get_pagetable :: PDFWriter (Map Page Object)
pdf_get_pagetable = do
  s <- get
  return $ pdf_pagetable s

-- | Look up the local font identifier for a font.
pdf_find_font :: String -> PDFWriter String  
pdf_find_font font = do
  s <- get
  let t = pdf_fonttable s
  case Map.lookup font t of
    Nothing -> do
      let f = pdf_font s
      let fontname = "F" ++ show f
      put s { pdf_font = f+1, pdf_fonttable = Map.insert font fontname t }
      return fontname
    Just fontname -> return fontname
  
-- | Retrieve the font table.
pdf_get_fonttable :: PDFWriter (Map String String)
pdf_get_fonttable = do
  s <- get
  return $ pdf_fonttable s

-- | Clear the font table.
pdf_clear_fonttable :: PDFWriter ()
pdf_clear_fonttable = do
  s <- get
  put s { pdf_font = 0, pdf_fonttable = Map.empty }

-- ----------------------------------------------------------------------
-- *** Filters
  
-- | A version of 'with_filter' tailored to the 'PDFWriter' monad.
-- 
-- This allows certain global state updates within the local block.
-- Specifically, updates to everything except the file position are
-- propagated from the inner to the outer block. The outer block's
-- file position is updated to reflect the encoded content's
-- length. From the inner block's point of view, the file position
-- starts from 0.
with_filter_pdf :: (String -> String) -> PDFWriter a -> PDFWriter a
with_filter_pdf encoding body = do
  s <- get
  let s' = s { pdf_filepos = 0 } -- pass everything except filepos to the body
  (a, s'') <- with_filter encoding $ do
    runStateT (unbox body) s'
  pos <- pdf_get_filepos
  put s'' { pdf_filepos = pos } -- pass everything except filepos from the body
  return a

-- ----------------------------------------------------------------------
-- *** Higher access functions

-- | Define an indirect PDF object with the given object id, which
-- must have previously been uniquely obtained with 'pdf_next_object'.
-- 
-- This can be used to define objects with forward references: first
-- obtain an object id, then create references to the object, and
-- finally define the object.
-- 
-- It should be used like this:
-- 
-- > obj <- pdf_next_object
-- > ...
-- > pdf_deferred_object obj $ do
-- >   <<object definition>>
pdf_deferred_object :: Object -> PDFWriter a -> PDFWriter a
pdf_deferred_object obj body = do
  pos <- pdf_get_filepos
  pdf_add_xref obj pos
  wprintf "%d 0 obj\n" obj
  a <- body
  wprintf "endobj\n"
  return a

-- | Define an indirect PDF object with a newly generated object id.
-- Return the object id. This essentially combines 'pdf_next_object'
-- and 'pdf_deferred_object' into a single function, and should be
-- used like this:
-- 
-- > obj <- pdf_define_object $ do
-- >   <<object definition>>
pdf_define_object :: PDFWriter a -> PDFWriter Object
pdf_define_object body = do
  obj <- pdf_next_object
  pdf_deferred_object obj body
  return obj

-- | Define a PDF stream object with the given object id, which must
-- have previously been uniquely obtained with 'pdf_next_object'. It
-- should be used like this:
-- 
-- > obj <- pdf_next_object
-- > ...
-- > pdf_deferred_stream obj $ do
-- >   <<stream contents>>
pdf_deferred_stream :: Object -> PDFWriter a -> PDFWriter a
pdf_deferred_stream obj body = do
  length_obj <- pdf_next_object
  (a, len) <- pdf_deferred_object obj $ do
    wprintf "<</Length %s>>\n" (objref length_obj)
    wPutStr "stream\n"
    x0 <- pdf_get_filepos
    a <- body
    x1 <- pdf_get_filepos
    wPutStr "\n"
    wPutStr "endstream\n"
    return (a, x1-x0)
  pdf_deferred_object length_obj $ do
    wprintf "%d\n" len
  return a

-- | Define a PDF stream object with a newly generated object
-- id. Return the object id. This should be used like this:
-- 
-- > obj <- pdf_define_stream $ do
-- >   <<stream contents>>
pdf_define_stream :: PDFWriter a -> PDFWriter Object  
pdf_define_stream body = do
  obj <- pdf_next_object
  pdf_deferred_stream obj body
  return obj

-- | Define a compressed PDF stream object with the given object id,
-- which must have previously been uniquely obtained with
-- 'pdf_next_object'. It should be used like this:
-- 
-- > obj <- pdf_next_object
-- > ...
-- > pdf_deferred_flate_stream obj $ do
-- >   <<stream contents>>
pdf_deferred_flate_stream :: Object -> PDFWriter a -> PDFWriter a
pdf_deferred_flate_stream obj body = do
  length_obj <- pdf_next_object
  (a, len) <- pdf_deferred_object obj $ do
    wprintf "<</Length %s/Filter/FlateDecode>>\n" (objref length_obj)
    wPutStr "stream\n"
    x0 <- pdf_get_filepos
    a <- with_filter_pdf flate_filter body
    x1 <- pdf_get_filepos
    wPutStr "\n"
    wPutStr "endstream\n"
    return (a, x1-x0)
  pdf_deferred_object length_obj $ do
    wprintf "%d\n" len
  return a

-- | Create a direct object from a reference to an indirect object.
objref :: Object -> String
objref n = 
  show n ++ " 0 R"

-- | Write one line in the cross reference table. This must be exactly
-- 20 characters long, including the terminating newline.
wprintf_xref_entry :: Filepos -> Integer -> Char -> PDFWriter ()
wprintf_xref_entry pos gen c =
  wprintf "%010u %05u %c \n" pos gen c

-- | Format the cross reference table. Return the file position of the
-- cross reference table.
wprintf_xref :: PDFWriter Filepos
wprintf_xref = do
  xref <- pdf_get_xref
  n <- pdf_get_objcount
  pos <- pdf_get_filepos
  wprintf "xref\n"
  wprintf "0 %d\n" (n+1)
  wprintf_xref_entry 0 65535 'f'
  sequence_ [ case Map.lookup obj xref of  
                 Nothing -> wprintf_xref_entry 0 0 'f' 
                 Just p -> wprintf_xref_entry p 0 'n' | obj <- [1..n] ]
  return pos

-- ----------------------------------------------------------------------
-- ** Internal rendering to the PDFWriter monad

-- | Set the fill color.
fillcolor_to_pdf :: Color -> PDFWriter ()
fillcolor_to_pdf (Color_RGB r g b) = do
  wprintf "%f %f %f rg\n" r g b
fillcolor_to_pdf (Color_Gray v) = do
  wprintf "%f g\n" v

-- | Set the stroke color.
strokecolor_to_pdf :: Color -> PDFWriter ()
strokecolor_to_pdf (Color_RGB r g b) = do
  wprintf "%f %f %f RG\n" r g b
strokecolor_to_pdf (Color_Gray v) = do
  wprintf "%f G\n" v

-- | Set the font.
font_to_pdf :: Font -> PDFWriter ()
font_to_pdf (Font TimesRoman pt) = do
  fn <- pdf_find_font "Times-Roman"
  wprintf "/%s %f Tf\n" fn pt
font_to_pdf (Font Helvetica pt) = do
  fn <- pdf_find_font "Helvetica"
  wprintf "/%s %f Tf\n" fn pt

-- | Render a drawing command to PDF.
command_to_pdf :: DrawCommand -> PDFWriter ()
command_to_pdf (Newpath) = do
  wPutStr "n\n"
command_to_pdf (Moveto x y) = do
  wprintf "%f %f m\n" x y
command_to_pdf (Lineto x y) = do
  wprintf "%f %f l\n" x y
command_to_pdf (Curveto x1 y1 x2 y2 x y) = do
  wprintf "%f %f %f %f %f %f c\n" x1 y1 x2 y2 x y
command_to_pdf (Closepath) = do
  wPutStr "h\n"
command_to_pdf (Stroke) = do
  wPutStr "S\n"
command_to_pdf (Clip) = do
  wPutStr "W\n"
command_to_pdf (Fill color) = do
  fillcolor_to_pdf color
  wPutStr "f\n"
command_to_pdf (FillStroke color) = do
  fillcolor_to_pdf color
  wPutStr "B\n"
command_to_pdf (TextBox align font color x0 y0 x1 y1 b s) = do
  let w = text_width font s
      dx = x1 - x0
      dy = y1 - y0
      d = sqrt (dx*dx + dy*dy)
      f = max w d
      dxf = if f > 0 then dx/f else 1
      dyf = if f > 0 then dy/f else 1
      xshift = (f-w) * align
      yshift = -b * nominalsize font
  wPutStr "BT\n"
  font_to_pdf font
  wprintf "%f %f %f %f %f %f Tm\n" dxf dyf (-dyf) dxf (x0 + xshift*dxf - yshift*dyf) (y0 + xshift*dyf + yshift*dxf)
  fillcolor_to_pdf color
  wprintf "(%s) Tj\n" (pdf_escape s)
  wPutStr "ET\n"
command_to_pdf (SetLineWidth x) = do
  wprintf "%f w\n" x
command_to_pdf (SetColor color) = do
  strokecolor_to_pdf color
command_to_pdf (Translate x y) = do
  wprintf "1 0 0 1 %f %f cm\n" x y
command_to_pdf (Scale x y) = do
  wprintf "%f 0 0 %f 0 0 cm\n" x y
command_to_pdf (Rotate angle) = do
  wprintf "%f %f %f %f 0 0 cm\n" c s (-s) c where
    c = cos (pi/180 * angle)
    s = sin (pi/180 * angle)
command_to_pdf (Comment s) = do
  wprintf "%% %s\n" (remove_nl s)
command_to_pdf (Subroutine draw alt) = do
  case custom_lookup Language_PDF alt of
    Just out -> wprintf "%s" (ensure_nl out)
    Nothing -> draw_to_pdf draw

-- | Render a draw action to PDF.
draw_to_pdf :: Draw a -> PDFWriter a
draw_to_pdf (Draw_Return x) = return x
draw_to_pdf (Draw_Write cmd cont) = do
  command_to_pdf cmd
  draw_to_pdf cont
draw_to_pdf (Draw_Block body) = do
  wprintf "q\n"
  cont <- draw_to_pdf body
  wprintf "Q\n"
  draw_to_pdf cont

-- | Render pages as PDF. The first argument is a reference to the
-- document's page tree node. 
-- 
-- Note: Acrobat reader cannot handle pages whose bounding box width
-- or height exceed 200 inches (14400 points). Therefore, we
-- automatically scale pages to be no greater than 199 inches.
pages_to_pdf :: Object -> Document a -> PDFWriter a
pages_to_pdf pagetree_obj (Document_Return a) = return a
pages_to_pdf pagetree_obj (Document_Page x y draw) = do
  let sc = 14328 / maximum [x, y, 14328]
  page <- pdf_next_page
  wprintf "%% Page %d\n" page
  pdf_clear_fonttable
  contents_obj <- pdf_next_object
  cont <- pdf_deferred_flate_stream contents_obj $ do
    when (sc /= 1.0) $ do
      draw_to_pdf $ do
        scale sc sc
    draw_to_pdf draw
  fonttable_obj <- pdf_define_object $ do
    fonttable <- pdf_get_fonttable
    wprintf "<<\n"
    sequence_ [ wprintf "/%s<</Type/Font/Subtype/Type1/BaseFont/%s>>\n" x f | (f,x) <- Map.toList fonttable ]
    wprintf ">>\n"
  page_obj <- pdf_define_object $ do
    wprintf "<</Type/Page/Parent %s/Resources<</ProcSet[/PDF]/Font %s>>/MediaBox[0 0 %f %f]/Contents %s>>\n" (objref pagetree_obj) (objref fonttable_obj) (x*sc) (y*sc) (objref contents_obj)
  pdf_add_pagetable page page_obj
  pages_to_pdf pagetree_obj cont
pages_to_pdf pagetree_obj (Document_Page_defer draw) = do
  page <- pdf_next_page
  wprintf "%% Page %d\n" page
  pdf_clear_fonttable
  contents_obj <- pdf_next_object
  (x, y, cont) <- pdf_deferred_stream contents_obj $ do
    draw_to_pdf draw
  fonttable_obj <- pdf_define_object $ do
    fonttable <- pdf_get_fonttable
    wprintf "<<\n"
    sequence_ [ wprintf "/%s<</Type/Font/Subtype/Type1/BaseFont/%s>>\n" x f | (f,x) <- Map.toList fonttable ]
    wprintf ">>\n"
  let sc = 14328 / maximum [x, y, 14328]
  scaled_contents_obj <- 
    if sc == 1.0 then do
      return contents_obj
    else do
      scale_obj <- pdf_define_stream $ do
        draw_to_pdf $ do
          scale sc sc
      obj <- pdf_define_object $ do
        wprintf "[%s %s]\n" (objref scale_obj) (objref contents_obj)
      return obj
  page_obj <- pdf_define_object $ do
    wprintf "<</Type/Page/Parent %s/Resources<</ProcSet[/PDF]/Font %s>>/MediaBox[0 0 %f %f]/Contents %s>>\n" (objref pagetree_obj) (objref fonttable_obj) (x*sc) (y*sc) (objref scaled_contents_obj)
  pdf_add_pagetable page page_obj
  pages_to_pdf pagetree_obj cont
 
-- | Render a document as PDF.
document_to_pdf :: Custom -> Document a -> PDFWriter a
document_to_pdf custom document = do
  -- global header
  wprintf "%%PDF-1.3\n"
  info_obj <- pdf_define_object $ do
    if (creator custom /= "") 
      then wprintf "<</Creator(%s)>>\n" (pdf_escape $ creator custom)
      else wprintf "<<>>\n"
  pagetree_obj <- pdf_next_object
  catalog_obj <- pdf_define_object $ do
    wprintf "<</Type/Catalog/Pages %s>>\n" (objref pagetree_obj)
  a <- pages_to_pdf pagetree_obj document
  pages <- pdf_get_pagecount
  pagetable <- pdf_get_pagetable
  pdf_deferred_object pagetree_obj $ do
    wprintf "<</Type/Pages/Count %d/Kids[\n" pages
    sequence_ [ wprintf "%s\n" (objref o) | o <- Map.elems pagetable ]
    wprintf "]>>\n"
  xref_pos <- wprintf_xref
  wprintf "trailer\n"
  objcount <- pdf_get_objcount
  wprintf "<</Size %d/Root %s/Info %s>>\n" objcount (objref catalog_obj) (objref info_obj)
  wprintf "startxref\n"
  wprintf "%d\n" xref_pos
  wprintf "%%%%EOF\n"
  return a

-- ----------------------------------------------------------------------
-- ** Rendering to the Writer monad

-- | Render document as PDF. The first argument is a
-- customization data structure.
render_pdf_custom :: Custom -> Document a -> Writer a
render_pdf_custom custom doc = pdfwriter_run (document_to_pdf custom doc)

-- ----------------------------------------------------------------------
-- * Generic output functions

-- $BACKENDS 
-- 
-- The following commands can be used to render documents to various
-- available formats. The available formats are PostScript, PDF, EPS,
-- and an ASCII-based debugging format. Output can be written to
-- standard output, to a file, or to a string.
  
-- | Available graphics formats for rendering.
data RenderFormat = 
  Format_PS            -- ^ PostScript.
  | Format_PDF         -- ^ Portable Document Format.
  | Format_EPS Integer -- ^ Encapsulated PostScript. The integer
                       -- argument specifies which single page to
                       -- extract from the document.
  | Format_Debug       -- ^ An ASCII-based debugging format.
 deriving Show

-- | Does the format require raw binary output?
is_binary_format :: RenderFormat -> Bool
is_binary_format Format_PS = False
is_binary_format Format_PDF = True
is_binary_format (Format_EPS page) = False
is_binary_format Format_Debug = False

-- ----------------------------------------------------------------------
-- ** Rendering with custom format

-- $CUSTOMRENDER
-- 
-- The following are versions of the generic rendering functions that
-- also take a customization data structure as an additional
-- parameter.

-- | Render a document to the 'Writer' monad, using the given output
-- format and customization data structure.
render_custom :: RenderFormat -> Custom -> Document a -> Writer a
render_custom Format_PS = render_ps_custom
render_custom Format_PDF = render_pdf_custom
render_custom (Format_EPS page) = (\c -> render_eps_custom c page)
render_custom Format_Debug = \c -> render_ascii

-- | Render a document to a file, using the given output format and
-- customization data structure.
render_custom_file :: Handle -> RenderFormat -> Custom -> Document a -> IO a
render_custom_file h format custom d = do
  when (is_binary_format format) $ do
    hSetBinaryMode h True
  writer_to_file h (render_custom format custom d)

-- | Render a document to standard output, using the given output
-- format and customization data structure.
render_custom_stdout :: RenderFormat -> Custom -> Document a -> IO a
render_custom_stdout = render_custom_file stdout

-- | Render a document to a string, using the given output format and
-- customization data structure.
render_custom_string :: RenderFormat -> Custom -> Document a -> String
render_custom_string format custom d =
  writer_to_string (render_custom format custom d)  

-- ----------------------------------------------------------------------
-- ** Rendering without custom format

-- | Render a document to the 'Writer' monad, using the given output format.
render :: RenderFormat -> Document a -> Writer a
render format doc = render_custom format custom doc

-- | Render a document to a file, using the given output format.
render_file :: Handle -> RenderFormat -> Document a -> IO a
render_file h format doc = render_custom_file h format custom doc

-- | Render a document to standard output, using the given output format.
render_stdout :: RenderFormat -> Document a -> IO a
render_stdout = render_file stdout

-- | Render a document to a string, using the given output format.
render_string :: RenderFormat -> Document a -> String
render_string format doc = render_custom_string format custom doc