git.iko.soy/elk
on efb86bc help sign in
elk/src/Reporting/Render/Type.hs
503 lines 12 kB history raw
1module Reporting.Render.Type
2 ( Localizer
3 , decl
4 , annotation
5 , toDoc
6 , diffToDocs
7 , Style(..)
8 )
9 where
11import Control.Arrow ((***), first)
12import qualified Data.Map as Map
13import qualified Data.Set as Set
14import Text.PrettyPrint.ANSI.Leijen
15 ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep
16 , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat
17 )
19import qualified AST.Helpers as Help
20import qualified AST.Type as Type
21import qualified AST.Variable as Var
22import qualified Reporting.Error.Helpers as Help
26-- PUBLIC API FOR CREATING DOCS
29toDoc :: Localizer -> Type.Canonical -> Doc
30toDoc localizer tipe =
31 docType localizer None tipe
34diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
35diffToDocs localizer leftType rightType =
36 case diff localizer None leftType rightType of
37 Same doc ->
38 (doc, doc)
40 Diff leftDoc rightDoc ->
41 (leftDoc, rightDoc)
44decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc
45decl localizer name vars tags =
46 let
47 docTag (tag, args) =
48 hang 2 (sep (text tag : map (docType localizer App) args))
49 in
50 hang 4 $ vcat $
51 (hsep (map text ("type" : name : vars)))
52 :
53 zipWith (<+>)
54 (equals : repeat (text "|"))
55 (map docTag tags)
58annotation :: Localizer -> String -> Type.Canonical -> Doc
59annotation localizer name tipe =
60 let
61 docName =
62 if Help.isOp name then parens (text name) else text name
63 in
64 case Type.collectLambdas tipe of
65 parts@(_ : _ : _) ->
66 hang 4 $ sep $
67 docName
68 : zipWith (<+>)
69 (colon : repeat (text "->"))
70 (map (docType localizer Func) parts)
72 _ ->
73 hang 4 $ sep $
74 [ docName <+> colon
75 , docType localizer None tipe
76 ]
80-- LOCALIZE TYPES
83type Localizer =
84 Map.Map String String
87varToDoc :: Localizer -> Var.Canonical -> Doc
88varToDoc localizer var =
89 let
90 name = Var.toString var
91 in
92 if name == "_Tuple0" then
93 text "()"
95 else
96 text (maybe name id (Map.lookup name localizer))
100-- DIFF BUILDER
103data Diff a
104 = Diff a a
105 | Same a
108instance Functor Diff where
109 fmap func d =
110 case d of
111 Diff left right ->
112 Diff (func left) (func right)
114 Same both ->
115 Same (func both)
118instance Applicative Diff where
119 pure a =
120 Same a
122 (<*>) func arg =
123 case (func, arg) of
124 (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
125 Diff (leftFunc leftArg) (rightFunc rightArg)
127 (Diff leftFunc rightFunc, Same arg) ->
128 Diff (leftFunc arg) (rightFunc arg)
130 (Same func, Diff leftArg rightArg) ->
131 Diff (func leftArg) (func rightArg)
133 (Same func, Same arg) ->
134 Same (func arg)
137partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
138partitionDiffs dict =
139 let
140 collect key value (diffKeys, sameKeys) =
141 case value of
142 Diff left right ->
143 ( (key, (left, right)) : diffKeys
144 , sameKeys
145 )
147 Same both ->
148 ( diffKeys
149 , (key, both) : sameKeys
150 )
151 in
152 Map.foldrWithKey collect ([],[]) dict
156-- DOC DIFF
159data Context
160 = None
161 | Func
162 | App
165diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
166diff localizer context leftType rightType =
167 let
168 go = diff localizer
169 in
170 case (leftType, rightType) of
171 (Type.Lambda _ _, Type.Lambda _ _) ->
172 let
173 leftParts = Type.collectLambdas leftType
174 rightParts = Type.collectLambdas rightType
175 in
177 if length leftParts /= length rightParts then
178 difference
179 (docLambda context (map (docType localizer Func) leftParts))
180 (docLambda context (map (docType localizer Func) rightParts))
182 else
183 docLambda context <$> sequenceA (zipWith (go Func) 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 context leftName leftArgs)
195 (docApp localizer context rightName rightArgs)
197 else
198 let
199 subContext =
200 if Var.isTuple leftName then None else App
201 in
202 docAppHelp localizer context leftName
203 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)
205 (Type.App _ _, Type.App _ _) ->
206 error "Type applications without concrete names should not get here."
208 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
209 let
210 (leftFields, leftExt) =
211 flattenRecord outerLeftFields outerLeftExt
213 (rightFields, rightExt) =
214 flattenRecord outerRightFields outerRightExt
215 in
216 diffRecord localizer leftFields leftExt rightFields rightExt
218 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
219 docAppHelp localizer context leftName
220 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
222 (Type.Aliased _ args real, _) ->
223 go context (Type.dealias args real) rightType
225 (_, Type.Aliased _ args real) ->
226 go context leftType (Type.dealias args real)
228 (_, _) ->
229 difference
230 (docType localizer context leftType)
231 (docType localizer context rightType)
234difference :: Doc -> Doc -> Diff Doc
235difference leftDoc rightDoc =
236 Diff (dullyellow leftDoc) (dullyellow rightDoc)
240-- RECORD DIFFS
243diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
244diffRecord localizer leftFields leftExt rightFields rightExt =
245 let
246 (leftOnly, both, rightOnly) =
247 vennDiagram leftFields rightFields
248 in
249 if Map.null leftOnly && Map.null rightOnly then
250 let
251 fieldDiffs =
252 Map.map (uncurry (diff localizer None)) both
253 in
254 case partitionDiffs fieldDiffs of
255 ([], sames) ->
256 let
257 mkRecord =
258 docRecord Full (map (first text) sames)
259 in
260 if leftExt == rightExt then
261 Same (mkRecord (fmap text leftExt))
263 else
264 Diff
265 (mkRecord (fmap (dullyellow . text) leftExt))
266 (mkRecord (fmap (dullyellow . text) rightExt))
268 (diffs, sames) ->
269 let
270 (lefts, rights) = unzipDiffs diffs
271 style = if null sames then Full else Elide
272 in
273 Diff
274 (docRecord style lefts (fmap text leftExt))
275 (docRecord style rights (fmap text rightExt))
277 else
278 let
279 (lefts, rights) =
280 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
282 style =
283 if Map.null both then Full else Elide
284 in
285 Diff
286 (docRecord style lefts (fmap text leftExt))
287 (docRecord style rights (fmap text rightExt))
290unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
291unzipDiffs diffPairs =
292 let
293 unzipHelp (name, (left, right)) =
294 (,) (text name, left) (text name, right)
295 in
296 unzip (map unzipHelp diffPairs)
300-- RECORD DIFFS HELPERS
303analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
304analyzeFields leftOnly rightOnly =
305 let
306 potentialTypos =
307 Help.findPotentialTypos leftOnly rightOnly
309 mkField func name =
310 ( func (text name), text "..." )
312 mkFieldWith counts name =
313 mkField (if Set.member name counts then dullyellow else id) name
314 in
315 case Help.vetTypos potentialTypos of
316 Just (leftTypos, rightTypos) ->
317 ( map (mkFieldWith leftTypos) leftOnly
318 , map (mkFieldWith rightTypos) rightOnly
319 )
321 Nothing ->
322 ( map (mkField dullyellow) leftOnly
323 , map (mkField dullyellow) rightOnly
324 )
327type Fields =
328 Map.Map String Type.Canonical
331type DoubleFields =
332 Map.Map String (Type.Canonical,Type.Canonical)
335vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
336vennDiagram leftFields rightFields =
337 ( Map.difference leftFields rightFields
338 , Map.intersectionWith (,) leftFields rightFields
339 , Map.difference rightFields leftFields
340 )
343flattenRecord
344 :: [(String, Type.Canonical)]
345 -> Maybe Type.Canonical
346 -> (Fields, Maybe String)
347flattenRecord fields ext =
348 first Map.fromList (flattenRecordHelp fields ext)
351flattenRecordHelp
352 :: [(String, Type.Canonical)]
353 -> Maybe Type.Canonical
354 -> ([(String, Type.Canonical)], Maybe String)
355flattenRecordHelp fields ext =
356 case ext of
357 Nothing ->
358 (fields, Nothing)
360 Just (Type.Var x) ->
361 (fields, Just x)
363 Just (Type.Record subFields subExt) ->
364 flattenRecordHelp (fields ++ subFields) subExt
366 Just (Type.Aliased _ args tipe) ->
367 flattenRecordHelp fields (Just (Type.dealias args tipe))
369 _ ->
370 error "Trying to flatten ill-formed record."
374-- TYPES TO DOCS
377docType :: Localizer -> Context -> Type.Canonical -> Doc
378docType localizer context tipe =
379 case tipe of
380 Type.Lambda _ _ ->
381 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
383 Type.Var x ->
384 text x
386 Type.Type name ->
387 varToDoc localizer name
389 Type.App (Type.Type name) args ->
390 docApp localizer context name args
392 Type.App _ _ ->
393 error "type applications should start with a type atom"
395 Type.Record outerFields outerExt ->
396 let
397 (fields, ext) =
398 flattenRecordHelp outerFields outerExt
399 in
400 docRecord Full
401 (map (text *** docType localizer None) fields)
402 (fmap text ext)
404 Type.Aliased name args _ ->
405 docApp localizer context name (map snd args)
409docLambda :: Context -> [Doc] -> Doc
410docLambda context docs =
411 case docs of
412 [] ->
413 error "cannot call docLambda with an empty list"
415 arg:rest ->
416 case context of
417 None ->
418 sep (arg : map (text "->" <+>) rest)
420 _ ->
421 cat
422 [ lparen
423 , sep (arg : map (text "->" <+>) rest)
424 , rparen
425 ]
429docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
430docApp localizer context name args =
431 let
432 argContext =
433 if Var.isTuple name then None else App
434 in
435 docAppHelp localizer context name (map (docType localizer argContext) args)
438docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
439docAppHelp localizer context name args =
440 if Var.isTuple name then
441 sep
442 [ cat (zipWith (<+>) (lparen : repeat comma) args)
443 , rparen
444 ]
446 else if null args then
447 varToDoc localizer name
449 else
450 case context of
451 App ->
452 cat
453 [ lparen
454 , hang 4 (sep (varToDoc localizer name : args))
455 , rparen
456 ]
458 _ ->
459 hang 4 (sep (varToDoc localizer name : args))
463data Style
464 = Elide
465 | Full
468docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
469docRecord style fields maybeExt =
470 let
471 docField (name, tipe) =
472 hang 4 (sep [ name <+> colon, tipe ])
474 elision =
475 case style of
476 Full ->
477 []
479 Elide ->
480 [ text "..." ]
482 fieldDocs =
483 elision ++ map docField fields
484 in
485 case (fieldDocs, maybeExt) of
486 ([], Nothing) ->
487 text "{}"
489 (_, Nothing) ->
490 sep
491 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
492 , rbrace
493 ]
495 (_, Just ext) ->
496 sep
497 [ hang 4 $ sep $
498 [ lbrace <+> ext
499 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
500 ]
501 , rbrace
502 ]