git.iko.soy/elk
on master help sign in
Update Type.Unify for new AST
8713bd9Evan Czaplicki
src/AST/Module/Name.hs+7−1
compare with master
unifiedsplit
@@ -3,7 +3,8 @@
3module AST.Module.Name
3module AST.Module.Name
4 ( Canonical(..)
4 ( Canonical(..)
5 , basics, maybe, list, array
5 , basics, maybe, list, array
6− , jsonEncode, cmd, sub
6+ , jsonDecode, jsonEncode
7+ , cmd, sub
7 , canonicalToText
8 , canonicalToText
8 , isKernel, getKernel, canonicalIsKernel
9 , isKernel, getKernel, canonicalIsKernel
9 )
10 )
@@ -55,6 +56,11 @@ array =
55 Canonical Pkg.core "Array"
56 Canonical Pkg.core "Array"
56
57
57
58
59+jsonDecode :: Canonical
60+jsonDecode =
61+ Canonical Pkg.core "Json.Decode"
62+
63+
58jsonEncode :: Canonical
64jsonEncode :: Canonical
59jsonEncode =
65jsonEncode =
60 Canonical Pkg.core "Json.Encode"
66 Canonical Pkg.core "Json.Encode"
src/Type/Unify.hs+54−39
@@ -8,8 +8,9 @@ import qualified Data.Map.Strict as Map
8import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
9import Data.Text (Text)
9import Data.Text (Text)
10
10
11+import qualified AST.Module.Name as ModuleName
11import AST.Type (Super(..))
12import AST.Type (Super(..))
12−import qualified AST.Variable as Var
13+import qualified Elm.Name as N
13import qualified Reporting.Region as R
14import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
15import qualified Reporting.Error.Type as Error
15import qualified Type.Occurs as Occurs
16import qualified Type.Occurs as Occurs
@@ -130,8 +131,8 @@ detectDecoder :: Variable -> IO Bool
130detectDecoder variable =
131detectDecoder variable =
131 do (Descriptor content _ _ _) <- UF.descriptor variable
132 do (Descriptor content _ _ _) <- UF.descriptor variable
132 case content of
133 case content of
133− Structure (App1 name [_]) | Var.decoder == name ->
134+ Structure (App1 home name [_]) ->
134− return True
135+ return (home == ModuleName.jsonDecode && name == "Decoder")
135
136
136 _ ->
137 _ ->
137 return False
138 return False
@@ -198,8 +199,8 @@ actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor
198 RigidSuper super name ->
199 RigidSuper super name ->
199 unifyRigid context (Just super) name firstContent secondContent
200 unifyRigid context (Just super) name firstContent secondContent
200
201
201− Alias name args realVar ->
202+ Alias home name args realVar ->
202− unifyAlias context name args realVar secondContent
203+ unifyAlias context home name args realVar secondContent
203
204
204 Structure flatType ->
205 Structure flatType ->
205 unifyStructure context flatType firstContent secondContent
206 unifyStructure context flatType firstContent secondContent
@@ -234,7 +235,7 @@ unifyFlex context otherContent =
234 RigidSuper _ _ ->
235 RigidSuper _ _ ->
235 merge context otherContent
236 merge context otherContent
236
237
237− Alias _ _ _ ->
238+ Alias _ _ _ _ ->
238 merge context otherContent
239 merge context otherContent
239
240
240 Structure _ ->
241 Structure _ ->
@@ -272,7 +273,7 @@ unifyRigid context maybeSuper name content otherContent =
272 mismatch context $ Just $
273 mismatch context $ Just $
273 Error.RigidClash name otherName
274 Error.RigidClash name otherName
274
275
275− Alias otherName _ _ ->
276+ Alias _ otherName _ _ ->
276 mismatch context $ Just $
277 mismatch context $ Just $
277 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
278 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
278 Error.SpecificType otherName
279 Error.SpecificType otherName
@@ -289,7 +290,7 @@ unifyRigid context maybeSuper name content otherContent =
289flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
290flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
290flatTypeToSpecificThing flatType =
291flatTypeToSpecificThing flatType =
291 case flatType of
292 case flatType of
292− App1 name _ ->
293+ App1 _ name _ ->
293 Error.SpecificType name
294 Error.SpecificType name
294
295
295 Fun1 _ _ ->
296 Fun1 _ _ ->
@@ -301,6 +302,12 @@ flatTypeToSpecificThing flatType =
301 Record1 _ _ ->
302 Record1 _ _ ->
302 Error.SpecificRecord
303 Error.SpecificRecord
303
304
305+ Unit1 ->
306+ Error.SpecificUnit
307+
308+ Tuple1 _ _ _ ->
309+ Error.SpecificTuple
310+
304
311
305
312
306-- UNIFY SUPER VARIABLES
313-- UNIFY SUPER VARIABLES
@@ -355,7 +362,7 @@ unifyFlexSuper context super content otherContent =
355 CompAppend -> merge context content
362 CompAppend -> merge context content
356 Number -> mismatch context Nothing -- Error.NumberAppendableClash
363 Number -> mismatch context Nothing -- Error.NumberAppendableClash
357
364
358− Alias _ _ realVar ->
365+ Alias _ _ _ realVar ->
359 subUnify context (_first context) realVar
366 subUnify context (_first context) realVar
360
367
361 Error _ ->
368 Error _ ->
@@ -369,32 +376,38 @@ combineRigidSupers rigid flex =
369 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
376 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
370
377
371
378
372−atomMatchesSuper :: Super -> Var.Canonical -> Bool
379+atomMatchesSuper :: Super -> ModuleName.Canonical -> N.Name -> Bool
373−atomMatchesSuper super name =
380+atomMatchesSuper super home name =
381+ home == ModuleName.basics
382+ &&
374 case super of
383 case super of
375 Number ->
384 Number ->
376− elem name [ Var.int, Var.float ]
385+ name == N.int
386+ || name == N.float
377
387
378 Comparable ->
388 Comparable ->
379− elem name [ Var.string, Var.int, Var.float, Var.char]
389+ name == N.int
390+ || name == N.float
391+ || name == N.string
392+ || name == N.char
380
393
381 Appendable ->
394 Appendable ->
382− name == Var.string
395+ name == N.string
383
396
384 CompAppend ->
397 CompAppend ->
385− name == Var.string
398+ name == N.string
386
399
387
400
388unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
401unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
389unifyFlexSuperStructure context super flatType =
402unifyFlexSuperStructure context super flatType =
390 case flatType of
403 case flatType of
391− App1 name [] ->
404+ App1 home name [] ->
392− if atomMatchesSuper super name then
405+ if atomMatchesSuper super home name then
393 merge context (Structure flatType)
406 merge context (Structure flatType)
394 else
407 else
395 mismatch context $ Just $ Error.NotPartOfSuper super
408 mismatch context $ Just $ Error.NotPartOfSuper super
396
409
397− App1 name [variable] | name == Var.list ->
410+ App1 home name [variable] | home == ModuleName.list && name == N.list ->
398 case super of
411 case super of
399 Number ->
412 Number ->
400 mismatch context $ Just $ Error.NotPartOfSuper super
413 mismatch context $ Just $ Error.NotPartOfSuper super
@@ -412,7 +425,7 @@ unifyFlexSuperStructure context super flatType =
412 merge context (Structure flatType)
425 merge context (Structure flatType)
413 unifyComparableRecursive (_orientation context) variable
426 unifyComparableRecursive (_orientation context) variable
414
427
415− App1 name args | Var.isTuple name ->
428+ Tuple1 a b cs ->
416 case super of
429 case super of
417 Number ->
430 Number ->
418 mismatch context $ Just $ Error.NotPartOfSuper super
431 mismatch context $ Just $ Error.NotPartOfSuper super
@@ -421,13 +434,9 @@ unifyFlexSuperStructure context super flatType =
421 mismatch context $ Just $ Error.NotPartOfSuper super
434 mismatch context $ Just $ Error.NotPartOfSuper super
422
435
423 Comparable ->
436 Comparable ->
424− if length args > 6 then
425− mismatch context (Just (Error.TooLongComparableTuple (length args)))
426−
427− else
428− do comparableOccursCheck context
437+ do comparableOccursCheck context
429− merge context (Structure flatType)
438+ merge context (Structure flatType)
430− mapM_ (unifyComparableRecursive (_orientation context)) args
439+ mapM_ (unifyComparableRecursive (_orientation context)) (a:b:cs)
431
440
432 CompAppend ->
441 CompAppend ->
433 mismatch context $ Just $ Error.NotPartOfSuper super
442 mismatch context $ Just $ Error.NotPartOfSuper super
@@ -461,11 +470,11 @@ unifyComparableRecursive orientation var =
461-- UNIFY ALIASES
470-- UNIFY ALIASES
462
471
463
472
464−unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
473+unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(Text, Variable)] -> Variable -> Content -> Unify ()
465−unifyAlias context name args realVar otherContent =
474+unifyAlias context home name args realVar otherContent =
466 case otherContent of
475 case otherContent of
467 FlexVar _ ->
476 FlexVar _ ->
468− merge context (Alias name args realVar)
477+ merge context (Alias home name args realVar)
469
478
470 FlexSuper _ _ ->
479 FlexSuper _ _ ->
471 subUnify context realVar (_second context)
480 subUnify context realVar (_second context)
@@ -476,8 +485,8 @@ unifyAlias context name args realVar otherContent =
476 RigidSuper _ _ ->
485 RigidSuper _ _ ->
477 subUnify context realVar (_second context)
486 subUnify context realVar (_second context)
478
487
479− Alias otherName otherArgs otherRealVar ->
488+ Alias otherHome otherName otherArgs otherRealVar ->
480− if name == otherName then
489+ if name == otherName && home == otherHome then
481 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
490 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
482 merge context otherContent
491 merge context otherContent
483
492
@@ -510,17 +519,17 @@ unifyStructure context flatType content otherContent =
510 RigidSuper super name ->
519 RigidSuper super name ->
511 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
520 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
512
521
513− Alias _ _ realVar ->
522+ Alias _ _ _ realVar ->
514 subUnify context (_first context) realVar
523 subUnify context (_first context) realVar
515
524
516 Structure otherTerm ->
525 Structure otherTerm ->
517 case (flatType, otherTerm) of
526 case (flatType, otherTerm) of
518− (App1 name args, App1 otherName otherArgs) ->
527+ (App1 home name args, App1 otherHome otherName otherArgs) ->
519− if name == otherName then
528+ if home == otherHome && name == otherName then
520 do zipWithM_ (subUnify context) args otherArgs
529 do zipWithM_ (subUnify context) args otherArgs
521 merge context otherContent
530 merge context otherContent
522
531
523− else if isIntFloat name otherName || isIntFloat otherName name then
532+ else if isIntFloat home name otherHome otherName then
524 mismatch context (Just Error.IntFloat)
533 mismatch context (Just Error.IntFloat)
525
534
526 else
535 else
@@ -553,9 +562,15 @@ unifyStructure context flatType content otherContent =
553
562
554
563
555
564
556−isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
565+isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
557−isIntFloat name otherName =
566+isIntFloat home name otherHome otherName =
558− Var.isPrim "Int" name && Var.isPrim "Float" otherName
567+ otherHome == ModuleName.basics
568+ && home == ModuleName.basics
569+ && (
570+ (name == N.int && otherName == N.float)
571+ ||
572+ (name == N.float && otherName == N.int)
573+ )
559
574
560
575
561
576
@@ -668,7 +683,7 @@ gatherFields context fields variable =
668 Structure EmptyRecord1 ->
683 Structure EmptyRecord1 ->
669 return (RecordStructure fields variable Empty)
684 return (RecordStructure fields variable Empty)
670
685
671− Alias _ _ var ->
686+ Alias _ _ _ var ->
672 -- TODO may be dropping useful alias info here
687 -- TODO may be dropping useful alias info here
673 gatherFields context fields var
688 gatherFields context fields var
674
689