« back to all changes in this revision
Viewing changes to src/UU/Pretty/Basic.hs
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Arjan Oosting
- Date: 2006-11-18 16:24:30 UTC
- Revision ID: james.westby@ubuntu.com-20061118162430-24ddyj27kj0uk17v
Tags: upstream-0.9.2
Import upstream version 0.9.2
- files added:
- src
- src/UU
- src/UU/DData
- src/UU/Parsing
- src/UU/Pretty
- src/UU/Scanner
- src/UU/Util
added
removed
src/UU/Pretty/Basic.hs
1
-- $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Basic.hs,v 1.2 2003/02/26 11:18:27 uust Exp $
2
-- $Name: $ (version name)
3
4
module UU.Pretty.Basic ( PP (..), PP_Doc, PP_Exp
5
-- Single layout combinators
6
, empty, text, indent, (>|<), (>-<), fill , fillblock
7
-- Multiple layout combinators
8
, (>//<), join, par, (>>$<)
9
, eindent, (>>|<<), (>>-<<), (>>//<<), ejoin, (>>$<<)
10
-- Displaying the result
11
, render, renderAll, disp
12
-- Additional generated combinators
13
, c2e, element_h1, eelement_h1, vcenter, invisible
14
-- Additional derived combinators
15
, fpar, spar
16
) where
17
18
{- Pretty-printers and pretty-printing combinators. Version 2.0d
19
Authors: S. Doaitse Swierstra and Pablo R. Azero
20
Date: July, 1999
21
-}
22
23
-- ...................................................................
24
-- ..... Interface definition ........................................
25
26
infixr 3 >|< , >>|<<
27
infixr 2 >-< , >>-<<
28
infixr 1 >//<, >>//<<
29
infixr 0 >>$<, >>$<<
30
31
-- -------------------------------------------------------------------
32
-- PP class ----------------------------------------------------------
33
34
newtype PP_Doc = PPDoc T_PPS
35
36
class Show a => PP a where
37
pp :: a -> PP_Doc
38
pp = text . show
39
40
ppList :: [a] -> PP_Doc
41
ppList as = if null as
42
then empty
43
else foldr (>|<) empty . map pp $ as
44
45
instance PP PP_Doc where
46
pp = id
47
48
instance PP Char where
49
pp c = text [c]
50
ppList = text
51
52
instance PP a => PP [a] where
53
pp = ppList
54
55
instance Show PP_Doc where
56
show p = disp p 200 ""
57
58
-- -------------------------------------------------------------------
59
-- Single layout combinators -----------------------------------------
60
61
empty :: PP_Doc
62
empty = PPDoc sem_PPS_Empty
63
64
text :: String -> PP_Doc
65
text = PPDoc . sem_PPS_Text
66
67
indent :: PP a => Int -> a -> PP_Doc
68
indent i fs = PPDoc (sem_PPS_Indent i nfs)
69
where (PPDoc nfs) = pp fs
70
71
(>|<) :: (PP a, PP b) => a -> b -> PP_Doc
72
l >|< r = PPDoc (sem_PPS_Beside ppl ppr)
73
where (PPDoc ppl) = pp l
74
(PPDoc ppr) = pp r
75
76
(>-<) :: (PP a, PP b) => a -> b -> PP_Doc
77
u >-< l = PPDoc (sem_PPS_Above ppu ppl)
78
where (PPDoc ppu) = pp u
79
(PPDoc ppl) = pp l
80
81
fill :: PP a => [a] -> PP_Doc
82
fill = PPDoc . sem_PPS_Fill . foldr fill_alg sem_FillList_Nil
83
where fill_alg f
84
= sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp)
85
86
fillblock :: PP a => Int -> [a] -> PP_Doc
87
fillblock i = PPDoc . sem_PPS_FillBlock i . foldr fill_alg sem_FillList_Nil
88
where fill_alg f
89
= sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp)
90
91
-- -------------------------------------------------------------------
92
-- Multiple layout combinators ---------------------------------------
93
94
(>//<) :: (PP a, PP b) => a -> b -> PP_Doc
95
a >//< b = PPDoc (sem_PPS_Dup ppa ppb)
96
where (PPDoc ppa) = pp a
97
(PPDoc ppb) = pp b
98
99
join :: PP_Doc -> PP_Doc
100
join (PPDoc d) = PPDoc . sem_PPS_Join $ d
101
102
newtype PP_Exp = PPExp T_PPC
103
104
eindent :: Int -> PP_Exp -> PP_Exp
105
eindent i (PPExp ppc) = PPExp (sem_PPC_Indent i ppc)
106
107
(>>|<<), (>>-<<), (>>//<<) :: PP_Exp -> PP_Exp -> PP_Exp
108
(PPExp l) >>|<< (PPExp r) = PPExp (sem_PPC_Beside l r)
109
(PPExp u) >>-<< (PPExp l) = PPExp (sem_PPC_Above u l)
110
(PPExp a) >>//<< (PPExp b) = PPExp (sem_PPC_Dup a b)
111
112
ejoin :: PP_Exp -> PP_Exp
113
ejoin (PPExp dc) = PPExp . sem_PPC_Join $ dc
114
115
par :: PP_Exp
116
par = PPExp sem_PPC_Par
117
118
(>>$<) :: PP a => PP_Exp -> [a] -> PP_Doc
119
(PPExp e) >>$< pl = PPDoc . sem_PPS_Apply e . foldr ppslist sem_PPSArgs_Nil $ pl
120
where ppslist p = sem_PPSArgs_Cons (case (pp p) of (PPDoc ppp) -> ppp)
121
122
(>>$<<) :: PP_Exp -> [PP_Exp] -> PP_Exp
123
(PPExp e) >>$<< pl = PPExp . sem_PPC_Apply e . foldr ppclist sem_PPCArgs_Nil $ pl
124
where ppclist (PPExp p) = sem_PPCArgs_Cons p
125
126
-- -------------------------------------------------------------------
127
-- Displaying the result ---------------------------------------------
128
129
render, renderAll :: PP_Doc -> Int -> IO ()
130
render (PPDoc fs) = putStr . sem_Root_Best fs
131
renderAll (PPDoc fs) = putStr . sem_Root_All fs
132
133
disp :: PP_Doc -> Int -> ShowS
134
disp (PPDoc fs) = sem_Disp_Disp fs
135
136
-- -------------------------------------------------------------------
137
-- Additional generated combinators ----------------------------------
138
139
c2e :: PP a => a -> PP_Exp
140
c2e s = let (PPDoc s') = pp s in PPExp . sem_PPC_Pps $ s'
141
142
element_h1 :: PP_Doc -> PP_Doc
143
element_h1 = \(PPDoc fs) -> PPDoc (sem_PPS_Filt fs)
144
145
eelement_h1 :: PP_Exp -> PP_Exp
146
eelement_h1 (PPExp pe) = PPExp . sem_PPC_Filt $ pe
147
148
vcenter :: PP a => [ a ] -> PP_Doc
149
vcenter = PPDoc . sem_PPS_Center . foldr center_alg sem_CenterList_Nil
150
where center_alg f = sem_CenterList_Cons (case (pp f) of (PPDoc pf) -> pf)
151
152
invisible :: PP_Doc -> PP_Doc
153
invisible (PPDoc a) = PPDoc . sem_PPS_Inv $ a
154
155
-- -------------------------------------------------------------------
156
-- Additional derived combinators ------------------------------------
157
158
fpar, spar :: PP_Exp
159
fpar = plift first par
160
spar = plift second par
161
162
first fs = case fs of
163
(TFormats fa _ ea _) -> (AFormat fa, ea )
164
(AFormat fa) -> (AFormat fa, False)
165
second fs = case fs of
166
(TFormats _ fb _ eb) -> (AFormat fb, eb )
167
(AFormat fb) -> (AFormat fb, False)
168
169
-- Utilities
170
171
lift :: (T_Formats -> T_Formats) -> PP_Doc -> PP_Doc
172
lift f (PPDoc p) = PPDoc . sem_LiftS_Lift p $ f
173
174
--elift :: (T_Formats -> T_Formats) -> T_PPC -> T_PPC
175
elift f (PPExp e) = PPExp . sem_LiftC_Lift e $ f
176
177
--plift :: (a -> b) -> T_PPC -> T_PPC
178
plift f (PPExp e) = PPExp . sem_LiftC_Pair e $ f
179
180
-- ...................................................................
181
-- ..... Basic machinery .............................................
182
183
type Formats = [Format]
184
185
{- Pretty-printer combinators with global page width -}
186
187
type T_PW = Int
188
type T_PLL = Int
189
type T_PH = Int
190
-- Width Width last line
191
data T_Frame = F T_PW T_PLL
192
deriving Eq
193
194
instance Ord T_Frame where
195
max x@(F w _) y@(F w' _)
196
| w > w' = x
197
| otherwise = y
198
199
empty_fmts ::Formats
200
empty_fmts = []
201
202
text_fmts :: String -> Formats
203
text_fmts s = [ s2fmt s ]
204
205
indent_fmts :: T_Frame -> Int -> Formats -> Formats
206
indent_fmts (F pw _) i = map (indent_fmt i)
207
. dropWhile (notFits (pw - i))
208
notFits delta e = total_w e > delta
209
210
beside_fmts :: T_Frame -> Formats -> Formats -> Formats
211
beside_fmts (F pw _) left right
212
= mergel [ map (l `beside_fmt`)
213
. dropWhile (tooWide pw l)
214
$ right
215
| l <- left
216
]
217
tooWide pw x y
218
= (total_w x `max` (last_w x + total_w y)) > pw
219
220
above_fmts :: Formats -> Formats -> Formats
221
above_fmts [] ls = []
222
above_fmts us [] = []
223
above_fmts up@(upper:ru) low@(lower:rl)
224
| utw >= ltw = firstelem : above_fmts ru low
225
| utw < ltw = firstelem : above_fmts up rl
226
where utw = total_w upper
227
ltw = total_w lower
228
firstelem = upper `above_fmt` lower
229
230
{- Pretty-printing with error correction -}
231
232
error_indent :: Int -> Formats -> Formats
233
error_indent i = map (indent_fmt i)
234
235
error_beside :: Formats -> Formats -> Formats
236
error_beside left right = mergel [ map (l `beside_fmt`) right
237
| l <- left
238
]
239
240
-- -------------------------------------------------------------------
241
-- Formatting one layout ---------------------------------------------
242
243
data Format = Elem { height :: T_PH
244
, last_w :: T_PLL
245
, total_w :: T_PW
246
, txtstr :: Int -> String -> String
247
}
248
249
instance Eq Format where
250
x == y = height x == height y
251
&& total_w x == total_w y
252
&& last_w x == last_w y
253
254
instance Ord Format where
255
x < y = height x < height y
256
|| ( height x == height y
257
&& total_w x < total_w y )
258
259
s2fmt :: String -> Format
260
s2fmt s = Elem 1 l l (\_ -> (s++))
261
where l = length s
262
263
indent_fmt :: Int -> Format -> Format
264
indent_fmt i (Elem dh dl dw dt)
265
= Elem dh (i + dl) (i + dw) (\n -> ((sp i) ++) . dt (i + n))
266
267
above_fmt, beside_fmt :: Format -> Format -> Format
268
(Elem uh ul uw ut) `above_fmt` (Elem lh ll lw lt)
269
= Elem (uh + lh) ll (uw `max` lw)
270
(make_ts_above ut lt)
271
where make_ts_above ut lt = \n -> let nl_skip = (('\n':sp n)++)
272
in ut n . nl_skip . lt n
273
(Elem lh ll lw lt) `beside_fmt` (Elem rh rl rw rt)
274
= Elem (lh + rh - 1) (ll + rl)
275
(lw `max` (ll + rw)) (\n -> lt n . rt (ll + n))
276
277
-- -------------------------------------------------------------------
278
-- Display the layout found ------------------------------------------
279
280
best fs = if null fs then "" else (txtstr . head $ fs) 0 ""
281
allf = concatMap (\fmt -> (txtstr fmt) 0 "\n\n")
282
dispf fs = if null fs then id else (txtstr . head $ fs) 0
283
284
-- -------------------------------------------------------------------
285
-- Utility functions -------------------------------------------------
286
287
merge [] ys = ys
288
merge xs [] = xs
289
merge xl@(x:xs) yl@(y:ys)
290
| x == y = x : merge xs ys
291
| x < y = x : merge xs yl
292
| otherwise = y : merge xl ys
293
294
spaces = ' ':spaces
295
sp n = if n >= 0 then take n spaces else ""
296
297
mergel :: Ord a => [[a]] -> [a]
298
mergel = foldr merge []
299
300
-- ...................................................................
301
-- ..... Generated code from Pretty.ag ...............................
302
303
narrow_frame i (F s l) = F (s - i) (l - i)
304
narrow_ll i (F s l) = F s (l - i)
305
306
type T_Mins = [ (T_PW, T_PLL, T_PH) ]
307
308
set_var_apply cond va vb = if cond then va else vb
309
310
type T_Reqs = [ T_Frame ]
311
312
type T_Fmts = [ T_Formats ]
313
type T_Errs = [ T_Error ]
314
315
beside_height lh rh
316
= lh + rh - if (lh == 0 || rh == 0) then 0 else 1
317
318
cons_height pPh acth avail
319
| acth == 0 = if pPh > 0 then 1 else 0
320
| otherwise = acth + if avail then 0 else 1
321
322
type T_Error = Bool
323
324
data T_Formats = AFormat Formats
325
| TFormats Formats Formats T_Error T_Error
326
327
afmt_txt = AFormat . text_fmts
328
329
set_fmts_empty = AFormat empty_fmts
330
331
set_fmts_text string minw error
332
= afmt_txt string
333
--(if error then (asts minw) else string)
334
335
set_fmts_indent int fmts pw minw frame error
336
| int < 0 = afmt_txt "<Error: negative indentation>"
337
-- int > pw = afmt_txt . asts $ minw
338
| error = set_fmts_indent' error_indent
339
| otherwise = set_fmts_indent' (indent_fmts frame)
340
where set_fmts_indent' fmt_fc
341
= case fmts of
342
AFormat fs -> AFormat (fmt_fc int fs)
343
TFormats as bs ae be
344
-> TFormats (fmt_fc int as)
345
(fmt_fc int bs) ae be
346
347
set_fmts_beside ls rs lh rh frame err
348
= set_fmts_ab ls rs set_fmts_beside' "<Error: can't beside two pairs>"
349
where set_fmts_beside' as bs
350
= set_ab (lh == 0) (rh == 0) as bs
351
(if err then error_beside
352
else beside_fmts frame)
353
354
set_fmts_above us ls uh lh
355
= set_fmts_ab us ls set_fmts_above' "<Error: can't above two pairs>"
356
where set_fmts_above' as bs = set_ab (uh == 0) (lh == 0) as bs above_fmts
357
358
set_ab aempty bempty as bs fmt_fc
359
= if aempty {- left operand empty? -}
360
then bs
361
else if bempty {- right operand empty? -}
362
then as
363
else fmt_fc as bs
364
365
set_fmts_ab fs gs fmt_fc etxt
366
= case fs of
367
AFormat ffmts -> case gs of
368
AFormat gfmts -> ( AFormat (fmt_fc ffmts gfmts), False )
369
TFormats as bs ae be
370
-> ( TFormats (fmt_fc ffmts as)
371
(fmt_fc ffmts bs) ae be
372
, False )
373
TFormats as bs ae be
374
-> case gs of
375
AFormat gfmts -> ( TFormats (fmt_fc as gfmts)
376
(fmt_fc bs gfmts) ae be
377
, False )
378
otherwise -> ( afmt_txt etxt, True )
379
380
sem_fmts_dup afs bfs ae be minw
381
= {-if (ae && be)
382
then afmt_txt . asts $ minw
383
else-}
384
let get_fmts fs
385
= case fs of
386
AFormat as -> as
387
TFormats _ _ _ _ -> text_fmts "<Error: can't dup a dup>"
388
afmts = get_fmts afs
389
bfmts = get_fmts bfs
390
in TFormats afmts bfmts ae be
391
392
set_fmts_join (TFormats as bs ae be) err
393
= ( AFormat $ if be
394
then (if null as then bs else as)
395
else if ae
396
then (if null bs then as else bs)
397
else merge as bs
398
, False
399
)
400
set_fmts_join fs@(AFormat _) err
401
= if err then (fs, err)
402
else (afmt_txt "<Error: can't join a single result>", True)
403
404
set_fmts_apply True a _ = a
405
set_fmts_apply False _ b = b
406
407
set_fmts_fillblock int fmts
408
| int < 0 = afmt_txt "<Error: negative page width in fillblock>"
409
| otherwise = AFormat fmts
410
411
set_error_msg numpars len
412
= "<Error: incorrect apply expression. #pars "
413
++ show numpars ++ " /= #args "
414
++ show len ++ ">"
415
{-
416
asts 0 = ""
417
asts 1 = "*"
418
asts s = '<' : replicate (s-2) '*' ++ ">"
419
-}
420
sem_fmts_cdup afs bfs ae be an bn minw em
421
= if an /= bn then afmt_txt em
422
else sem_fmts_dup afs bfs ae be minw
423
424
set_error_msg' apars bpars
425
= "<Error: incorrect choice expression. #pars left " ++ show apars
426
++ " /= #pars right " ++ show bpars
427
++ ">"
428
429
set_fmts_filllist ifmts nfmts ih nh frame avail
430
= case nfmts of
431
AFormat ns -> if ih == 0 {- left operand empty? -}
432
then (ns, False)
433
else if nh == 0 {- right operand empty? -}
434
then (ifmts, False)
435
else if nh <= 1
436
then ( choose_ab (beside_fmts frame) ifmts ns, False )
437
else ( choose_ab error_beside
438
ifmts (text_fmts "<Error: element in fill higher than 1>")
439
, True )
440
otherwise -> ( set_fmts_filllist' . text_fmts $ "<Error: element in fill list is a pair>"
441
, True )
442
where set_fmts_filllist' fs
443
= set_ab (ih == 0) (nh == 0) fs ifmts (choose_ab error_beside)
444
choose_ab bsd_fc = if avail then bsd_fc else above_fmts
445
446
set_fmts_render pw fs
447
= if pw < 0
448
then text_fmts "<Error: negative page width >"
449
else case fs of
450
AFormat fmts -> fmts
451
otherwise -> text_fmts "<Error: can't render a pair>"
452
453
type T_Function = T_Formats -> T_Formats
454
455
set_fmts_filt (AFormat fs ) minw
456
= {-if null height1 then ( afmt_txt . asts $ minw , True )
457
else-} ( AFormat height1 , False )
458
where height1 = takeWhile ((<=1).height) fs
459
set_fmts_filt _ _
460
= ( afmt_txt $ "<Error: can not filter a pair>", True )
461
462
set_fmts_inv fs
463
= case fs of
464
AFormat fmts -> AFormat . set_inv $ fmts
465
TFormats as bs ae be -> TFormats (set_inv as) (set_inv bs) ae be
466
where set_inv = (:[]) . (Elem 1 0 0) . txtstr . head
467
468
type T_SynPPS = ( T_Formats, T_Error, T_PH, T_PLL, T_PW )
469
470
vapp fmts spaces pPS frame
471
= sem_PPS_Above (\frame -> fmts) (sem_PPS_Indent spaces pPS) frame
472
473
---------------------- PPS -------------------------
474
-- semantic domains
475
type T_PPS = T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW)
476
-- funcs
477
sem_PPS_Empty :: T_PPS
478
sem_PPS_Empty lhs_frame = ( (set_fmts_empty), False, 0, (0), (0) )
479
sem_PPS_Text ::String -> T_PPS
480
sem_PPS_Text string lhs_frame
481
= let{ minw = (length string)
482
; error = (minw > pw)
483
; f@(F pw _ ) = (lhs_frame)
484
}in ( (set_fmts_text string minw error), error, (1), (minw), minw )
485
sem_PPS_Indent ::Int -> T_PPS -> T_PPS
486
sem_PPS_Indent int pPS lhs_frame
487
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (narrow_frame int lhs_frame)
488
; minw = (int + pPS_minw)
489
; f@(F pw _ ) = (lhs_frame)
490
}in ( (set_fmts_indent int pPS_fmts pw minw lhs_frame pPS_error)
491
, (or [int < 0, int > pw, pPS_error])
492
, pPS_maxh
493
, (int + pPS_minll)
494
, (minw)
495
)
496
sem_PPS_Beside :: T_PPS -> T_PPS -> T_PPS
497
sem_PPS_Beside left right lhs_frame
498
= let{ ( left_fmts, left_error, left_maxh, left_minll, left_minw ) = left (narrow_ll right_minw lhs_frame)
499
; ( right_fmts, right_error, right_maxh, right_minll, right_minw ) = right (narrow_frame left_minll lhs_frame)
500
; error = (left_error || right_error)
501
; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error)
502
}in ( (bfmts)
503
, (error || berror)
504
, (beside_height left_maxh right_maxh)
505
, (left_minll + right_minll)
506
, (left_minw `max` (left_minll + right_minw))
507
)
508
sem_PPS_Above :: T_PPS -> T_PPS -> T_PPS
509
sem_PPS_Above upper lower lhs_frame
510
= let{ ( upper_fmts, upper_error, upper_maxh, upper_minll, upper_minw ) = upper lhs_frame
511
; ( lower_fmts, lower_error, lower_maxh, lower_minll, lower_minw ) = lower lhs_frame
512
; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh)
513
}in ( (afmts)
514
, (or [lower_error, upper_error, aerror])
515
, upper_maxh + lower_maxh
516
, (lower_minll)
517
, (upper_minw `max` lower_minw)
518
)
519
sem_PPS_Dup :: T_PPS -> T_PPS -> T_PPS
520
sem_PPS_Dup opta optb lhs_frame
521
= let{ ( opta_fmts, opta_error, opta_maxh, opta_minll, opta_minw ) = opta lhs_frame
522
; ( optb_fmts, optb_error, optb_maxh, optb_minll, optb_minw ) = optb lhs_frame
523
; minw = (opta_minw `min` optb_minw)
524
; error = (opta_error && optb_error)
525
}in ( (sem_fmts_dup opta_fmts optb_fmts opta_error optb_error minw)
526
, (error)
527
, (opta_maxh `max` optb_maxh)
528
, (opta_minll `min` optb_minll)
529
, (minw)
530
)
531
sem_PPS_Join :: T_PPS -> T_PPS
532
sem_PPS_Join pPS lhs_frame
533
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame
534
; fe@(jfmts,jerror) = (set_fmts_join pPS_fmts pPS_error)
535
}in ( (jfmts), (pPS_error || jerror), pPS_maxh, pPS_minll, pPS_minw )
536
sem_PPS_Apply :: T_PPC -> T_PPSArgs -> T_PPS
537
sem_PPS_Apply pPC pPSArgs lhs_frame
538
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
539
= pPC (pPSArgs_error) (pPSArgs_fmts) lhs_frame (pPSArgs_mins)
540
; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs pPC_reqs
541
; error = (set_var_apply error_cond True pPC_error)
542
; error_cond = (pPC_numpars /= pPSArgs_len)
543
; lem = (length error_msg)
544
; error_msg = (set_error_msg pPC_numpars pPSArgs_len)
545
}in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts)
546
, (error)
547
, (set_var_apply error_cond 1 pPC_maxh)
548
, (set_var_apply error_cond lem pPC_minll)
549
, (set_var_apply error_cond lem pPC_minw)
550
)
551
sem_PPS_Fill :: T_FillList -> T_PPS
552
sem_PPS_Fill fillList lhs_frame
553
= let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )
554
= fillList (empty_fmts) (False) (0) (0) (0) (F w w) (w)
555
; f@(F w _ ) = (lhs_frame)
556
}in ( (AFormat fillList_fmts), fillList_error, fillList_maxh, fillList_minll, fillList_minw )
557
sem_PPS_FillBlock ::Int -> T_FillList -> T_PPS
558
sem_PPS_FillBlock int fillList lhs_frame
559
= let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )
560
= fillList (empty_fmts) (False) (0) (0) (0) (f_frame) (f_width)
561
; f@(F w _ ) = (lhs_frame)
562
; f_width = (if int > w then w else int)
563
; f_frame = (if int > w then lhs_frame else (F int int))
564
; error = (or [int < 0, fillList_error])
565
}in ( (set_fmts_fillblock int fillList_fmts), (error), fillList_maxh, fillList_minll, fillList_minw )
566
sem_PPS_Filt :: T_PPS -> T_PPS
567
sem_PPS_Filt pPS lhs_frame
568
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame
569
; ef@(fmts,error) = (set_fmts_filt pPS_fmts pPS_minw)
570
}in ( (fmts), (error || pPS_error), pPS_maxh, pPS_minll, pPS_minw )
571
sem_PPS_Inv :: T_PPS -> T_PPS
572
sem_PPS_Inv pPS lhs_frame
573
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F maxBound maxBound)
574
}in ( (set_fmts_inv pPS_fmts), (False), (1), (0), (0) )
575
sem_PPS_Center :: T_CenterList -> T_PPS
576
sem_PPS_Center centerList lhs_frame
577
= let{ ( centerList_maxw, centerList_fmts ) = centerList (centerList_maxw) (sem_PPS_Empty lhs_frame) lhs_frame
578
; clf@(fmts,error,maxh,minll,minw) = (centerList_fmts)
579
}in ( (fmts), (error), (maxh), (minll), (minw) )
580
---------------------- PPC -------------------------
581
-- semantic domains
582
type T_PPC = T_Errs -> T_Fmts -> T_Frame -> T_Mins ->
583
(T_Formats,T_Error,T_PH,T_Reqs,T_PLL
584
,T_PW,Int)
585
-- funcs
586
sem_PPC_Indent ::Int -> T_PPC -> T_PPC
587
sem_PPC_Indent int pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
588
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
589
= pPC lhs_fillerrs lhs_fillfmts (narrow_frame int lhs_frame) lhs_fillmins
590
; minw = (int + pPC_minw)
591
; f@(F pw _ ) = (lhs_frame)
592
}in ( (set_fmts_indent int pPC_fmts pw minw lhs_frame pPC_error)
593
, (or [int < 0, int > pw, pPC_error])
594
, pPC_maxh
595
, pPC_reqs
596
, (int + pPC_minll)
597
, (minw)
598
, pPC_numpars
599
)
600
sem_PPC_Beside :: T_PPC -> T_PPC -> T_PPC
601
sem_PPC_Beside left right lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
602
= let{ ( left_fmts, left_error, left_maxh, left_reqs, left_minll, left_minw, left_numpars )
603
= left (les) (lfs) (narrow_ll right_minw lhs_frame) (lim)
604
; ( right_fmts, right_error, right_maxh, right_reqs, right_minll, right_minw, right_numpars )
605
= right (res) (rfs) (narrow_frame left_minll lhs_frame) (rim)
606
; i@(lim,rim) = (splitAt left_numpars lhs_fillmins)
607
; e@(les,res) = (splitAt left_numpars lhs_fillerrs)
608
; m@(lfs,rfs) = (splitAt left_numpars lhs_fillfmts)
609
; error = (left_error || right_error)
610
; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error)
611
}in ( (bfmts)
612
, (error || berror)
613
, (beside_height left_maxh right_maxh)
614
, left_reqs ++ right_reqs
615
, (left_minll + right_minll)
616
, (left_minw `max` (left_minll + right_minw))
617
, left_numpars + right_numpars
618
)
619
sem_PPC_Above :: T_PPC -> T_PPC -> T_PPC
620
sem_PPC_Above upper lower lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
621
= let{ ( upper_fmts, upper_error, upper_maxh, upper_reqs, upper_minll, upper_minw, upper_numpars )
622
= upper (ues) (ufs) lhs_frame (uim)
623
; ( lower_fmts, lower_error, lower_maxh, lower_reqs, lower_minll, lower_minw, lower_numpars )
624
= lower (les) (lfs) lhs_frame (lim)
625
; i@(uim,lim) = (splitAt upper_numpars lhs_fillmins)
626
; e@(ues,les) = (splitAt upper_numpars lhs_fillerrs)
627
; m@(ufs,lfs) = (splitAt upper_numpars lhs_fillfmts)
628
; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh)
629
}in ( (afmts)
630
, (or [lower_error, upper_error, aerror])
631
, (upper_maxh + lower_maxh)
632
, upper_reqs ++ lower_reqs
633
, lower_minll
634
, (upper_minw `max` lower_minw)
635
, upper_numpars + lower_numpars
636
)
637
sem_PPC_Dup :: T_PPC -> T_PPC -> T_PPC
638
sem_PPC_Dup opta optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
639
= let{ ( opta_fmts, opta_error, opta_maxh, opta_reqs, opta_minll, opta_minw, opta_numpars )
640
= opta lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
641
; ( optb_fmts, optb_error, optb_maxh, optb_reqs, optb_minll, optb_minw, optb_numpars )
642
= optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
643
; minw = (opta_minw `min` optb_minw)
644
; error = (or [opta_numpars /= optb_numpars, opta_error && optb_error])
645
; error_msg = (set_error_msg' opta_numpars optb_numpars)
646
}in ( (sem_fmts_cdup opta_fmts optb_fmts opta_error optb_error opta_numpars optb_numpars minw error_msg)
647
, (error)
648
, (opta_maxh `max` optb_maxh)
649
, (zipWith max opta_reqs optb_reqs)
650
, (opta_minll `min` optb_minll)
651
, (minw)
652
, (opta_numpars)
653
)
654
sem_PPC_Join :: T_PPC -> T_PPC
655
sem_PPC_Join pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
656
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
657
= pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
658
; fe@(jfmts,jerror) = (set_fmts_join pPC_fmts pPC_error)
659
}in ( (jfmts), (pPC_error || jerror), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
660
sem_PPC_Par :: T_PPC
661
sem_PPC_Par lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
662
= let{ m@(minw,minll,maxh) = (head lhs_fillmins)
663
; error = (head lhs_fillerrs)
664
; fmts = (head lhs_fillfmts)
665
}in ( fmts, error, maxh, ([lhs_frame]), minll, minw, 1 )
666
sem_PPC_Apply :: T_PPC -> T_PPCArgs -> T_PPC
667
sem_PPC_Apply pPC pPCArgs lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
668
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
669
= pPC (pPCArgs_error) (pPCArgs_fmts) (lhs_frame) (pPCArgs_ofillmins)
670
; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len )
671
= pPCArgs (lhs_fillerrs) (lhs_fillfmts) (pPC_reqs) (lhs_fillmins)
672
; error = (set_var_apply error_cond True pPC_error)
673
; error_cond = (pPC_numpars /= pPCArgs_len)
674
; lem = (length error_msg)
675
; error_msg = (set_error_msg pPC_numpars pPCArgs_len)
676
}in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts)
677
, (error)
678
, (set_var_apply error_cond 1 pPC_maxh)
679
, (pPCArgs_reqs)
680
, (set_var_apply error_cond lem pPC_minll)
681
, (set_var_apply error_cond lem pPC_minw)
682
, (pPCArgs_numpars)
683
)
684
sem_PPC_Pps :: T_PPS -> T_PPC
685
sem_PPC_Pps pPS lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
686
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame
687
}in ( pPS_fmts, pPS_error, pPS_maxh, ([]), pPS_minll, pPS_minw, (0) )
688
sem_PPC_Filt :: T_PPC -> T_PPC
689
sem_PPC_Filt pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
690
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
691
= pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
692
; ef@(fmts,error) = (set_fmts_filt pPC_fmts pPC_minw)
693
}in ( (fmts), (error || pPC_error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
694
---------------------- PPSArgs -------------------------
695
-- semantic domains
696
type T_PPSArgs = T_Reqs ->(T_Errs,T_Fmts,T_Mins,Int)
697
-- funcs
698
sem_PPSArgs_Nil :: T_PPSArgs
699
sem_PPSArgs_Nil lhs_reqs = ( ([]), ([]), ([]), (0) )
700
sem_PPSArgs_Cons :: T_PPS -> T_PPSArgs -> T_PPSArgs
701
sem_PPSArgs_Cons pPS pPSArgs lhs_reqs
702
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (head lhs_reqs)
703
; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs (tail lhs_reqs)
704
}in ( (pPS_error:pPSArgs_error), (pPS_fmts:pPSArgs_fmts), ((pPS_minw ,pPS_minll, pPS_maxh):pPSArgs_mins), (pPSArgs_len + 1) )
705
---------------------- PPCArgs -------------------------
706
-- semantic domains
707
type T_PPCArgs = T_Errs -> T_Fmts -> T_Reqs -> T_Mins ->(T_Errs,T_Fmts,T_Reqs,T_Mins,Int,Int)
708
-- funcs
709
sem_PPCArgs_Nil :: T_PPCArgs
710
sem_PPCArgs_Nil lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins = ( ([]), ([]), [], ([]), 0, (0) )
711
sem_PPCArgs_Cons :: T_PPC -> T_PPCArgs -> T_PPCArgs
712
sem_PPCArgs_Cons pPC pPCArgs lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins
713
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC (pef) (pff) (head lhs_ireqs) (pim)
714
; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len )
715
= pPCArgs (lef) (lff) (tail lhs_ireqs) (lim)
716
; i@(pim,lim) = (splitAt pPC_numpars lhs_ifillmins)
717
; e@(pef,lef) = (splitAt pPC_numpars lhs_ifillerrs)
718
; m@(pff,lff) = (splitAt pPC_numpars lhs_ifillfmts)
719
}in ( (pPC_error:pPCArgs_error)
720
, (pPC_fmts:pPCArgs_fmts)
721
, pPC_reqs ++ pPCArgs_reqs
722
, ((pPC_minw ,pPC_minll,pPC_maxh):pPCArgs_ofillmins)
723
, pPC_numpars + pPCArgs_numpars
724
, (pPCArgs_len + 1)
725
)
726
---------------------- FillList -------------------------
727
-- semantic domains
728
type T_FillList = Formats -> T_Error -> T_PH -> T_PW -> T_PLL -> T_Frame -> T_PW ->(Formats,T_Error,T_PH,T_PW,T_PLL)
729
-- funcs
730
sem_FillList_Nil :: T_FillList
731
sem_FillList_Nil lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw
732
= ( lhs_fmts, lhs_error, lhs_maxh, lhs_minw, lhs_minll )
733
sem_FillList_Cons :: T_PPS -> T_FillList -> T_FillList
734
sem_FillList_Cons pPS fillList lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw
735
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame)
736
; ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll )
737
= fillList (ffmts)
738
(lhs_error || ferror)
739
(cons_height pPS_maxh lhs_maxh avail)
740
(if (not avail) || (lhs_minw == lhs_pw) then lhs_pw else lhs_minll)
741
(if ferror then lhs_pw + 1 else if avail then newll else pPS_minw)
742
lhs_frame
743
lhs_pw
744
; avail = (lhs_pw - newll >= 0)
745
; newll = (lhs_minll + pPS_minw)
746
; fe@(ffmts,ferror) = (set_fmts_filllist lhs_fmts pPS_fmts lhs_maxh pPS_maxh lhs_frame avail)
747
}in ( fillList_fmts, (fillList_error || pPS_error), fillList_maxh, fillList_minw, fillList_minll )
748
---------------------- Root -------------------------
749
-- semantic domains
750
type T_Root = T_PW ->String
751
-- funcs
752
sem_Root_Best :: T_PPS -> T_Root
753
sem_Root_Best pPS lhs_pw
754
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw)
755
}in (best . set_fmts_render lhs_pw $ pPS_fmts)
756
sem_Root_All :: T_PPS -> T_Root
757
sem_Root_All pPS lhs_pw
758
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw)
759
}in (allf . set_fmts_render lhs_pw $ pPS_fmts)
760
---------------------- Disp -------------------------
761
-- semantic domains
762
type T_Disp = T_PW ->ShowS
763
-- funcs
764
sem_Disp_Disp :: T_PPS -> T_Disp
765
sem_Disp_Disp pPS lhs_pw
766
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw)
767
}in (dispf . set_fmts_render lhs_pw $ pPS_fmts)
768
---------------------- LiftS -------------------------
769
-- semantic domains
770
type T_LiftS = T_Function -> T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW)
771
-- funcs
772
sem_LiftS_Lift :: T_PPS -> T_LiftS
773
sem_LiftS_Lift pPS lhs_f lhs_frame
774
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame
775
}in ( (lhs_f pPS_fmts), pPS_error, pPS_maxh, pPS_minll, pPS_minw )
776
---------------------- LiftC -------------------------
777
-- funcs
778
sem_LiftC_Lift pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
779
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
780
= pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
781
}in ( (lhs_f pPC_fmts), pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
782
sem_LiftC_Pair pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
783
= let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
784
= pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins
785
; fe@(fmts,error) = (lhs_f pPC_fmts)
786
}in ( (fmts), (pPC_error || error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars )
787
---------------------- CenterList -------------------------
788
-- semantic domains
789
type T_CenterList = Int -> T_SynPPS -> T_Frame ->(Int,T_SynPPS)
790
-- funcs
791
sem_CenterList_Nil :: T_CenterList
792
sem_CenterList_Nil lhs_maxw lhs_fmts lhs_frame = ( (0), lhs_fmts )
793
sem_CenterList_Cons :: T_PPS -> T_CenterList -> T_CenterList
794
sem_CenterList_Cons pPS centerList lhs_maxw lhs_fmts lhs_frame
795
= let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame)
796
; ( centerList_maxw, centerList_fmts ) = centerList lhs_maxw (vapp lhs_fmts spaces pPS lhs_frame) lhs_frame
797
; spaces = ((lhs_maxw - pPS_minw) `div` 2)
798
}in ( (pPS_minw `max` centerList_maxw), centerList_fmts )
Loggerhead is a web-based interface for Breezy
Version: 2.0.1