git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Reporting/Render/Type.hs
524 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Render.Type
4 ( Localizer
5 , decl
6 , annotation
7 , toDoc
8 , diffToDocs
9 , Style(..)
10 )
11 where
13import Control.Arrow ((***), first)
14import qualified Data.Map as Map
15import qualified Data.Set as Set
16import Data.Text (Text)
18import qualified AST.Helpers as Help
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified Reporting.Helpers as Help
22import Reporting.Helpers
23 ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep
24 , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat
25 )
29-- PUBLIC API FOR CREATING DOCS
32toDoc :: Localizer -> Type.Canonical -> Doc
33toDoc localizer tipe =
34 docType localizer None tipe
37diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
38diffToDocs localizer leftType rightType =
39 case diff localizer None leftType rightType of
40 Same doc ->
41 (doc, doc)
43 Diff leftDoc rightDoc ->
44 (leftDoc, rightDoc)
47decl :: Localizer -> Text -> [Text] -> [(Text, [Type.Canonical])] -> Doc
48decl localizer name vars tags =
49 let
50 docTag (tag, args) =
51 hang 2 (sep (text tag : map (docType localizer App) args))
52 in
53 hang 4 $ vcat $
54 (hsep (text "type" : map text (name : vars)))
55 :
56 zipWith (<+>)
57 (equals : repeat (text "|"))
58 (map docTag tags)
61annotation :: Localizer -> Text -> Type.Canonical -> Doc
62annotation localizer name tipe =
63 let
64 docName =
65 if Help.isOp name then parens (text name) else text name
66 in
67 case Type.collectLambdas tipe of
68 parts@(_ : _ : _) ->
69 hang 4 $ sep $
70 docName
71 : zipWith (<+>)
72 (colon : repeat (text "->"))
73 (map (docType localizer Func) parts)
75 _ ->
76 hang 4 $ sep $
77 [ docName <+> colon
78 , docType localizer None tipe
79 ]
83-- LOCALIZE TYPES
86type Localizer =
87 Map.Map Var.Canonical Text
90varToDoc :: Localizer -> Var.Canonical -> Doc
91varToDoc localizer var =
92 let
93 name =
94 Var.toText var
95 in
96 if name == Help.zeroTuple then
97 text "()"
99 else
100 text (maybe name id (Map.lookup var localizer))
104-- DIFF BUILDER
107data Diff a
108 = Diff a a
109 | Same a
112instance Functor Diff where
113 fmap func d =
114 case d of
115 Diff left right ->
116 Diff (func left) (func right)
118 Same both ->
119 Same (func both)
122instance Applicative Diff where
123 pure a =
124 Same a
126 (<*>) function argument =
127 case (function, argument) of
128 (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
129 Diff (leftFunc leftArg) (rightFunc rightArg)
131 (Diff leftFunc rightFunc, Same arg) ->
132 Diff (leftFunc arg) (rightFunc arg)
134 (Same func, Diff leftArg rightArg) ->
135 Diff (func leftArg) (func rightArg)
137 (Same func, Same arg) ->
138 Same (func arg)
141partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
142partitionDiffs dict =
143 let
144 collect key value (diffKeys, sameKeys) =
145 case value of
146 Diff left right ->
147 ( (key, (left, right)) : diffKeys
148 , sameKeys
149 )
151 Same both ->
152 ( diffKeys
153 , (key, both) : sameKeys
154 )
155 in
156 Map.foldrWithKey collect ([],[]) dict
160-- DOC DIFF
163data Context
164 = None
165 | Func
166 | App
169diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
170diff localizer context leftType rightType =
171 let
172 go = diff localizer
173 in
174 case (leftType, rightType) of
175 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
176 docAppHelp localizer context leftName
177 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
179 (Type.Lambda _ _, _) ->
180 diffLambda localizer context leftType rightType
182 (_, Type.Lambda _ _) ->
183 diffLambda localizer context leftType rightType
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 (_, _) ->
219 difference
220 (docType localizer context leftType)
221 (docType localizer context rightType)
224difference :: Doc -> Doc -> Diff Doc
225difference leftDoc rightDoc =
226 Diff (dullyellow leftDoc) (dullyellow rightDoc)
230-- FUNCTION DIFFS
233diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
234diffLambda localizer context leftType rightType =
235 let
236 leftArgs = reverse $ Type.collectLambdas leftType
237 rightArgs = reverse $ Type.collectLambdas rightType
239 extraToDoc types =
240 map (dullyellow . docType localizer Func) types
242 extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs
243 extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs
245 alignedArgDiff =
246 reverse <$> sequenceA (zipWith (diff localizer Func) leftArgs rightArgs)
247 in
248 docLambda context <$>
249 case (extraLefts, extraRights, alignedArgDiff) of
250 ([], [], _) ->
251 alignedArgDiff
253 (_, _, Same docs) ->
254 Diff (extraLefts ++ docs) (extraRights ++ docs)
256 (_, _, Diff lefts rights) ->
257 Diff (extraLefts ++ lefts) (extraRights ++ rights)
261-- RECORD DIFFS
264diffRecord :: Localizer -> Fields -> Maybe Text -> Fields -> Maybe Text -> Diff Doc
265diffRecord localizer leftFields leftExt rightFields rightExt =
266 let
267 (leftOnly, both, rightOnly) =
268 vennDiagram leftFields rightFields
269 in
270 if Map.null leftOnly && Map.null rightOnly then
271 let
272 fieldDiffs =
273 Map.map (uncurry (diff localizer None)) both
274 in
275 case partitionDiffs fieldDiffs of
276 ([], sames) ->
277 let
278 mkRecord =
279 docRecord Full (map (first text) sames)
280 in
281 if leftExt == rightExt then
282 Same (mkRecord (fmap text leftExt))
284 else
285 Diff
286 (mkRecord (fmap (dullyellow . text) leftExt))
287 (mkRecord (fmap (dullyellow . text) rightExt))
289 (diffs, sames) ->
290 let
291 (lefts, rights) = unzipDiffs diffs
292 style = if null sames then Full else Elide
293 in
294 Diff
295 (docRecord style lefts (fmap text leftExt))
296 (docRecord style rights (fmap text rightExt))
298 else
299 let
300 (lefts, rights) =
301 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
303 style =
304 if Map.null both then Full else Elide
305 in
306 Diff
307 (docRecord style lefts (fmap text leftExt))
308 (docRecord style rights (fmap text rightExt))
311unzipDiffs :: [(Text, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
312unzipDiffs diffPairs =
313 let
314 unzipHelp (name, (left, right)) =
315 (,) (text name, left) (text name, right)
316 in
317 unzip (map unzipHelp diffPairs)
321-- RECORD DIFFS HELPERS
324analyzeFields :: [Text] -> [Text] -> ( [(Doc, Doc)], [(Doc, Doc)] )
325analyzeFields leftOnly rightOnly =
326 let
327 typoPairs =
328 Help.findTypoPairs leftOnly rightOnly
330 mkField func name =
331 ( func (text name), text "..." )
333 mkFieldWith counts name =
334 mkField (if Set.member name counts then dullyellow else id) name
335 in
336 case Help.vetTypos typoPairs of
337 Just (leftTypos, rightTypos) ->
338 ( map (mkFieldWith leftTypos) leftOnly
339 , map (mkFieldWith rightTypos) rightOnly
340 )
342 Nothing ->
343 ( map (mkField dullyellow) leftOnly
344 , map (mkField dullyellow) rightOnly
345 )
348type Fields =
349 Map.Map Text Type.Canonical
352type DoubleFields =
353 Map.Map Text (Type.Canonical,Type.Canonical)
356vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
357vennDiagram leftFields rightFields =
358 ( Map.difference leftFields rightFields
359 , Map.intersectionWith (,) leftFields rightFields
360 , Map.difference rightFields leftFields
361 )
364flattenRecord
365 :: [(Text, Type.Canonical)]
366 -> Maybe Type.Canonical
367 -> (Fields, Maybe Text)
368flattenRecord fields ext =
369 first Map.fromList (flattenRecordHelp fields ext)
372flattenRecordHelp
373 :: [(Text, Type.Canonical)]
374 -> Maybe Type.Canonical
375 -> ([(Text, Type.Canonical)], Maybe Text)
376flattenRecordHelp fields ext =
377 case ext of
378 Nothing ->
379 (fields, Nothing)
381 Just (Type.Var x) ->
382 (fields, Just x)
384 Just (Type.Record subFields subExt) ->
385 flattenRecordHelp (fields ++ subFields) subExt
387 Just (Type.Aliased _ args tipe) ->
388 flattenRecordHelp fields (Just (Type.dealias args tipe))
390 _ ->
391 error "Trying to flatten ill-formed record."
395-- TYPES TO DOCS
398docType :: Localizer -> Context -> Type.Canonical -> Doc
399docType localizer context tipe =
400 case tipe of
401 Type.Lambda _ _ ->
402 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
404 Type.Var x ->
405 text x
407 Type.Type name ->
408 varToDoc localizer name
410 Type.App (Type.Type name) args ->
411 docApp localizer context name args
413 Type.App _ _ ->
414 error "type applications should start with a type atom"
416 Type.Record outerFields outerExt ->
417 let
418 (fields, ext) =
419 flattenRecordHelp outerFields outerExt
420 in
421 docRecord Full
422 (map (text *** docType localizer None) fields)
423 (fmap text ext)
425 Type.Aliased name args _ ->
426 docApp localizer context name (map snd args)
430docLambda :: Context -> [Doc] -> Doc
431docLambda context docs =
432 case docs of
433 [] ->
434 error "cannot call docLambda with an empty list"
436 arg:rest ->
437 case context of
438 None ->
439 sep (arg : map (text "->" <+>) rest)
441 _ ->
442 cat
443 [ lparen
444 , sep (arg : map (text "->" <+>) rest)
445 , rparen
446 ]
450docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
451docApp localizer context name args =
452 let
453 argContext =
454 if Var.isTuple name then None else App
455 in
456 docAppHelp localizer context name (map (docType localizer argContext) args)
459docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
460docAppHelp localizer context name args =
461 if Var.isTuple name then
462 sep
463 [ cat (zipWith (<+>) (lparen : repeat comma) args)
464 , rparen
465 ]
467 else if null args then
468 varToDoc localizer name
470 else
471 case context of
472 App ->
473 cat
474 [ lparen
475 , hang 4 (sep (varToDoc localizer name : args))
476 , rparen
477 ]
479 _ ->
480 hang 4 (sep (varToDoc localizer name : args))
484data Style
485 = Elide
486 | Full
489docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
490docRecord style fields maybeExt =
491 let
492 docField (name, tipe) =
493 hang 4 (sep [ name <+> colon, tipe ])
495 elision =
496 case style of
497 Full ->
498 []
500 Elide ->
501 [ text "..." ]
503 fieldDocs =
504 elision ++ map docField fields
505 in
506 case (fieldDocs, maybeExt) of
507 ([], Nothing) ->
508 text "{}"
510 (_, Nothing) ->
511 sep
512 [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
513 , rbrace
514 ]
516 (_, Just ext) ->
517 sep
518 [ hang 4 $ sep $
519 [ lbrace <+> ext
520 , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)
521 ]
522 , rbrace
523 ]