git.iko.soy/elk
on f9de430 help sign in
elk/compiler/src/Type/Error.hs
589 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 | ArityMismatch Int Int
179 | BadFlexSuper Direction Super Name.Name Type
180 | BadRigidVar Name.Name Type
181 | BadRigidSuper Super Name.Name Type
182 | FieldTypo Name.Name [Name.Name]
183 | FieldsMissing [Name.Name]
186data Direction = Have | Need
189instance Functor Diff where
190 fmap func (Diff a b status) =
191 Diff (func a) (func b) status
194instance Applicative Diff where
195 pure a =
196 Diff a a Similar
198 (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
199 Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
202merge :: Status -> Status -> Status
203merge status1 status2 =
204 case status1 of
205 Similar ->
206 status2
208 Different problems1 ->
209 case status2 of
210 Similar ->
211 status1
213 Different problems2 ->
214 Different (Bag.append problems1 problems2)
218-- COMPARISON
221toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
222toComparison localizer tipe1 tipe2 =
223 case toDiff localizer RT.None tipe1 tipe2 of
224 Diff doc1 doc2 Similar ->
225 (doc1, doc2, [])
227 Diff doc1 doc2 (Different problems) ->
228 (doc1, doc2, Bag.toList problems)
231toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
232toDiff localizer ctx tipe1 tipe2 =
233 case (tipe1, tipe2) of
234 (Unit , Unit ) -> same localizer ctx tipe1
235 (Error , Error ) -> same localizer ctx tipe1
236 (Infinite, Infinite) -> same localizer ctx tipe1
238 (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
239 (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
240 (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
241 (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
243 (FlexVar _, _ ) -> similar localizer ctx tipe1 tipe2
244 (_ , FlexVar _) -> similar localizer ctx tipe1 tipe2
246 (FlexSuper s _, t ) | isSuper s t -> similar localizer ctx tipe1 tipe2
247 (t , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2
249 (Lambda a b cs, Lambda x y zs) ->
250 if length cs == length zs then
251 RT.lambda ctx
252 <$> toDiff localizer RT.Func a x
253 <*> toDiff localizer RT.Func b y
254 <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
255 else
256 let f = toDoc localizer RT.Func in
257 different
258 (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs)))
259 (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs)))
260 (Bag.one (ArityMismatch (2 + length cs) (2 + length zs)))
262 (Tuple a b Nothing, Tuple x y Nothing) ->
263 RT.tuple
264 <$> toDiff localizer RT.None a x
265 <*> toDiff localizer RT.None b y
266 <*> pure []
268 (Tuple a b (Just c), Tuple x y (Just z)) ->
269 RT.tuple
270 <$> toDiff localizer RT.None a x
271 <*> toDiff localizer RT.None b y
272 <*> ((:[]) <$> toDiff localizer RT.None c z)
274 (Record fields1 ext1, Record fields2 ext2) ->
275 diffRecord localizer fields1 ext1 fields2 ext2
277 (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
278 RT.apply ctx (L.toDoc localizer home1 name1)
279 <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)
281 (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
282 RT.apply ctx (L.toDoc localizer home1 name1)
283 <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))
285 -- start trying to find specific problems
287 (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
288 different
289 (nameClashToDoc ctx localizer home1 name1 args1)
290 (nameClashToDoc ctx localizer home2 name2 args2)
291 Bag.empty
293 (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
294 different
295 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
296 (toDoc localizer ctx t2)
297 (Bag.one AnythingFromMaybe)
299 (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
300 different
301 (toDoc localizer ctx t1)
302 (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
303 Bag.empty
305 (Alias home1 name1 args1 t1, t2) ->
306 case diffAliasedRecord localizer t1 t2 of
307 Just (Diff _ doc2 status) ->
308 Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status
310 Nothing ->
311 case t2 of
312 Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
313 different
314 (nameClashToDoc ctx localizer home1 name1 (map snd args1))
315 (nameClashToDoc ctx localizer home2 name2 args2)
316 Bag.empty
318 _ ->
319 different
320 (D.dullyellow (toDoc localizer ctx tipe1))
321 (D.dullyellow (toDoc localizer ctx tipe2))
322 Bag.empty
324 (t1, Alias home2 name2 args2 t2) ->
325 case diffAliasedRecord localizer t1 t2 of
326 Just (Diff doc1 _ status) ->
327 Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status
329 Nothing ->
330 case t1 of
331 Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
332 different
333 (nameClashToDoc ctx localizer home1 name1 args1)
334 (nameClashToDoc ctx localizer home2 name2 (map snd args2))
335 Bag.empty
337 _ ->
338 different
339 (D.dullyellow (toDoc localizer ctx tipe1))
340 (D.dullyellow (toDoc localizer ctx tipe2))
341 Bag.empty
343 pair ->
344 let
345 doc1 = D.dullyellow (toDoc localizer ctx tipe1)
346 doc2 = D.dullyellow (toDoc localizer ctx tipe2)
347 in
348 different doc1 doc2 $
349 case pair of
350 (RigidVar x, other) -> Bag.one $ BadRigidVar x other
351 (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other
352 (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
353 (other, RigidVar x) -> Bag.one $ BadRigidVar x other
354 (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other
355 (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
357 (Type home1 name1 [], Type home2 name2 [])
358 | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
359 | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
360 | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
361 | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
362 | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
363 | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
364 | isBool home2 name2 -> Bag.one AnythingToBool
366 (_, _) ->
367 Bag.empty
371-- DIFF HELPERS
374same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
375same localizer ctx tipe =
376 let
377 doc = toDoc localizer ctx tipe
378 in
379 Diff doc doc Similar
382similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
383similar localizer ctx t1 t2 =
384 Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
387different :: a -> a -> Bag.Bag Problem -> Diff a
388different a b problems =
389 Diff a b (Different problems)
392isSimilar :: Diff a -> Bool
393isSimilar (Diff _ _ status) =
394 case status of
395 Similar -> True
396 Different _ -> False
400-- IS TYPE?
403isBool :: ModuleName.Canonical -> Name.Name -> Bool
404isBool home name =
405 home == ModuleName.basics && name == Name.bool
408isInt :: ModuleName.Canonical -> Name.Name -> Bool
409isInt home name =
410 home == ModuleName.basics && name == Name.int
413isFloat :: ModuleName.Canonical -> Name.Name -> Bool
414isFloat home name =
415 home == ModuleName.basics && name == Name.float
418isString :: ModuleName.Canonical -> Name.Name -> Bool
419isString home name =
420 home == ModuleName.string && name == Name.string
423isChar :: ModuleName.Canonical -> Name.Name -> Bool
424isChar home name =
425 home == ModuleName.char && name == Name.char
428isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
429isMaybe home name =
430 home == ModuleName.maybe && name == Name.maybe
433isList :: ModuleName.Canonical -> Name.Name -> Bool
434isList home name =
435 home == ModuleName.list && name == Name.list
439-- IS SUPER?
442isSuper :: Super -> Type -> Bool
443isSuper super tipe =
444 case iteratedDealias tipe of
445 Type h n args ->
446 case super of
447 Number -> isInt h n || isFloat h n
448 Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
449 Appendable -> isString h n || isList h n
450 CompAppend -> isString h n || isList h n && isSuper Comparable (head args)
452 Tuple a b maybeC ->
453 case super of
454 Number -> False
455 Comparable -> isSuper super a && isSuper super b && maybe True (isSuper super) maybeC
456 Appendable -> False
457 CompAppend -> False
459 _ ->
460 False
464-- NAME CLASH
467nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc
468nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
469 RT.apply ctx
470 (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
471 (map (toDoc localizer RT.App) args)
475-- DIFF ALIASED RECORD
478diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
479diffAliasedRecord localizer t1 t2 =
480 case (iteratedDealias t1, iteratedDealias t2) of
481 (Record fields1 ext1, Record fields2 ext2) ->
482 Just (diffRecord localizer fields1 ext1 fields2 ext2)
484 _ ->
485 Nothing
489-- RECORD DIFFS
492diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc
493diffRecord localizer fields1 ext1 fields2 ext2 =
494 let
495 toUnknownDocs field tipe =
496 ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )
498 toOverlapDocs field t1 t2 =
499 (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
501 left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
502 both = Map.intersectionWithKey toOverlapDocs fields1 fields2
503 right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
505 fieldsDiff =
506 Map.elems <$>
507 if Map.null left && Map.null right then
508 sequenceA both
509 else
510 Map.union
511 <$> sequenceA both
512 <*> Diff left right (Different Bag.empty)
514 (Diff doc1 doc2 status) =
515 RT.record
516 <$> fieldsDiff
517 <*> extToDiff ext1 ext2
518 in
519 Diff doc1 doc2 $ merge status $
520 case (hasFixedFields ext1, hasFixedFields ext2) of
521 (True, True) ->
522 case Map.lookupMin left of
523 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
524 Nothing ->
525 if Map.null right
526 then Similar
527 else Different $ Bag.one $ FieldsMissing (Map.keys right)
529 (False, True) ->
530 case Map.lookupMin left of
531 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
532 Nothing -> Similar
534 (True, False) ->
535 case Map.lookupMin right of
536 Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
537 Nothing -> Similar
539 (False, False) ->
540 Similar
543hasFixedFields :: Extension -> Bool
544hasFixedFields ext =
545 case ext of
546 Closed -> True
547 FlexOpen _ -> False
548 RigidOpen _ -> True
552-- DIFF RECORD EXTENSION
555extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
556extToDiff ext1 ext2 =
557 let
558 status = extToStatus ext1 ext2
559 extDoc1 = extToDoc ext1
560 extDoc2 = extToDoc ext2
561 in
562 case status of
563 Similar ->
564 Diff extDoc1 extDoc2 status
566 Different _ ->
567 Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
570extToStatus :: Extension -> Extension -> Status
571extToStatus ext1 ext2 =
572 case ext1 of
573 Closed ->
574 case ext2 of
575 Closed -> Similar
576 FlexOpen _ -> Similar
577 RigidOpen _ -> Different Bag.empty
579 FlexOpen _ ->
580 Similar
582 RigidOpen x ->
583 case ext2 of
584 Closed -> Different Bag.empty
585 FlexOpen _ -> Similar
586 RigidOpen y ->
587 if x == y
588 then Similar
589 else Different $ Bag.one $ BadRigidVar x (RigidVar y)