module MarXup.PrettyPrint.Core(Doc(..),pretty,group,flatten,space,spacing,BoxTex(..)) where
import Data.Monoid
import MarXup (textual)
import MarXup.Latex
import MarXup.Tex
import MarXup.MultiRef
import Graphics.Diagrams.Core (BoxSpec (..))
import MarXup.Diagram.Tikz (showDistance)
import Data.Foldable (forM_)
import Control.Applicative
import Data.Function (on)
import Data.List (partition,minimumBy,sort)
import Data.Either (partitionEithers)
data BoxTex = TeX TeX BoxSpec | Spacing Double
data Doc = Empty
| Text BoxTex
| Line !Bool
| Cat Doc Doc
| Nest Double Doc
| Union Doc Doc
| Column (Double -> Doc)
| Nesting (Double -> Doc)
data SimpleDoc = SEmpty
| SText BoxTex SimpleDoc
| SLine Double SimpleDoc
toksToSimple [] = SEmpty
toksToSimple (Ln d:ts) = SLine d $ toksToSimple ts
toksToSimple (Tx s:ts) = SText s $ toksToSimple ts
instance Monoid Doc where
mempty = Empty
mappend = Cat
group :: Doc -> Doc
group x = Union (flatten x) x
flatten :: Doc -> Doc
flatten (Cat x y) = Cat (flatten x) (flatten y)
flatten (Nest i x) = Nest i (flatten x)
flatten (Line noSpace) = if noSpace then Empty else Text (Spacing 3.5)
flatten (Union x _y) = flatten x
flatten (Column f) = Column (flatten . f)
flatten (Nesting f) = Nesting (flatten . f)
flatten other = other --Empty,Char,Text
space = spacing 3.5
spacing = Text . Spacing
len (TeX _ b)= boxWidth b
len (Spacing x) = x
hei (TeX _ x) = boxHeight x + boxDepth x
hei (Spacing _) = 0
fits w _x | w < 0 = False
fits _w SEmpty = True
fits w (SText s x) = fits (w len s) x
fits w (SLine i x) = True
data Docs = Nil
| Cons !Double Doc Docs
data Token = Ln Double | Tx BoxTex
data Process = Process {overflow :: Double
,curIndent :: !Double
,numToks :: Int
,tokens :: [Token]
,rest :: !Docs
}
measure = \Process{..} -> (curIndent, negate numToks)
instance Eq Process where
(==) = (==) `on` measure
instance Ord Process where
compare = compare `on` measure
filtering :: [Process] -> [Process]
filtering (x:y:xs) | numToks x >= numToks y = filtering (x:xs)
| otherwise = x:filtering (y:xs)
filtering xs = xs
renderAll :: Double -> Double -> Doc -> SimpleDoc
renderAll rfrac w doc = toksToSimple $ reverse $ loop [Process 0 0 0 [] $ Cons 0 doc Nil]
where
loop ps = case dones of
((_,done):_) -> done
[] -> case conts of
(_:_) -> loop $ filtering $ sort $ conts
[] -> case conts'over of
(_:_) -> loop [minimumBy (compare `on` overflow) conts'over]
[] -> case dones'over of
((_,done):_) -> done
[] -> [Tx $ TeX (textual "Pretty print: Panic") (BoxSpec 0 0 0)]
where
ps' = concatMap (\Process{..} -> rall numToks tokens curIndent curIndent rest) ps
(dones0,conts0) = partitionEithers ps'
(conts,conts'over) = partition (\p -> overflow p <= 0) conts0
(dones,dones'over) = partition (\(o,_) -> o <= 0) dones0
r = max 0 (min w (w * rfrac))
count (Spacing _) = 0
count (TeX _ _) = 1
rall :: Int -> [Token] -> Double -> Double -> Docs -> [Either (Double,[Token]) Process]
rall nts ts n k ds0 = case ds0 of
Nil -> [Left $ (overflow,ts)]
Cons i d ds -> case d of
Empty -> rall nts ts n k ds
Text s -> let k' = k+len s in seq k' (rall (nts+count s) (Tx s:ts) n k' ds)
Line _ -> [Right $ Process overflow i nts (Ln i:ts) ds]
Cat x y -> rall nts ts n k (Cons i x (Cons i y ds))
Nest j x -> let i' = i+j in seq i' (rall nts ts n k (Cons i' x ds))
Union x y -> rall nts ts n k (Cons i x ds) ++ rall nts ts n k (Cons i y ds)
Column f -> rall nts ts n k (Cons i (f k) ds)
Nesting f -> rall nts ts n k (Cons i (f i) ds)
where overflow = negate $ min (w k) (r k + n)
renderPretty :: Double -> Double -> Doc -> SimpleDoc
renderPretty rfrac w doc
= best 0 0 (Cons 0 doc Nil)
where
r = max 0 (min w (w * rfrac))
best _n _k Nil = SEmpty
best n k (Cons i d ds)
= case d of
Empty -> best n k ds
Text s -> let k' = k+len s in seq k' (SText s (best n k' ds))
Line _ -> SLine i (best i i ds)
Cat x y -> best n k (Cons i x (Cons i y ds))
Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds))
Union x y -> nicest n k (best n k (Cons i x ds))
(best n k (Cons i y ds))
Column f -> best n k (Cons i (f k) ds)
Nesting f -> best n k (Cons i (f i) ds)
nicest n k x y | fits width x = x
| otherwise = y
where
width = min (w k) (r k + n)
linify0 :: SimpleDoc -> [(Double, [BoxTex])]
linify0 d = linify d 0 []
linify :: SimpleDoc -> Double -> [BoxTex] -> [(Double,[BoxTex])]
linify SEmpty i t = [(i,t)]
linify (SText s x) i t = linify x i (t ++ [s])
linify (SLine i' x) i t = (i,t):linify x i' mempty
computeHeights :: BoxTex -> [(Double,[BoxTex])] -> [Double]
computeHeights strut ls = scanl (\y (_i,boxes) -> y maximum (map hei (strut:boxes))) 0 ls
heights :: BoxTex -> [(Double,[BoxTex])] -> [(Double,(Double, [BoxTex]))]
heights strut ls = zip (computeHeights strut ls) ls
computeWidths :: Double -> [BoxTex] -> [Double]
computeWidths = scanl (\x b -> len b + x)
layout :: SimpleDoc -> Tex ()
layout d = env "tikzpicture" $ do
strutBox <- justBox $
cmd0 "strut"
let strut = TeX mempty strutBox
forM_ (heights strut $ linify0 d) $ \(y,(i,boxes)) -> do
let mh = maximum (map hei (strut:boxes))
forM_ (zip boxes $ computeWidths i boxes) $ \(tx,x) -> do
case tx of
Spacing _ -> return ()
TeX t box -> do
let y' = y (mh boxHeight box)
tex $ "\\node[anchor=north west,inner sep=0] at (" ++ showDistance x ++ "," ++ showDistance y' ++ ")"
braces $ t
tex ";\n"
pretty :: Double -> Double -> Doc -> TeX
pretty rfrac w d = do
layout $ renderAll rfrac w d