on master help sign in
Update for max tuple size of 3 in types

Also move arity check of unions and aliases out into Canonicalize.Type

commit1aaf7939649db8c3cd9dc39a08428ee4af5394ab authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 6 Nov 2017, 15:01 (9 years ago) parentf3ae567
3 files changed+61−11
src/Canonicalize/Type.hs+42−7 src/Type/Solve.hs+9−2 src/Type/Unify.hs+10−2
src/Canonicalize/Type.hs+42−7
@@ -11,8 +11,10 @@ import qualified Data.Map as Map
1111import qualified AST.Type as Type
1212import qualified Canonicalize.Environment.Dups as Dups
1313import qualified Canonicalize.Environment.Internals as Env
14+import qualified Elm.Name as N
1415import qualified Reporting.Annotation as A
1516import qualified Reporting.Error.Canonicalize as Error
17+import qualified Reporting.Region as R
1618import qualified Reporting.Result as Result
1719import qualified Reporting.Warning as Warning
1820
@@ -30,20 +32,21 @@ type Result i a =
3032
3133
3234canonicalize :: Env.Env -> Type.Raw -> Result () Type.Canonical
33−canonicalize env (A.A _ tipe) =
35+canonicalize env (A.A typeRegion tipe) =
3436 case tipe of
3537 Type.RVar x ->
3638 Result.ok (Type.Var x)
3739
3840 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
4042 cargs <- traverse (canonicalize env) args
41− return $
42− case info of
43− Env.Alias home argNames aliasedType ->
43+ case info of
44+ Env.Alias arity home argNames aliasedType ->
45+ checkArgs Error.AliasArgs arity typeRegion name args $
4446 Type.Aliased home name (zip argNames cargs) (Type.Holey aliasedType)
4547
46− Env.Union home ->
48+ Env.Union arity home ->
49+ checkArgs Error.UnionArgs arity typeRegion name args $
4750 Type.Type home name cargs
4851
4952 Type.RLambda a b ->
@@ -64,4 +67,36 @@ canonicalize env (A.A _ tipe) =
6467 Type.Tuple
6568 <$> canonicalize env a
6669 <*> canonicalize env b
67− <*> traverse (canonicalize env) cs
70+ <*>
71+ case cs of
72+ [] ->
73+ return Nothing
74+
75+ [c] ->
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 =
308308 -- THEORY: a unit never needs to get generalized
309309 return outermostRank
310310
311− Tuple1 a b cs ->
312− foldM (\rank arg -> max rank <$> go arg) outermostRank (a:b:cs)
311+ Tuple1 a b maybeC ->
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
313320
314321 Alias _ _ args _ ->
315322 -- THEORY: anything in the realVar would be outermostRank
src/Type/Unify.hs+10−2
@@ -425,7 +425,7 @@ unifyFlexSuperStructure context super flatType =
425425 merge context (Structure flatType)
426426 unifyComparableRecursive (_orientation context) variable
427427
428− Tuple1 a b cs ->
428+ Tuple1 a b maybeC ->
429429 case super of
430430 Number ->
431431 mismatch context $ Just $ Error.NotPartOfSuper super
@@ -436,7 +436,15 @@ unifyFlexSuperStructure context super flatType =
436436 Comparable ->
437437 do comparableOccursCheck context
438438 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
440448
441449 CompAppend ->
442450 mismatch context $ Just $ Error.NotPartOfSuper super