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

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