git.iko.soy/elk
on 17618de help sign in
elk/src/Reporting/Render/Type.hs
504 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 =
91 Var.toString var
92 in
93 if name == "_Tuple0" then
94 text "()"
96 else
97 text (maybe name id (Map.lookup name localizer))
101-- DIFF BUILDER
104data Diff a
105 = Diff a a
106 | Same a
109instance Functor Diff where
110 fmap func d =
111 case d of
112 Diff left right ->
113 Diff (func left) (func right)
115 Same both ->
116 Same (func both)
119instance Applicative Diff where
120 pure a =
121 Same a
123 (<*>) func arg =
124 case (func, arg) of
125 (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
126 Diff (leftFunc leftArg) (rightFunc rightArg)
128 (Diff leftFunc rightFunc, Same arg) ->
129 Diff (leftFunc arg) (rightFunc arg)
131 (Same func, Diff leftArg rightArg) ->
132 Diff (func leftArg) (func rightArg)
134 (Same func, Same arg) ->
135 Same (func arg)
138partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
139partitionDiffs dict =
140 let
141 collect key value (diffKeys, sameKeys) =
142 case value of
143 Diff left right ->
144 ( (key, (left, right)) : diffKeys
145 , sameKeys
146 )
148 Same both ->
149 ( diffKeys
150 , (key, both) : sameKeys
151 )
152 in
153 Map.foldrWithKey collect ([],[]) dict
157-- DOC DIFF
160data Context
161 = None
162 | Func
163 | App
166diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
167diff localizer context leftType rightType =
168 let
169 go = diff localizer
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
178 if length leftParts /= length rightParts then
179 difference
180 (docLambda context (map (docType localizer Func) leftParts))
181 (docLambda context (map (docType localizer Func) rightParts))
183 else
184 docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)
186 (Type.Var x, Type.Var y) | x == y ->
187 pure (text x)
189 (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
190 pure (varToDoc localizer leftName)
192 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
193 if leftName /= rightName || length leftArgs /= length rightArgs then
194 difference
195 (docApp localizer context leftName leftArgs)
196 (docApp localizer context rightName rightArgs)
198 else
199 let
200 subContext =
201 if Var.isTuple leftName then None else App
202 in
203 docAppHelp localizer context leftName
204 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)
206 (Type.App _ _, Type.App _ _) ->
207 error "Type applications without concrete names should not get here."
209 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
210 let
211 (leftFields, leftExt) =
212 flattenRecord outerLeftFields outerLeftExt
214 (rightFields, rightExt) =
215 flattenRecord outerRightFields outerRightExt
216 in
217 diffRecord localizer leftFields leftExt rightFields rightExt
219 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
220 docAppHelp localizer context leftName
221 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
223 (Type.Aliased _ args real, _) ->
224 go context (Type.dealias args real) rightType
226 (_, Type.Aliased _ args real) ->
227 go context leftType (Type.dealias args real)
229 (_, _) ->
230 difference
231 (docType localizer context leftType)
232 (docType localizer context rightType)
235difference :: Doc -> Doc -> Diff Doc
236difference leftDoc rightDoc =
237 Diff (dullyellow leftDoc) (dullyellow rightDoc)
241-- RECORD DIFFS
244diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
245diffRecord 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 None)) 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-- RECORD DIFFS HELPERS
304analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
305analyzeFields leftOnly rightOnly =
306 let
307 potentialTypos =
308 Help.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 Help.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 )
328type Fields =
329 Map.Map String Type.Canonical
332type DoubleFields =
333 Map.Map String (Type.Canonical,Type.Canonical)
336vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
337vennDiagram leftFields rightFields =
338 ( Map.difference leftFields rightFields
339 , Map.intersectionWith (,) leftFields rightFields
340 , Map.difference rightFields leftFields
341 )
344flattenRecord
345 :: [(String, Type.Canonical)]
346 -> Maybe Type.Canonical
347 -> (Fields, Maybe String)
348flattenRecord fields ext =
349 first Map.fromList (flattenRecordHelp fields ext)
352flattenRecordHelp
353 :: [(String, Type.Canonical)]
354 -> Maybe Type.Canonical
355 -> ([(String, Type.Canonical)], Maybe String)
356flattenRecordHelp fields ext =
357 case ext of
358 Nothing ->
359 (fields, Nothing)
361 Just (Type.Var x) ->
362 (fields, Just x)
364 Just (Type.Record subFields subExt) ->
365 flattenRecordHelp (fields ++ subFields) subExt
367 Just (Type.Aliased _ args tipe) ->
368 flattenRecordHelp fields (Just (Type.dealias args tipe))
370 _ ->
371 error "Trying to flatten ill-formed record."
375-- TYPES TO DOCS
378docType :: Localizer -> Context -> Type.Canonical -> Doc
379docType localizer context tipe =
380 case tipe of
381 Type.Lambda _ _ ->
382 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
384 Type.Var x ->
385 text x
387 Type.Type name ->
388 varToDoc localizer name
390 Type.App (Type.Type name) args ->
391 docApp localizer context name args
393 Type.App _ _ ->
394 error "type applications should start with a type atom"
396 Type.Record outerFields outerExt ->
397 let
398 (fields, ext) =
399 flattenRecordHelp outerFields outerExt
400 in
401 docRecord Full
402 (map (text *** docType localizer None) fields)
403 (fmap text ext)
405 Type.Aliased name args _ ->
406 docApp localizer context name (map snd args)
410docLambda :: Context -> [Doc] -> Doc
411docLambda context docs =
412 case docs of
413 [] ->
414 error "cannot call docLambda with an empty list"
416 arg:rest ->
417 case context of
418 None ->
419 sep (arg : map (text "->" <+>) rest)
421 _ ->
422 cat
423 [ lparen
424 , sep (arg : map (text "->" <+>) rest)
425 , rparen
426 ]
430docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
431docApp localizer context name args =
432 let
433 argContext =
434 if Var.isTuple name then None else App
435 in
436 docAppHelp localizer context name (map (docType localizer argContext) args)
439docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
440docAppHelp localizer context name args =
441 if Var.isTuple name then
442 sep
443 [ cat (zipWith (<+>) (lparen : repeat comma) args)
444 , rparen
445 ]
447 else if null args then
448 varToDoc localizer name
450 else
451 case context of
452 App ->
453 cat
454 [ lparen
455 , hang 4 (sep (varToDoc localizer name : args))
456 , rparen
457 ]
459 _ ->
460 hang 4 (sep (varToDoc localizer name : args))
464data Style
465 = Elide
466 | Full
469docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
470docRecord style fields maybeExt =
471 let
472 docField (name, tipe) =
473 hang 4 (sep [ name <+> colon, tipe ])
475 elision =
476 case style of
477 Full ->
478 []
480 Elide ->
481 [ text "..." ]
483 fieldDocs =
484 elision ++ map docField fields
485 in
486 case (fieldDocs, maybeExt) of
487 ([], Nothing) ->
488 text "{}"
490 (_, Nothing) ->
491 sep
492 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
493 , rbrace
494 ]
496 (_, Just ext) ->
497 sep
498 [ hang 4 $ sep $
499 [ lbrace <+> ext
500 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
501 ]
502 , rbrace
503 ]