@@ -6,6 +6,8 @@ module Type.Error
66 , iteratedDealias
77 , Localizer
88 , toDoc
9+ , toDiffDocs
10+ , Problem(..)
911 )
1012 where
1113
@@ -15,6 +17,7 @@ import qualified Data.Maybe as Maybe
1517import Data.Monoid ((<>))
1618
1719import qualified AST.Module.Name as ModuleName
20+import qualified Data.Bag as Bag
1821import qualified Elm.Name as N
1922import qualified Reporting.Helpers as H
2023import qualified Reporting.Render.Type as RT
@@ -63,8 +66,8 @@ type Localizer = Map.Map (ModuleName.Canonical, N.Name) String
6366
6467
6568nameToDoc :: Localizer -> ModuleName.Canonical -> N.Name -> H.Doc
66−nameToDoc localizer home@(ModuleName.Canonical _ moduleName) name =
67− case Map.lookup (home, name) localizer of
69+nameToDoc dict home@(ModuleName.Canonical _ moduleName) name =
70+ case Map.lookup (home, name) dict of
6871 Nothing ->
6972 H.nameToDoc moduleName <> "." <> H.nameToDoc name
7073
@@ -73,13 +76,13 @@ nameToDoc localizer home@(ModuleName.Canonical _ moduleName) name =
7376
7477
7578toDoc :: Localizer -> RT.Context -> Type -> H.Doc
76−toDoc localizer context tipe =
79+toDoc dict ctx tipe =
7780 case tipe of
7881 Lambda a b cs ->
79− RT.lambda context
80− (toDoc localizer RT.Func a)
81− (toDoc localizer RT.Func b)
82− (map (toDoc localizer RT.Func) cs)
82+ RT.lambda ctx
83+ (toDoc dict RT.Func a)
84+ (toDoc dict RT.Func b)
85+ (map (toDoc dict RT.Func) cs)
8386
8487 Infinite ->
8588 "∞"
@@ -100,14 +103,14 @@ toDoc localizer context tipe =
100103 H.nameToDoc name
101104
102105 Type home name args ->
103− RT.apply context
104− (nameToDoc localizer home name)
105− (map (toDoc localizer RT.App) args)
106+ RT.apply ctx
107+ (nameToDoc dict home name)
108+ (map (toDoc dict RT.App) args)
106109
107110 Record fields ext ->
108111 let
109112 entryToDocs (fieldName, fieldType) =
110− ( H.nameToDoc fieldName, toDoc localizer RT.None fieldType )
113+ ( H.nameToDoc fieldName, toDoc dict RT.None fieldType )
111114
112115 fieldDocs =
113116 map entryToDocs (Map.toList fields)
@@ -124,112 +127,278 @@ toDoc localizer context tipe =
124127
125128 Tuple a b maybeC ->
126129 RT.tuple
127− (toDoc localizer RT.None a)
128− (toDoc localizer RT.None b)
129− (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
130+ (toDoc dict RT.None a)
131+ (toDoc dict RT.None b)
132+ (map (toDoc dict RT.None) (Maybe.maybeToList maybeC))
130133
131134 Alias home name args _ ->
132− RT.apply context
133− (nameToDoc localizer home name)
134− (map (toDoc localizer RT.App . snd) args)
135+ RT.apply ctx
136+ (nameToDoc dict home name)
137+ (map (toDoc dict RT.App . snd) args)
135138
136139
137140
138−{-- DIFF
141+-- DIFF
139142
140143
141−data Diff
142− = TooFewArgs
143− |
144+toDiffDocs :: Localizer -> Type -> Type -> (H.Doc, H.Doc, [Problem])
145+toDiffDocs dict a b =
146+ case diff dict RT.None a b of
147+ Similar aDoc bDoc ->
148+ (aDoc, bDoc, [])
144149
150+ Different aDoc bDoc problems ->
151+ (aDoc, bDoc, Bag.toList problems)
145152
146153
154+data Diff a
155+ = Similar a a
156+ | Different a a (Bag.Bag Problem)
147157
148−-- DETECT MISSING ARGS
149158
159+instance Functor Diff where
160+ fmap func d =
161+ case d of
162+ Similar a b -> Similar (func a) (func b)
163+ Different a b ps -> Different (func a) (func b) ps
150164
151−detectMissingArgs :: Type -> Type -> Maybe (Type, [Type])
152−detectMissingArgs actual expected =
153− detectMissingArgsHelp (reverseArgs actual) (reverseArgs expected)
154165
166+instance Applicative Diff where
167+ pure a =
168+ Similar a a
155169
156−detectMissingArgsHelp :: [Type] -> [Type] -> Maybe (Type, [Type])
157−detectMissingArgsHelp actuals expecteds =
158− case (actuals, expecteds) of
159− (x:xs, y:ys) -> if isMatchy x y then detectMissingArgsHelp xs ys else Nothing
160− (x:xs, []) -> Just (x, xs)
161− ([], []) -> Nothing
162− ([], _:_) -> Nothing
170+ (<*>) dFunc dArg =
171+ case dFunc of
172+ Similar aFunc bFunc ->
173+ case dArg of
174+ Similar a b -> Similar (aFunc a) (bFunc b)
175+ Different a b ps -> Different (aFunc a) (bFunc b) ps
163176
177+ Different aFunc bFunc ps ->
178+ case dArg of
179+ Similar a b -> Different (aFunc a) (bFunc b) ps
180+ Different a b ps2 -> Different (aFunc a) (bFunc b) (Bag.append ps ps2)
164181
165−reverseArgs :: Type -> [Type]
166−reverseArgs tipe =
167− case tipe of
168− Lambda a b cs -> reverse (a:b:cs)
169− Infinite -> [tipe]
170− Error -> [tipe]
171− FlexVar _ -> [tipe]
172− FlexSuper _ -> [tipe]
173− RigidVar _ -> [tipe]
174− RigidSuper _ -> [tipe]
175− Type _ _ _ -> [tipe]
176− Record _ _ -> [tipe]
177− Unit -> [tipe]
178− Tuple _ _ _ -> [tipe]
179− Alias _ _ _ t -> reverseArgs t
180182
181183
182−isMatchy :: Type -> Type -> Bool
183−isMatchy t1 t2 =
184− case (t1, t2) of
185− (Lambda a b cs, Lambda x y zs) ->
186− isMatchy a x && isMatchy b y && length cs == length zs && and (zipWith isMatchy cs zs)
184+-- PROBLEMS
185+
186+
187+data Problem
188+ = IntFloat
189+ | MissingArgs Int
190+ | ReturnMismatch Int Int
191+ | TupleMismatch
192+ | BadFlexSuper N.Name Type
193+ | BadRigidVar N.Name Type
194+ | BadRigidSuper N.Name Type
195+
196+
197+
198+-- COMPUTE DIFF
199+
200+
201+diff :: Localizer -> RT.Context -> Type -> Type -> Diff H.Doc
202+diff dict ctx tipe1 tipe2 =
203+ case (tipe1, tipe2) of
204+ (FlexVar x, FlexVar y) | x == y -> pure (H.nameToDoc x)
205+ (FlexSuper x, FlexSuper y) | x == y -> pure (H.nameToDoc x)
206+ (RigidVar x, RigidVar y) | x == y -> pure (H.nameToDoc x)
207+ (RigidSuper x, RigidSuper y) | x == y -> pure (H.nameToDoc x)
208+
209+ (Infinite, Infinite) -> pure "∞"
210+ (Error, Error) -> pure "?"
211+ (Unit, Unit) -> pure "()"
212+
213+ (Tuple a b maybeC, Tuple x y maybeZ) ->
214+ RT.tuple
215+ <$> diff dict RT.None a x
216+ <*> diff dict RT.None b y
217+ <*>
218+ case (maybeC, maybeZ) of
219+ (Nothing, Nothing) -> pure []
220+ (Just c , Nothing) -> Different [H.dullyellow (toDoc dict RT.None c)] [] (Bag.one TupleMismatch)
221+ (Nothing, Just z ) -> Different [] [H.dullyellow (toDoc dict RT.None z)] (Bag.one TupleMismatch)
222+ (Just c , Just z ) -> (:[]) <$> diff dict RT.None c z
223+
224+ (Record fields1 ext1, Record fields2 ext2) -> diffRecord dict fields1 ext1 fields2 ext2
225+
226+ (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
227+ RT.apply ctx (nameToDoc dict home1 name1) <$>
228+ sequenceA (zipWith (diff dict RT.App) args1 args2)
229+
230+ (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
231+ RT.apply ctx (nameToDoc dict home1 name1) <$>
232+ sequenceA (zipWith (diff dict RT.App) (map snd args1) (map snd args2))
233+
234+ (Alias _ _ _ alias1, other) -> diff dict ctx alias1 other
235+ (other, Alias _ _ _ alias2) -> diff dict ctx other alias2
236+
237+ (Lambda a b cs, Lambda x y zs) -> diffLambda dict ctx (a:b:cs) (x:y:zs)
238+ (Lambda a b cs, result ) -> diffLambda dict ctx (a:b:cs) [result]
239+ (result , Lambda x y zs) -> diffLambda dict ctx [result] (x:y:zs)
240+
241+ (FlexVar x, other) -> Similar (H.nameToDoc x) (toDoc dict ctx other)
242+ (other, FlexVar x) -> Similar (toDoc dict ctx other) (H.nameToDoc x)
243+
244+ pair ->
245+ let
246+ doc1 = H.dullyellow (toDoc dict ctx tipe1)
247+ doc2 = H.dullyellow (toDoc dict ctx tipe2)
248+ in
249+ Different doc1 doc2 $
250+ case pair of
251+ (RigidVar x, other) -> Bag.one $ BadRigidVar x other
252+ (FlexSuper x, other) -> Bag.one $ BadFlexSuper x other
253+ (RigidSuper x, other) -> Bag.one $ BadRigidSuper x other
254+ (other, RigidVar x) -> Bag.one $ BadRigidVar x other
255+ (other, FlexSuper x) -> Bag.one $ BadFlexSuper x other
256+ (other, RigidSuper x) -> Bag.one $ BadRigidSuper x other
257+
258+ (Type home1 name1 [], Type home2 name2 []) | isIntFloat home1 name1 home2 name2 -> Bag.one IntFloat
259+
260+ (_, _) -> Bag.empty
261+
262+
263+isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
264+isIntFloat home1 name1 home2 name2 =
265+ home1 == ModuleName.basics
266+ &&
267+ home2 == ModuleName.basics
268+ &&
269+ (
270+ (name1 == N.int && name2 == N.float)
271+ ||
272+ (name1 == N.float && name2 == N.int)
273+ )
274+
275+
276+
277+-- DIFF LAMBDAS
278+
279+
280+--
281+-- INVARIANT: notNull types1 && notNull types2
282+--
283+diffLambda :: Localizer -> RT.Context -> [Type] -> [Type] -> Diff H.Doc
284+diffLambda dict ctx types1 types2 =
285+ let
286+ (result1:revArgs1) = reverse types1
287+ (result2:revArgs2) = reverse types2
288+
289+ numArgs1 = length revArgs1
290+ numArgs2 = length revArgs2
291+
292+ resultDiff = diff dict RT.Func result1 result2
293+ in
294+ case resultDiff of
295+ Similar resultDoc1 resultDoc2 ->
296+ if numArgs1 == numArgs2 then
297+ (\resultDoc revArgsDoc ->
298+ let (x:y:zs) = reverse (resultDoc:revArgsDoc) in
299+ RT.lambda ctx x y zs
300+ )
301+ <$> resultDiff
302+ <*> sequenceA (zipWith (diff dict RT.Func) revArgs1 revArgs2)
303+
304+ else if numArgs1 < numArgs2 then
305+ diffArgMismatch dict ctx revArgs1 resultDoc1 revArgs2 resultDoc2
306+
307+ else
308+ diffArgMismatch dict ctx revArgs2 resultDoc2 revArgs1 resultDoc1
309+
310+ Different resultDoc1 resultDoc2 problems ->
311+ let
312+ (x1:y1:zs1) = reverse (resultDoc1 : map (toDoc dict RT.Func) revArgs1)
313+ (x2:y2:zs2) = reverse (resultDoc2 : map (toDoc dict RT.Func) revArgs2)
314+ in
315+ Different
316+ (RT.lambda ctx x1 y1 zs1)
317+ (RT.lambda ctx x2 y2 zs2)
318+ (Bag.append (Bag.one (ReturnMismatch numArgs1 numArgs2)) problems)
319+
320+
321+--
322+-- INVARIANT: notNull shortRevArgs && notNull longRevArgs
323+--
324+diffArgMismatch :: Localizer -> RT.Context -> [Type] -> H.Doc -> [Type] -> H.Doc -> Diff H.Doc
325+diffArgMismatch dict ctx shortRevArgs shortResult longRevArgs longResult =
326+ case toGreedyMatch dict shortRevArgs longRevArgs (GreedyMatch [] []) of
327+ Just (GreedyMatch shortRevArgDocs longRevArgDocs) ->
328+ let
329+ (a:b:cs) = reverse (shortResult:shortRevArgDocs)
330+ (x:y:zs) = reverse (longResult:longRevArgDocs)
331+ in
332+ Different
333+ (RT.lambda ctx a b cs)
334+ (RT.lambda ctx x y zs)
335+ (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
336+
337+ Nothing ->
338+ case toGreedyMatch dict (reverse shortRevArgs) (reverse longRevArgs) (GreedyMatch [] []) of
339+ Just (GreedyMatch shortArgDocs longArgDocs) ->
340+ let
341+ (a:b:cs) = shortArgDocs ++ [shortResult]
342+ (x:y:zs) = longArgDocs ++ [longResult ]
343+ in
344+ Different
345+ (RT.lambda ctx a b cs)
346+ (RT.lambda ctx x y zs)
347+ (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
348+
349+ Nothing ->
350+ let
351+ toYellowDoc tipe =
352+ H.dullyellow (toDoc dict RT.Func tipe)
353+
354+ (a:b:cs) = reverse (shortResult : map toYellowDoc shortRevArgs)
355+ (x:y:zs) = reverse (longResult : map toYellowDoc longRevArgs )
356+ in
357+ Different
358+ (RT.lambda ctx a b cs)
359+ (RT.lambda ctx x y zs)
360+ (Bag.one (MissingArgs (length longRevArgs - length shortRevArgs)))
361+
187362
188− (Infinite, Infinite) ->
189− True
190363
191− (Error, Error) ->
192− True
364+-- GREEDY ARG MATCHER
193365
194− (FlexVar _, _) ->
195− True
196366
197− (_, FlexVar _) ->
198− True
367+data GreedyMatch =
368+ GreedyMatch [H.Doc] [H.Doc]
199369
200− (FlexSuper x, FlexSuper y) ->
201− x == y
202370
203− (RigidVar x, RigidVar y) ->
204− x == y
371+toGreedyMatch :: Localizer -> [Type] -> [Type] -> GreedyMatch -> Maybe GreedyMatch
372+toGreedyMatch dict shorterArgs longerArgs match@(GreedyMatch shorterDocs longerDocs) =
373+ let
374+ toYellowDoc tipe =
375+ H.dullyellow (toDoc dict RT.Func tipe)
376+ in
377+ case (shorterArgs, longerArgs) of
378+ (x:xs, y:ys) ->
379+ case diff dict RT.Func x y of
380+ Similar a b ->
381+ toGreedyMatch dict xs ys $
382+ GreedyMatch (a:shorterDocs) (b:longerDocs)
205383
206− (RigidSuper x, RigidSuper y) ->
207− x == y
384+ Different _ _ _ ->
385+ toGreedyMatch dict shorterArgs ys $
386+ GreedyMatch shorterDocs (toYellowDoc y : longerDocs)
208387
209− (Type home1 name1 args1, Type home2 name2 args2) ->
210− home1 == home2 && name1 == name2 && and (zipWith isMatchy args1 args2)
388+ ([], []) ->
389+ Just match
211390
212− (Record fields1 ext1, Record fields2 ext2) ->
213− isMatchRecord
214− (Map.size (Map.difference fields1 fields2))
215− (Map.intersectionWith isMatchy fields1 fields2)
216− (Map.size (Map.difference fields2 fields1))
391+ ([], _:_) ->
392+ Just (GreedyMatch shorterDocs (map toYellowDoc longerArgs))
217393
218− (Unit, Unit) ->
219− True
394+ (_:_, []) ->
395+ Nothing
220396
221− (Tuple a b Nothing, Tuple x y Nothing) ->
222− isMatchy a x && isMatchy b y
223397
224− (Tuple a b (Just c), Tuple x y (Just z)) ->
225− isMatchy a x && isMatchy b y && isMatchy c z
226398
227− (Alias _ _ _ alias1, tipe2) ->
228− isMatchy alias1 tipe2
399+-- RECORD DIFFS
229400
230− (tipe1, Alias _ _ _ alias2) ->
231− isMatchy tipe1 alias2
232401
233− (_, _) ->
234− False
235−-}
402+diffRecord :: Localizer -> Map.Map N.Name Type -> Extension -> Map.Map N.Name Type -> Extension -> Diff H.Doc
403+diffRecord dict fields1 ext1 fields2 ext2 =
404+ error "TODO" dict fields1 ext1 fields2 ext2