module Wumpus.Drawing.Text.Base.DocTextZero
(
GenDoc
, Doc
, GenDocGraphic
, DocGraphic
, runGenDoc
, (<+>)
, blank
, space
, string
, escaped
, embedPosObject
, bold
, italic
, boldItalic
, monospace
, int
, integer
, float
, ffloat
, strikethrough
, underline
, highlight
) where
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
import Data.Monoid
import Numeric
newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a }
type instance DUnit (GenDoc st u a) = u
type instance UState (GenDoc st u a) = st
type GenDocGraphic st u = GenDoc st u (UNil u)
type Doc u a = GenDoc () u a
type DocGraphic u = Doc u (UNil u)
data DocEnv = DocEnv
{ doc_alignment :: VAlign
, doc_font_family :: FontFamily
}
instance Functor (GenDoc st u) where
fmap f ma = GenDoc $ \env -> fmap f $ getGenDoc ma env
instance Applicative (GenDoc st u) where
pure a = GenDoc $ \_ -> pure a
mf <*> ma = GenDoc $ \env -> getGenDoc mf env <*> getGenDoc ma env
instance Monad (GenDoc st u) where
return a = GenDoc $ \_ -> return a
ma >>= k = GenDoc $ \env -> getGenDoc ma env >>= \a -> getGenDoc (k a) env
instance (Monoid a, InterpretUnit u) => Monoid (GenDoc st u a) where
mempty = GenDoc $ \_ -> mempty
ma `mappend` mb = GenDoc $ \env -> getGenDoc ma env `hconcat` getGenDoc mb env
instance DrawingCtxM (GenDoc st u) where
askDC = GenDoc $ \_ -> askDC
asksDC fn = GenDoc $ \_ -> asksDC fn
localize upd ma = GenDoc $ \env -> localize upd (getGenDoc ma env)
instance UserStateM (GenDoc st u) where
getState = GenDoc $ \_ -> getState
setState s = GenDoc $ \_ -> setState s
updateState upd = GenDoc $ \_ -> updateState upd
runGenDoc :: VAlign -> FontFamily -> GenDoc st u a -> GenPosObject st u a
runGenDoc va ff ma = getGenDoc ma env1
where
env1 = DocEnv { doc_alignment = va, doc_font_family = ff }
instance (Monoid a, Fractional u, InterpretUnit u) =>
Concat (GenDoc st u a) where
hconcat = mappend
vconcat = vcatImpl
vcatImpl :: (Monoid a, Fractional u, InterpretUnit u)
=> GenDoc st u a -> GenDoc st u a -> GenDoc st u a
vcatImpl ma mb = GenDoc $ \env ->
let va = doc_alignment env
in textlineSpace >>= \sep ->
valignSpace va sep (getGenDoc ma env) (getGenDoc mb env)
infixr 6 <+>
(<+>) :: InterpretUnit u
=> GenDocGraphic st u -> GenDocGraphic st u -> GenDocGraphic st u
a <+> b = a `mappend` space `mappend` b
blank :: InterpretUnit u => GenDocGraphic st u
blank = GenDoc $ \_ -> posTextPrim (Left "")
space :: InterpretUnit u => GenDocGraphic st u
space = GenDoc $ \_ -> posCharPrim (Left ' ')
string :: InterpretUnit u => String -> GenDocGraphic st u
string ss = GenDoc $ \_ -> posTextPrim (Left ss)
escaped :: InterpretUnit u => EscapedText -> GenDocGraphic st u
escaped esc = GenDoc $ \_ -> posTextPrim (Right esc)
embedPosObject :: GenPosObject st u a -> GenDoc st u a
embedPosObject ma = GenDoc $ \_ -> ma
bold :: GenDoc st u a -> GenDoc st u a
bold ma = GenDoc $ \env ->
localize (set_font $ boldWeight $ doc_font_family env)
(getGenDoc ma env)
italic :: GenDoc st u a -> GenDoc st u a
italic ma = GenDoc $ \env ->
localize (set_font $ italicWeight $ doc_font_family env)
(getGenDoc ma env)
boldItalic :: GenDoc st u a -> GenDoc st u a
boldItalic ma = GenDoc $ \env ->
localize (set_font $ boldItalicWeight $ doc_font_family env)
(getGenDoc ma env)
monospace :: InterpretUnit u
=> EscapedChar -> EscapedText -> GenDocGraphic st u
monospace ref_ch esc = GenDoc $ \_ ->
monospaceEscText (vector_x <$> escCharVector ref_ch) esc
int :: InterpretUnit u => Int -> GenDocGraphic st u
int i = integer $ fromIntegral i
integer :: InterpretUnit u => Integer -> GenDocGraphic st u
integer i = monospace (CharLiteral '0') (escapeString $ show i)
float :: (RealFloat a, InterpretUnit u) => a -> GenDocGraphic st u
float = ffloat Nothing
ffloat :: (RealFloat a, InterpretUnit u)
=> (Maybe Int) -> a -> GenDocGraphic st u
ffloat mb d =
monospace (CharLiteral '0') $ escapeString $ ($ "") $ showFFloat mb d
strikethrough :: (Fractional u, InterpretUnit u)
=> GenDoc st u a -> GenDoc st u a
strikethrough = decorateDoc ZABOVE drawStrikethrough
underline :: (Fractional u, InterpretUnit u)
=> GenDoc st u a -> GenDoc st u a
underline = decorateDoc ZABOVE drawUnderline
highlight :: (Fractional u, InterpretUnit u)
=> RGBi -> GenDoc st u a -> GenDoc st u a
highlight rgb = decorateDoc ZBELOW (drawBackfill rgb)
decorateDoc :: InterpretUnit u
=> ZOrder -> (Orientation u -> LocGraphic u) -> GenDoc st u a
-> GenDoc st u a
decorateDoc zdec fn ma = GenDoc $ \env ->
decoratePosObject zdec fn $ getGenDoc ma env
drawStrikethrough :: (Fractional u, InterpretUnit u)
=> Orientation u -> LocGraphic u
drawStrikethrough (Orientation xmin xmaj _ ymaj) =
linestyle $ moveStart (vec (xmin) vpos) ln
where
vpos = 0.45 * ymaj
ln = locStraightLine (hvec $ xmin + xmaj)
drawUnderline :: (Fractional u, InterpretUnit u)
=> Orientation u -> LocGraphic u
drawUnderline (Orientation xmin xmaj _ _) =
underlinePosition >>= \vpos ->
linestyle $ moveStart (vec (xmin) vpos) ln
where
ln = locStraightLine (hvec $ xmin + xmaj)
linestyle :: LocGraphic u -> LocGraphic u
linestyle mf =
underlineThickness >>= \sz ->
localize (stroke_use_text_colour . set_line_width sz) mf
drawBackfill :: (Fractional u, InterpretUnit u)
=> RGBi -> Orientation u -> LocGraphic u
drawBackfill rgb (Orientation xmin xmaj ymin ymaj) =
textMargin >>= \(dx,dy) ->
let hdx = 0.25 * dx
hdy = 0.25 * dy
in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy)
where
mkVec dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)
mkRect dx dy = let w = dx + xmin + xmaj + dx
h = dy + ymin + ymaj + dy
in dcRectangle DRAW_FILL w h