git.iko.soy/elk
on c19392f help sign in
elk/src/Reporting/Render/Type.hs
505 lines 12 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 ( Doc, (<+>), cat, dullyellow, hang, hsep, parens, sep, text, vcat )
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 -> Text -> [Text] -> [(Text, [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 ("type" : map text (name : vars)))
52 :
53 zipWith (<+>) ("=" : repeat "|") (map docTag tags)
56annotation :: Localizer -> Text -> Type.Canonical -> Doc
57annotation localizer name tipe =
58 let
59 docName =
60 if Help.isOp name then parens (text name) else text name
61 in
62 case Type.collectLambdas tipe of
63 parts@(_ : _ : _) ->
64 hang 4 $ sep $
65 docName
66 : zipWith (<+>)
67 (":" : repeat "->")
68 (map (docType localizer Func) parts)
70 _ ->
71 hang 4 $ sep $
72 [ docName <+> ":"
73 , docType localizer None tipe
74 ]
78-- LOCALIZE TYPES
81type Localizer =
82 Map.Map Var.Canonical Text
85varToDoc :: Localizer -> Var.Canonical -> Doc
86varToDoc localizer var =
87 let
88 name =
89 Var.toText var
90 in
91 if name == Help.zeroTuple then
92 text "()"
94 else
95 text (maybe name id (Map.lookup var localizer))
99-- DIFF BUILDER
102data Diff a
103 = Diff a a
104 | Same a
107instance Functor Diff where
108 fmap func d =
109 case d of
110 Diff left right ->
111 Diff (func left) (func right)
113 Same both ->
114 Same (func both)
117instance Applicative Diff where
118 pure a =
119 Same a
121 (<*>) function argument =
122 case (function, argument) of
123 (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
124 Diff (leftFunc leftArg) (rightFunc rightArg)
126 (Diff leftFunc rightFunc, Same arg) ->
127 Diff (leftFunc arg) (rightFunc arg)
129 (Same func, Diff leftArg rightArg) ->
130 Diff (func leftArg) (func rightArg)
132 (Same func, Same arg) ->
133 Same (func arg)
136partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
137partitionDiffs dict =
138 let
139 collect key value (diffKeys, sameKeys) =
140 case value of
141 Diff left right ->
142 ( (key, (left, right)) : diffKeys
143 , sameKeys
144 )
146 Same both ->
147 ( diffKeys
148 , (key, both) : sameKeys
149 )
150 in
151 Map.foldrWithKey collect ([],[]) dict
155-- DOC DIFF
158data Context
159 = None
160 | Func
161 | App
164diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
165diff localizer context leftType rightType =
166 let
167 go = diff localizer
168 in
169 case (leftType, rightType) of
170 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
171 docAppHelp localizer context leftName
172 <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
174 (Type.Lambda _ _, _) ->
175 diffLambda localizer context leftType rightType
177 (_, Type.Lambda _ _) ->
178 diffLambda localizer context leftType rightType
180 (Type.Var x, Type.Var y) | x == y ->
181 pure (text x)
183 (Type.Type leftName leftArgs, Type.Type rightName rightArgs) ->
184 if leftName /= rightName || length leftArgs /= length rightArgs then
185 difference
186 (docApp localizer context leftName leftArgs)
187 (docApp localizer context rightName rightArgs)
189 else
190 let
191 subContext =
192 if Var.isTuple leftName then None else App
193 in
194 docAppHelp localizer context leftName
195 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)
197 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
198 let
199 (leftFields, leftExt) =
200 flattenRecord outerLeftFields outerLeftExt
202 (rightFields, rightExt) =
203 flattenRecord outerRightFields outerRightExt
204 in
205 diffRecord localizer leftFields leftExt rightFields rightExt
207 (_, _) ->
208 difference
209 (docType localizer context leftType)
210 (docType localizer context rightType)
213difference :: Doc -> Doc -> Diff Doc
214difference leftDoc rightDoc =
215 Diff (dullyellow leftDoc) (dullyellow rightDoc)
219-- FUNCTION DIFFS
222diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
223diffLambda localizer context leftType rightType =
224 let
225 leftArgs = reverse $ Type.collectLambdas leftType
226 rightArgs = reverse $ Type.collectLambdas rightType
228 extraToDoc types =
229 map (dullyellow . docType localizer Func) types
231 extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs
232 extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs
234 alignedArgDiff =
235 reverse <$> sequenceA (zipWith (diff localizer Func) leftArgs rightArgs)
236 in
237 docLambda context <$>
238 case (extraLefts, extraRights, alignedArgDiff) of
239 ([], [], _) ->
240 alignedArgDiff
242 (_, _, Same docs) ->
243 Diff (extraLefts ++ docs) (extraRights ++ docs)
245 (_, _, Diff lefts rights) ->
246 Diff (extraLefts ++ lefts) (extraRights ++ rights)
250-- RECORD DIFFS
253diffRecord :: Localizer -> Fields -> Maybe Text -> Fields -> Maybe Text -> Diff Doc
254diffRecord localizer leftFields leftExt rightFields rightExt =
255 let
256 (leftOnly, both, rightOnly) =
257 vennDiagram leftFields rightFields
258 in
259 if Map.null leftOnly && Map.null rightOnly then
260 let
261 fieldDiffs =
262 Map.map (uncurry (diff localizer None)) both
263 in
264 case partitionDiffs fieldDiffs of
265 ([], sames) ->
266 let
267 mkRecord =
268 docRecord Full (map (first text) sames)
269 in
270 if leftExt == rightExt then
271 Same (mkRecord (fmap text leftExt))
273 else
274 Diff
275 (mkRecord (fmap (dullyellow . text) leftExt))
276 (mkRecord (fmap (dullyellow . text) rightExt))
278 (diffs, sames) ->
279 let
280 (lefts, rights) = unzipDiffs diffs
281 style = if null sames then Full else Elide
282 in
283 Diff
284 (docRecord style lefts (fmap text leftExt))
285 (docRecord style rights (fmap text rightExt))
287 else
288 let
289 (lefts, rights) =
290 analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
292 style =
293 if Map.null both then Full else Elide
294 in
295 Diff
296 (docRecord style lefts (fmap text leftExt))
297 (docRecord style rights (fmap text rightExt))
300unzipDiffs :: [(Text, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
301unzipDiffs diffPairs =
302 let
303 unzipHelp (name, (left, right)) =
304 (,) (text name, left) (text name, right)
305 in
306 unzip (map unzipHelp diffPairs)
310-- RECORD DIFFS HELPERS
313analyzeFields :: [Text] -> [Text] -> ( [(Doc, Doc)], [(Doc, Doc)] )
314analyzeFields leftOnly rightOnly =
315 let
316 typoPairs =
317 Help.findTypoPairs leftOnly rightOnly
319 mkField func name =
320 ( func (text name), text "..." )
322 mkFieldWith counts name =
323 mkField (if Set.member name counts then dullyellow else id) name
324 in
325 case Help.vetTypos typoPairs of
326 Just (leftTypos, rightTypos) ->
327 ( map (mkFieldWith leftTypos) leftOnly
328 , map (mkFieldWith rightTypos) rightOnly
329 )
331 Nothing ->
332 ( map (mkField dullyellow) leftOnly
333 , map (mkField dullyellow) rightOnly
334 )
337type Fields =
338 Map.Map Text Type.Canonical
341type DoubleFields =
342 Map.Map Text (Type.Canonical,Type.Canonical)
345vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
346vennDiagram leftFields rightFields =
347 ( Map.difference leftFields rightFields
348 , Map.intersectionWith (,) leftFields rightFields
349 , Map.difference rightFields leftFields
350 )
353flattenRecord
354 :: [(Text, Type.Canonical)]
355 -> Maybe Type.Canonical
356 -> (Fields, Maybe Text)
357flattenRecord fields ext =
358 first Map.fromList (flattenRecordHelp fields ext)
361flattenRecordHelp
362 :: [(Text, Type.Canonical)]
363 -> Maybe Type.Canonical
364 -> ([(Text, Type.Canonical)], Maybe Text)
365flattenRecordHelp fields ext =
366 case ext of
367 Nothing ->
368 (fields, Nothing)
370 Just (Type.Var x) ->
371 (fields, Just x)
373 Just (Type.Record subFields subExt) ->
374 flattenRecordHelp (fields ++ subFields) subExt
376 Just (Type.Aliased _ args tipe) ->
377 flattenRecordHelp fields (Just (Type.dealias args tipe))
379 _ ->
380 error "Trying to flatten ill-formed record."
384-- TYPES TO DOCS
387docType :: Localizer -> Context -> Type.Canonical -> Doc
388docType localizer context tipe =
389 case tipe of
390 Type.Lambda _ _ ->
391 docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
393 Type.Var x ->
394 text x
396 Type.Type name args ->
397 docApp localizer context name args
399 Type.Record outerFields outerExt ->
400 let
401 (fields, ext) =
402 flattenRecordHelp outerFields outerExt
403 in
404 docRecord Full
405 (map (text *** docType localizer None) fields)
406 (fmap text ext)
408 Type.Aliased name args _ ->
409 docApp localizer context name (map snd args)
413docLambda :: Context -> [Doc] -> Doc
414docLambda context docs =
415 case docs of
416 [] ->
417 error "cannot call docLambda with an empty list"
419 arg:rest ->
420 case context of
421 None ->
422 sep (arg : map ("->" <+>) rest)
424 _ ->
425 cat
426 [ "("
427 , sep (arg : map ("->" <+>) rest)
428 , ")"
429 ]
433docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
434docApp localizer context name args =
435 let
436 argContext =
437 if Var.isTuple name then None else App
438 in
439 docAppHelp localizer context name (map (docType localizer argContext) args)
442docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
443docAppHelp localizer context name arguments =
444 case arguments of
445 [] ->
446 if Var.isTuple name then "()" else varToDoc localizer name
448 arg : args ->
449 if Var.isTuple name then
450 sep
451 [ cat ("(" <+> arg : map ("," <+>) args)
452 , ")"
453 ]
455 else
456 case context of
457 App ->
458 cat [ "(", hang 4 (sep (varToDoc localizer name : arg : args)), ")" ]
460 _ ->
461 hang 4 (sep (varToDoc localizer name : arg : args))
465data Style
466 = Elide
467 | Full
470docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
471docRecord style fields maybeExt =
472 let
473 docField (name, tipe) =
474 hang 4 (sep [ name <+> ":", tipe ])
476 elision =
477 case style of
478 Full ->
479 []
481 Elide ->
482 [ text "..." ]
484 fieldDocs =
485 elision ++ map docField fields
486 in
487 case (fieldDocs, maybeExt) of
488 ([], Nothing) ->
489 text "{}"
491 (_, Nothing) ->
492 sep
493 [ cat (zipWith (<+>) ("{" : repeat ",") fieldDocs)
494 , "}"
495 ]
497 (_, Just ext) ->
498 sep
499 [ hang 4 $ sep $
500 [ "{" <+> ext
501 , cat (zipWith (<+>) (text "|" : repeat ",") fieldDocs)
502 ]
503 , "}"
504 ]