@@ -1,505 +1,102 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Reporting.Render.Type
4− ( Localizer
5− , decl
6− , annotation
7− , toDoc
8− , diffToDocs
9− , Style(..)
4+ ( Context(..)
5+ , lambda
6+ , apply
7+ , tuple
8+ , record
9+ , recordSnippet
1010 )
1111 where
1212
13−import Control.Arrow ((***), first)
14−import qualified Data.Map as Map
15−import qualified Data.Set as Set
16−import Data.Text (Text)
1713
18−import qualified AST.Helpers as Help
19−import qualified AST.Type as Type
20−import qualified AST.Variable as Var
21−import qualified Reporting.Helpers as Help
22−import Reporting.Helpers ( Doc, (<+>), cat, dullyellow, hang, hsep, parens, sep, text, vcat )
14+import qualified Reporting.Helpers as H
15+import Reporting.Helpers ( Doc, (<+>) )
2316
2417
2518
26−-- PUBLIC API FOR CREATING DOCS
27−
28−
29−toDoc :: Localizer -> Type.Canonical -> Doc
30−toDoc localizer tipe =
31− docType localizer None tipe
32−
33−
34−diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)
35−diffToDocs localizer leftType rightType =
36− case diff localizer None leftType rightType of
37− Same doc ->
38− (doc, doc)
39−
40− Diff leftDoc rightDoc ->
41− (leftDoc, rightDoc)
42−
43−
44−decl :: Localizer -> Text -> [Text] -> [(Text, [Type.Canonical])] -> Doc
45−decl 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)
54−
55−
56−annotation :: Localizer -> Text -> Type.Canonical -> Doc
57−annotation 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)
69−
70− _ ->
71− hang 4 $ sep $
72− [ docName <+> ":"
73− , docType localizer None tipe
74− ]
75−
76−
77−
78−-- LOCALIZE TYPES
79−
80−
81−type Localizer =
82− Map.Map Var.Canonical Text
83−
84−
85−varToDoc :: Localizer -> Var.Canonical -> Doc
86−varToDoc localizer var =
87− let
88− name =
89− Var.toText var
90− in
91− if name == Help.zeroTuple then
92− text "()"
93−
94− else
95− text (maybe name id (Map.lookup var localizer))
96−
97−
98−
99−-- DIFF BUILDER
100−
101−
102−data Diff a
103− = Diff a a
104− | Same a
105−
106−
107−instance Functor Diff where
108− fmap func d =
109− case d of
110− Diff left right ->
111− Diff (func left) (func right)
112−
113− Same both ->
114− Same (func both)
115−
116−
117−instance Applicative Diff where
118− pure a =
119− Same a
120−
121− (<*>) function argument =
122− case (function, argument) of
123− (Diff leftFunc rightFunc, Diff leftArg rightArg) ->
124− Diff (leftFunc leftArg) (rightFunc rightArg)
125−
126− (Diff leftFunc rightFunc, Same arg) ->
127− Diff (leftFunc arg) (rightFunc arg)
128−
129− (Same func, Diff leftArg rightArg) ->
130− Diff (func leftArg) (func rightArg)
131−
132− (Same func, Same arg) ->
133− Same (func arg)
134−
135−
136−partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )
137−partitionDiffs 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− )
145−
146− Same both ->
147− ( diffKeys
148− , (key, both) : sameKeys
149− )
150− in
151− Map.foldrWithKey collect ([],[]) dict
152−
153−
154−
155−-- DOC DIFF
19+-- TO DOC
15620
15721
15822data Context
159− = None
160− | Func
161− | App
23+ = None
24+ | Func
25+ | App
16226
16327
164−diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
165−diff localizer context leftType rightType =
28+lambda :: Context -> Doc -> [Doc] -> Doc
29+lambda context arg args =
16630 let
167− go = diff localizer
31+ lambdaDoc =
32+ H.sep (arg : map ("->" <+>) args)
16833 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))
173−
174− (Type.Lambda _ _, _) ->
175− diffLambda localizer context leftType rightType
176−
177− (_, Type.Lambda _ _) ->
178− diffLambda localizer context leftType rightType
179−
180− (Type.Var x, Type.Var y) | x == y ->
181− pure (text x)
182−
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)
188−
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)
196−
197− (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->
198− let
199− (leftFields, leftExt) =
200− flattenRecord outerLeftFields outerLeftExt
201−
202− (rightFields, rightExt) =
203− flattenRecord outerRightFields outerRightExt
204− in
205− diffRecord localizer leftFields leftExt rightFields rightExt
206−
207− (_, _) ->
208− difference
209− (docType localizer context leftType)
210− (docType localizer context rightType)
211−
212−
213−difference :: Doc -> Doc -> Diff Doc
214−difference leftDoc rightDoc =
215− Diff (dullyellow leftDoc) (dullyellow rightDoc)
216−
217−
218−
219−-- FUNCTION DIFFS
220−
221−
222−diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc
223−diffLambda localizer context leftType rightType =
224− let
225− leftArgs = reverse $ Type.collectLambdas leftType
226− rightArgs = reverse $ Type.collectLambdas rightType
227−
228− extraToDoc types =
229− map (dullyellow . docType localizer Func) types
230−
231− extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs
232− extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs
233−
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
241−
242− (_, _, Same docs) ->
243− Diff (extraLefts ++ docs) (extraRights ++ docs)
244−
245− (_, _, Diff lefts rights) ->
246− Diff (extraLefts ++ lefts) (extraRights ++ rights)
247−
248−
34+ case context of
35+ None -> lambdaDoc
36+ Func -> H.cat [ "(", lambdaDoc, ")" ]
37+ App -> H.cat [ "(", lambdaDoc, ")" ]
24938
250−-- RECORD DIFFS
25139
252−
253−diffRecord :: Localizer -> Fields -> Maybe Text -> Fields -> Maybe Text -> Diff Doc
254−diffRecord 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))
272−
273− else
274− Diff
275− (mkRecord (fmap (dullyellow . text) leftExt))
276− (mkRecord (fmap (dullyellow . text) rightExt))
277−
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))
286−
287− else
288− let
289− (lefts, rights) =
290− analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)
291−
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))
298−
299−
300−unzipDiffs :: [(Text, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )
301−unzipDiffs diffPairs =
302− let
303− unzipHelp (name, (left, right)) =
304− (,) (text name, left) (text name, right)
305− in
306− unzip (map unzipHelp diffPairs)
307−
308−
309−
310−-- RECORD DIFFS HELPERS
311−
312−
313−analyzeFields :: [Text] -> [Text] -> ( [(Doc, Doc)], [(Doc, Doc)] )
314−analyzeFields leftOnly rightOnly =
315− let
316− typoPairs =
317− Help.findTypoPairs leftOnly rightOnly
318−
319− mkField func name =
320− ( func (text name), text "..." )
321−
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− )
330−
331− Nothing ->
332− ( map (mkField dullyellow) leftOnly
333− , map (mkField dullyellow) rightOnly
334− )
335−
336−
337−type Fields =
338− Map.Map Text Type.Canonical
339−
340−
341−type DoubleFields =
342− Map.Map Text (Type.Canonical,Type.Canonical)
343−
344−
345−vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)
346−vennDiagram leftFields rightFields =
347− ( Map.difference leftFields rightFields
348− , Map.intersectionWith (,) leftFields rightFields
349− , Map.difference rightFields leftFields
350− )
351−
352−
353−flattenRecord
354− :: [(Text, Type.Canonical)]
355− -> Maybe Type.Canonical
356− -> (Fields, Maybe Text)
357−flattenRecord fields ext =
358− first Map.fromList (flattenRecordHelp fields ext)
359−
360−
361−flattenRecordHelp
362− :: [(Text, Type.Canonical)]
363− -> Maybe Type.Canonical
364− -> ([(Text, Type.Canonical)], Maybe Text)
365−flattenRecordHelp fields ext =
366− case ext of
367− Nothing ->
368− (fields, Nothing)
369−
370− Just (Type.Var x) ->
371− (fields, Just x)
372−
373− Just (Type.Record subFields subExt) ->
374− flattenRecordHelp (fields ++ subFields) subExt
375−
376− Just (Type.Aliased _ args tipe) ->
377− flattenRecordHelp fields (Just (Type.dealias args tipe))
378−
379− _ ->
380− error "Trying to flatten ill-formed record."
381−
382−
383−
384−-- TYPES TO DOCS
385−
386−
387−docType :: Localizer -> Context -> Type.Canonical -> Doc
388−docType localizer context tipe =
389− case tipe of
390− Type.Lambda _ _ ->
391− docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))
392−
393− Type.Var x ->
394− text x
395−
396− Type.Type name args ->
397− docApp localizer context name args
398−
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)
407−
408− Type.Aliased name args _ ->
409− docApp localizer context name (map snd args)
410−
411−
412−
413−docLambda :: Context -> [Doc] -> Doc
414−docLambda context docs =
415− case docs of
40+apply :: Context -> Doc -> [Doc] -> Doc
41+apply context name args =
42+ case args of
41643 [] ->
417− error "cannot call docLambda with an empty list"
44+ name
41845
419− arg:rest ->
420− case context of
421− None ->
422− sep (arg : map ("->" <+>) rest)
46+ _:_ ->
47+ let
48+ applyDoc =
49+ H.hang 4 (H.sep (name : args))
50+ in
51+ case context of
52+ App -> H.cat [ "(", applyDoc, ")" ]
53+ Func -> applyDoc
54+ None -> applyDoc
42355
424− _ ->
425− cat
426− [ "("
427− , sep (arg : map ("->" <+>) rest)
428− , ")"
429− ]
43056
431−
432−
433−docApp :: Localizer -> Context -> Var.Canonical -> [Type.Canonical] -> Doc
434−docApp localizer context name args =
57+tuple :: Doc -> Doc -> Maybe Doc -> Doc
58+tuple a b maybeC =
43559 let
436− argContext =
437− if Var.isTuple name then None else App
60+ entries =
61+ case maybeC of
62+ Nothing -> [ "(" <+> a, "," <+> b ]
63+ Just c -> [ "(" <+> a, "," <+> b, "," <+> c ]
43864 in
439− docAppHelp localizer context name (map (docType localizer argContext) args)
440−
441−
442−docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc
443−docAppHelp localizer context name arguments =
444− case arguments of
445− [] ->
446− if Var.isTuple name then "()" else varToDoc localizer name
447−
448− arg : args ->
449− if Var.isTuple name then
450− sep
451− [ cat ("(" <+> arg : map ("," <+>) args)
452− , ")"
453− ]
454−
455− else
456− case context of
457− App ->
458− cat [ "(", hang 4 (sep (varToDoc localizer name : arg : args)), ")" ]
459−
460− _ ->
461− hang 4 (sep (varToDoc localizer name : arg : args))
65+ H.sep [ H.cat entries, ")" ]
46266
46367
46468
465−data Style
466− = Elide
467− | Full
468−
469−
470−docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc
471−docRecord style fields maybeExt =
472− let
473− docField (name, tipe) =
474− hang 4 (sep [ name <+> ":", tipe ])
475−
476− elision =
477− case style of
478− Full ->
479− []
480−
481− Elide ->
482− [ text "..." ]
483−
484− fieldDocs =
485− elision ++ map docField fields
486− in
487− case (fieldDocs, maybeExt) of
69+record :: [(Doc, Doc)] -> Maybe Doc -> Doc
70+record entries maybeExt =
71+ case (map entryToDoc entries, maybeExt) of
48872 ([], Nothing) ->
489− text "{}"
73+ "{}"
49074
491− (_, Nothing) ->
492− sep
493− [ cat (zipWith (<+>) ("{" : repeat ",") fieldDocs)
75+ (fields, Nothing) ->
76+ H.sep
77+ [ H.cat (zipWith (<+>) ("{" : repeat ",") fields)
49478 , "}"
49579 ]
49680
497− (_, Just ext) ->
498− sep
499− [ hang 4 $ sep $
81+ (fields, Just ext) ->
82+ H.sep
83+ [ H.hang 4 $ H.sep $
50084 [ "{" <+> ext
501− , cat (zipWith (<+>) (text "|" : repeat ",") fieldDocs)
85+ , H.cat (zipWith (<+>) ("|" : repeat ",") fields)
50286 ]
50387 , "}"
50488 ]
50589
90+
91+entryToDoc :: (Doc, Doc) -> Doc
92+entryToDoc (fieldName, fieldType) =
93+ H.hang 4 (H.sep [ fieldName <+> ":", fieldType ])
94+
95+
96+recordSnippet :: (Doc, Doc) -> [(Doc, Doc)] -> Doc
97+recordSnippet entry entries =
98+ let
99+ field = "{" <+> entryToDoc entry
100+ fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."])
101+ in
102+ H.sep [ H.cat (field:fields), "}" ]