git.iko.soy/elk
on master help sign in
Implement a type renderer with diffing and colors
e828e6eEvan Czaplicki
src/Reporting/Render/Type.hs+391−174
compare with master
unifiedsplit
@@ -1,270 +1,487 @@
1module Reporting.Render.Type
1module Reporting.Render.Type
2 ( Localizer
2 ( Localizer
3− , typeDecl
3+ , decl
4 , aliasDecl
4 , aliasDecl
5 , annotation
5 , annotation
6− , tipe
6+ , toDoc
7+ , diffToDocs
8+ , Style(..)
7 )
9 )
8 where
10 where
9
11
12+import Control.Arrow ((***), first)
10import qualified Data.Map as Map
13import qualified Data.Map as Map
14+import qualified Data.Set as Set
11import Text.PrettyPrint.ANSI.Leijen
15import Text.PrettyPrint.ANSI.Leijen
16+ ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep, indent
17+ , lbrace, lparen, rbrace, rparen, sep, text, vcat
18+ )
12
19
13−import qualified AST.Helpers as Help
20+import qualified AST.Type as Type
21+import qualified AST.Variable as Var
22+import Reporting.Error.Helpers as Help
14
23
15
24
16−type Localizer =
17− Map.Map String String
18
25
26+-- PUBLIC API FOR CREATING DOCS
19
27
20−typeDecl =
28+
21− error "TODO"
29+decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc
30+decl localizer name vars tags =
31+ let
32+ docTag (tag, args) =
33+ hang 2 (sep (text tag : map (docType localizer) args))
34+ in
35+ hang 4 $ vcat $
36+ (hsep (map text ("type" : name : vars)))
37+ :
38+ zipWith (<+>)
39+ (equals : repeat (text "|"))
40+ (map docTag tags)
22
41
23
42
24−aliasDecl =
43+aliasDecl :: Localizer -> String -> [String] -> Type.Canonical -> Doc
25− error "TODO"
44+aliasDecl localizer name vars tipe =
45+ hang 4 $ vcat $
46+ [ hsep (map text ("type" : name : vars) ++ [equals])
47+ , docType localizer tipe
48+ ]
26
49
27
50
28annotation =
51annotation =
29 error "TODO"
52 error "TODO"
30
53
31
54
32−tipe =
55+toDoc :: Localizer -> Type.Canonical -> Doc
33− error "TODO"
56+toDoc localizer tipe =
57+ docType localizer tipe
58+
59+
60+diffToDocs :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
61+diffToDocs localizer style leftType rightType =
62+ case diff localizer style leftType rightType of
63+ Same doc ->
64+ (doc, doc)
65+
66+ Diff leftDoc rightDoc ->
67+ (leftDoc, rightDoc)
34
68
35
69
36
70
37−{-- HELPERS
71+-- LOCALIZE TYPES
38
72
39−commaCat :: [Doc] -> Doc
40−commaCat docs =
41− cat (punctuate comma docs)
42
73
74+type Localizer =
75+ Map.Map String String
76+
77+
78+varToDoc :: Localizer -> Var.Canonical -> Doc
79+varToDoc localizer var =
80+ let
81+ name = Var.toString var
82+ in
83+ if name == "_Tuple0" then
84+ text "()"
43
85
44−commaSep :: [Doc] -> Doc
86+ else
45−commaSep docs =
87+ text (maybe name id (Map.lookup name localizer))
46− sep (punctuate comma docs)
47
88
48
89
49−parensIf :: Bool -> Doc -> Doc
50−parensIf bool doc =
51− if bool then parens doc else doc
52
90
91+-- DIFF BUILDER
53
92
54−variable :: String -> Doc
55−variable x =
56− if Help.isOp x then parens (text x) else text x
57
93
94+data Diff a
95+ = Diff a a
96+ | Same a
58
97
59
98
60−-- PRETTY PRINTING
99+instance Functor Diff where
100+ fmap func d =
101+ case d of
102+ Diff left right ->
103+ Diff (func left) (func right)
61
104
62−instance (P.Pretty t) => P.Pretty (Port t) where
105+ Same both ->
63− pretty dealiaser needsParens portType =
106+ Same (func both)
64− P.pretty dealiaser needsParens (getPortType portType)
65
107
66
108
67−instance P.Pretty Raw' where
109+instance Applicative Diff where
68− pretty dealiaser needsParens tipe =
110+ pure a =
69− case tipe of
111+ Same a
70− RLambda arg body ->
71− P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
72
112
73− RVar x ->
113+ (<*>) func arg =
74− P.text x
114+ case (func, arg) of
115+ (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
116+ Diff (leftFunc leftArg) (rightFunc rightArg)
75
117
76− RType var ->
118+ (Diff leftFunc rightFunc, Same arg) ->
77− prettyType dealiaser var
119+ Diff (leftFunc arg) (rightFunc arg)
78
120
79− RApp func args ->
121+ (Same func, Diff leftArg rightArg) ->
80− let
122+ Diff (func leftArg) (func rightArg)
81− isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
82− isTuple _ = False
83− in
84− prettyApp dealiaser needsParens isTuple func args
85
123
86− RRecord fields ext ->
124+ (Same func, Same arg) ->
87− prettyRecord dealiaser (flattenRawRecord fields ext)
125+ Same (func arg)
88
126
89
127
90−instance P.Pretty Canonical where
128+partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
91− pretty dealiaser needsParens tipe =
129+partitionDiffs dict =
130+ let
131+ collect key value (diffKeys, sameKeys) =
92− case tipe of
132+ case value of
93− Lambda arg body ->
133+ Diff left right ->
94− P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
134+ ( (key, (left, right)) : diffKeys
135+ , sameKeys
136+ )
95
137
96− Var x ->
138+ Same both ->
97− P.text x
139+ ( diffKeys
140+ , (key, both) : sameKeys
141+ )
142+ in
143+ Map.foldrWithKey collect ([],[]) dict
98
144
99− Type var ->
100− prettyType dealiaser var
101
145
102− App func args ->
103− let
104− isTuple (Type name) = Help.isTuple (Var.toString name)
105− isTuple _ = False
106− in
107− prettyApp dealiaser needsParens isTuple func args
108
146
109− Record fields ext ->
147+-- DOC DIFF
110− prettyRecord dealiaser (flattenCanRecord fields ext)
111
148
112− Aliased name args _ ->
113− P.parensIf (needsParens && not (null args)) $
114− P.hang
115− (P.pretty dealiaser False name)
116− 2
117− (P.sep (map (P.pretty dealiaser True . snd) args))
118
149
150+data Style
151+ = Elide
152+ | Full
119
153
120−-- PRETTY HELPERS
121
154
122−prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
155+diff :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> Diff Doc
123−prettyType dealiaser var =
156+diff localizer style leftType rightType =
124 let
157 let
125− v = Var.toString var
158+ go = diff localizer style
126 in
159 in
127− P.text $
160+ case (leftType, rightType) of
128− if v == "_Tuple0" then
161+ (Type.Lambda _ _, Type.Lambda _ _) ->
129− "()"
162+ let
130− else
163+ leftParts = Type.collectLambdas leftType
131− maybe v id (Map.lookup v dealiaser)
164+ rightParts = Type.collectLambdas rightType
165+ in
166+ if length leftParts /= length rightParts then
167+ difference
168+ (docLambda (map (docType localizer) leftParts))
169+ (docLambda (map (docType localizer) rightParts))
132
170
171+ else
172+ docLambda <$> sequenceA (zipWith go leftParts rightParts)
133
173
134−-- PRETTY LAMBDAS
174+ (Type.Var x, Type.Var y) | x == y ->
175+ pure (text x)
135
176
136−prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
177+ (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
137−prettyLambda dealiaser getLambda arg body =
178+ pure (varToDoc localizer leftName)
138− let
139− rest =
140− gatherLambda getLambda body
141
179
142− prettyArg t =
180+ (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
143− P.pretty dealiaser (Maybe.isJust (getLambda t)) t
181+ if leftName /= rightName || length leftArgs /= length rightArgs then
144− in
182+ difference
145− P.sep
183+ (docApp localizer leftName (map (docType localizer) leftArgs))
146− [ prettyArg arg
184+ (docApp localizer rightName (map (docType localizer) rightArgs))
147− , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
148− ]
149
185
186+ else
187+ docApp localizer leftName
188+ <$> sequenceA (zipWith go leftArgs rightArgs)
150
189
151−getRawLambda :: Raw -> Maybe (Raw, Raw)
190+ (Type.App _ _, Type.App _ _) ->
152−getRawLambda (A.A _ tipe) =
191+ error "Type applications without concrete names should not get here."
153− case tipe of
154− RLambda arg body -> Just (arg, body)
155− _ -> Nothing
156
192
193+ (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
194+ let
195+ (leftFields, leftExt) =
196+ flattenRecord outerLeftFields outerLeftExt
157
197
158−getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
198+ (rightFields, rightExt) =
159−getCanLambda tipe =
199+ flattenRecord outerRightFields outerRightExt
200+ in
160− case tipe of
201+ case style of
161− Lambda arg body -> Just (arg, body)
202+ Elide ->
162− _ -> Nothing
203+ diffRecordElide localizer leftFields leftExt rightFields rightExt
163
204
205+ Full ->
206+ error "TODO"
164
207
165−gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
208+ (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
166−gatherLambda get tipe =
209+ docApp localizer leftName
167− case get tipe of
210+ <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))
168− Just (arg, body) ->
211+
169− arg : gatherLambda get body
212+ (Type.Aliased _ args real, _) ->
213+ go (Type.dealias args real) rightType
214+
215+ (_, Type.Aliased _ args real) ->
216+ go leftType (Type.dealias args real)
217+
218+ (_, _) ->
219+ difference
220+ (docType localizer leftType)
221+ (docType localizer rightType)
170
222
171− Nothing ->
172− [tipe]
173
223
224+difference :: Doc -> Doc -> Diff Doc
225+difference leftDoc rightDoc =
226+ Diff (dullyellow leftDoc) (dullyellow rightDoc)
174
227
175−collectLambdas :: Canonical -> [Canonical]
176−collectLambdas tipe =
177− gatherLambda getCanLambda tipe
178
228
179
229
180−-- PRETTY APP
230+-- RECORD DIFFS
181
231
182−prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
183−prettyApp dealiaser needsParens isTuple func args
184− | isTuple func =
185− P.parens $ P.sep $
186− P.punctuate P.comma (map (P.pretty dealiaser False) args)
187
232
188− | null args =
233+diffRecordElide :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
189− P.pretty dealiaser needsParens func
234+diffRecordElide localizer leftFields leftExt rightFields rightExt =
235+ let
236+ (leftOnly, both, rightOnly) =
237+ vennDiagram leftFields rightFields
238+ in
239+ if Map.null leftOnly && Map.null rightOnly then
240+ let
241+ fieldDiffs =
242+ Map.map (uncurry (diff localizer Elide)) both
243+ in
244+ case partitionDiffs fieldDiffs of
245+ ([], sames) ->
246+ let
247+ mkRecord =
248+ docRecord Full (map (first text) sames)
249+ in
250+ if leftExt == rightExt then
251+ Same (mkRecord (fmap text leftExt))
252+
253+ else
254+ Diff
255+ (mkRecord (fmap (dullyellow . text) leftExt))
256+ (mkRecord (fmap (dullyellow . text) rightExt))
257+
258+ (diffs, sames) ->
259+ let
260+ (lefts, rights) = unzipDiffs diffs
261+ style = if null sames then Full else Elide
262+ in
263+ Diff
264+ (docRecord style lefts (fmap text leftExt))
265+ (docRecord style rights (fmap text rightExt))
266+
267+ else
268+ let
269+ (lefts, rights) =
270+ analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
271+
272+ style =
273+ if Map.null both then Full else Elide
274+ in
275+ Diff
276+ (docRecord style lefts (fmap text leftExt))
277+ (docRecord style rights (fmap text rightExt))
278+
279+
280+unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
281+unzipDiffs diffPairs =
282+ let
283+ unzipHelp (name, (left, right)) =
284+ (,) (text name, left) (text name, right)
285+ in
286+ unzip (map unzipHelp diffPairs)
287+
190
288
191− | otherwise =
192− P.parensIf needsParens $
193− P.hang
194− (P.pretty dealiaser True func)
195− 2
196− (P.sep (map (P.pretty dealiaser True) args))
197
289
290+-- ANALYZE FIELD NAMES FOR SIMILAR NAMES
198
291
199−-- PRETTY RECORD
200
292
201−prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
293+analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
202−prettyRecord dealiaser recordInfo =
294+analyzeFields leftOnly rightOnly =
203 let
295 let
204− prettyField (field, tipe) =
296+ potentialTypos =
205− P.hang
297+ findPotentialTypos leftOnly rightOnly
206− (P.text field <+> P.text ":")
298+
207− 4
299+ mkField func name =
208− (P.pretty dealiaser False tipe)
300+ ( func (text name), text "…" )
301+
302+ mkFieldWith counts name =
303+ mkField (if Set.member name counts then dullyellow else id) name
209 in
304 in
210− case recordInfo of
305+ case vetTypos potentialTypos of
211− ([], Nothing) ->
306+ Just (leftTypos, rightTypos) ->
212− P.text "{}"
307+ ( map (mkFieldWith leftTypos) leftOnly
308+ , map (mkFieldWith rightTypos) rightOnly
309+ )
213
310
214− (fields, Nothing) ->
311+ Nothing ->
215− P.sep
312+ ( map (mkField dullyellow) leftOnly
216− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
313+ , map (mkField dullyellow) rightOnly
217− , P.rbrace
314+ )
218− ]
219
315
220− (fields, Just x) ->
221− P.hang
222− (P.lbrace <+> P.text x <+> P.text "|")
223− 4
224− (P.sep
225− [ P.sep (P.punctuate P.comma (map prettyField fields))
226− , P.rbrace
227− ]
228− )
229
316
317+findPotentialTypos :: [String] -> [String] -> [(String, String)]
318+findPotentialTypos leftOnly rightOnly =
319+ let
320+ veryNear leftName =
321+ map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)
322+ in
323+ concatMap veryNear leftOnly
230
324
231−flattenRawRecord
232− :: [(String, Raw)]
233− -> Maybe Raw
234− -> ( [(String, Raw)], Maybe String )
235−flattenRawRecord fields ext =
236− case ext of
237− Nothing ->
238− (fields, Nothing)
239
325
240− Just (A.A _ (RVar x)) ->
326+vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
241− (fields, Just x)
327+vetTypos potentialTypos =
328+ let
329+ tallyNames (ln, rn) (lc, rc) =
330+ ( Map.insertWith (+) ln 1 lc
331+ , Map.insertWith (+) rn 1 rc
332+ )
242
333
243− Just (A.A _ (RRecord fields' ext')) ->
334+ (leftCounts, rightCounts) =
244− flattenRawRecord (fields' ++ fields) ext'
335+ foldr tallyNames (Map.empty, Map.empty) potentialTypos
245
336
246− _ ->
337+ allUnique counts =
247− error "Trying to flatten ill-formed record."
338+ Map.foldr (\n unique -> n < 2 && unique) True counts
339+ in
340+ if allUnique leftCounts && allUnique rightCounts then
341+ Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
342+
343+ else
344+ Nothing
345+
346+
347+-- RECORD DIFFS HELPERS
348+
349+
350+type Fields =
351+ Map.Map String Type.Canonical
352+
353+
354+type DoubleFields =
355+ Map.Map String (Type.Canonical,Type.Canonical)
356+
357+
358+vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
359+vennDiagram leftFields rightFields =
360+ ( Map.difference leftFields rightFields
361+ , Map.intersectionWith (,) leftFields rightFields
362+ , Map.difference rightFields leftFields
363+ )
248
364
249
365
250−flattenCanRecord
366+flattenRecord
251− :: [(String, Canonical)]
367+ :: [(String, Type.Canonical)]
252− -> Maybe Canonical
368+ -> Maybe Type.Canonical
369+ -> (Fields, Maybe String)
370+flattenRecord fields ext =
371+ first Map.fromList (flattenRecordHelp fields ext)
372+
373+
374+flattenRecordHelp
375+ :: [(String, Type.Canonical)]
376+ -> Maybe Type.Canonical
253− -> ( [(String, Canonical)], Maybe String )
377+ -> ([(String, Type.Canonical)], Maybe String)
254−flattenCanRecord fields ext =
378+flattenRecordHelp fields ext =
255 case ext of
379 case ext of
256 Nothing ->
380 Nothing ->
257 (fields, Nothing)
381 (fields, Nothing)
258
382
259− Just (Var x) ->
383+ Just (Type.Var x) ->
260 (fields, Just x)
384 (fields, Just x)
261
385
262− Just (Record fields' ext') ->
386+ Just (Type.Record subFields subExt) ->
263− flattenCanRecord (fields' ++ fields) ext'
387+ flattenRecordHelp (fields ++ subFields) subExt
264
388
265− Just (Aliased _ args tipe) ->
389+ Just (Type.Aliased _ args tipe) ->
266− flattenCanRecord fields (Just (dealias args tipe))
390+ flattenRecordHelp fields (Just (Type.dealias args tipe))
267
391
268 _ ->
392 _ ->
269 error "Trying to flatten ill-formed record."
393 error "Trying to flatten ill-formed record."
270−--}
394+
395+
396+
397+-- TYPES TO DOCS
398+
399+
400+docType :: Localizer -> Type.Canonical -> Doc
401+docType localizer tipe =
402+ case tipe of
403+ Type.Lambda _ _ ->
404+ docLambda (map (docType localizer) (Type.collectLambdas tipe))
405+
406+ Type.Var x ->
407+ text x
408+
409+ Type.Type name ->
410+ varToDoc localizer name
411+
412+ Type.App (Type.Type name) args ->
413+ docApp localizer name (map (docType localizer) args)
414+
415+ Type.App _ _ ->
416+ error "type applications should start with a type atom"
417+
418+ Type.Record outerFields outerExt ->
419+ let
420+ (fields, ext) =
421+ flattenRecordHelp outerFields outerExt
422+ in
423+ docRecord Full
424+ (map (text *** docType localizer) fields)
425+ (fmap text ext)
426+
427+ Type.Aliased name args _ ->
428+ docApp localizer name (map (docType localizer . snd) args)
429+
430+
431+
432+docLambda :: [Doc] -> Doc
433+docLambda (arg:rest) =
434+ sep (arg : map (text "->" <+>) rest)
435+
436+
437+
438+docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc
439+docApp localizer name args =
440+ if Var.isTuple name then
441+ sep
442+ [ cat (zipWith (<+>) (lparen : repeat comma) args)
443+ , rparen
444+ ]
445+
446+ else if null args then
447+ varToDoc localizer name
448+
449+ else
450+ hang 4 (sep (varToDoc localizer name : args))
451+
452+
453+
454+docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
455+docRecord style fields maybeExt =
456+ let
457+ docField (name, tipe) =
458+ hang 4 (sep [ name <+> colon, tipe ])
459+
460+ elision =
461+ case style of
462+ Full ->
463+ []
464+
465+ Elide ->
466+ [ text "…" ]
467+
468+ fieldDocs =
469+ elision ++ map docField fields
470+ in
471+ case (fieldDocs, maybeExt) of
472+ ([], Nothing) ->
473+ text "{}"
474+
475+ (_, Nothing) ->
476+ sep
477+ [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
478+ , rbrace
479+ ]
480+
481+ (_, Just ext) ->
482+ sep
483+ [ lbrace <+> ext
484+ , indent 4 (cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs))
485+ , rbrace
486+ ]
487+