1 {-# LANGUAGE PolyKinds #-}
2 module Language.Symantic.Document.Sym where
4 import Data.Char (Char)
5 import Data.Foldable (Foldable(..))
6 import Data.Function ((.))
7 import Data.Functor (Functor(..))
8 import Data.Int (Int, Int64)
9 import Data.Semigroup (Semigroup(..))
10 import Data.String (String, IsString)
11 import Data.Text (Text)
12 import Prelude (Integer, fromInteger, toInteger)
13 import qualified Data.List as L
14 import qualified Data.Text as T
15 import qualified Data.Text.Lazy as TL
18 class (IsString d, Semigroup d) => Doc_Text d where
19 charH :: Char -> d -- ^ XXX: MUST NOT be '\n'
20 stringH :: String -> d -- ^ XXX: MUST NOT contain '\n'
21 textH :: Text -> d -- ^ XXX: MUST NOT contain '\n'
22 ltextH :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'
23 replicate :: Int -> d -> d
24 integer :: Integer -> d
25 default charH :: Doc_Text (ReprOf d) => Trans d => Char -> d
26 default stringH :: Doc_Text (ReprOf d) => Trans d => String -> d
27 default textH :: Doc_Text (ReprOf d) => Trans d => Text -> d
28 default ltextH :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
29 default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
30 default integer :: Doc_Text (ReprOf d) => Trans d => Integer -> d
32 stringH = trans . stringH
34 ltextH = trans . ltextH
35 replicate = trans1 . replicate
36 integer = trans . integer
47 catH :: Foldable f => f d -> d
48 catV :: Foldable f => f d -> d
60 spaces i = replicate i space
61 int = integer . toInteger
62 char = \case '\n' -> eol; c -> charH c
63 string = catV . fmap stringH . L.lines
64 text = catV . fmap textH . T.lines
65 ltext = catV . fmap ltextH . TL.lines
66 catH = foldr (<>) empty
67 catV l = if null l then empty else foldr1 (\a acc -> a <> eol <> acc) l
68 paren d = charH '(' <> d <> charH ')'
69 brace d = charH '{' <> d <> charH '}'
70 bracket d = charH '[' <> d <> charH ']'
71 bquote d = charH '`' <> d <> charH '`'
72 dquote d = charH '\"' <> d <> charH '\"'
73 fquote d = "« " <> d <> " »"
74 squote d = charH '\'' <> d <> charH '\''
75 -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
76 -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
77 -- catH l = trans (catH (fmap unTrans l))
78 -- catV l = trans (catV (fmap unTrans l))
80 -- * Class 'Doc_Color'
81 class Doc_Color d where
122 onMagentaer :: d -> d
126 default reverse :: Doc_Color (ReprOf d) => Trans d => d -> d
127 default black :: Doc_Color (ReprOf d) => Trans d => d -> d
128 default red :: Doc_Color (ReprOf d) => Trans d => d -> d
129 default green :: Doc_Color (ReprOf d) => Trans d => d -> d
130 default yellow :: Doc_Color (ReprOf d) => Trans d => d -> d
131 default blue :: Doc_Color (ReprOf d) => Trans d => d -> d
132 default magenta :: Doc_Color (ReprOf d) => Trans d => d -> d
133 default cyan :: Doc_Color (ReprOf d) => Trans d => d -> d
134 default white :: Doc_Color (ReprOf d) => Trans d => d -> d
135 default blacker :: Doc_Color (ReprOf d) => Trans d => d -> d
136 default redder :: Doc_Color (ReprOf d) => Trans d => d -> d
137 default greener :: Doc_Color (ReprOf d) => Trans d => d -> d
138 default yellower :: Doc_Color (ReprOf d) => Trans d => d -> d
139 default bluer :: Doc_Color (ReprOf d) => Trans d => d -> d
140 default magentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
141 default cyaner :: Doc_Color (ReprOf d) => Trans d => d -> d
142 default whiter :: Doc_Color (ReprOf d) => Trans d => d -> d
143 default onBlack :: Doc_Color (ReprOf d) => Trans d => d -> d
144 default onRed :: Doc_Color (ReprOf d) => Trans d => d -> d
145 default onGreen :: Doc_Color (ReprOf d) => Trans d => d -> d
146 default onYellow :: Doc_Color (ReprOf d) => Trans d => d -> d
147 default onBlue :: Doc_Color (ReprOf d) => Trans d => d -> d
148 default onMagenta :: Doc_Color (ReprOf d) => Trans d => d -> d
149 default onCyan :: Doc_Color (ReprOf d) => Trans d => d -> d
150 default onWhite :: Doc_Color (ReprOf d) => Trans d => d -> d
151 default onBlacker :: Doc_Color (ReprOf d) => Trans d => d -> d
152 default onRedder :: Doc_Color (ReprOf d) => Trans d => d -> d
153 default onGreener :: Doc_Color (ReprOf d) => Trans d => d -> d
154 default onYellower :: Doc_Color (ReprOf d) => Trans d => d -> d
155 default onBluer :: Doc_Color (ReprOf d) => Trans d => d -> d
156 default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
157 default onCyaner :: Doc_Color (ReprOf d) => Trans d => d -> d
158 default onWhiter :: Doc_Color (ReprOf d) => Trans d => d -> d
160 reverse = trans1 reverse
164 yellow = trans1 yellow
166 magenta = trans1 magenta
169 blacker = trans1 blacker
170 redder = trans1 redder
171 greener = trans1 greener
172 yellower = trans1 yellower
174 magentaer = trans1 magentaer
175 cyaner = trans1 cyaner
176 whiter = trans1 whiter
177 onBlack = trans1 onBlack
179 onGreen = trans1 onGreen
180 onYellow = trans1 onYellow
181 onBlue = trans1 onBlue
182 onMagenta = trans1 onMagenta
183 onCyan = trans1 onCyan
184 onWhite = trans1 onWhite
185 onBlacker = trans1 onBlacker
186 onRedder = trans1 onRedder
187 onGreener = trans1 onGreener
188 onYellower = trans1 onYellower
189 onBluer = trans1 onBluer
190 onMagentaer = trans1 onMagentaer
191 onCyaner = trans1 onCyaner
192 onWhiter = trans1 onWhiter
194 -- * Class 'Doc_Decoration'
195 class Doc_Decoration d where
199 default bold :: Doc_Decoration (ReprOf d) => Trans d => d -> d
200 default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
201 default italic :: Doc_Decoration (ReprOf d) => Trans d => d -> d
203 underline = trans1 underline
204 italic = trans1 italic
208 -- | Return the underlying @tr@ of the transformer.
211 -- | Lift a tr to the transformer's.
212 trans :: ReprOf tr -> tr
213 -- | Unlift a tr from the transformer's.
214 unTrans :: tr -> ReprOf tr
216 -- | Identity transformation for a unary symantic method.
217 trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
218 trans1 f = trans . f . unTrans
220 -- | Identity transformation for a binary symantic method.
222 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
224 trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
226 -- | Identity transformation for a ternary symantic method.
228 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
229 -> (tr -> tr -> tr -> tr)
230 trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
232 int64OfInt :: Int -> Int64
233 int64OfInt = fromInteger . toInteger