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
19
20
21import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
23import Data.Monoid ((<>))
24import qualified Data.Name as Name
25
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
31
32
33
34-- ERROR TYPES
35
36
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
50
51
52data Super
53  = Number
54  | Comparable
55  | Appendable
56  | CompAppend
57  deriving (Eq)
58
59
60data Extension
61  = Closed
62  | FlexOpen Name.Name
63  | RigidOpen Name.Name
64
65
66iteratedDealias :: Type -> Type
67iteratedDealias tipe =
68  case tipe of
69    Alias _ _ _ real ->
70      iteratedDealias real
71
72    _ ->
73      tipe
74
75
76
77-- TO DOC
78
79
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)
88
89    Infinite ->
90      "∞"
91
92    Error ->
93      "?"
94
95    FlexVar name ->
96      D.fromName name
97
98    FlexSuper _ name ->
99      D.fromName name
100
101    RigidVar name ->
102      D.fromName name
103
104    RigidSuper _ name ->
105      D.fromName name
106
107    Type home name args ->
108      RT.apply ctx
109        (L.toDoc localizer home name)
110        (map (toDoc localizer RT.App) args)
111
112    Record fields ext ->
113      RT.record (fieldsToDocs localizer fields) (extToDoc ext)
114
115    Unit ->
116      "()"
117
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))
123
124    Alias home name args _ ->
125      aliasToDoc localizer ctx home name args
126
127
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)
133
134
135fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)]
136fieldsToDocs localizer fields =
137  Map.foldrWithKey (addField localizer) [] fields
138
139
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
147
148
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)
155
156
157
158-- DIFF
159
160
161data Diff a =
162  Diff a a Status
163
164
165data Status
166  = Similar
167  | Different (Bag.Bag Problem)
168
169
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]
184
185
186data Direction = Have | Need
187
188
189instance Functor Diff where
190  fmap func (Diff a b status) =
191    Diff (func a) (func b) status
192
193
194instance Applicative Diff where
195  pure a =
196    Diff a a Similar
197
198  (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
199    Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
200
201
202merge :: Status -> Status -> Status
203merge status1 status2 =
204  case status1 of
205    Similar ->
206      status2
207
208    Different problems1 ->
209      case status2 of
210        Similar ->
211          status1
212
213        Different problems2 ->
214          Different (Bag.append problems1 problems2)
215
216
217
218-- COMPARISON
219
220
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, [])
226
227    Diff doc1 doc2 (Different problems) ->
228      (doc1, doc2, Bag.toList problems)
229
230
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
237
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
242
243    (FlexVar _, _        ) -> similar localizer ctx tipe1 tipe2
244    (_        , FlexVar _) -> similar localizer ctx tipe1 tipe2
245
246    (FlexSuper s _, t            ) | isSuper s t -> similar localizer ctx tipe1 tipe2
247    (t            , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2
248
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)))
261
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 []
267
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)
273
274    (Record fields1 ext1, Record fields2 ext2) ->
275      diffRecord localizer fields1 ext1 fields2 ext2
276
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)
280
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))
284
285    -- start trying to find specific problems
286
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
292
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)
298
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
304
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
309
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
317
318            _ ->
319              different
320                (D.dullyellow (toDoc localizer ctx tipe1))
321                (D.dullyellow (toDoc localizer ctx tipe2))
322                Bag.empty
323
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
328
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
336
337            _ ->
338              different
339                (D.dullyellow (toDoc localizer ctx tipe1))
340                (D.dullyellow (toDoc localizer ctx tipe2))
341                Bag.empty
342
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
356
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
365
366          (_, _) ->
367            Bag.empty
368
369
370
371-- DIFF HELPERS
372
373
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
380
381
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
385
386
387different :: a -> a -> Bag.Bag Problem -> Diff a
388different a b problems =
389  Diff a b (Different problems)
390
391
392isSimilar :: Diff a -> Bool
393isSimilar (Diff _ _ status) =
394  case status of
395    Similar -> True
396    Different _ -> False
397
398
399
400-- IS TYPE?
401
402
403isBool :: ModuleName.Canonical -> Name.Name -> Bool
404isBool home name =
405  home == ModuleName.basics && name == Name.bool
406
407
408isInt :: ModuleName.Canonical -> Name.Name -> Bool
409isInt home name =
410  home == ModuleName.basics && name == Name.int
411
412
413isFloat :: ModuleName.Canonical -> Name.Name -> Bool
414isFloat home name =
415  home == ModuleName.basics && name == Name.float
416
417
418isString :: ModuleName.Canonical -> Name.Name -> Bool
419isString home name =
420  home == ModuleName.string && name == Name.string
421
422
423isChar :: ModuleName.Canonical -> Name.Name -> Bool
424isChar home name =
425  home == ModuleName.char && name == Name.char
426
427
428isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
429isMaybe home name =
430  home == ModuleName.maybe && name == Name.maybe
431
432
433isList :: ModuleName.Canonical -> Name.Name -> Bool
434isList home name =
435  home == ModuleName.list && name == Name.list
436
437
438
439-- IS SUPER?
440
441
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)
451
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
458
459    _ ->
460      False
461
462
463
464-- NAME CLASH
465
466
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)
472
473
474
475-- DIFF ALIASED RECORD
476
477
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)
483
484    _ ->
485      Nothing
486
487
488
489-- RECORD DIFFS
490
491
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 )
497
498    toOverlapDocs field t1 t2 =
499      (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
500
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)
504
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)
513
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)
528
529      (False, True) ->
530        case Map.lookupMin left of
531          Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
532          Nothing    -> Similar
533
534      (True, False) ->
535        case Map.lookupMin right of
536          Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
537          Nothing    -> Similar
538
539      (False, False) ->
540        Similar
541
542
543hasFixedFields :: Extension -> Bool
544hasFixedFields ext =
545  case ext of
546    Closed      -> True
547    FlexOpen _  -> False
548    RigidOpen _ -> True
549
550
551
552-- DIFF RECORD EXTENSION
553
554
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
565
566    Different _ ->
567      Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
568
569
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
578
579    FlexOpen _ ->
580      Similar
581
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)
590