]> Git — Sourcephile - haskell/symantic.git/blob - symantic-document/Language/Symantic/Document/Term/Dim.hs
Use Nat, instead of convoluted type families.
[haskell/symantic.git] / 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.Monoid (Monoid(..))
11 import Data.Ord (Ord(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (IsString(..))
14 import GHC.Exts (IsList(..))
15 import Prelude ((+), pred)
16 import Text.Show (Show(..))
17
18 import Language.Symantic.Document.Sym
19
20 -- * Type 'Dim'
21 data Dim
22 = Dim
23 { dim_width :: Nat -- ^ Maximun line length.
24 , dim_height :: Nat -- ^ Number of newlines.
25 , dim_width_first :: Nat -- ^ Nat of the first line.
26 , dim_width_last :: Nat -- ^ Nat of the last line.
27 } deriving (Eq, Show)
28 instance Semigroup Dim where
29 Dim{dim_width=wx, dim_height=hx, dim_width_first=wfx, dim_width_last=wlx} <>
30 Dim{dim_width=wy, dim_height=hy, dim_width_first=wfy, dim_width_last=wly} =
31 let h = hx + hy in
32 case (hx, hy) of
33 (0, 0) -> let w = wx + wy in Dim w h w w
34 (0, _) -> let v = wfx + wfy in Dim (max v (wx + wy)) h v wly
35 (_, 0) -> let v = wlx + wfy in Dim (max v (wx + wy)) h wfx v
36 _ -> Dim (max wx wy) h wfx wly
37 instance Monoid Dim where
38 mempty = Dim 0 0 0 0
39 mappend = (<>)
40
41 -- * Type 'Reader'
42 data Reader
43 = Reader
44 { reader_indent :: !Indent -- ^ Current indentation level, used by 'newline'.
45 , reader_newline :: Dimension -- ^ How to display 'newline'.
46 , reader_wrap_column :: !Column -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
47 , reader_colorable :: !Bool -- ^ Whether colors are activated or not.
48 , reader_decorable :: !Bool -- ^ Whether decorations are activated or not.
49 }
50
51 -- | Default 'Reader'.
52 defReader :: Reader
53 defReader = Reader
54 { reader_indent = 0
55 , reader_newline = newlineWithIndent
56 , reader_wrap_column = Nat 80
57 , reader_colorable = True
58 , reader_decorable = True
59 }
60
61 -- * Type 'State'
62 type State = Column
63
64 defState :: State
65 defState = 0
66
67 -- * Type 'Dimension'
68 newtype Dimension
69 = Dimension
70 { unDimension :: Reader ->
71 State ->
72 (State -> Dim -> Dim) -> -- normal continuation
73 (State -> Dim -> Dim) -> -- should-wrap continuation
74 Dim }
75
76 dim :: Dimension -> Dim
77 dim (Dimension p) = p defReader defState oko oko
78 where oko _st = id
79
80 instance IsList Dimension where
81 type Item Dimension = Dimension
82 fromList = mconcat
83 toList = pure
84 instance Semigroup Dimension where
85 x <> y = Dimension $ \ro st ok ko ->
86 unDimension x ro st
87 (\sx tx -> unDimension y ro sx
88 (\sy ty -> ok sy (tx<>ty))
89 (\sy ty -> ko sy (tx<>ty)))
90 (\sx tx -> unDimension y ro sx
91 (\sy ty -> ko sy (tx<>ty))
92 (\sy ty -> ko sy (tx<>ty)))
93 instance Monoid Dimension where
94 mempty = empty
95 mappend = (<>)
96 instance IsString Dimension where
97 fromString = string
98
99 writeH :: Column -> Dimension
100 writeH len =
101 Dimension $ \ro col ok ko ->
102 let newCol = col + len in
103 (if newCol <= reader_wrap_column ro then ok else ko)
104 newCol Dim
105 { dim_width = newCol
106 , dim_height = 0
107 , dim_width_last = newCol
108 , dim_width_first = newCol
109 }
110
111 instance Textable Dimension where
112 empty = Dimension $ \_ro st ok _ko -> ok st mempty
113 charH _ = writeH 1
114 stringH = writeH . length
115 textH = writeH . length
116 ltextH = writeH . length
117 int = stringH . show
118 integer = stringH . show
119 replicate cnt p | cnt <= 0 = empty
120 | otherwise = p <> replicate (pred cnt) p
121 newline = Dimension $ \ro -> unDimension (reader_newline ro) ro
122 instance Alignable Dimension where
123 align p = Dimension $ \ro st -> unDimension p ro{reader_indent=st} st
124 withNewline nl p = Dimension $ \ro -> unDimension p ro{reader_newline=nl}
125 withIndent ind p = Dimension $ \ro -> unDimension p ro{reader_indent=ind}
126 incrIndent ind p = Dimension $ \ro -> unDimension p ro{reader_indent=reader_indent ro + ind}
127 column f = Dimension $ \ro st -> unDimension (f st) ro st
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 Wrapable Dimension where
145 ifWrap y x = Dimension $ \ro st ok ko ->
146 unDimension x ro st ok (\_sx _tx -> unDimension y ro st ok ko)
147 breakpoint onNoBreak onBreak p = Dimension $ \ro st ok ko ->
148 unDimension (onNoBreak <> p) ro st ok
149 (\_sp _tp -> unDimension (onBreak <> p) ro st ok ko)
150 withWrapColumn col p = Dimension $ \ro -> unDimension p ro{reader_wrap_column=col}
151 instance Colorable Dimension where
152 colorable f = Dimension $ \ro -> unDimension (f (reader_colorable ro)) ro
153 withColorable b t = Dimension $ \ro -> unDimension t ro{reader_colorable=b}
154 reverse = id
155 black = id
156 red = id
157 green = id
158 yellow = id
159 blue = id
160 magenta = id
161 cyan = id
162 white = id
163 blacker = id
164 redder = id
165 greener = id
166 yellower = id
167 bluer = id
168 magentaer = id
169 cyaner = id
170 whiter = id
171 onBlack = id
172 onRed = id
173 onGreen = id
174 onYellow = id
175 onBlue = id
176 onMagenta = id
177 onCyan = id
178 onWhite = id
179 onBlacker = id
180 onRedder = id
181 onGreener = id
182 onYellower = id
183 onBluer = id
184 onMagentaer = id
185 onCyaner = id
186 onWhiter = id
187 instance Decorable Dimension where
188 decorable f = Dimension $ \ro -> unDimension (f (reader_decorable ro)) ro
189 withDecorable b t = Dimension $ \ro -> unDimension t ro{reader_decorable=b}
190 bold = id
191 underline = id
192 italic = id