git.iko.soy/elk
on 267f708 help sign in
elk/src/Reporting/Render/Type.hs
527 lines 13 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.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
173 docAppHelp localizer context leftName
174 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
176 (Type.Aliased _ args real, _) ->
177 go context (Type.dealias args real) rightType
179 (_, Type.Aliased _ args real) ->
180 go context leftType (Type.dealias args real)
182 (Type.Lambda _ _, _) ->
183 diffLambda localizer context leftType rightType
185 (_, Type.Lambda _ _) ->
186 diffLambda localizer context leftType rightType
188 (Type.Var x, Type.Var y) | x == y ->
189 pure (text x)
191 (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
192 pure (varToDoc localizer leftName)
194 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
195 if leftName /= rightName || length leftArgs /= length rightArgs then
196 difference
197 (docApp localizer context leftName leftArgs)
198 (docApp localizer context rightName rightArgs)
200 else
201 let
202 subContext =
203 if Var.isTuple leftName then None else App
204 in
205 docAppHelp localizer context leftName
206 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)
208 (Type.App _ _, Type.App _ _) ->
209 error "Type applications without concrete names should not get here."
211 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
212 let
213 (leftFields, leftExt) =
214 flattenRecord outerLeftFields outerLeftExt
216 (rightFields, rightExt) =
217 flattenRecord outerRightFields outerRightExt
218 in
219 diffRecord localizer leftFields leftExt rightFields rightExt
221 (_, _) ->
222 difference
223 (docType localizer context leftType)
224 (docType localizer context rightType)
227difference :: Doc -> Doc -> Diff Doc
228difference leftDoc rightDoc =
229 Diff (dullyellow leftDoc) (dullyellow rightDoc)
233-- FUNCTION DIFFS
236diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
237diffLambda localizer context leftType rightType =
238 let
239 leftArgs = reverse $ Type.collectLambdas leftType
240 rightArgs = reverse $ Type.collectLambdas rightType
242 extraToDoc types =
243 map (dullyellow . docType localizer Func) types
245 extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs
246 extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs
248 alignedArgDiff =
249 reverse <$> sequenceA (zipWith (diff localizer Func) leftArgs rightArgs)
250 in
251 docLambda context <$>
252 case (extraLefts, extraRights, alignedArgDiff) of
253 ([], [], _) ->
254 alignedArgDiff
256 (_, _, Same docs) ->
257 Diff (extraLefts ++ docs) (extraRights ++ docs)
259 (_, _, Diff lefts rights) ->
260 Diff (extraLefts ++ lefts) (extraRights ++ rights)
264-- RECORD DIFFS
267diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
268diffRecord localizer leftFields leftExt rightFields rightExt =
269 let
270 (leftOnly, both, rightOnly) =
271 vennDiagram leftFields rightFields
272 in
273 if Map.null leftOnly && Map.null rightOnly then
274 let
275 fieldDiffs =
276 Map.map (uncurry (diff localizer None)) both
277 in
278 case partitionDiffs fieldDiffs of
279 ([], sames) ->
280 let
281 mkRecord =
282 docRecord Full (map (first text) sames)
283 in
284 if leftExt == rightExt then
285 Same (mkRecord (fmap text leftExt))
287 else
288 Diff
289 (mkRecord (fmap (dullyellow . text) leftExt))
290 (mkRecord (fmap (dullyellow . text) rightExt))
292 (diffs, sames) ->
293 let
294 (lefts, rights) = unzipDiffs diffs
295 style = if null sames then Full else Elide
296 in
297 Diff
298 (docRecord style lefts (fmap text leftExt))
299 (docRecord style rights (fmap text rightExt))
301 else
302 let
303 (lefts, rights) =
304 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
306 style =
307 if Map.null both then Full else Elide
308 in
309 Diff
310 (docRecord style lefts (fmap text leftExt))
311 (docRecord style rights (fmap text rightExt))
314unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
315unzipDiffs diffPairs =
316 let
317 unzipHelp (name, (left, right)) =
318 (,) (text name, left) (text name, right)
319 in
320 unzip (map unzipHelp diffPairs)
324-- RECORD DIFFS HELPERS
327analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
328analyzeFields leftOnly rightOnly =
329 let
330 potentialTypos =
331 Help.findPotentialTypos leftOnly rightOnly
333 mkField func name =
334 ( func (text name), text "..." )
336 mkFieldWith counts name =
337 mkField (if Set.member name counts then dullyellow else id) name
338 in
339 case Help.vetTypos potentialTypos of
340 Just (leftTypos, rightTypos) ->
341 ( map (mkFieldWith leftTypos) leftOnly
342 , map (mkFieldWith rightTypos) rightOnly
343 )
345 Nothing ->
346 ( map (mkField dullyellow) leftOnly
347 , map (mkField dullyellow) rightOnly
348 )
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 -> Context -> Type.Canonical -> Doc
402docType localizer context tipe =
403 case tipe of
404 Type.Lambda _ _ ->
405 docLambda context (map (docType localizer Func) (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 context name 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 None) fields)
426 (fmap text ext)
428 Type.Aliased name args _ ->
429 docApp localizer context name (map snd args)
433docLambda :: Context -> [Doc] -> Doc
434docLambda context docs =
435 case docs of
436 [] ->
437 error "cannot call docLambda with an empty list"
439 arg:rest ->
440 case context of
441 None ->
442 sep (arg : map (text "->" <+>) rest)
444 _ ->
445 cat
446 [ lparen
447 , sep (arg : map (text "->" <+>) rest)
448 , rparen
449 ]
453docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
454docApp localizer context name args =
455 let
456 argContext =
457 if Var.isTuple name then None else App
458 in
459 docAppHelp localizer context name (map (docType localizer argContext) args)
462docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
463docAppHelp localizer context name args =
464 if Var.isTuple name then
465 sep
466 [ cat (zipWith (<+>) (lparen : repeat comma) args)
467 , rparen
468 ]
470 else if null args then
471 varToDoc localizer name
473 else
474 case context of
475 App ->
476 cat
477 [ lparen
478 , hang 4 (sep (varToDoc localizer name : args))
479 , rparen
480 ]
482 _ ->
483 hang 4 (sep (varToDoc localizer name : args))
487data Style
488 = Elide
489 | Full
492docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
493docRecord style fields maybeExt =
494 let
495 docField (name, tipe) =
496 hang 4 (sep [ name <+> colon, tipe ])
498 elision =
499 case style of
500 Full ->
501 []
503 Elide ->
504 [ text "..." ]
506 fieldDocs =
507 elision ++ map docField fields
508 in
509 case (fieldDocs, maybeExt) of
510 ([], Nothing) ->
511 text "{}"
513 (_, Nothing) ->
514 sep
515 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
516 , rbrace
517 ]
519 (_, Just ext) ->
520 sep
521 [ hang 4 $ sep $
522 [ lbrace <+> ext
523 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
524 ]
525 , rbrace
526 ]