git.iko.soy/elk
on 262a293 help sign in
elk/src/Reporting/Render/Type.hs
505 lines 12 kB history raw
1module Reporting.Render.Type
2 ( Localizer
3 , decl
4 , annotation
5 , toDoc
6 , diffToDocs
7 , Style(..)
8 , findPotentialTypos
9 , vetTypos
10 )
11 where
13import Control.Arrow ((***), first)
14import qualified Data.Map as Map
15import qualified Data.Set as Set
16import Text.PrettyPrint.ANSI.Leijen
17 ( Doc, (<>), (<+>), cat, colon, comma, dullyellow, equals, hang, hsep
18 , lbrace, lparen, parens, rbrace, rparen, sep, space, text, vcat
19 )
21import qualified AST.Helpers as Help
22import qualified AST.Type as Type
23import qualified AST.Variable as Var
24import Reporting.Error.Helpers as Help
28-- PUBLIC API FOR CREATING DOCS
31toDoc :: Localizer -> Type.Canonical -> Doc
32toDoc localizer tipe =
33 docType localizer tipe
36diffToDocs :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
37diffToDocs localizer style leftType rightType =
38 case diff localizer style leftType rightType of
39 Same doc ->
40 (doc, doc)
42 Diff leftDoc rightDoc ->
43 (leftDoc, rightDoc)
46decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc
47decl localizer name vars tags =
48 let
49 docTag (tag, args) =
50 hang 2 (sep (text tag : map (docType localizer) args))
51 in
52 hang 4 $ vcat $
53 (hsep (map text ("type" : name : vars)))
54 :
55 zipWith (<+>)
56 (equals : repeat (text "|"))
57 (map docTag tags)
60annotation :: Localizer -> String -> Type.Canonical -> Doc
61annotation localizer name tipe =
62 let
63 docName =
64 if Help.isOp name then parens (text name) else text name
65 in
66 case Type.collectLambdas tipe of
67 parts@(_ : _ : _) ->
68 hang 4 $ sep $
69 docName
70 : zipWith (<+>)
71 ((colon <> space) : repeat (text "->"))
72 (map (docType localizer) parts)
74 _ ->
75 hang 4 $ sep $
76 [ docName <+> colon
77 , docType localizer tipe
78 ]
82-- LOCALIZE TYPES
85type Localizer =
86 Map.Map String String
89varToDoc :: Localizer -> Var.Canonical -> Doc
90varToDoc localizer var =
91 let
92 name = Var.toString var
93 in
94 if name == "_Tuple0" then
95 text "()"
97 else
98 text (maybe name id (Map.lookup name localizer))
102-- DIFF BUILDER
105data Diff a
106 = Diff a a
107 | Same a
110instance Functor Diff where
111 fmap func d =
112 case d of
113 Diff left right ->
114 Diff (func left) (func right)
116 Same both ->
117 Same (func both)
120instance Applicative Diff where
121 pure a =
122 Same a
124 (<*>) func arg =
125 case (func, arg) of
126 (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
127 Diff (leftFunc leftArg) (rightFunc rightArg)
129 (Diff leftFunc rightFunc, Same arg) ->
130 Diff (leftFunc arg) (rightFunc arg)
132 (Same func, Diff leftArg rightArg) ->
133 Diff (func leftArg) (func rightArg)
135 (Same func, Same arg) ->
136 Same (func arg)
139partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
140partitionDiffs dict =
141 let
142 collect key value (diffKeys, sameKeys) =
143 case value of
144 Diff left right ->
145 ( (key, (left, right)) : diffKeys
146 , sameKeys
147 )
149 Same both ->
150 ( diffKeys
151 , (key, both) : sameKeys
152 )
153 in
154 Map.foldrWithKey collect ([],[]) dict
158-- DOC DIFF
161data Style
162 = Elide
163 | Full
166diff :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> Diff Doc
167diff localizer style leftType rightType =
168 let
169 go = diff localizer style
170 in
171 case (leftType, rightType) of
172 (Type.Lambda _ _, Type.Lambda _ _) ->
173 let
174 leftParts = Type.collectLambdas leftType
175 rightParts = Type.collectLambdas rightType
176 in
177 if length leftParts /= length rightParts then
178 difference
179 (docLambda (map (docType localizer) leftParts))
180 (docLambda (map (docType localizer) rightParts))
182 else
183 docLambda <$> sequenceA (zipWith go leftParts rightParts)
185 (Type.Var x, Type.Var y) | x == y ->
186 pure (text x)
188 (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
189 pure (varToDoc localizer leftName)
191 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
192 if leftName /= rightName || length leftArgs /= length rightArgs then
193 difference
194 (docApp localizer leftName (map (docType localizer) leftArgs))
195 (docApp localizer rightName (map (docType localizer) rightArgs))
197 else
198 docApp localizer leftName
199 <$> sequenceA (zipWith go leftArgs rightArgs)
201 (Type.App _ _, Type.App _ _) ->
202 error "Type applications without concrete names should not get here."
204 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
205 let
206 (leftFields, leftExt) =
207 flattenRecord outerLeftFields outerLeftExt
209 (rightFields, rightExt) =
210 flattenRecord outerRightFields outerRightExt
211 in
212 case style of
213 Elide ->
214 diffRecordElide localizer leftFields leftExt rightFields rightExt
216 Full ->
217 error "TODO"
219 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
220 docApp localizer leftName
221 <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))
223 (Type.Aliased _ args real, _) ->
224 go (Type.dealias args real) rightType
226 (_, Type.Aliased _ args real) ->
227 go leftType (Type.dealias args real)
229 (_, _) ->
230 difference
231 (docType localizer leftType)
232 (docType localizer rightType)
235difference :: Doc -> Doc -> Diff Doc
236difference leftDoc rightDoc =
237 Diff (dullyellow leftDoc) (dullyellow rightDoc)
241-- RECORD DIFFS
244diffRecordElide :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
245diffRecordElide localizer leftFields leftExt rightFields rightExt =
246 let
247 (leftOnly, both, rightOnly) =
248 vennDiagram leftFields rightFields
249 in
250 if Map.null leftOnly && Map.null rightOnly then
251 let
252 fieldDiffs =
253 Map.map (uncurry (diff localizer Elide)) both
254 in
255 case partitionDiffs fieldDiffs of
256 ([], sames) ->
257 let
258 mkRecord =
259 docRecord Full (map (first text) sames)
260 in
261 if leftExt == rightExt then
262 Same (mkRecord (fmap text leftExt))
264 else
265 Diff
266 (mkRecord (fmap (dullyellow . text) leftExt))
267 (mkRecord (fmap (dullyellow . text) rightExt))
269 (diffs, sames) ->
270 let
271 (lefts, rights) = unzipDiffs diffs
272 style = if null sames then Full else Elide
273 in
274 Diff
275 (docRecord style lefts (fmap text leftExt))
276 (docRecord style rights (fmap text rightExt))
278 else
279 let
280 (lefts, rights) =
281 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
283 style =
284 if Map.null both then Full else Elide
285 in
286 Diff
287 (docRecord style lefts (fmap text leftExt))
288 (docRecord style rights (fmap text rightExt))
291unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
292unzipDiffs diffPairs =
293 let
294 unzipHelp (name, (left, right)) =
295 (,) (text name, left) (text name, right)
296 in
297 unzip (map unzipHelp diffPairs)
301-- ANALYZE FIELD NAMES FOR SIMILAR NAMES
304analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
305analyzeFields leftOnly rightOnly =
306 let
307 potentialTypos =
308 findPotentialTypos leftOnly rightOnly
310 mkField func name =
311 ( func (text name), text "…" )
313 mkFieldWith counts name =
314 mkField (if Set.member name counts then dullyellow else id) name
315 in
316 case vetTypos potentialTypos of
317 Just (leftTypos, rightTypos) ->
318 ( map (mkFieldWith leftTypos) leftOnly
319 , map (mkFieldWith rightTypos) rightOnly
320 )
322 Nothing ->
323 ( map (mkField dullyellow) leftOnly
324 , map (mkField dullyellow) rightOnly
325 )
328findPotentialTypos :: [String] -> [String] -> [(String, String)]
329findPotentialTypos leftOnly rightOnly =
330 let
331 veryNear leftName =
332 map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)
333 in
334 concatMap veryNear leftOnly
337vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
338vetTypos potentialTypos =
339 let
340 tallyNames (ln, rn) (lc, rc) =
341 ( Map.insertWith (+) ln 1 lc
342 , Map.insertWith (+) rn 1 rc
343 )
345 (leftCounts, rightCounts) =
346 foldr tallyNames (Map.empty, Map.empty) potentialTypos
348 allUnique counts =
349 Map.foldr (\n unique -> n < 2 && unique) True counts
350 in
351 if allUnique leftCounts && allUnique rightCounts then
352 Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
354 else
355 Nothing
358-- RECORD DIFFS HELPERS
361type Fields =
362 Map.Map String Type.Canonical
365type DoubleFields =
366 Map.Map String (Type.Canonical,Type.Canonical)
369vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
370vennDiagram leftFields rightFields =
371 ( Map.difference leftFields rightFields
372 , Map.intersectionWith (,) leftFields rightFields
373 , Map.difference rightFields leftFields
374 )
377flattenRecord
378 :: [(String, Type.Canonical)]
379 -> Maybe Type.Canonical
380 -> (Fields, Maybe String)
381flattenRecord fields ext =
382 first Map.fromList (flattenRecordHelp fields ext)
385flattenRecordHelp
386 :: [(String, Type.Canonical)]
387 -> Maybe Type.Canonical
388 -> ([(String, Type.Canonical)], Maybe String)
389flattenRecordHelp fields ext =
390 case ext of
391 Nothing ->
392 (fields, Nothing)
394 Just (Type.Var x) ->
395 (fields, Just x)
397 Just (Type.Record subFields subExt) ->
398 flattenRecordHelp (fields ++ subFields) subExt
400 Just (Type.Aliased _ args tipe) ->
401 flattenRecordHelp fields (Just (Type.dealias args tipe))
403 _ ->
404 error "Trying to flatten ill-formed record."
408-- TYPES TO DOCS
411docType :: Localizer -> Type.Canonical -> Doc
412docType localizer tipe =
413 case tipe of
414 Type.Lambda _ _ ->
415 docLambda (map (docType localizer) (Type.collectLambdas tipe))
417 Type.Var x ->
418 text x
420 Type.Type name ->
421 varToDoc localizer name
423 Type.App (Type.Type name) args ->
424 docApp localizer name (map (docType localizer) args)
426 Type.App _ _ ->
427 error "type applications should start with a type atom"
429 Type.Record outerFields outerExt ->
430 let
431 (fields, ext) =
432 flattenRecordHelp outerFields outerExt
433 in
434 docRecord Full
435 (map (text *** docType localizer) fields)
436 (fmap text ext)
438 Type.Aliased name args _ ->
439 docApp localizer name (map (docType localizer . snd) args)
443docLambda :: [Doc] -> Doc
444docLambda docs =
445 case docs of
446 [] ->
447 error "cannot call docLambda with an empty list"
449 arg:rest ->
450 sep (arg : map (text "->" <+>) rest)
454docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc
455docApp localizer name args =
456 if Var.isTuple name then
457 sep
458 [ cat (zipWith (<+>) (lparen : repeat comma) args)
459 , rparen
460 ]
462 else if null args then
463 varToDoc localizer name
465 else
466 hang 4 (sep (varToDoc localizer name : args))
470docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
471docRecord style fields maybeExt =
472 let
473 docField (name, tipe) =
474 hang 4 (sep [ name <+> colon, tipe ])
476 elision =
477 case style of
478 Full ->
479 []
481 Elide ->
482 [ text "…" ]
484 fieldDocs =
485 elision ++ map docField fields
486 in
487 case (fieldDocs, maybeExt) of
488 ([], Nothing) ->
489 text "{}"
491 (_, Nothing) ->
492 sep
493 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
494 , rbrace
495 ]
497 (_, Just ext) ->
498 sep
499 [ hang 4 $ sep $
500 [ lbrace <+> ext
501 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
502 ]
503 , rbrace
504 ]