@@ -1,270 +1,487 @@
11module Reporting.Render.Type
22 ( Localizer
3− , typeDecl
3+ , decl
44 , aliasDecl
55 , annotation
6− , tipe
6+ , toDoc
7+ , diffToDocs
8+ , Style(..)
79 )
810 where
911
12+import Control.Arrow ((***), first)
1013import qualified Data.Map as Map
14+import qualified Data.Set as Set
1115import Text.PrettyPrint.ANSI.Leijen
16+ ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep, indent
17+ , lbrace, lparen, rbrace, rparen, sep, text, vcat
18+ )
1219
13−import qualified AST.Helpers as Help
20+import qualified AST.Type as Type
21+import qualified AST.Variable as Var
22+import Reporting.Error.Helpers as Help
1423
1524
16−type Localizer =
17− Map.Map String String
1825
26+-- PUBLIC API FOR CREATING DOCS
1927
20−typeDecl =
21− error "TODO"
28+
29+decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc
30+decl localizer name vars tags =
31+ let
32+ docTag (tag, args) =
33+ hang 2 (sep (text tag : map (docType localizer) args))
34+ in
35+ hang 4 $ vcat $
36+ (hsep (map text ("type" : name : vars)))
37+ :
38+ zipWith (<+>)
39+ (equals : repeat (text "|"))
40+ (map docTag tags)
2241
2342
24−aliasDecl =
25− error "TODO"
43+aliasDecl :: Localizer -> String -> [String] -> Type.Canonical -> Doc
44+aliasDecl localizer name vars tipe =
45+ hang 4 $ vcat $
46+ [ hsep (map text ("type" : name : vars) ++ [equals])
47+ , docType localizer tipe
48+ ]
2649
2750
2851annotation =
2952 error "TODO"
3053
3154
32−tipe =
33− error "TODO"
55+toDoc :: Localizer -> Type.Canonical -> Doc
56+toDoc localizer tipe =
57+ docType localizer tipe
58+
59+
60+diffToDocs :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
61+diffToDocs localizer style leftType rightType =
62+ case diff localizer style leftType rightType of
63+ Same doc ->
64+ (doc, doc)
65+
66+ Diff leftDoc rightDoc ->
67+ (leftDoc, rightDoc)
3468
3569
3670
37−{-- HELPERS
71+-- LOCALIZE TYPES
3872
39−commaCat :: [Doc] -> Doc
40−commaCat docs =
41− cat (punctuate comma docs)
4273
74+type Localizer =
75+ Map.Map String String
76+
77+
78+varToDoc :: Localizer -> Var.Canonical -> Doc
79+varToDoc localizer var =
80+ let
81+ name = Var.toString var
82+ in
83+ if name == "_Tuple0" then
84+ text "()"
4385
44−commaSep :: [Doc] -> Doc
45−commaSep docs =
46− sep (punctuate comma docs)
86+ else
87+ text (maybe name id (Map.lookup name localizer))
4788
4889
49−parensIf :: Bool -> Doc -> Doc
50−parensIf bool doc =
51− if bool then parens doc else doc
5290
91+-- DIFF BUILDER
5392
54−variable :: String -> Doc
55−variable x =
56− if Help.isOp x then parens (text x) else text x
5793
94+data Diff a
95+ = Diff a a
96+ | Same a
5897
5998
60−-- PRETTY PRINTING
99+instance Functor Diff where
100+ fmap func d =
101+ case d of
102+ Diff left right ->
103+ Diff (func left) (func right)
61104
62−instance (P.Pretty t) => P.Pretty (Port t) where
63− pretty dealiaser needsParens portType =
64− P.pretty dealiaser needsParens (getPortType portType)
105+ Same both ->
106+ Same (func both)
65107
66108
67−instance P.Pretty Raw' where
68− pretty dealiaser needsParens tipe =
69− case tipe of
70− RLambda arg body ->
71− P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
109+instance Applicative Diff where
110+ pure a =
111+ Same a
72112
73− RVar x ->
74− P.text x
113+ (<*>) func arg =
114+ case (func, arg) of
115+ (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
116+ Diff (leftFunc leftArg) (rightFunc rightArg)
75117
76− RType var ->
77− prettyType dealiaser var
118+ (Diff leftFunc rightFunc, Same arg) ->
119+ Diff (leftFunc arg) (rightFunc arg)
78120
79− RApp func args ->
80− let
81− isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
82− isTuple _ = False
83− in
84− prettyApp dealiaser needsParens isTuple func args
121+ (Same func, Diff leftArg rightArg) ->
122+ Diff (func leftArg) (func rightArg)
85123
86− RRecord fields ext ->
87− prettyRecord dealiaser (flattenRawRecord fields ext)
124+ (Same func, Same arg) ->
125+ Same (func arg)
88126
89127
90−instance P.Pretty Canonical where
91− pretty dealiaser needsParens tipe =
92− case tipe of
93− Lambda arg body ->
94− P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
128+partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
129+partitionDiffs dict =
130+ let
131+ collect key value (diffKeys, sameKeys) =
132+ case value of
133+ Diff left right ->
134+ ( (key, (left, right)) : diffKeys
135+ , sameKeys
136+ )
95137
96− Var x ->
97− P.text x
138+ Same both ->
139+ ( diffKeys
140+ , (key, both) : sameKeys
141+ )
142+ in
143+ Map.foldrWithKey collect ([],[]) dict
98144
99− Type var ->
100− prettyType dealiaser var
101145
102− App func args ->
103− let
104− isTuple (Type name) = Help.isTuple (Var.toString name)
105− isTuple _ = False
106− in
107− prettyApp dealiaser needsParens isTuple func args
108146
109− Record fields ext ->
110− prettyRecord dealiaser (flattenCanRecord fields ext)
147+-- DOC DIFF
111148
112− Aliased name args _ ->
113− P.parensIf (needsParens && not (null args)) $
114− P.hang
115− (P.pretty dealiaser False name)
116− 2
117− (P.sep (map (P.pretty dealiaser True . snd) args))
118149
150+data Style
151+ = Elide
152+ | Full
119153
120−-- PRETTY HELPERS
121154
122−prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
123−prettyType dealiaser var =
155+diff :: Localizer -> Style -> Type.Canonical -> Type.Canonical -> Diff Doc
156+diff localizer style leftType rightType =
124157 let
125− v = Var.toString var
158+ go = diff localizer style
126159 in
127− P.text $
128− if v == "_Tuple0" then
129− "()"
130− else
131− maybe v id (Map.lookup v dealiaser)
160+ case (leftType, rightType) of
161+ (Type.Lambda _ _, Type.Lambda _ _) ->
162+ let
163+ leftParts = Type.collectLambdas leftType
164+ rightParts = Type.collectLambdas rightType
165+ in
166+ if length leftParts /= length rightParts then
167+ difference
168+ (docLambda (map (docType localizer) leftParts))
169+ (docLambda (map (docType localizer) rightParts))
132170
171+ else
172+ docLambda <$> sequenceA (zipWith go leftParts rightParts)
133173
134−-- PRETTY LAMBDAS
174+ (Type.Var x, Type.Var y) | x == y ->
175+ pure (text x)
135176
136−prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
137−prettyLambda dealiaser getLambda arg body =
138− let
139− rest =
140− gatherLambda getLambda body
177+ (Type.Type leftName, Type.Type rightName) | leftName == rightName ->
178+ pure (varToDoc localizer leftName)
141179
142− prettyArg t =
143− P.pretty dealiaser (Maybe.isJust (getLambda t)) t
144− in
145− P.sep
146− [ prettyArg arg
147− , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
148− ]
180+ (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->
181+ if leftName /= rightName || length leftArgs /= length rightArgs then
182+ difference
183+ (docApp localizer leftName (map (docType localizer) leftArgs))
184+ (docApp localizer rightName (map (docType localizer) rightArgs))
149185
186+ else
187+ docApp localizer leftName
188+ <$> sequenceA (zipWith go leftArgs rightArgs)
150189
151−getRawLambda :: Raw -> Maybe (Raw, Raw)
152−getRawLambda (A.A _ tipe) =
153− case tipe of
154− RLambda arg body -> Just (arg, body)
155− _ -> Nothing
190+ (Type.App _ _, Type.App _ _) ->
191+ error "Type applications without concrete names should not get here."
156192
193+ (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
194+ let
195+ (leftFields, leftExt) =
196+ flattenRecord outerLeftFields outerLeftExt
157197
158−getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
159−getCanLambda tipe =
160− case tipe of
161− Lambda arg body -> Just (arg, body)
162− _ -> Nothing
198+ (rightFields, rightExt) =
199+ flattenRecord outerRightFields outerRightExt
200+ in
201+ case style of
202+ Elide ->
203+ diffRecordElide localizer leftFields leftExt rightFields rightExt
163204
205+ Full ->
206+ error "TODO"
164207
165−gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
166−gatherLambda get tipe =
167− case get tipe of
168− Just (arg, body) ->
169− arg : gatherLambda get body
208+ (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->
209+ docApp localizer leftName
210+ <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))
211+
212+ (Type.Aliased _ args real, _) ->
213+ go (Type.dealias args real) rightType
214+
215+ (_, Type.Aliased _ args real) ->
216+ go leftType (Type.dealias args real)
217+
218+ (_, _) ->
219+ difference
220+ (docType localizer leftType)
221+ (docType localizer rightType)
170222
171− Nothing ->
172− [tipe]
173223
224+difference :: Doc -> Doc -> Diff Doc
225+difference leftDoc rightDoc =
226+ Diff (dullyellow leftDoc) (dullyellow rightDoc)
174227
175−collectLambdas :: Canonical -> [Canonical]
176−collectLambdas tipe =
177− gatherLambda getCanLambda tipe
178228
179229
180−-- PRETTY APP
230+-- RECORD DIFFS
181231
182−prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
183−prettyApp dealiaser needsParens isTuple func args
184− | isTuple func =
185− P.parens $ P.sep $
186− P.punctuate P.comma (map (P.pretty dealiaser False) args)
187232
188− | null args =
189− P.pretty dealiaser needsParens func
233+diffRecordElide :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc
234+diffRecordElide localizer leftFields leftExt rightFields rightExt =
235+ let
236+ (leftOnly, both, rightOnly) =
237+ vennDiagram leftFields rightFields
238+ in
239+ if Map.null leftOnly && Map.null rightOnly then
240+ let
241+ fieldDiffs =
242+ Map.map (uncurry (diff localizer Elide)) both
243+ in
244+ case partitionDiffs fieldDiffs of
245+ ([], sames) ->
246+ let
247+ mkRecord =
248+ docRecord Full (map (first text) sames)
249+ in
250+ if leftExt == rightExt then
251+ Same (mkRecord (fmap text leftExt))
252+
253+ else
254+ Diff
255+ (mkRecord (fmap (dullyellow . text) leftExt))
256+ (mkRecord (fmap (dullyellow . text) rightExt))
257+
258+ (diffs, sames) ->
259+ let
260+ (lefts, rights) = unzipDiffs diffs
261+ style = if null sames then Full else Elide
262+ in
263+ Diff
264+ (docRecord style lefts (fmap text leftExt))
265+ (docRecord style rights (fmap text rightExt))
266+
267+ else
268+ let
269+ (lefts, rights) =
270+ analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
271+
272+ style =
273+ if Map.null both then Full else Elide
274+ in
275+ Diff
276+ (docRecord style lefts (fmap text leftExt))
277+ (docRecord style rights (fmap text rightExt))
278+
279+
280+unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
281+unzipDiffs diffPairs =
282+ let
283+ unzipHelp (name, (left, right)) =
284+ (,) (text name, left) (text name, right)
285+ in
286+ unzip (map unzipHelp diffPairs)
287+
190288
191− | otherwise =
192− P.parensIf needsParens $
193− P.hang
194− (P.pretty dealiaser True func)
195− 2
196− (P.sep (map (P.pretty dealiaser True) args))
197289
290+-- ANALYZE FIELD NAMES FOR SIMILAR NAMES
198291
199−-- PRETTY RECORD
200292
201−prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
202−prettyRecord dealiaser recordInfo =
293+analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )
294+analyzeFields leftOnly rightOnly =
203295 let
204− prettyField (field, tipe) =
205− P.hang
206− (P.text field <+> P.text ":")
207− 4
208− (P.pretty dealiaser False tipe)
296+ potentialTypos =
297+ findPotentialTypos leftOnly rightOnly
298+
299+ mkField func name =
300+ ( func (text name), text "…" )
301+
302+ mkFieldWith counts name =
303+ mkField (if Set.member name counts then dullyellow else id) name
209304 in
210− case recordInfo of
211− ([], Nothing) ->
212− P.text "{}"
305+ case vetTypos potentialTypos of
306+ Just (leftTypos, rightTypos) ->
307+ ( map (mkFieldWith leftTypos) leftOnly
308+ , map (mkFieldWith rightTypos) rightOnly
309+ )
213310
214− (fields, Nothing) ->
215− P.sep
216− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
217− , P.rbrace
218− ]
311+ Nothing ->
312+ ( map (mkField dullyellow) leftOnly
313+ , map (mkField dullyellow) rightOnly
314+ )
219315
220− (fields, Just x) ->
221− P.hang
222− (P.lbrace <+> P.text x <+> P.text "|")
223− 4
224− (P.sep
225− [ P.sep (P.punctuate P.comma (map prettyField fields))
226− , P.rbrace
227− ]
228− )
229316
317+findPotentialTypos :: [String] -> [String] -> [(String, String)]
318+findPotentialTypos leftOnly rightOnly =
319+ let
320+ veryNear leftName =
321+ map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)
322+ in
323+ concatMap veryNear leftOnly
230324
231−flattenRawRecord
232− :: [(String, Raw)]
233− -> Maybe Raw
234− -> ( [(String, Raw)], Maybe String )
235−flattenRawRecord fields ext =
236− case ext of
237− Nothing ->
238− (fields, Nothing)
239325
240− Just (A.A _ (RVar x)) ->
241− (fields, Just x)
326+vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
327+vetTypos potentialTypos =
328+ let
329+ tallyNames (ln, rn) (lc, rc) =
330+ ( Map.insertWith (+) ln 1 lc
331+ , Map.insertWith (+) rn 1 rc
332+ )
242333
243− Just (A.A _ (RRecord fields' ext')) ->
244− flattenRawRecord (fields' ++ fields) ext'
334+ (leftCounts, rightCounts) =
335+ foldr tallyNames (Map.empty, Map.empty) potentialTypos
245336
246− _ ->
247− error "Trying to flatten ill-formed record."
337+ allUnique counts =
338+ Map.foldr (\n unique -> n < 2 && unique) True counts
339+ in
340+ if allUnique leftCounts && allUnique rightCounts then
341+ Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
342+
343+ else
344+ Nothing
345+
346+
347+-- RECORD DIFFS HELPERS
348+
349+
350+type Fields =
351+ Map.Map String Type.Canonical
352+
353+
354+type DoubleFields =
355+ Map.Map String (Type.Canonical,Type.Canonical)
356+
357+
358+vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
359+vennDiagram leftFields rightFields =
360+ ( Map.difference leftFields rightFields
361+ , Map.intersectionWith (,) leftFields rightFields
362+ , Map.difference rightFields leftFields
363+ )
248364
249365
250−flattenCanRecord
251− :: [(String, Canonical)]
252− -> Maybe Canonical
253− -> ( [(String, Canonical)], Maybe String )
254−flattenCanRecord fields ext =
366+flattenRecord
367+ :: [(String, Type.Canonical)]
368+ -> Maybe Type.Canonical
369+ -> (Fields, Maybe String)
370+flattenRecord fields ext =
371+ first Map.fromList (flattenRecordHelp fields ext)
372+
373+
374+flattenRecordHelp
375+ :: [(String, Type.Canonical)]
376+ -> Maybe Type.Canonical
377+ -> ([(String, Type.Canonical)], Maybe String)
378+flattenRecordHelp fields ext =
255379 case ext of
256380 Nothing ->
257381 (fields, Nothing)
258382
259− Just (Var x) ->
383+ Just (Type.Var x) ->
260384 (fields, Just x)
261385
262− Just (Record fields' ext') ->
263− flattenCanRecord (fields' ++ fields) ext'
386+ Just (Type.Record subFields subExt) ->
387+ flattenRecordHelp (fields ++ subFields) subExt
264388
265− Just (Aliased _ args tipe) ->
266− flattenCanRecord fields (Just (dealias args tipe))
389+ Just (Type.Aliased _ args tipe) ->
390+ flattenRecordHelp fields (Just (Type.dealias args tipe))
267391
268392 _ ->
269393 error "Trying to flatten ill-formed record."
270−--}
394+
395+
396+
397+-- TYPES TO DOCS
398+
399+
400+docType :: Localizer -> Type.Canonical -> Doc
401+docType localizer tipe =
402+ case tipe of
403+ Type.Lambda _ _ ->
404+ docLambda (map (docType localizer) (Type.collectLambdas tipe))
405+
406+ Type.Var x ->
407+ text x
408+
409+ Type.Type name ->
410+ varToDoc localizer name
411+
412+ Type.App (Type.Type name) args ->
413+ docApp localizer name (map (docType localizer) args)
414+
415+ Type.App _ _ ->
416+ error "type applications should start with a type atom"
417+
418+ Type.Record outerFields outerExt ->
419+ let
420+ (fields, ext) =
421+ flattenRecordHelp outerFields outerExt
422+ in
423+ docRecord Full
424+ (map (text *** docType localizer) fields)
425+ (fmap text ext)
426+
427+ Type.Aliased name args _ ->
428+ docApp localizer name (map (docType localizer . snd) args)
429+
430+
431+
432+docLambda :: [Doc] -> Doc
433+docLambda (arg:rest) =
434+ sep (arg : map (text "->" <+>) rest)
435+
436+
437+
438+docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc
439+docApp localizer name args =
440+ if Var.isTuple name then
441+ sep
442+ [ cat (zipWith (<+>) (lparen : repeat comma) args)
443+ , rparen
444+ ]
445+
446+ else if null args then
447+ varToDoc localizer name
448+
449+ else
450+ hang 4 (sep (varToDoc localizer name : args))
451+
452+
453+
454+docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
455+docRecord style fields maybeExt =
456+ let
457+ docField (name, tipe) =
458+ hang 4 (sep [ name <+> colon, tipe ])
459+
460+ elision =
461+ case style of
462+ Full ->
463+ []
464+
465+ Elide ->
466+ [ text "…" ]
467+
468+ fieldDocs =
469+ elision ++ map docField fields
470+ in
471+ case (fieldDocs, maybeExt) of
472+ ([], Nothing) ->
473+ text "{}"
474+
475+ (_, Nothing) ->
476+ sep
477+ [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)
478+ , rbrace
479+ ]
480+
481+ (_, Just ext) ->
482+ sep
483+ [ lbrace <+> ext
484+ , indent 4 (cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs))
485+ , rbrace
486+ ]
487+