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
|
--------------------------------------------------------------------------------
-- |
-- Module : Text.Show.Pretty
-- Copyright : (c) Iavor S. Diatchki 2009
-- License : BSD3
--
-- Maintainer : iavor.diatchki@gmail.com
-- Stability : provisional
-- Portability : Haskell 98
--
-- Functions for human-readable derived 'Show' instances.
--------------------------------------------------------------------------------
module Text.Show.Pretty
( Name, Value(..)
, parseValue, reify, ppValue, ppDoc, ppShow
) where
import Text.PrettyPrint
import qualified Text.Show.Parser as P
import Text.Show.Value
import Language.Haskell.Lexer(rmSpace,lexerPass0)
reify :: Show a => a -> Maybe Value
reify = parseValue . show
parseValue :: String -> Maybe Value
parseValue = P.parseValue . rmSpace . lexerPass0
-- | Convert a generic value into a pretty 'String', if possible.
ppShow :: Show a => a -> String
ppShow = show . ppDoc
-- | Try to show a value, prettily. If we do not understand the value, then we
-- just use its standard 'Show' instance.
ppDoc :: Show a => a -> Doc
ppDoc a = case parseValue txt of
Just v -> ppValue v
Nothing -> text txt
where txt = show a
-- | Pretty print a generic value. Our intention is that the result is
-- equivalent to the 'Show' instance for the original value, except possibly
-- easier to understand by a human.
ppValue :: Value -> Doc
ppValue val = case val of
Con c vs -> ppCon c vs
Rec c fs -> hang (text c) 2 $ block '{' '}' (map ppField fs)
where ppField (x,v) = text x <+> char '=' <+> ppValue v
List vs -> block '[' ']' (map ppValue vs)
Tuple vs -> block '(' ')' (map ppValue vs)
Neg v -> char '-' <> ppAtom v
Ratio x y -> ppCon "(%)" [x,y]
Integer x -> text x
Float x -> text x
Char x -> text x
String x -> text x
-- Private ---------------------------------------------------------------------
ppAtom :: Value -> Doc
ppAtom v
| isAtom v = ppValue v
| otherwise = parens (ppValue v)
ppCon :: Name -> [Value] -> Doc
ppCon c [] = text c
ppCon c (v : vs) = hang line1 2 (foldl addParam doc1 vs)
where (line1,doc1)
| isAtom v = (text c, ppValue v)
| otherwise = (text c <+> char '(', ppValue v <+> char ')')
addParam d p
| isAtom p = d $$ ppValue p
| otherwise = (d <+> char '(') $$ (ppValue p <+> char ')')
isAtom :: Value -> Bool
isAtom (Con _ (_:_)) = False
isAtom (Ratio {}) = False
isAtom (Neg {}) = False
isAtom _ = True
block :: Char -> Char -> [Doc] -> Doc
block a b [] = char a <> char b
block a b (d:ds) = char a <+> d
$$ vcat [ char ',' <+> x | x <- ds ]
$$ char b
|
