git.iko.soy/elk
on master help sign in
Complete TODO for unbound type variables in union type declarations
5fb82e2Evan Czaplicki
src/AST/Valid.hs+2−2
compare with master
unifiedsplit
@@ -88,8 +88,8 @@ data Module =
88
88
89
89
90data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
90data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
91−data Union = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])]
91+data Union = Union R.Region (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])]
92−data Alias = Alias (A.Located N.Name) [A.Located N.Name] Src.Type
92+data Alias = Alias R.Region (A.Located N.Name) [A.Located N.Name] Src.Type
93data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name
93data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name
94
94
95
95
src/Canonicalize/Environment/Local.hs+13−14
@@ -100,8 +100,8 @@ toEffectDups effects =
100addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
100addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
101addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
101addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
102 let
102 let
103− addAliasDups dups (Valid.Alias (A.At region name) _ _) = Dups.insert name region () dups
103+ addAliasDups dups (Valid.Alias _ (A.At region name) _ _) = Dups.insert name region () dups
104− addUnionDups dups (Valid.Union (A.At region name) _ _) = Dups.insert name region () dups
104+ addUnionDups dups (Valid.Union _ (A.At region name) _ _) = Dups.insert name region () dups
105 typeNameDups =
105 typeNameDups =
106 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
106 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
107 in
107 in
@@ -111,7 +111,7 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs
111
111
112
112
113addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
113addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
114−addUnion home types union@(Valid.Union (A.At _ name) _ _) =
114+addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =
115 do arity <- checkUnionFreeVars union
115 do arity <- checkUnionFreeVars union
116 let one = Map.singleton home (Env.Union arity home)
116 let one = Map.singleton home (Env.Union arity home)
117 Result.ok $ Map.insert name one types
117 Result.ok $ Map.insert name one types
@@ -133,7 +133,7 @@ addAliases aliases env =
133addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
133addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
134addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
134addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
135 case scc of
135 case scc of
136− Graph.AcyclicSCC alias@(Valid.Alias (A.At _ name) _ tipe) ->
136+ Graph.AcyclicSCC alias@(Valid.Alias _ (A.At _ name) _ tipe) ->
137 do args <- checkAliasFreeVars alias
137 do args <- checkAliasFreeVars alias
138 ctype <- Type.canonicalize env tipe
138 ctype <- Type.canonicalize env tipe
139 let one = Map.singleton home (Env.Alias (length args) home args ctype)
139 let one = Map.singleton home (Env.Alias (length args) home args ctype)
@@ -143,9 +143,9 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
143 Graph.CyclicSCC [] ->
143 Graph.CyclicSCC [] ->
144 Result.ok env
144 Result.ok env
145
145
146− Graph.CyclicSCC (alias@(Valid.Alias (A.At region name1) _ tipe) : others) ->
146+ Graph.CyclicSCC (alias@(Valid.Alias _ (A.At region name1) _ tipe) : others) ->
147 do args <- checkAliasFreeVars alias
147 do args <- checkAliasFreeVars alias
148− let toName (Valid.Alias (A.At _ name) _ _) = name
148+ let toName (Valid.Alias _ (A.At _ name) _ _) = name
149 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
149 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
150
150
151
151
@@ -154,7 +154,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
154
154
155
155
156toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
156toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
157−toNode alias@(Valid.Alias (A.At _ name) _ tipe) =
157+toNode alias@(Valid.Alias _ (A.At _ name) _ tipe) =
158 ( alias, name, getEdges [] tipe )
158 ( alias, name, getEdges [] tipe )
159
159
160
160
@@ -188,7 +188,7 @@ getEdges edges (A.At _ tipe) =
188
188
189
189
190checkUnionFreeVars :: Valid.Union -> Result i w Int
190checkUnionFreeVars :: Valid.Union -> Result i w Int
191−checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
191+checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =
192 let
192 let
193 addArg (A.At region arg) dict =
193 addArg (A.At region arg) dict =
194 Dups.insert arg region region dict
194 Dups.insert arg region region dict
@@ -202,14 +202,13 @@ checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
202 [] ->
202 [] ->
203 Result.ok (length args)
203 Result.ok (length args)
204
204
205− unbound ->
205+ unbound:unbounds ->
206− let toLoc (arg, region) = A.At region arg in
207 Result.throw $
206 Result.throw $
208− Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
207+ Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
209
208
210
209
211checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
210checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
212−checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
211+checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =
213 let
212 let
214 addArg (A.At region arg) dict =
213 addArg (A.At region arg) dict =
215 Dups.insert arg region region dict
214 Dups.insert arg region region dict
@@ -294,7 +293,7 @@ type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
294
293
295
294
296canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
295canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
297−canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias (A.At region name) args tipe) =
296+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =
298 case tipe of
297 case tipe of
299 A.At _ (Src.TRecord fields Nothing) ->
298 A.At _ (Src.TRecord fields Nothing) ->
300 do cfields <- traverse (traverse (Type.canonicalize env)) fields
299 do cfields <- traverse (traverse (Type.canonicalize env)) fields
@@ -324,7 +323,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias (A.At region nam
324
323
325
324
326canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
325canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
327−canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union (A.At _ name) avars ctors) =
326+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name) avars ctors) =
328 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
327 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
329 let vars = map A.toValue avars
328 let vars = map A.toValue avars
330 let alts = map A.toValue cctors
329 let alts = map A.toValue cctors
src/Reporting/Error/Canonicalize.hs+43−4
@@ -72,7 +72,7 @@ data Error
72 | RecursiveLet (A.Located N.Name) [N.Name]
72 | RecursiveLet (A.Located N.Name) [N.Name]
73 | Shadowing N.Name R.Region R.Region
73 | Shadowing N.Name R.Region R.Region
74 | TupleLargerThanThree R.Region
74 | TupleLargerThanThree R.Region
75− | TypeVarsUnboundInUnion R.Region N.Name [N.Name] [A.Located N.Name]
75+ | TypeVarsUnboundInUnion R.Region N.Name [N.Name] (N.Name, R.Region) [(N.Name, R.Region)]
76 | TypeVarsMessedUpInAlias R.Region N.Name [N.Name] [A.Located N.Name] [A.Located N.Name]
76 | TypeVarsMessedUpInAlias R.Region N.Name [N.Name] [A.Located N.Name] [A.Located N.Name]
77
77
78
78
@@ -735,15 +735,54 @@ toReport source err =
735 ]
735 ]
736 )
736 )
737
737
738− TypeVarsUnboundInUnion _ _ _ _ ->
738+ TypeVarsUnboundInUnion unionRegion tipe allVars (unboundVar, varRegion) unboundVars ->
739− error "TODO TypeVarsUnboundInUnion"
739+ let
740+ backQuote name =
741+ "`" <> H.nameToDoc name <> "`"
742+
743+ (title, subRegion, overview) =
744+ case map fst unboundVars of
745+ [] ->
746+ ( "UNBOUND TYPE VARIABLE"
747+ , Just varRegion
748+ , ["The",backQuote tipe,"type","uses","an","unbound","type","variable"
749+ ,H.dullyellow (backQuote unboundVar),"in","its","definition:"
750+ ]
751+ )
752+
753+ vars ->
754+ ( "UNBOUND TYPE VARIABLES"
755+ , Nothing
756+ , ["Type","variables"]
757+ ++ H.commaSep "and" H.dullyellow (H.nameToDoc unboundVar : map H.nameToDoc vars)
758+ ++ ["are","unbound","in","the",backQuote tipe,"type","definition:"]
759+ )
760+ in
761+ Report.Report title unionRegion [] $
762+ Report.toCodeSnippet source unionRegion subRegion
763+ (
764+ H.fillSep overview
765+ ,
766+ H.stack
767+ [ H.reflow $
768+ "You probably need to change the type declaration to something like this:"
769+ , H.indent 4 $ H.hsep $
770+ ["type", H.nameToDoc tipe]
771+ ++ map H.nameToDoc allVars
772+ ++ map (H.green . H.nameToDoc) (unboundVar : map fst unboundVars)
773+ ++ ["=", "..."]
774+ , H.reflow $
775+ "Why? Well, imagine one `" ++ N.toString tipe ++ "` where `" ++ N.toString unboundVar ++
776+ "` is an Int and another where it is a Bool. When we explicitly list the type\
777+ \ variables, the type checker can see that they are actually different types."
778+ ]
779+ )
740
780
741 TypeVarsMessedUpInAlias _ _ _ _ _ ->
781 TypeVarsMessedUpInAlias _ _ _ _ _ ->
742 error "TODO TypeVarsMessedUpInAlias"
782 error "TODO TypeVarsMessedUpInAlias"
743
783
744
784
745
785
746−
747-- UnboundTypeVarsInUnion typeName givenVars unbound ->
786-- UnboundTypeVarsInUnion typeName givenVars unbound ->
748-- unboundTypeVars "type" typeName givenVars unbound
787-- unboundTypeVars "type" typeName givenVars unbound
749
788
src/Validate.hs+2−2
@@ -69,11 +69,11 @@ vsdHelp decls stuff =
69 A.At region decl : otherDecls ->
69 A.At region decl : otherDecls ->
70 case decl of
70 case decl of
71 Src.Union name tvars ctors ->
71 Src.Union name tvars ctors ->
72− do let union = Valid.Union name tvars ctors
72+ do let union = Valid.Union region name tvars ctors
73 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
73 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
74
74
75 Src.Alias name tvars tipe ->
75 Src.Alias name tvars tipe ->
76− do let alias = Valid.Alias name tvars tipe
76+ do let alias = Valid.Alias region name tvars tipe
77 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
77 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
78
78
79 Src.Binop op assoc prec val ->
79 Src.Binop op assoc prec val ->