@@ -23,12 +23,14 @@ mistakes :: [D.ValidDecl] -> [Doc]
2323mistakes decls =
2424 concat
2525 [ infiniteTypeAliases decls
26− , illFormedTypes decls
26+ , illFormedTypeDecls decls
2727 , map P.text (duplicateTypeDeclarations decls)
2828 , map P.text (duplicateValues decls)
2929 ]
3030
3131
32+-- DUPLICATES
33+
3234dups :: Ord a => [a] -> [a]
3335dups names =
3436 List.sort names
@@ -97,82 +99,118 @@ dupCtorError name =
9799 ++ " something should be renamed or moved to a different module."
98100
99101
100−illFormedTypes :: [D.ValidDecl] -> [Doc]
101−illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
102− where
103− aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
104− adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
105−
106− freeVars tipe =
107− case tipe of
108− T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
109− T.Var x -> Set.singleton x
110− T.Type _ -> Set.empty
111− T.App t ts -> Set.unions (map freeVars (t:ts))
112− T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
113− where ext' = maybe Set.empty freeVars ext
114− T.Aliased _ t -> freeVars t
115−
116− undeclared tvars tipes = Set.difference used declared
117− where
118− used = Set.unions (map freeVars tipes)
119− declared = Set.fromList tvars
120−
121− isIllFormed (decl, tvars, tipes) =
122− let unbound = undeclared tvars tipes in
123− if Set.null unbound then Nothing
124− else Just (decl, Set.toList unbound)
125−
126− report (decl, tvars) =
127− P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
128− , P.text "\n"
129− , nest 4 (pretty decl) ]
130− where
131− listing =
132− case tvars of
133− [tvar] -> " " ++ quote tvar ++ " is"
134− _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
135−
136− addCommas xs
137− | length xs < 3 = concat xs
138− | otherwise = List.intercalate "," xs
139−
140− addAnd xs
141− | length xs < 2 = xs
142− | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
143−
144− quote tvar = "'" ++ tvar ++ "'"
102+-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
103+
104+illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
105+illFormedTypeDecls decls =
106+ map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
107+ where
108+ aliases =
109+ [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
110+
111+ adts =
112+ [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
113+
114+ freeVars tipe =
115+ case tipe of
116+ T.Lambda t1 t2 ->
117+ Set.union (freeVars t1) (freeVars t2)
118+
119+ T.Var x ->
120+ Set.singleton x
121+
122+ T.Type _ ->
123+ Set.empty
124+
125+ T.App t ts ->
126+ Set.unions (map freeVars (t:ts))
127+
128+ T.Record fields ext ->
129+ let ext' = maybe Set.empty freeVars ext
130+ in
131+ Set.unions (ext' : map (freeVars . snd) fields)
145132
133+ T.Aliased _ t ->
134+ freeVars t
135+
136+ undeclared tvars tipes =
137+ Set.difference used declared
138+ where
139+ used = Set.unions (map freeVars tipes)
140+ declared = Set.fromList tvars
141+
142+ isIllFormed (decl, tvars, tipes) =
143+ let unbound = undeclared tvars tipes in
144+ if Set.null unbound
145+ then Nothing
146+ else Just (decl, Set.toList unbound)
147+
148+ report (decl, tvars) =
149+ P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
150+ , P.text "\n"
151+ , nest 4 (pretty decl) ]
152+ where
153+ listing =
154+ case tvars of
155+ [tvar] -> " " ++ quote tvar ++ " is"
156+ _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
157+
158+ addCommas xs
159+ | length xs < 3 = concat xs
160+ | otherwise = List.intercalate "," xs
161+
162+ addAnd xs
163+ | length xs < 2 = xs
164+ | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
165+
166+ quote tvar = "'" ++ tvar ++ "'"
167+
168+
169+-- INFINITE TYPE ALIASES
146170
147171infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
148172infiniteTypeAliases decls =
149− [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
150− , infiniteType name tipe ]
151− where
152− infiniteType :: String -> T.Type Var.Raw -> Bool
153− infiniteType name tipe =
154− let infinite = infiniteType name in
155− case tipe of
156− T.Lambda a b -> infinite a || infinite b
157− T.Var _ -> False
158− T.Type (Var.Raw name') -> name == name'
159− T.App t ts -> any infinite (t:ts)
160− T.Record fields _ -> any (infinite . snd) fields
161− T.Aliased _ t -> infinite t
162−
163− indented :: D.ValidDecl -> Doc
164− indented decl = P.text "\n " <> pretty decl <> P.text "\n"
165−
166− report name args tipe =
167− P.vcat
168− [ P.text $ eightyCharLines 0 msg1
169− , indented $ D.TypeAlias name args tipe
170− , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
171− , indented $ D.Datatype name args [(name,[tipe])]
172− , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
173− ]
174− where
175− msg1 =
176− "Type alias '" ++ name ++ "' is an infinite type. " ++
177− "Notice that it appears in its own definition, so when \
178− \you expand it, it just keeps getting bigger:"
173+ [ report name tvars tipe
174+ | D.TypeAlias name tvars tipe <- decls
175+ , infiniteType name tipe
176+ ]
177+ where
178+ infiniteType :: String -> T.Type Var.Raw -> Bool
179+ infiniteType name tipe =
180+ let infinite = infiniteType name in
181+ case tipe of
182+ T.Lambda a b ->
183+ infinite a || infinite b
184+
185+ T.Var _ ->
186+ False
187+
188+ T.Type (Var.Raw name') ->
189+ name == name'
190+
191+ T.App t ts ->
192+ any infinite (t:ts)
193+
194+ T.Record fields _ ->
195+ any (infinite . snd) fields
196+
197+ T.Aliased _ t ->
198+ infinite t
199+
200+ indented :: D.ValidDecl -> Doc
201+ indented decl =
202+ P.text "\n " <> pretty decl <> P.text "\n"
203+
204+ report name args tipe =
205+ P.vcat
206+ [ P.text $ eightyCharLines 0 msg1
207+ , indented $ D.TypeAlias name args tipe
208+ , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
209+ , indented $ D.Datatype name args [(name,[tipe])]
210+ , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
211+ ]
212+ where
213+ msg1 =
214+ "Type alias '" ++ name ++ "' is an infinite type. " ++
215+ "Notice that it appears in its own definition, so when \
216+ \you expand it, it just keeps getting bigger:"