git.iko.soy/elk
on master help sign in
Update for max tuple size of 3 in types
1aaf793Evan Czaplicki
src/Canonicalize/Type.hs+42−7
compare with master
unifiedsplit
@@ -11,8 +11,10 @@ import qualified Data.Map as Map
11import qualified AST.Type as Type
11import qualified AST.Type as Type
12import qualified Canonicalize.Environment.Dups as Dups
12import qualified Canonicalize.Environment.Dups as Dups
13import qualified Canonicalize.Environment.Internals as Env
13import qualified Canonicalize.Environment.Internals as Env
14+import qualified Elm.Name as N
14import qualified Reporting.Annotation as A
15import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Canonicalize as Error
16import qualified Reporting.Error.Canonicalize as Error
17+import qualified Reporting.Region as R
16import qualified Reporting.Result as Result
18import qualified Reporting.Result as Result
17import qualified Reporting.Warning as Warning
19import qualified Reporting.Warning as Warning
18
20
@@ -30,20 +32,21 @@ type Result i a =
30
32
31
33
32canonicalize :: Env.Env -> Type.Raw -> Result () Type.Canonical
34canonicalize :: Env.Env -> Type.Raw -> Result () Type.Canonical
33−canonicalize env (A.A _ tipe) =
35+canonicalize env (A.A typeRegion tipe) =
34 case tipe of
36 case tipe of
35 Type.RVar x ->
37 Type.RVar x ->
36 Result.ok (Type.Var x)
38 Result.ok (Type.Var x)
37
39
38 Type.RType region maybePrefix name args ->
40 Type.RType region maybePrefix name args ->
39− do info <- Env.findType region env maybePrefix name (length args)
41+ do info <- Env.findType region env maybePrefix name
40 cargs <- traverse (canonicalize env) args
42 cargs <- traverse (canonicalize env) args
41− return $
42− case info of
43+ case info of
43− Env.Alias home argNames aliasedType ->
44+ Env.Alias arity home argNames aliasedType ->
45+ checkArgs Error.AliasArgs arity typeRegion name args $
44 Type.Aliased home name (zip argNames cargs) (Type.Holey aliasedType)
46 Type.Aliased home name (zip argNames cargs) (Type.Holey aliasedType)
45
47
46− Env.Union home ->
48+ Env.Union arity home ->
49+ checkArgs Error.UnionArgs arity typeRegion name args $
47 Type.Type home name cargs
50 Type.Type home name cargs
48
51
49 Type.RLambda a b ->
52 Type.RLambda a b ->
@@ -64,4 +67,36 @@ canonicalize env (A.A _ tipe) =
64 Type.Tuple
67 Type.Tuple
65 <$> canonicalize env a
68 <$> canonicalize env a
66 <*> canonicalize env b
69 <*> canonicalize env b
70+ <*>
71+ case cs of
72+ [] ->
73+ return Nothing
74+
75+ [c] ->
67− <*> traverse (canonicalize env) cs
76+ Just <$> canonicalize env c
77+
78+ _ ->
79+ let (A.A start _, A.A end _) = (head cs, last cs) in
80+ Result.throw typeRegion $
81+ Error.TupleLargerThanThree (R.merge start end)
82+
83+
84+
85+-- CHECK ARGS
86+
87+
88+checkArgs :: Error.Args -> Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result () answer
89+checkArgs argsType expected region name args answer =
90+ let actual = length args in
91+ if expected == actual then
92+ Result.ok answer
93+ else
94+ Result.throw region $
95+ if actual < expected then
96+ Error.TooFew argsType name expected actual
97+ else
98+ let
99+ extras = drop expected args
100+ (A.A start _, A.A end _) = (head extras, last extras)
101+ in
102+ Error.TooMany argsType name expected actual (R.merge start end)
src/Type/Solve.hs+9−2
@@ -308,8 +308,15 @@ adjustRankContent youngMark visitMark groupRank content =
308 -- THEORY: a unit never needs to get generalized
308 -- THEORY: a unit never needs to get generalized
309 return outermostRank
309 return outermostRank
310
310
311− Tuple1 a b cs ->
311+ Tuple1 a b maybeC ->
312− foldM (\rank arg -> max rank <$> go arg) outermostRank (a:b:cs)
312+ do ma <- go a
313+ mb <- go b
314+ case maybeC of
315+ Nothing ->
316+ return (max ma mb)
317+
318+ Just c ->
319+ max (max ma mb) <$> go c
313
320
314 Alias _ _ args _ ->
321 Alias _ _ args _ ->
315 -- THEORY: anything in the realVar would be outermostRank
322 -- THEORY: anything in the realVar would be outermostRank
src/Type/Unify.hs+10−2
@@ -425,7 +425,7 @@ unifyFlexSuperStructure context super flatType =
425 merge context (Structure flatType)
425 merge context (Structure flatType)
426 unifyComparableRecursive (_orientation context) variable
426 unifyComparableRecursive (_orientation context) variable
427
427
428− Tuple1 a b cs ->
428+ Tuple1 a b maybeC ->
429 case super of
429 case super of
430 Number ->
430 Number ->
431 mismatch context $ Just $ Error.NotPartOfSuper super
431 mismatch context $ Just $ Error.NotPartOfSuper super
@@ -436,7 +436,15 @@ unifyFlexSuperStructure context super flatType =
436 Comparable ->
436 Comparable ->
437 do comparableOccursCheck context
437 do comparableOccursCheck context
438 merge context (Structure flatType)
438 merge context (Structure flatType)
439− mapM_ (unifyComparableRecursive (_orientation context)) (a:b:cs)
439+ let orientation = _orientation context
440+ unifyComparableRecursive orientation a
441+ unifyComparableRecursive orientation b
442+ case maybeC of
443+ Nothing ->
444+ return ()
445+
446+ Just c ->
447+ unifyComparableRecursive orientation c
440
448
441 CompAppend ->
449 CompAppend ->
442 mismatch context $ Just $ Error.NotPartOfSuper super
450 mismatch context $ Just $ Error.NotPartOfSuper super