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

   1 module Language.Symantic.Document.Term.Dim
   2  ( module Language.Symantic.Document.Sym
   3  , module Language.Symantic.Document.Term.Dim
   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.Int (Int)
  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 ((+), pred)
  17 import Text.Show (Show(..))
  18 import qualified Data.List as List
  19 import qualified Data.Text as Text
  20 import qualified Data.Text.Lazy as TL
  21
  22 import Language.Symantic.Document.Sym
  23
  24 -- * Type 'Dim'
  25 data Dim
  26  =   Dim
  27  {   dim_width       :: Int -- ^ Maximun line length.
  28  ,   dim_height      :: Int -- ^ Number of newlines.
  29  ,   dim_width_first :: Int -- ^ Length of the first line.
  30  ,   dim_width_last  :: Int -- ^ Length of the last line.
  31  } deriving (Eq, Show)
  32 instance Semigroup Dim where
  33         Dim{dim_width=wx, dim_height=hx, dim_width_first=wfx, dim_width_last=wlx} <>
  34          Dim{dim_width=wy, dim_height=hy, dim_width_first=wfy, dim_width_last=wly} =
  35                 let h = hx + hy in
  36                 case (hx, hy) of
  37                  (0, 0) -> let w = wx  + wy  in Dim w h w w
  38                  (0, _) -> let v = wfx + wfy in Dim (max v (wx + wy)) h v wly
  39                  (_, 0) -> let v = wlx + wfy in Dim (max v (wx + wy)) h wfx v
  40                  _      -> Dim (max wx wy) h wfx wly
  41 instance Monoid Dim where
  42         mempty  = Dim 0 0 0 0
  43         mappend = (<>)
  44
  45 -- * Type 'Reader'
  46 data Reader
  47  =   Reader
  48  {   reader_indent      :: !(Indent Dimension) -- ^ Current indentation level, used by 'newline'.
  49  ,   reader_newline     :: Dimension           -- ^ How to display 'newline'.
  50  ,   reader_wrap_column :: !(Column Dimension) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
  51  ,   reader_colorable   :: !Bool               -- ^ Whether colors are activated or not.
  52  ,   reader_decorable   :: !Bool               -- ^ Whether decorations are activated or not.
  53  }
  54
  55 -- | Default 'Reader'.
  56 defReader :: Reader
  57 defReader = Reader
  58  { reader_indent      = 0
  59  , reader_newline     = newlineWithIndent
  60  , reader_wrap_column = 80
  61  , reader_colorable   = True
  62  , reader_decorable   = True
  63  }
  64
  65 -- * Type 'State'
  66 type State = Column Dimension
  67
  68 defState :: State
  69 defState = 0
  70
  71 -- * Type 'Dimension'
  72 newtype Dimension
  73  =      Dimension
  74  {    unDimension :: Reader ->
  75                      State  ->
  76                      (State -> Dim -> Dim) -> -- normal continuation
  77                      (State -> Dim -> Dim) -> -- should-wrap continuation
  78                      Dim }
  79 type instance Column Dimension = Int
  80 type instance Indent Dimension = Int
  81
  82 dim :: Dimension -> Dim
  83 dim (Dimension p) = p defReader defState oko oko
  84         where oko _st = id
  85
  86 instance IsList Dimension where
  87         type Item Dimension = Dimension
  88         fromList = mconcat
  89         toList   = pure
  90 instance Semigroup Dimension where
  91         x <> y = Dimension $ \ro st ok ko ->
  92                 unDimension x ro st
  93                  (\sx tx -> unDimension y ro sx
  94                          (\sy ty -> ok sy (tx<>ty))
  95                          (\sy ty -> ko sy (tx<>ty)))
  96                  (\sx tx -> unDimension y ro sx
  97                          (\sy ty -> ko sy (tx<>ty))
  98                          (\sy ty -> ko sy (tx<>ty)))
  99 instance Monoid Dimension where
 100         mempty  = empty
 101         mappend = (<>)
 102 instance IsString Dimension where
 103         fromString = string
 104
 105 writeH :: Column Dimension -> Dimension
 106 writeH len =
 107         Dimension $ \ro col ok ko ->
 108                 let newCol = col + len in
 109                 (if newCol <= reader_wrap_column ro then ok else ko)
 110                 newCol Dim
 111                  { dim_width       = newCol
 112                  , dim_height      = 0
 113                  , dim_width_last  = newCol
 114                  , dim_width_first = newCol
 115                  }
 116
 117 instance Doc_Text Dimension where
 118         empty     = Dimension $ \_ro st ok _ko -> ok st mempty
 119         charH   _ = writeH 1
 120         stringH t = writeH $ List.length t
 121         textH   t = writeH $ Text.length t
 122         ltextH  t = writeH $ intOfInt64 $ TL.length t
 123         int       = stringH . show
 124         integer   = stringH . show
 125         replicate cnt p | cnt <= 0  = empty
 126                         | otherwise = p <> replicate (pred cnt) p
 127         newline = Dimension $ \ro -> unDimension (reader_newline ro) ro
 128 instance Doc_Align Dimension where
 129         align p = Dimension $ \ro st -> unDimension p ro{reader_indent=st} st
 130         withNewline nl  p = Dimension $ \ro -> unDimension p ro{reader_newline=nl}
 131         withIndent  ind p = Dimension $ \ro -> unDimension p ro{reader_indent=ind}
 132         incrIndent  ind p = Dimension $ \ro -> unDimension p ro{reader_indent=reader_indent ro + ind}
 133         column f = Dimension $ \ro st -> unDimension (f st) ro st
 134         newlineWithoutIndent = Dimension $ \_ro _st ok _ko ->
 135                 ok 0 Dim
 136                  { dim_width       = 0
 137                  , dim_height      = 1
 138                  , dim_width_first = 0
 139                  , dim_width_last  = 0
 140                  }
 141         newlineWithIndent = Dimension $ \ro _st ok _ko ->
 142                 let ind = reader_indent ro in
 143                 ok ind Dim
 144                  { dim_width       = ind
 145                  , dim_height      = 1
 146                  , dim_width_first = 0
 147                  , dim_width_last  = ind
 148                  }
 149
 150 instance Doc_Wrap Dimension where
 151         ifFit x y = Dimension $ \ro st ok ko ->
 152                 unDimension x ro st ok (\_sx _tx -> unDimension y ro st ok ko)
 153         breakpoint onNoBreak onBreak p = Dimension $ \ro st ok ko ->
 154                 unDimension (onNoBreak <> p) ro st ok
 155                  (\_sp _tp -> unDimension (onBreak <> p) ro st ok ko)
 156         withWrapColumn col p = Dimension $ \ro -> unDimension p ro{reader_wrap_column=col}
 157 instance Doc_Color 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 Doc_Decoration 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