@@ -5,8 +5,6 @@ module Reporting.Render.Type
55 , toDoc
66 , diffToDocs
77 , Style(..)
8− , findPotentialTypos
9− , vetTypos
108 )
119 where
1210
@@ -14,14 +12,14 @@ import Control.Arrow ((***), first)
1412import qualified Data.Map as Map
1513import qualified Data.Set as Set
1614import Text.PrettyPrint.ANSI.Leijen
17− ( Doc, (<>), (<+>), cat, colon, comma, dullyellow, equals, hang, hsep
18− , lbrace, lparen, parens, rbrace, rparen, sep, space, text, vcat
15+ ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep
16+ , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat
1917 )
2018
2119import qualified AST.Helpers as Help
2220import qualified AST.Type as Type
2321import qualified AST.Variable as Var
24−import Reporting.Error.Helpers as Help
22+import qualified Reporting.Error.Helpers as Help
2523
2624
2725
@@ -30,12 +28,12 @@ import Reporting.Error.Helpers as Help
3028
3129toDoc :: Localizer -> Type.Canonical -> Doc
3230toDoc localizer tipe =
33− docType localizer tipe
31+ docType localizer None tipe
3432
3533
3634diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
3735diffToDocs localizer leftType rightType =
38− case diff localizer leftType rightType of
36+ case diff localizer None leftType rightType of
3937 Same doc ->
4038 (doc, doc)
4139
@@ -47,7 +45,7 @@ decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc
4745decl localizer name vars tags =
4846 let
4947 docTag (tag, args) =
50− hang 2 (sep (text tag : map (docType localizer) args))
48+ hang 2 (sep (text tag : map (docType localizer App) args))
5149 in
5250 hang 4 $ vcat $
5351 (hsep (map text ("type" : name : vars)))
@@ -68,13 +66,13 @@ annotation localizer name tipe =
6866 hang 4 $ sep $
6967 docName
7068 : zipWith (<+>)
71− ((colon <> space) : repeat (text "->"))
72− (map (docType localizer) parts)
69+ (colon : repeat (text "->"))
70+ (map (docType localizer Func) parts)
7371
7472 _ ->
7573 hang 4 $ sep $
7674 [ docName <+> colon
77− , docType localizer tipe
75+ , docType localizer None tipe
7876 ]
7977
8078
@@ -158,8 +156,14 @@ partitionDiffs dict =
158156-- DOC DIFF
159157
160158
161−diff :: Localizer -> Type.Canonical -> Type.Canonical -> Diff Doc
162−diff localizer leftType rightType =
159+data Context
160+ = None
161+ | Func
162+ | App
163+
164+
165+diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
166+diff localizer context leftType rightType =
163167 let
164168 go = diff localizer
165169 in
@@ -169,13 +173,14 @@ diff localizer leftType rightType =
169173 leftParts = Type.collectLambdas leftType
170174 rightParts = Type.collectLambdas rightType
171175 in
176+
172177 if length leftParts /= length rightParts then
173178 difference
174− (docLambda (map (docType localizer) leftParts))
175− (docLambda (map (docType localizer) rightParts))
179+ (docLambda context (map (docType localizer Func) leftParts))
180+ (docLambda context (map (docType localizer Func) rightParts))
176181
177182 else
178− docLambda <$> sequenceA (zipWith go leftParts rightParts)
183+ docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)
179184
180185 (Type.Var x, Type.Var y) | x == y ->
181186 pure (text x)
@@ -186,12 +191,12 @@ diff localizer leftType rightType =
186191 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
187192 if leftName /= rightName || length leftArgs /= length rightArgs then
188193 difference
189− (docApp localizer leftName (map (docType localizer) leftArgs))
190− (docApp localizer rightName (map (docType localizer) rightArgs))
194+ (docApp localizer context leftName (map (docType localizer App) leftArgs))
195+ (docApp localizer context rightName (map (docType localizer App) rightArgs))
191196
192197 else
193− docApp localizer leftName
194− <$> sequenceA (zipWith go leftArgs rightArgs)
198+ docApp localizer context leftName
199+ <$> sequenceA (zipWith (go App) leftArgs rightArgs)
195200
196201 (Type.App _ _, Type.App _ _) ->
197202 error "Type applications without concrete names should not get here."
@@ -207,19 +212,19 @@ diff localizer leftType rightType =
207212 diffRecord localizer leftFields leftExt rightFields rightExt
208213
209214 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
210− docApp localizer leftName
211− <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))
215+ docApp localizer context leftName
216+ <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))
212217
213218 (Type.Aliased _ args real, _) ->
214− go (Type.dealias args real) rightType
219+ go context (Type.dealias args real) rightType
215220
216221 (_, Type.Aliased _ args real) ->
217− go leftType (Type.dealias args real)
222+ go context leftType (Type.dealias args real)
218223
219224 (_, _) ->
220225 difference
221− (docType localizer leftType)
222− (docType localizer rightType)
226+ (docType localizer context leftType)
227+ (docType localizer context rightType)
223228
224229
225230difference :: Doc -> Doc -> Diff Doc
@@ -240,7 +245,7 @@ diffRecord localizer leftFields leftExt rightFields rightExt =
240245 if Map.null leftOnly && Map.null rightOnly then
241246 let
242247 fieldDiffs =
243− Map.map (uncurry (diff localizer)) both
248+ Map.map (uncurry (diff localizer None)) both
244249 in
245250 case partitionDiffs fieldDiffs of
246251 ([], sames) ->
@@ -288,14 +293,14 @@ unzipDiffs diffPairs =
288293
289294
290295
291−-- ANALYZE FIELD NAMES FOR SIMILAR NAMES
296+-- RECORD DIFFS HELPERS
292297
293298
294299analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
295300analyzeFields leftOnly rightOnly =
296301 let
297302 potentialTypos =
298− findPotentialTypos leftOnly rightOnly
303+ Help.findPotentialTypos leftOnly rightOnly
299304
300305 mkField func name =
301306 ( func (text name), text "…" )
@@ -303,7 +308,7 @@ analyzeFields leftOnly rightOnly =
303308 mkFieldWith counts name =
304309 mkField (if Set.member name counts then dullyellow else id) name
305310 in
306− case vetTypos potentialTypos of
311+ case Help.vetTypos potentialTypos of
307312 Just (leftTypos, rightTypos) ->
308313 ( map (mkFieldWith leftTypos) leftOnly
309314 , map (mkFieldWith rightTypos) rightOnly
@@ -315,39 +320,6 @@ analyzeFields leftOnly rightOnly =
315320 )
316321
317322
318−findPotentialTypos :: [String] -> [String] -> [(String, String)]
319−findPotentialTypos leftOnly rightOnly =
320− let
321− veryNear leftName =
322− map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)
323− in
324− concatMap veryNear leftOnly
325−
326−
327−vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
328−vetTypos potentialTypos =
329− let
330− tallyNames (ln, rn) (lc, rc) =
331− ( Map.insertWith (+) ln 1 lc
332− , Map.insertWith (+) rn 1 rc
333− )
334−
335− (leftCounts, rightCounts) =
336− foldr tallyNames (Map.empty, Map.empty) potentialTypos
337−
338− allUnique counts =
339− Map.foldr (\n unique -> n < 2 && unique) True counts
340− in
341− if allUnique leftCounts && allUnique rightCounts then
342− Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
343−
344− else
345− Nothing
346−
347−
348−-- RECORD DIFFS HELPERS
349−
350−
351323type Fields =
352324 Map.Map String Type.Canonical
353325
@@ -398,11 +370,11 @@ flattenRecordHelp fields ext =
398370-- TYPES TO DOCS
399371
400372
401−docType :: Localizer -> Type.Canonical -> Doc
402−docType localizer tipe =
373+docType :: Localizer -> Context -> Type.Canonical -> Doc
374+docType localizer context tipe =
403375 case tipe of
404376 Type.Lambda _ _ ->
405− docLambda (map (docType localizer) (Type.collectLambdas tipe))
377+ docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
406378
407379 Type.Var x ->
408380 text x
@@ -411,7 +383,7 @@ docType localizer tipe =
411383 varToDoc localizer name
412384
413385 Type.App (Type.Type name) args ->
414− docApp localizer name (map (docType localizer) args)
386+ docApp localizer context name (map (docType localizer App) args)
415387
416388 Type.App _ _ ->
417389 error "type applications should start with a type atom"
@@ -422,27 +394,36 @@ docType localizer tipe =
422394 flattenRecordHelp outerFields outerExt
423395 in
424396 docRecord Full
425− (map (text *** docType localizer) fields)
397+ (map (text *** docType localizer None) fields)
426398 (fmap text ext)
427399
428400 Type.Aliased name args _ ->
429− docApp localizer name (map (docType localizer . snd) args)
401+ docApp localizer context name (map (docType localizer App . snd) args)
430402
431403
432404
433−docLambda :: [Doc] -> Doc
434−docLambda docs =
405+docLambda :: Context -> [Doc] -> Doc
406+docLambda context docs =
435407 case docs of
436408 [] ->
437409 error "cannot call docLambda with an empty list"
438410
439411 arg:rest ->
440− sep (arg : map (text "->" <+>) rest)
412+ case context of
413+ None ->
414+ sep (arg : map (text "->" <+>) rest)
415+
416+ _ ->
417+ cat
418+ [ lparen
419+ , sep (arg : map (text "->" <+>) rest)
420+ , rparen
421+ ]
441422
442423
443424
444−docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc
445−docApp localizer name args =
425+docApp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
426+docApp localizer context name args =
446427 if Var.isTuple name then
447428 sep
448429 [ cat (zipWith (<+>) (lparen : repeat comma) args)
@@ -453,7 +434,16 @@ docApp localizer name args =
453434 varToDoc localizer name
454435
455436 else
456− hang 4 (sep (varToDoc localizer name : args))
437+ case context of
438+ App ->
439+ cat
440+ [ lparen
441+ , hang 4 (sep (varToDoc localizer name : args))
442+ , rparen
443+ ]
444+
445+ _ ->
446+ hang 4 (sep (varToDoc localizer name : args))
457447
458448
459449