git.iko.soy/elk
on c2b65bc help sign in
elk/src/Reporting/Render/Type.hs
490 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 (map (docType localizer App) leftArgs))
195 (docApp localizer context rightName (map (docType localizer App) rightArgs))
197 else
198 docApp localizer context leftName
199 <$> sequenceA (zipWith (go App) 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 diffRecord localizer leftFields leftExt rightFields rightExt
214 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
215 docApp localizer context leftName
216 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
218 (Type.Aliased _ args real, _) ->
219 go context (Type.dealias args real) rightType
221 (_, Type.Aliased _ args real) ->
222 go context leftType (Type.dealias args real)
224 (_, _) ->
225 difference
226 (docType localizer context leftType)
227 (docType localizer context rightType)
230difference :: Doc -> Doc -> Diff Doc
231difference leftDoc rightDoc =
232 Diff (dullyellow leftDoc) (dullyellow rightDoc)
236-- RECORD DIFFS
239diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
240diffRecord localizer leftFields leftExt rightFields rightExt =
241 let
242 (leftOnly, both, rightOnly) =
243 vennDiagram leftFields rightFields
244 in
245 if Map.null leftOnly && Map.null rightOnly then
246 let
247 fieldDiffs =
248 Map.map (uncurry (diff localizer None)) both
249 in
250 case partitionDiffs fieldDiffs of
251 ([], sames) ->
252 let
253 mkRecord =
254 docRecord Full (map (first text) sames)
255 in
256 if leftExt == rightExt then
257 Same (mkRecord (fmap text leftExt))
259 else
260 Diff
261 (mkRecord (fmap (dullyellow . text) leftExt))
262 (mkRecord (fmap (dullyellow . text) rightExt))
264 (diffs, sames) ->
265 let
266 (lefts, rights) = unzipDiffs diffs
267 style = if null sames then Full else Elide
268 in
269 Diff
270 (docRecord style lefts (fmap text leftExt))
271 (docRecord style rights (fmap text rightExt))
273 else
274 let
275 (lefts, rights) =
276 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
278 style =
279 if Map.null both then Full else Elide
280 in
281 Diff
282 (docRecord style lefts (fmap text leftExt))
283 (docRecord style rights (fmap text rightExt))
286unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
287unzipDiffs diffPairs =
288 let
289 unzipHelp (name, (left, right)) =
290 (,) (text name, left) (text name, right)
291 in
292 unzip (map unzipHelp diffPairs)
296-- RECORD DIFFS HELPERS
299analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
300analyzeFields leftOnly rightOnly =
301 let
302 potentialTypos =
303 Help.findPotentialTypos leftOnly rightOnly
305 mkField func name =
306 ( func (text name), text "…" )
308 mkFieldWith counts name =
309 mkField (if Set.member name counts then dullyellow else id) name
310 in
311 case Help.vetTypos potentialTypos of
312 Just (leftTypos, rightTypos) ->
313 ( map (mkFieldWith leftTypos) leftOnly
314 , map (mkFieldWith rightTypos) rightOnly
315 )
317 Nothing ->
318 ( map (mkField dullyellow) leftOnly
319 , map (mkField dullyellow) rightOnly
320 )
323type Fields =
324 Map.Map String Type.Canonical
327type DoubleFields =
328 Map.Map String (Type.Canonical,Type.Canonical)
331vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
332vennDiagram leftFields rightFields =
333 ( Map.difference leftFields rightFields
334 , Map.intersectionWith (,) leftFields rightFields
335 , Map.difference rightFields leftFields
336 )
339flattenRecord
340 :: [(String, Type.Canonical)]
341 -> Maybe Type.Canonical
342 -> (Fields, Maybe String)
343flattenRecord fields ext =
344 first Map.fromList (flattenRecordHelp fields ext)
347flattenRecordHelp
348 :: [(String, Type.Canonical)]
349 -> Maybe Type.Canonical
350 -> ([(String, Type.Canonical)], Maybe String)
351flattenRecordHelp fields ext =
352 case ext of
353 Nothing ->
354 (fields, Nothing)
356 Just (Type.Var x) ->
357 (fields, Just x)
359 Just (Type.Record subFields subExt) ->
360 flattenRecordHelp (fields ++ subFields) subExt
362 Just (Type.Aliased _ args tipe) ->
363 flattenRecordHelp fields (Just (Type.dealias args tipe))
365 _ ->
366 error "Trying to flatten ill-formed record."
370-- TYPES TO DOCS
373docType :: Localizer -> Context -> Type.Canonical -> Doc
374docType localizer context tipe =
375 case tipe of
376 Type.Lambda _ _ ->
377 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
379 Type.Var x ->
380 text x
382 Type.Type name ->
383 varToDoc localizer name
385 Type.App (Type.Type name) args ->
386 docApp localizer context name (map (docType localizer App) args)
388 Type.App _ _ ->
389 error "type applications should start with a type atom"
391 Type.Record outerFields outerExt ->
392 let
393 (fields, ext) =
394 flattenRecordHelp outerFields outerExt
395 in
396 docRecord Full
397 (map (text *** docType localizer None) fields)
398 (fmap text ext)
400 Type.Aliased name args _ ->
401 docApp localizer context name (map (docType localizer App . snd) args)
405docLambda :: Context -> [Doc] -> Doc
406docLambda context docs =
407 case docs of
408 [] ->
409 error "cannot call docLambda with an empty list"
411 arg:rest ->
412 case context of
413 None ->
414 sep (arg : map (text "->" <+>) rest)
416 _ ->
417 cat
418 [ lparen
419 , sep (arg : map (text "->" <+>) rest)
420 , rparen
421 ]
425docApp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
426docApp localizer context name args =
427 if Var.isTuple name then
428 sep
429 [ cat (zipWith (<+>) (lparen : repeat comma) args)
430 , rparen
431 ]
433 else if null args then
434 varToDoc localizer name
436 else
437 case context of
438 App ->
439 cat
440 [ lparen
441 , hang 4 (sep (varToDoc localizer name : args))
442 , rparen
443 ]
445 _ ->
446 hang 4 (sep (varToDoc localizer name : args))
450data Style
451 = Elide
452 | Full
455docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
456docRecord style fields maybeExt =
457 let
458 docField (name, tipe) =
459 hang 4 (sep [ name <+> colon, tipe ])
461 elision =
462 case style of
463 Full ->
464 []
466 Elide ->
467 [ text "…" ]
469 fieldDocs =
470 elision ++ map docField fields
471 in
472 case (fieldDocs, maybeExt) of
473 ([], Nothing) ->
474 text "{}"
476 (_, Nothing) ->
477 sep
478 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
479 , rbrace
480 ]
482 (_, Just ext) ->
483 sep
484 [ hang 4 $ sep $
485 [ lbrace <+> ext
486 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
487 ]
488 , rbrace
489 ]