never executed always true always false
1 {-# LANGUAGE TypeSynonymInstances #-}
2
3 module Conjure.Language.Pretty
4 ( module X
5 , Pretty(..)
6 , (<+->),(<++>)
7 , prettyList, prettyListDoc
8 , parensIf
9 , render, renderNormal, renderWide
10 , prEmpty, prParens, prBrackets, prBraces
11 , Doc
12 , prettyContext
13 , logDebugId
14 , tracingPretty
15 , prettyT
16 ) where
17 import Text.PrettyPrint.Annotated.HughesPJ as X
18 (
19 (<>), (<+>), ($$)
20 , hang, nest, punctuate , cat
21 , hcat, vcat, fsep, hsep, sep
22 )
23 -- conjure
24 import Conjure.Prelude
25
26 -- base
27 import Text.Printf ( printf )
28
29 -- text
30 -- text
31 import qualified Data.Text as T ( Text, unpack, length, singleton, concatMap, pack )
32
33 -- pretty
34
35
36 -- aeson
37 import Data.Aeson as JSON
38 import qualified Data.Aeson.KeyMap as KM
39 import Data.Scientific ( Scientific, floatingOrInteger ) -- scientific
40 import qualified Data.HashMap.Strict as M -- unordered-containers
41 import qualified Data.Vector as V -- vector
42 -- import qualified Prettyprinter.Render.String as Pr
43 -- import qualified Prettyprinter as Pr
44
45 import qualified Text.PrettyPrint.Annotated.HughesPJ as Pr
46 import Text.PrettyPrint.Annotated.HughesPJ hiding (Doc,render)
47
48
49 class Show a => Pretty a where
50 pretty :: a -> Doc
51 prettyPrec :: Int -> a -> Doc
52
53 pretty = prettyPrec 0
54 prettyPrec _ = pretty
55
56 instance Pretty Doc where pretty = id
57 instance Pretty T.Text where pretty = pretty . T.unpack
58 instance Pretty String where pretty = text
59 instance Pretty () where pretty = pretty . show
60 instance Pretty Bool where pretty = pretty . show
61 instance Pretty Int where pretty = pretty . show
62 instance Pretty Integer where pretty = pretty . show
63 instance Pretty Double where pretty x = pretty (printf "%.2f" x :: String)
64
65 instance (Pretty a, Pretty b) => Pretty (a, b) where
66 pretty (a, b) = prettyListDoc parens "," [pretty a, pretty b]
67
68 instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
69 pretty (a, b, c) = prettyListDoc parens "," [pretty a, pretty b, pretty c]
70
71 instance Pretty a => Pretty (Maybe a) where
72 pretty Nothing = "Nothing"
73 pretty (Just x) = "Just" <+> parens (pretty x)
74
75
76 infixl 5 <++>
77 (<++>) :: Doc -> Doc -> Doc
78 a <++> b = hang a 4 b
79
80 -- | For debugging output, truncates the second argument to 5 lines
81 (<+->) :: Doc -> Doc -> Doc
82 a <+-> b = a <+> (Pr.vcat $ map pretty $ take 5 $ lines $ renderWide $ b)
83
84 prettyList :: Pretty a => (Doc -> Doc) -> Doc -> [a] -> Doc
85 prettyList wrap punc = prettyListDoc wrap punc . map pretty
86
87 prettyListDoc :: (Doc -> Doc) -> Doc -> [Doc] -> Doc
88 prettyListDoc wrap punc = wrap . fsep . punctuate punc
89
90 parensIf :: Bool -> Doc -> Doc
91 parensIf = wrapIf parens
92 where
93 wrapIf :: (Doc -> Doc) -> Bool -> Doc -> Doc
94 wrapIf wrap c = if c then wrap else id
95
96 renderNormal :: Pretty a => a -> String
97 renderNormal = render 120
98
99 renderWide :: Pretty a => a -> String
100 renderWide = render 240
101
102 render :: Pretty a => Int -> a -> String
103 -- render w = Pr.renderString . (Pr.layoutSmart (Pr.LayoutOptions $ AvailablePerLine w 1.0) . pretty)
104 render w = renderStyle (style { lineLength = w, ribbonsPerLine = 1 }) . pretty
105
106 prEmpty :: Doc
107 prEmpty = empty
108
109 prParens :: Doc -> Doc
110 prParens = parens
111
112 prBrackets :: Doc -> Doc
113 prBrackets = brackets
114
115 prBraces :: Doc -> Doc
116 prBraces = braces
117
118 prettyContext :: (Pretty a, Pretty b) => [(a,b)] -> [Doc]
119 prettyContext = map (\ (a,b) -> Pr.nest 4 $ pretty a <> ":" <+> pretty b )
120
121
122
123
124
125 --------------------------------------------------------------------------------
126 -- JSON ------------------------------------------------------------------------
127 --------------------------------------------------------------------------------
128
129 -- Not exhaustive, just the ones that are
130 -- likely to appear and cause trouble in output.
131 jsonEsc :: Char -> Text
132 jsonEsc '"' = "\\\""
133 jsonEsc '\\' = "\\\\"
134 jsonEsc '\r' = "\\r"
135 jsonEsc '\n' = "\\n"
136 jsonEsc c = T.singleton c
137
138 instance Pretty JSON.Value where
139 pretty (Object x) = pretty x
140 pretty (Array x) = pretty x
141 pretty (String x) = "\"" <> pretty (T.unpack (T.concatMap jsonEsc x)) <> "\""
142 pretty (Number x) = pretty x
143 pretty (Bool False) = "false"
144 pretty (Bool True) = "true"
145 pretty Null = "null"
146
147 instance Pretty JSON.Object where
148 pretty = prBraces . fsep . Pr.punctuate "," . map f . sortBy (comp `on` fst) . KM.toList
149 where
150 f (key, Array value)
151 | not (any (\ v -> case v of String t -> T.length t < 20 ; _ -> True ) value)
152 = pretty (show key) <> ":" <++> prettyArrayVCat value
153 f (key, value) = pretty (show key) <> ":" <++> pretty value
154
155 keyOrder :: M.HashMap Key Int
156 keyOrder = M.fromList $
157 zip [ "finds", "givens", "enumGivens", "enumLettings", "unnameds"
158 , "strategyQ", "strategyA"
159 , "trailCompact", "trailVerbose", "trailRewrites"
160 , "nameGenState", "nbExtraGivens"
161 , "representations", "representationsTree"
162 , "originalDomains"
163 , "before", "after"
164 ] [1..]
165 comp :: Key -> Key -> Ordering
166 comp a b =
167 let preferred = compare <$> M.lookup a keyOrder
168 <*> M.lookup b keyOrder
169 in fromMaybe (compare a b) preferred
170
171 instance Pretty JSON.Array where
172 pretty = prBrackets . fsep . Pr.punctuate "," . map pretty . V.toList
173
174 prettyArrayVCat :: V.Vector Value -> Doc
175 prettyArrayVCat = prBrackets . Pr.vcat . Pr.punctuate "," . map pretty . V.toList
176
177 instance Pretty Scientific where
178 pretty = either pretty pretty . (floatingOrInteger :: Scientific -> Either Double Integer)
179
180 logDebugId :: (MonadLog m, Pretty a) => Doc -> a -> m a
181 logDebugId msg a = logDebug (msg <++> pretty a) >> return a
182
183 tracingPretty :: Pretty a => Doc -> a -> a
184 tracingPretty s a = trace (renderWide $ "tracing" <+> s <> ": " <++> pretty a) a
185
186 prettyT :: Pretty a => a -> Text
187 prettyT = T.pack.show.pretty