git.iko.soy/elk
on 7d2da8d help sign in
elk/compiler/src/Type/Error.hs
583 lines 16 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Error
4 ( Type(..)
5 , Super(..)
6 , Extension(..)
7 , iteratedDealias
8 , toDoc
9 , Problem(..)
10 , Direction(..)
11 , toComparison
12 , isInt
13 , isFloat
14 , isString
15 , isChar
16 , isList
17 )
18 where
21import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
23import Data.Monoid ((<>))
24import qualified Data.Name as Name
26import qualified Data.Bag as Bag
27import qualified Elm.ModuleName as ModuleName
28import qualified Reporting.Doc as D
29import qualified Reporting.Render.Type as RT
30import qualified Reporting.Render.Type.Localizer as L
34-- ERROR TYPES
37data Type
38 = Lambda Type Type [Type]
39 | Infinite
40 | Error
41 | FlexVar Name.Name
42 | FlexSuper Super Name.Name
43 | RigidVar Name.Name
44 | RigidSuper Super Name.Name
45 | Type ModuleName.Canonical Name.Name [Type]
46 | Record (Map.Map Name.Name Type) Extension
47 | Unit
48 | Tuple Type Type (Maybe Type)
49 | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type
52data Super
53 = Number
54 | Comparable
55 | Appendable
56 | CompAppend
57 deriving (Eq)
60data Extension
61 = Closed
62 | FlexOpen Name.Name
63 | RigidOpen Name.Name
66iteratedDealias :: Type -> Type
67iteratedDealias tipe =
68 case tipe of
69 Alias _ _ _ real ->
70 iteratedDealias real
72 _ ->
73 tipe
77-- TO DOC
80toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
81toDoc localizer ctx tipe =
82 case tipe of
83 Lambda a b cs ->
84 RT.lambda ctx
85 (toDoc localizer RT.Func a)
86 (toDoc localizer RT.Func b)
87 (map (toDoc localizer RT.Func) cs)
89 Infinite ->
90 "∞"
92 Error ->
93 "?"
95 FlexVar name ->
96 D.fromName name
98 FlexSuper _ name ->
99 D.fromName name
101 RigidVar name ->
102 D.fromName name
104 RigidSuper _ name ->
105 D.fromName name
107 Type home name args ->
108 RT.apply ctx
109 (L.toDoc localizer home name)
110 (map (toDoc localizer RT.App) args)
112 Record fields ext ->
113 RT.record (fieldsToDocs localizer fields) (extToDoc ext)
115 Unit ->
116 "()"
118 Tuple a b maybeC ->
119 RT.tuple
120 (toDoc localizer RT.None a)
121 (toDoc localizer RT.None b)
122 (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))
124 Alias home name args _ ->
125 aliasToDoc localizer ctx home name args
128aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc
129aliasToDoc localizer ctx home name args =
130 RT.apply ctx
131 (L.toDoc localizer home name)
132 (map (toDoc localizer RT.App . snd) args)
135fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)]
136fieldsToDocs localizer fields =
137 Map.foldrWithKey (addField localizer) [] fields
140addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
141addField localizer fieldName fieldType docs =
142 let
143 f = D.fromName fieldName
144 t = toDoc localizer RT.None fieldType
145 in
146 (f,t) : docs
149extToDoc :: Extension -> Maybe D.Doc
150extToDoc ext =
151 case ext of
152 Closed -> Nothing
153 FlexOpen x -> Just (D.fromName x)
154 RigidOpen x -> Just (D.fromName x)
158-- DIFF
161data Diff a =
162 Diff a a Status
165data Status
166 = Similar
167 | Different (Bag.Bag Problem)
170data Problem
171 = IntFloat
172 | StringFromInt
173 | StringFromFloat
174 | StringToInt
175 | StringToFloat
176 | AnythingToBool
177 | AnythingFromMaybe
178 | AnythingToList
179 | ArityMismatch Int Int
180 | BadFlexSuper Direction Super Name.Name Type
181 | BadRigidVar Name.Name Type
182 | BadRigidSuper Super Name.Name Type
183 | FieldTypo Name.Name [Name.Name]
184 | FieldsMissing [Name.Name]
187data Direction = Have | Need
190instance Functor Diff where
191 fmap func (Diff a b status) =
192 Diff (func a) (func b) status
195instance Applicative Diff where
196 pure a =
197 Diff a a Similar
199 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
200 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
203merge :: Status -> Status -> Status
204merge status1 status2 =
205 case status1 of
206 Similar ->
207 status2
209 Different problems1 ->
210 case status2 of
211 Similar ->
212 status1
214 Different problems2 ->
215 Different (Bag.append problems1 problems2)
219-- COMPARISON
222toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
223toComparison localizer tipe1 tipe2 =
224 case toDiff localizer RT.None tipe1 tipe2 of
225 Diff doc1 doc2 Similar ->
226 (doc1, doc2, [])
228 Diff doc1 doc2 (Different problems) ->
229 (doc1, doc2, Bag.toList problems)
232toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
233toDiff localizer ctx tipe1 tipe2 =
234 case (tipe1, tipe2) of
235 (Unit , Unit ) -> same localizer ctx tipe1
236 (Error , Error ) -> same localizer ctx tipe1
237 (Infinite, Infinite) -> same localizer ctx tipe1
239 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
240 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
241 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
242 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
244 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2
245 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2
247 (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2
248 (t , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2
250 (Lambda a b cs, Lambda x y zs) ->
251 if length cs == length zs then
252 RT.lambda ctx
253 <$> toDiff localizer RT.Func a x
254 <*> toDiff localizer RT.Func b y
255 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
256 else
257 let f = toDoc localizer RT.Func in
258 different
259 (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs)))
260 (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs)))
261 (Bag.one (ArityMismatch (2 + length cs) (2 + length zs)))
263 (Tuple a b Nothing, Tuple x y Nothing) ->
264 RT.tuple
265 <$> toDiff localizer RT.None a x
266 <*> toDiff localizer RT.None b y
267 <*> pure []
269 (Tuple a b (Just c), Tuple x y (Just z)) ->
270 RT.tuple
271 <$> toDiff localizer RT.None a x
272 <*> toDiff localizer RT.None b y
273 <*> ((:[]) <$> toDiff localizer RT.None c z)
275 (Record fields1 ext1, Record fields2 ext2) ->
276 diffRecord localizer fields1 ext1 fields2 ext2
278 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
279 RT.apply ctx (L.toDoc localizer home1 name1)
280 <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)
282 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
283 RT.apply ctx (L.toDoc localizer home1 name1)
284 <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))
286 -- start trying to find specific problems
288 (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
289 different
290 (nameClashToDoc ctx localizer home1 name1 args1)
291 (nameClashToDoc ctx localizer home2 name2 args2)
292 Bag.empty
294 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
295 different
296 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
297 (toDoc localizer ctx t2)
298 (Bag.one AnythingFromMaybe)
300 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
301 different
302 (toDoc localizer ctx t1)
303 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
304 (Bag.one AnythingToList)
306 (Alias home1 name1 args1 t1, t2) ->
307 case diffAliasedRecord localizer t1 t2 of
308 Just (Diff _ doc2 status) ->
309 Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status
311 Nothing ->
312 case t2 of
313 Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
314 different
315 (nameClashToDoc ctx localizer home1 name1 (map snd args1))
316 (nameClashToDoc ctx localizer home2 name2 args2)
317 Bag.empty
319 _ ->
320 different
321 (D.dullyellow (toDoc localizer ctx tipe1))
322 (D.dullyellow (toDoc localizer ctx tipe2))
323 Bag.empty
325 (t1, Alias home2 name2 args2 t2) ->
326 case diffAliasedRecord localizer t1 t2 of
327 Just (Diff doc1 _ status) ->
328 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status
330 Nothing ->
331 case t1 of
332 Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
333 different
334 (nameClashToDoc ctx localizer home1 name1 args1)
335 (nameClashToDoc ctx localizer home2 name2 (map snd args2))
336 Bag.empty
338 _ ->
339 different
340 (D.dullyellow (toDoc localizer ctx tipe1))
341 (D.dullyellow (toDoc localizer ctx tipe2))
342 Bag.empty
344 pair ->
345 let
346 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
347 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
348 in
349 different doc1 doc2 $
350 case pair of
351 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
352 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other
353 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
354 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
355 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other
356 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
358 (Type home1 name1 [], Type home2 name2 [])
359 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
360 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
361 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
362 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
363 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
364 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
365 | isBool home2 name2 -> Bag.one AnythingToBool
367 (_, _) ->
368 Bag.empty
372-- DIFF HELPERS
375same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
376same localizer ctx tipe =
377 let
378 doc = toDoc localizer ctx tipe
379 in
380 Diff doc doc Similar
383similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
384similar localizer ctx t1 t2 =
385 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
388different :: a -> a -> Bag.Bag Problem -> Diff a
389different a b problems =
390 Diff a b (Different problems)
393isSimilar :: Diff a -> Bool
394isSimilar (Diff _ _ status) =
395 case status of
396 Similar -> True
397 Different _ -> False
401-- IS TYPE?
404isBool :: ModuleName.Canonical -> Name.Name -> Bool
405isBool home name =
406 home == ModuleName.basics && name == Name.bool
409isInt :: ModuleName.Canonical -> Name.Name -> Bool
410isInt home name =
411 home == ModuleName.basics && name == Name.int
414isFloat :: ModuleName.Canonical -> Name.Name -> Bool
415isFloat home name =
416 home == ModuleName.basics && name == Name.float
419isString :: ModuleName.Canonical -> Name.Name -> Bool
420isString home name =
421 home == ModuleName.string && name == Name.string
424isChar :: ModuleName.Canonical -> Name.Name -> Bool
425isChar home name =
426 home == ModuleName.char && name == Name.char
429isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
430isMaybe home name =
431 home == ModuleName.maybe && name == Name.maybe
434isList :: ModuleName.Canonical -> Name.Name -> Bool
435isList home name =
436 home == ModuleName.list && name == Name.list
440-- IS SUPER?
443isSuper :: Super -> Type -> Bool
444isSuper super tipe =
445 case iteratedDealias tipe of
446 Type h n args ->
447 case super of
448 Number -> isInt h n || isFloat h n
449 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
450 Appendable -> isString h n || isList h n
451 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
453 _ ->
454 False
458-- NAME CLASH
461nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc
462nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
463 RT.apply ctx
464 (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
465 (map (toDoc localizer RT.App) args)
469-- DIFF ALIASED RECORD
472diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
473diffAliasedRecord localizer t1 t2 =
474 case (iteratedDealias t1, iteratedDealias t2) of
475 (Record fields1 ext1, Record fields2 ext2) ->
476 Just (diffRecord localizer fields1 ext1 fields2 ext2)
478 _ ->
479 Nothing
483-- RECORD DIFFS
486diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc
487diffRecord localizer fields1 ext1 fields2 ext2 =
488 let
489 toUnknownDocs field tipe =
490 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
492 toOverlapDocs field t1 t2 =
493 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
495 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
496 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
497 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
499 fieldsDiff =
500 Map.elems <$>
501 if Map.null left && Map.null right then
502 sequenceA both
503 else
504 Map.union
505 <$> sequenceA both
506 <*> Diff left right (Different Bag.empty)
508 (Diff doc1 doc2 status) =
509 RT.record
510 <$> fieldsDiff
511 <*> extToDiff ext1 ext2
512 in
513 Diff doc1 doc2 $ merge status $
514 case (hasFixedFields ext1, hasFixedFields ext2) of
515 (True, True) ->
516 case Map.lookupMin left of
517 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
518 Nothing ->
519 if Map.null right
520 then Similar
521 else Different $ Bag.one $ FieldsMissing (Map.keys right)
523 (False, True) ->
524 case Map.lookupMin left of
525 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
526 Nothing -> Similar
528 (True, False) ->
529 case Map.lookupMin right of
530 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
531 Nothing -> Similar
533 (False, False) ->
534 Similar
537hasFixedFields :: Extension -> Bool
538hasFixedFields ext =
539 case ext of
540 Closed -> True
541 FlexOpen _ -> False
542 RigidOpen _ -> True
546-- DIFF RECORD EXTENSION
549extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
550extToDiff ext1 ext2 =
551 let
552 status = extToStatus ext1 ext2
553 extDoc1 = extToDoc ext1
554 extDoc2 = extToDoc ext2
555 in
556 case status of
557 Similar ->
558 Diff extDoc1 extDoc2 status
560 Different _ ->
561 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
564extToStatus :: Extension -> Extension -> Status
565extToStatus ext1 ext2 =
566 case ext1 of
567 Closed ->
568 case ext2 of
569 Closed -> Similar
570 FlexOpen _ -> Similar
571 RigidOpen _ -> Different Bag.empty
573 FlexOpen _ ->
574 Similar
576 RigidOpen x ->
577 case ext2 of
578 Closed -> Different Bag.empty
579 FlexOpen _ -> Similar
580 RigidOpen y ->
581 if x == y
582 then Similar
583 else Different $ Bag.one $ BadRigidVar x (RigidVar y)