git.iko.soy/elk
on 780ee73 help sign in
elk/src/Reporting/Render/Type.hs
500 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 -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
37diffToDocs localizer leftType rightType =
38 case diff localizer 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
161diff :: Localizer -> Type.Canonical -> Type.Canonical -> Diff Doc
162diff localizer leftType rightType =
163 let
164 go = diff localizer
165 in
166 case (leftType, rightType) of
167 (Type.Lambda _ _, Type.Lambda _ _) ->
168 let
169 leftParts = Type.collectLambdas leftType
170 rightParts = Type.collectLambdas rightType
171 in
172 if length leftParts /= length rightParts then
173 difference
174 (docLambda (map (docType localizer) leftParts))
175 (docLambda (map (docType localizer) rightParts))
177 else
178 docLambda <$> sequenceA (zipWith go leftParts rightParts)
180 (Type.Var x, Type.Var y) | x == y ->
181 pure (text x)
183 (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
184 pure (varToDoc localizer leftName)
186 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
187 if leftName /= rightName || length leftArgs /= length rightArgs then
188 difference
189 (docApp localizer leftName (map (docType localizer) leftArgs))
190 (docApp localizer rightName (map (docType localizer) rightArgs))
192 else
193 docApp localizer leftName
194 <$> sequenceA (zipWith go leftArgs rightArgs)
196 (Type.App _ _, Type.App _ _) ->
197 error "Type applications without concrete names should not get here."
199 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
200 let
201 (leftFields, leftExt) =
202 flattenRecord outerLeftFields outerLeftExt
204 (rightFields, rightExt) =
205 flattenRecord outerRightFields outerRightExt
206 in
207 diffRecord localizer leftFields leftExt rightFields rightExt
209 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
210 docApp localizer leftName
211 <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))
213 (Type.Aliased _ args real, _) ->
214 go (Type.dealias args real) rightType
216 (_, Type.Aliased _ args real) ->
217 go leftType (Type.dealias args real)
219 (_, _) ->
220 difference
221 (docType localizer leftType)
222 (docType localizer rightType)
225difference :: Doc -> Doc -> Diff Doc
226difference leftDoc rightDoc =
227 Diff (dullyellow leftDoc) (dullyellow rightDoc)
231-- RECORD DIFFS
234diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
235diffRecord localizer leftFields leftExt rightFields rightExt =
236 let
237 (leftOnly, both, rightOnly) =
238 vennDiagram leftFields rightFields
239 in
240 if Map.null leftOnly && Map.null rightOnly then
241 let
242 fieldDiffs =
243 Map.map (uncurry (diff localizer)) both
244 in
245 case partitionDiffs fieldDiffs of
246 ([], sames) ->
247 let
248 mkRecord =
249 docRecord Full (map (first text) sames)
250 in
251 if leftExt == rightExt then
252 Same (mkRecord (fmap text leftExt))
254 else
255 Diff
256 (mkRecord (fmap (dullyellow . text) leftExt))
257 (mkRecord (fmap (dullyellow . text) rightExt))
259 (diffs, sames) ->
260 let
261 (lefts, rights) = unzipDiffs diffs
262 style = if null sames then Full else Elide
263 in
264 Diff
265 (docRecord style lefts (fmap text leftExt))
266 (docRecord style rights (fmap text rightExt))
268 else
269 let
270 (lefts, rights) =
271 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
273 style =
274 if Map.null both then Full else Elide
275 in
276 Diff
277 (docRecord style lefts (fmap text leftExt))
278 (docRecord style rights (fmap text rightExt))
281unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
282unzipDiffs diffPairs =
283 let
284 unzipHelp (name, (left, right)) =
285 (,) (text name, left) (text name, right)
286 in
287 unzip (map unzipHelp diffPairs)
291-- ANALYZE FIELD NAMES FOR SIMILAR NAMES
294analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
295analyzeFields leftOnly rightOnly =
296 let
297 potentialTypos =
298 findPotentialTypos leftOnly rightOnly
300 mkField func name =
301 ( func (text name), text "…" )
303 mkFieldWith counts name =
304 mkField (if Set.member name counts then dullyellow else id) name
305 in
306 case vetTypos potentialTypos of
307 Just (leftTypos, rightTypos) ->
308 ( map (mkFieldWith leftTypos) leftOnly
309 , map (mkFieldWith rightTypos) rightOnly
310 )
312 Nothing ->
313 ( map (mkField dullyellow) leftOnly
314 , map (mkField dullyellow) rightOnly
315 )
318findPotentialTypos :: [String] -> [String] -> [(String, String)]
319findPotentialTypos leftOnly rightOnly =
320 let
321 veryNear leftName =
322 map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)
323 in
324 concatMap veryNear leftOnly
327vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
328vetTypos potentialTypos =
329 let
330 tallyNames (ln, rn) (lc, rc) =
331 ( Map.insertWith (+) ln 1 lc
332 , Map.insertWith (+) rn 1 rc
333 )
335 (leftCounts, rightCounts) =
336 foldr tallyNames (Map.empty, Map.empty) potentialTypos
338 allUnique counts =
339 Map.foldr (\n unique -> n < 2 && unique) True counts
340 in
341 if allUnique leftCounts && allUnique rightCounts then
342 Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
344 else
345 Nothing
348-- RECORD DIFFS HELPERS
351type Fields =
352 Map.Map String Type.Canonical
355type DoubleFields =
356 Map.Map String (Type.Canonical,Type.Canonical)
359vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
360vennDiagram leftFields rightFields =
361 ( Map.difference leftFields rightFields
362 , Map.intersectionWith (,) leftFields rightFields
363 , Map.difference rightFields leftFields
364 )
367flattenRecord
368 :: [(String, Type.Canonical)]
369 -> Maybe Type.Canonical
370 -> (Fields, Maybe String)
371flattenRecord fields ext =
372 first Map.fromList (flattenRecordHelp fields ext)
375flattenRecordHelp
376 :: [(String, Type.Canonical)]
377 -> Maybe Type.Canonical
378 -> ([(String, Type.Canonical)], Maybe String)
379flattenRecordHelp fields ext =
380 case ext of
381 Nothing ->
382 (fields, Nothing)
384 Just (Type.Var x) ->
385 (fields, Just x)
387 Just (Type.Record subFields subExt) ->
388 flattenRecordHelp (fields ++ subFields) subExt
390 Just (Type.Aliased _ args tipe) ->
391 flattenRecordHelp fields (Just (Type.dealias args tipe))
393 _ ->
394 error "Trying to flatten ill-formed record."
398-- TYPES TO DOCS
401docType :: Localizer -> Type.Canonical -> Doc
402docType localizer tipe =
403 case tipe of
404 Type.Lambda _ _ ->
405 docLambda (map (docType localizer) (Type.collectLambdas tipe))
407 Type.Var x ->
408 text x
410 Type.Type name ->
411 varToDoc localizer name
413 Type.App (Type.Type name) args ->
414 docApp localizer name (map (docType localizer) args)
416 Type.App _ _ ->
417 error "type applications should start with a type atom"
419 Type.Record outerFields outerExt ->
420 let
421 (fields, ext) =
422 flattenRecordHelp outerFields outerExt
423 in
424 docRecord Full
425 (map (text *** docType localizer) fields)
426 (fmap text ext)
428 Type.Aliased name args _ ->
429 docApp localizer name (map (docType localizer . snd) args)
433docLambda :: [Doc] -> Doc
434docLambda docs =
435 case docs of
436 [] ->
437 error "cannot call docLambda with an empty list"
439 arg:rest ->
440 sep (arg : map (text "->" <+>) rest)
444docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc
445docApp localizer name args =
446 if Var.isTuple name then
447 sep
448 [ cat (zipWith (<+>) (lparen : repeat comma) args)
449 , rparen
450 ]
452 else if null args then
453 varToDoc localizer name
455 else
456 hang 4 (sep (varToDoc localizer name : args))
460data Style
461 = Elide
462 | Full
465docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
466docRecord style fields maybeExt =
467 let
468 docField (name, tipe) =
469 hang 4 (sep [ name <+> colon, tipe ])
471 elision =
472 case style of
473 Full ->
474 []
476 Elide ->
477 [ text "…" ]
479 fieldDocs =
480 elision ++ map docField fields
481 in
482 case (fieldDocs, maybeExt) of
483 ([], Nothing) ->
484 text "{}"
486 (_, Nothing) ->
487 sep
488 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
489 , rbrace
490 ]
492 (_, Just ext) ->
493 sep
494 [ hang 4 $ sep $
495 [ lbrace <+> ext
496 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
497 ]
498 , rbrace
499 ]