1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module LambdaCube.Compiler.Pretty
( module LambdaCube.Compiler.Pretty
, Doc
, (<+>), (</>), (<$$>)
, hsep, hcat, vcat
, punctuate
, tupled, braces, parens
, text
, nest
) where
import Data.String
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad.Except
import Debug.Trace
import Text.PrettyPrint.Leijen
--------------------------------------------------------------------------------
instance IsString Doc where fromString = text
instance Monoid Doc where
mempty = empty
mappend = (<>)
class PShow a where
pShowPrec :: Int -> a -> Doc
pShow = pShowPrec (-2)
ppShow = show . pShow
ppShow' = show
{-
prec 0: no outer parens needed
prec 10: argument of a function
f x (g y)
-}
--------------------------------------------------------------------------------
pParens p x
| p = tupled [x]
| otherwise = x
pOp i j k sep p a b = pParens (p >= i) $ pShowPrec j a <+> sep <+> pShowPrec k b
pOp' i j k sep p a b = pParens (p >= i) $ pShowPrec j a </> sep <+> pShowPrec k b
pInfixl i = pOp i (i-1) i
pInfixr i = pOp i i (i-1)
pInfixr' i = pOp' i i (i-1)
pInfix i = pOp i i i
pTyApp = pInfixl 10 "@"
pApps p x [] = pShowPrec p x
pApps p x xs = pParens (p > 9) $ hsep $ pShowPrec 9 x: map (pShowPrec 10) xs
pApp p a b = pApps p a [b]
showRecord = braces . hsep . punctuate (pShow ',') . map (\(a, b) -> pShow a <> ":" <+> pShow b)
--------------------------------------------------------------------------------
instance PShow Bool where
pShowPrec p b = if b then "True" else "False"
instance (PShow a, PShow b) => PShow (a, b) where
pShowPrec p (a, b) = tupled [pShow a, pShow b]
instance (PShow a, PShow b, PShow c) => PShow (a, b, c) where
pShowPrec p (a, b, c) = tupled [pShow a, pShow b, pShow c]
instance PShow a => PShow [a] where
pShowPrec p = brackets . sep . punctuate comma . map pShow
instance PShow a => PShow (Maybe a) where
pShowPrec p = \case
Nothing -> "Nothing"
Just x -> "Just" <+> pShow x
instance PShow a => PShow (Set a) where
pShowPrec p = pShowPrec p . Set.toList
instance (PShow s, PShow a) => PShow (Map s a) where
pShowPrec p = braces . vcat . map (\(k, t) -> pShow k <> colon <+> pShow t) . Map.toList
instance (PShow a, PShow b) => PShow (Either a b) where
pShowPrec p = either (("Left" <+>) . pShow) (("Right" <+>) . pShow)
instance PShow Doc where
pShowPrec p x = x
instance PShow Int where pShowPrec _ = int
instance PShow Integer where pShowPrec _ = integer
instance PShow Double where pShowPrec _ = double
instance PShow Char where pShowPrec _ = char
instance PShow () where pShowPrec _ _ = "()"
-------------------------------------------------------------------------------- ANSI terminal colors
pattern ESC a b <- (splitESC -> Just (a, b)) where ESC a b | 'm' `notElem` a = "\ESC[" ++ a ++ "m" ++ b
splitESC ('\ESC':'[': (span (/='m') -> (a, c: b))) | c == 'm' = Just (a, b)
splitESC _ = Nothing
withEsc i s = ESC (show i) $ s ++ ESC "" ""
inGreen = withEsc 32
inBlue = withEsc 34
inRed = withEsc 31
underlined = withEsc 47
removeEscs :: String -> String
removeEscs (ESC _ cs) = removeEscs cs
removeEscs (c: cs) = c: removeEscs cs
removeEscs [] = []
correctEscs :: String -> String
correctEscs = (++ "\ESC[K") . f ["39","49"] where
f acc (ESC i@(_:_) cs) = esc (i /= head acc) i $ f (i: acc) cs
f (a: acc) (ESC "" cs) = esc (a /= head acc) (compOld (cType a) acc) $ f acc cs
f acc (c: cs) = c: f acc cs
f acc [] = []
esc b i = if b then ESC i else id
compOld x xs = head $ filter ((== x) . cType) xs
cType n
| "30" <= n && n <= "39" = 0
| "40" <= n && n <= "49" = 1
| otherwise = 2
putStrLn_ = putStrLn . correctEscs
error_ = error . correctEscs
trace_ = trace . correctEscs
throwError_ = throwError . correctEscs
|
