{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Text.Base.DocTextZero -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- -- Flexible text type, composable with @pretty-print@ style -- operators. -- -- Direction zero (left-to-right) only. -- -------------------------------------------------------------------------------- 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 -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Control.Applicative import Data.Monoid import Numeric -- | Doc type. -- 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 } -------------------------------------------------------------------------------- -- Get vcat vconcat... from the Concat class 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) -------------------------------------------------------------------------------- -- Primitives infixr 6 <+> -- | Concatenate two Docs separated with a space. -- -- (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 -------------------------------------------------------------------------------- -- Change font weight 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 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) -------------------------------------------------------------------------------- -- | Specialized version of 'ffloat' - the answer is always -- rendered at \"full precision\". -- float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u float = ffloat Nothing -- | This is equivalent to 'showFFloat' in the Numeric module. -- -- Like 'showFFloat', the answer is rendered to supplied -- precision. @Nothing@ indicated full precision. -- ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u ffloat mb d = monospace (CharLiteral '0') $ escapeString $ ($ "") $ showFFloat mb d -------------------------------------------------------------------------------- -- Decorate 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 -- API might be simple if we conditionally apply strikethrough on -- interpText (possibly including spaces), but never on interpSpace. -- -- Might want to derive stroke_colour from text_colour and linewidth -- fromf font size as well... -- 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) -- | This uses underline_thickness ... -- linestyle :: LocGraphic u -> LocGraphic u linestyle mf = underlineThickness >>= \sz -> localize (stroke_use_text_colour . set_line_width sz) mf -- | Note - quarter margin looks good. -- 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