git.iko.soy/elk
on fcf5cef help sign in
elk/src/Reporting/Render/Type.hs
521 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.Lambda _ _, _) ->
177 diffLambda localizer context leftType rightType
179 (_, Type.Lambda _ _) ->
180 diffLambda localizer context leftType rightType
182 (Type.Var x, Type.Var y) | x == y ->
183 pure (text x)
185 (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
186 pure (varToDoc localizer leftName)
188 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
189 if leftName /= rightName || length leftArgs /= length rightArgs then
190 difference
191 (docApp localizer context leftName leftArgs)
192 (docApp localizer context rightName rightArgs)
194 else
195 let
196 subContext =
197 if Var.isTuple leftName then None else App
198 in
199 docAppHelp localizer context leftName
200 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)
202 (Type.App _ _, Type.App _ _) ->
203 error "Type applications without concrete names should not get here."
205 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
206 let
207 (leftFields, leftExt) =
208 flattenRecord outerLeftFields outerLeftExt
210 (rightFields, rightExt) =
211 flattenRecord outerRightFields outerRightExt
212 in
213 diffRecord localizer leftFields leftExt rightFields rightExt
215 (_, _) ->
216 difference
217 (docType localizer context leftType)
218 (docType localizer context rightType)
221difference :: Doc -> Doc -> Diff Doc
222difference leftDoc rightDoc =
223 Diff (dullyellow leftDoc) (dullyellow rightDoc)
227-- FUNCTION DIFFS
230diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
231diffLambda localizer context leftType rightType =
232 let
233 leftArgs = reverse $ Type.collectLambdas leftType
234 rightArgs = reverse $ Type.collectLambdas rightType
236 extraToDoc types =
237 map (dullyellow . docType localizer Func) types
239 extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs
240 extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs
242 alignedArgDiff =
243 reverse <$> sequenceA (zipWith (diff localizer Func) leftArgs rightArgs)
244 in
245 docLambda context <$>
246 case (extraLefts, extraRights, alignedArgDiff) of
247 ([], [], _) ->
248 alignedArgDiff
250 (_, _, Same docs) ->
251 Diff (extraLefts ++ docs) (extraRights ++ docs)
253 (_, _, Diff lefts rights) ->
254 Diff (extraLefts ++ lefts) (extraRights ++ rights)
258-- RECORD DIFFS
261diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
262diffRecord localizer leftFields leftExt rightFields rightExt =
263 let
264 (leftOnly, both, rightOnly) =
265 vennDiagram leftFields rightFields
266 in
267 if Map.null leftOnly && Map.null rightOnly then
268 let
269 fieldDiffs =
270 Map.map (uncurry (diff localizer None)) both
271 in
272 case partitionDiffs fieldDiffs of
273 ([], sames) ->
274 let
275 mkRecord =
276 docRecord Full (map (first text) sames)
277 in
278 if leftExt == rightExt then
279 Same (mkRecord (fmap text leftExt))
281 else
282 Diff
283 (mkRecord (fmap (dullyellow . text) leftExt))
284 (mkRecord (fmap (dullyellow . text) rightExt))
286 (diffs, sames) ->
287 let
288 (lefts, rights) = unzipDiffs diffs
289 style = if null sames then Full else Elide
290 in
291 Diff
292 (docRecord style lefts (fmap text leftExt))
293 (docRecord style rights (fmap text rightExt))
295 else
296 let
297 (lefts, rights) =
298 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
300 style =
301 if Map.null both then Full else Elide
302 in
303 Diff
304 (docRecord style lefts (fmap text leftExt))
305 (docRecord style rights (fmap text rightExt))
308unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
309unzipDiffs diffPairs =
310 let
311 unzipHelp (name, (left, right)) =
312 (,) (text name, left) (text name, right)
313 in
314 unzip (map unzipHelp diffPairs)
318-- RECORD DIFFS HELPERS
321analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
322analyzeFields leftOnly rightOnly =
323 let
324 typoPairs =
325 Help.findTypoPairs leftOnly rightOnly
327 mkField func name =
328 ( func (text name), text "..." )
330 mkFieldWith counts name =
331 mkField (if Set.member name counts then dullyellow else id) name
332 in
333 case Help.vetTypos typoPairs of
334 Just (leftTypos, rightTypos) ->
335 ( map (mkFieldWith leftTypos) leftOnly
336 , map (mkFieldWith rightTypos) rightOnly
337 )
339 Nothing ->
340 ( map (mkField dullyellow) leftOnly
341 , map (mkField dullyellow) rightOnly
342 )
345type Fields =
346 Map.Map String Type.Canonical
349type DoubleFields =
350 Map.Map String (Type.Canonical,Type.Canonical)
353vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
354vennDiagram leftFields rightFields =
355 ( Map.difference leftFields rightFields
356 , Map.intersectionWith (,) leftFields rightFields
357 , Map.difference rightFields leftFields
358 )
361flattenRecord
362 :: [(String, Type.Canonical)]
363 -> Maybe Type.Canonical
364 -> (Fields, Maybe String)
365flattenRecord fields ext =
366 first Map.fromList (flattenRecordHelp fields ext)
369flattenRecordHelp
370 :: [(String, Type.Canonical)]
371 -> Maybe Type.Canonical
372 -> ([(String, Type.Canonical)], Maybe String)
373flattenRecordHelp fields ext =
374 case ext of
375 Nothing ->
376 (fields, Nothing)
378 Just (Type.Var x) ->
379 (fields, Just x)
381 Just (Type.Record subFields subExt) ->
382 flattenRecordHelp (fields ++ subFields) subExt
384 Just (Type.Aliased _ args tipe) ->
385 flattenRecordHelp fields (Just (Type.dealias args tipe))
387 _ ->
388 error "Trying to flatten ill-formed record."
392-- TYPES TO DOCS
395docType :: Localizer -> Context -> Type.Canonical -> Doc
396docType localizer context tipe =
397 case tipe of
398 Type.Lambda _ _ ->
399 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
401 Type.Var x ->
402 text x
404 Type.Type name ->
405 varToDoc localizer name
407 Type.App (Type.Type name) args ->
408 docApp localizer context name args
410 Type.App _ _ ->
411 error "type applications should start with a type atom"
413 Type.Record outerFields outerExt ->
414 let
415 (fields, ext) =
416 flattenRecordHelp outerFields outerExt
417 in
418 docRecord Full
419 (map (text *** docType localizer None) fields)
420 (fmap text ext)
422 Type.Aliased name args _ ->
423 docApp localizer context name (map snd args)
427docLambda :: Context -> [Doc] -> Doc
428docLambda context docs =
429 case docs of
430 [] ->
431 error "cannot call docLambda with an empty list"
433 arg:rest ->
434 case context of
435 None ->
436 sep (arg : map (text "->" <+>) rest)
438 _ ->
439 cat
440 [ lparen
441 , sep (arg : map (text "->" <+>) rest)
442 , rparen
443 ]
447docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
448docApp localizer context name args =
449 let
450 argContext =
451 if Var.isTuple name then None else App
452 in
453 docAppHelp localizer context name (map (docType localizer argContext) args)
456docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
457docAppHelp localizer context name args =
458 if Var.isTuple name then
459 sep
460 [ cat (zipWith (<+>) (lparen : repeat comma) args)
461 , rparen
462 ]
464 else if null args then
465 varToDoc localizer name
467 else
468 case context of
469 App ->
470 cat
471 [ lparen
472 , hang 4 (sep (varToDoc localizer name : args))
473 , rparen
474 ]
476 _ ->
477 hang 4 (sep (varToDoc localizer name : args))
481data Style
482 = Elide
483 | Full
486docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
487docRecord style fields maybeExt =
488 let
489 docField (name, tipe) =
490 hang 4 (sep [ name <+> colon, tipe ])
492 elision =
493 case style of
494 Full ->
495 []
497 Elide ->
498 [ text "..." ]
500 fieldDocs =
501 elision ++ map docField fields
502 in
503 case (fieldDocs, maybeExt) of
504 ([], Nothing) ->
505 text "{}"
507 (_, Nothing) ->
508 sep
509 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
510 , rbrace
511 ]
513 (_, Just ext) ->
514 sep
515 [ hang 4 $ sep $
516 [ lbrace <+> ext
517 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
518 ]
519 , rbrace
520 ]