module Wumpus.Drawing.Text.Base.DocTextZero
(
Doc
, DocGraphic
, runDoc
, (<+>)
, 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 Doc u a = Doc { getDoc :: DocEnv -> PosObject u a }
type instance DUnit (Doc u a) = u
type DocGraphic u = Doc u (UNil u)
data DocEnv = DocEnv
{ doc_alignment :: VAlign
, doc_font_family :: FontFamily
}
instance Functor (Doc u) where
fmap f ma = Doc $ \env -> fmap f $ getDoc ma env
instance Applicative (Doc u) where
pure a = Doc $ \_ -> pure a
mf <*> ma = Doc $ \env -> getDoc mf env <*> getDoc ma env
instance Monad (Doc u) where
return a = Doc $ \_ -> return a
ma >>= k = Doc $ \env -> getDoc ma env >>= \a -> getDoc (k a) env
instance DrawingCtxM (Doc u) where
askDC = Doc $ \_ -> askDC
asksDC fn = Doc $ \_ -> asksDC fn
localize upd ma = Doc $ \env -> localize upd (getDoc ma env)
instance (Monoid a, InterpretUnit u) => Monoid (Doc u a) where
mempty = Doc $ \_ -> mempty
ma `mappend` mb = Doc $ \env -> getDoc ma env `hconcat` getDoc mb env
runDoc :: Doc u a -> VAlign -> FontFamily -> PosObject u a
runDoc ma va ff = getDoc ma env1
where
env1 = DocEnv { doc_alignment = va, doc_font_family = ff }
instance (Monoid a, Fractional u, InterpretUnit u) => Concat (Doc u a) where
hconcat = mappend
vconcat = vcatImpl
vcatImpl :: (Monoid a, Fractional u, InterpretUnit u)
=> Doc u a -> Doc u a -> Doc u a
vcatImpl ma mb = Doc $ \env ->
let va = doc_alignment env
in textlineSpace >>= \sep ->
valignSpace va sep (getDoc ma env) (getDoc mb env)
infixr 6 <+>
(<+>) :: InterpretUnit u => DocGraphic u -> DocGraphic u -> DocGraphic u
a <+> b = a `mappend` space `mappend` b
blank :: InterpretUnit u => DocGraphic u
blank = Doc $ \_ -> posTextPrim (Left "")
space :: InterpretUnit u => DocGraphic u
space = Doc $ \_ -> posCharPrim (Left ' ')
string :: InterpretUnit u => String -> DocGraphic u
string ss = Doc $ \_ -> posTextPrim (Left ss)
escaped :: InterpretUnit u => EscapedText -> DocGraphic u
escaped esc = Doc $ \_ -> posTextPrim (Right esc)
embedPosObject :: PosObject u a -> Doc u a
embedPosObject ma = Doc $ \_ -> ma
bold :: Doc u a -> Doc u a
bold ma = Doc $ \env ->
localize (set_font $ boldWeight $ doc_font_family env)
(getDoc ma env)
italic :: Doc u a -> Doc u a
italic ma = Doc $ \env ->
localize (set_font $ italicWeight $ doc_font_family env)
(getDoc ma env)
boldItalic :: Doc u a -> Doc u a
boldItalic ma = Doc $ \env ->
localize (set_font $ boldItalicWeight $ doc_font_family env)
(getDoc ma env)
monospace :: InterpretUnit u => EscapedChar -> EscapedText -> DocGraphic u
monospace ref_ch esc = Doc $ \_ ->
monospaceEscText (vector_x <$> escCharVector ref_ch) esc
int :: InterpretUnit u => Int -> DocGraphic u
int i = integer $ fromIntegral i
integer :: InterpretUnit u => Integer -> DocGraphic u
integer i = monospace (CharLiteral '0') (escapeString $ show i)
float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u
float = ffloat Nothing
ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u
ffloat mb d =
monospace (CharLiteral '0') $ escapeString $ ($ "") $ showFFloat mb d
strikethrough :: (Fractional u, InterpretUnit u)
=> Doc u a -> Doc u a
strikethrough = decorateDoc SUPERIOR drawStrikethrough
underline :: (Fractional u, InterpretUnit u)
=> Doc u a -> Doc u a
underline = decorateDoc SUPERIOR drawUnderline
highlight :: (Fractional u, InterpretUnit u)
=> RGBi -> Doc u a -> Doc u a
highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb)
decorateDoc :: InterpretUnit u
=> ZDeco -> (Orientation u -> LocGraphic u) -> Doc u a -> Doc u a
decorateDoc zdec fn ma = Doc $ \env ->
decoratePosObject zdec fn $ getDoc 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 FILL w h