symantic-document/Symantic/Document/Term/Dimension.hs

   1 module Symantic.Document.Term.Dimension
   2  ( module Symantic.Document.Sym
   3  , module Symantic.Document.Term.Dimension
   4  ) where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Bool
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.), id)
  10 import Data.Maybe (Maybe(..))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Ord (Ord(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.String (IsString(..))
  15 import GHC.Exts (IsList(..))
  16 import Prelude ((+))
  17 import Text.Show (Show(..))
  18
  19 import Symantic.Document.Sym
  20
  21 -- * Type 'Dim'
  22 data Dim
  23  =   Dim
  24  {   dim_width       :: Nat -- ^ Maximun line length.
  25  ,   dim_height      :: Nat -- ^ Number of newlines.
  26  ,   dim_width_first :: Nat -- ^ Nat of the first line.
  27  ,   dim_width_last  :: Nat -- ^ Nat of the last line.
  28  } deriving (Eq, Show)
  29 instance Semigroup Dim where
  30         Dim{dim_width=wx, dim_height=hx, dim_width_first=wfx, dim_width_last=wlx} <>
  31          Dim{dim_width=wy, dim_height=hy, dim_width_first=wfy, dim_width_last=wly} =
  32                 let h = hx + hy in
  33                 case (hx, hy) of
  34                  (0, 0) -> let w = wx  + wy  in Dim w h w w
  35                  (0, _) -> let v = wx  + wfy in Dim (max v wy) h v wly
  36                  (_, 0) -> let v = wlx + wy  in Dim (max v wx) h wfx v
  37                  _      -> Dim (max wx wy) h wfx wly
  38 instance Monoid Dim where
  39         mempty  = Dim 0 0 0 0
  40         mappend = (<>)
  41
  42 -- * Type 'DimInh'
  43 data DimInh
  44  =   DimInh
  45  {   dimInh_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
  46  ,   dimInh_newline   :: Dimension       -- ^ How to display 'newline'.
  47  ,   dimInh_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'
  48  ,   dimInh_colorable :: !Bool           -- ^ Whether colors are activated or not.
  49  ,   dimInh_decorable :: !Bool           -- ^ Whether decorations are activated or not.
  50  }
  51
  52 -- | Default 'DimInh'.
  53 defDimInh :: DimInh
  54 defDimInh = DimInh
  55  { dimInh_indent    = 0
  56  , dimInh_newline   = newlineWithIndent
  57  , dimInh_breakable = Nothing
  58  , dimInh_colorable = True
  59  , dimInh_decorable = True
  60  }
  61
  62 -- * Type 'DimState'
  63 type DimState = Column
  64
  65 defDimState :: DimState
  66 defDimState = 0
  67
  68 -- * Type 'Dimension'
  69 newtype Dimension = Dimension
  70  { unDimension :: DimInh -> DimState  ->
  71                   (DimState -> Dim -> Dim) -> -- normal continuation
  72                   (DimState -> Dim -> Dim) -> -- should-break continuation
  73                   Dim }
  74
  75 dim :: Dimension -> Dim
  76 dim (Dimension p) = p defDimInh defDimState oko oko
  77         where oko _st = id
  78
  79 instance IsList Dimension where
  80         type Item Dimension = Dimension
  81         fromList = mconcat
  82         toList   = pure
  83 instance Semigroup Dimension where
  84         x <> y = Dimension $ \ro st ok ko ->
  85                 unDimension x ro st
  86                  (\sx tx -> unDimension y ro sx
  87                          (\sy ty -> ok sy (tx<>ty))
  88                          (\sy ty -> ko sy (tx<>ty)))
  89                  (\sx tx -> unDimension y ro sx
  90                          (\sy ty -> ko sy (tx<>ty))
  91                          (\sy ty -> ko sy (tx<>ty)))
  92 instance Monoid Dimension where
  93         mempty  = empty
  94         mappend = (<>)
  95 instance IsString Dimension where
  96         fromString = string
  97
  98 writeH :: Column -> Dimension
  99 writeH len =
 100         Dimension $ \ro currCol ok ko ->
 101                 let newCol = currCol + len in
 102                 (case dimInh_breakable ro of
 103                  Just breakCol | breakCol < newCol -> ko
 104                  _ -> ok)
 105                 newCol Dim
 106                  { dim_width       = len
 107                  , dim_height      = 0
 108                  , dim_width_last  = len
 109                  , dim_width_first = len
 110                  }
 111
 112 instance Textable Dimension where
 113         empty     = Dimension $ \_ro st ok _ko -> ok st mempty
 114         charH   _ = writeH 1
 115         stringH   = writeH . length
 116         textH     = writeH . length
 117         ltextH    = writeH . length
 118         newline   = Dimension $ \ro -> unDimension (dimInh_newline ro) ro
 119 instance Indentable Dimension where
 120         align p = Dimension $ \ro st -> unDimension p ro{dimInh_indent=st} st
 121         withNewline nl  p = Dimension $ \ro -> unDimension p ro{dimInh_newline=nl}
 122         withIndent  ind p = Dimension $ \ro -> unDimension p ro{dimInh_indent=ind}
 123         incrIndent  ind p = Dimension $ \ro -> unDimension p ro{dimInh_indent=dimInh_indent ro + ind}
 124         column f = Dimension $ \ro st -> unDimension (f st) ro st
 125         indent f = Dimension $ \ro -> unDimension (f (dimInh_indent ro)) ro
 126         newlineWithoutIndent = Dimension $ \_ro _st ok _ko ->
 127                 ok 0 Dim
 128                  { dim_width       = 0
 129                  , dim_height      = 1
 130                  , dim_width_first = 0
 131                  , dim_width_last  = 0
 132                  }
 133         newlineWithIndent = Dimension $ \ro _st ok _ko ->
 134                 let ind = dimInh_indent ro in
 135                 ok ind Dim
 136                  { dim_width       = ind
 137                  , dim_height      = 1
 138                  , dim_width_first = 0
 139                  , dim_width_last  = ind
 140                  }
 141
 142 instance Breakable Dimension where
 143         breakable f = Dimension $ \ro -> unDimension (f (dimInh_breakable ro)) ro
 144         withBreakable col p = Dimension $ \ro -> unDimension p ro{dimInh_breakable=col}
 145         ifBreak y x = Dimension $ \ro st ok ko ->
 146                 unDimension x ro st ok $
 147                 case dimInh_breakable ro of
 148                  Nothing -> ko
 149                  Just{} -> (\_sx _tx -> unDimension y ro st ok ko)
 150         breakpoint onNoBreak onBreak t = Dimension $ \ro st ok ko ->
 151                 unDimension (onNoBreak <> t) ro st ok $
 152                 case dimInh_breakable ro of
 153                  Nothing -> ko
 154                  Just{} -> (\_sp _tp -> unDimension (onBreak <> t) ro st ok ko)
 155 instance Colorable Dimension where
 156         colorable f       = Dimension $ \ro -> unDimension (f (dimInh_colorable ro)) ro
 157         withColorable b t = Dimension $ \ro -> unDimension t ro{dimInh_colorable=b}
 158         reverse     = id
 159         black       = id
 160         red         = id
 161         green       = id
 162         yellow      = id
 163         blue        = id
 164         magenta     = id
 165         cyan        = id
 166         white       = id
 167         blacker     = id
 168         redder      = id
 169         greener     = id
 170         yellower    = id
 171         bluer       = id
 172         magentaer   = id
 173         cyaner      = id
 174         whiter      = id
 175         onBlack     = id
 176         onRed       = id
 177         onGreen     = id
 178         onYellow    = id
 179         onBlue      = id
 180         onMagenta   = id
 181         onCyan      = id
 182         onWhite     = id
 183         onBlacker   = id
 184         onRedder    = id
 185         onGreener   = id
 186         onYellower  = id
 187         onBluer     = id
 188         onMagentaer = id
 189         onCyaner    = id
 190         onWhiter    = id
 191 instance Decorable Dimension where
 192         decorable f       = Dimension $ \ro -> unDimension (f (dimInh_decorable ro)) ro
 193         withDecorable b t = Dimension $ \ro -> unDimension t ro{dimInh_decorable=b}
 194         bold      = id
 195         underline = id
 196         italic    = id