git.iko.soy/elk
on 8a87749 help sign in
elk/src/Transform/Check.hs
216 lines 6.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Check (mistakes) where
4import qualified Data.List as List
5import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
8import qualified AST.Expression.Valid as Valid
9import qualified AST.Declaration as D
10import qualified AST.Pattern as Pattern
11import qualified AST.Type as T
12import qualified AST.Variable as Var
13import qualified Transform.Expression as Expr
14import qualified Transform.Canonicalize.Setup as Setup
16import AST.PrettyPrint
17import Elm.Utils ((|>))
18import Text.PrettyPrint as P
21mistakes :: [D.ValidDecl] -> [Doc]
22mistakes decls =
23 concat
24 [ infiniteTypeAliases decls
25 , illFormedTypeDecls decls
26 , map P.text (duplicateTypeDeclarations decls)
27 , map P.text (duplicateValues decls)
28 ]
31-- DUPLICATES
33dups :: Ord a => [a] -> [a]
34dups names =
35 List.sort names
36 |> List.group
37 |> filter ((>1) . length)
38 |> map head
41duplicateValues :: [D.ValidDecl] -> [String]
42duplicateValues decls =
43 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
44 case mapM exprDups defExprs of
45 Left name -> [msg name]
46 Right _ -> []
48 where
49 msg x =
50 "Name Collision: There can only be one definition of '" ++ x ++ "'."
52 (defPatterns, defExprs) =
53 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
55 portNames =
56 [ D.getName port | D.Port port <- decls ]
58 exprDups :: Valid.Expr -> Either String Valid.Expr
59 exprDups expr =
60 Expr.crawlLet defsDups expr
62 defsDups :: [Valid.Def] -> Either String [Valid.Def]
63 defsDups defs =
64 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
65 case dups $ concatMap varsIn defs of
66 [] -> Right defs
67 name:_ -> Left name
70duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
71duplicateTypeDeclarations decls =
72 map dupTypeError (dups (typeNames ++ aliasNames))
73 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
74 where
75 typeNames =
76 [ name | D.Datatype name _ _ <- decls ]
78 aliasNames =
79 [ name | D.TypeAlias name _ _ <- decls ]
81 ctorNames =
82 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
85dupTypeError :: String -> String
86dupTypeError name =
87 "Name Collision: There can only be one type named '" ++ name ++ "'"
90dupCtorError :: String -> String
91dupCtorError name =
92 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
93 ++ " Constructors are created for record type aliases and for union types, so\n"
94 ++ " something should be renamed or moved to a different module."
97-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
99illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
100illFormedTypeDecls decls =
101 map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
102 where
103 aliases =
104 [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
106 adts =
107 [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
109 freeVars tipe =
110 case tipe of
111 T.Lambda t1 t2 ->
112 Set.union (freeVars t1) (freeVars t2)
114 T.Var x ->
115 Set.singleton x
117 T.Type _ ->
118 Set.empty
120 T.App t ts ->
121 Set.unions (map freeVars (t:ts))
123 T.Record fields ext ->
124 let ext' = maybe Set.empty freeVars ext
125 in
126 Set.unions (ext' : map (freeVars . snd) fields)
128 T.Aliased _ args t ->
129 freeVars (T.dealias args t)
131 undeclared tvars tipes =
132 Set.difference used declared
133 where
134 used = Set.unions (map freeVars tipes)
135 declared = Set.fromList tvars
137 isIllFormed (decl, tvars, tipes) =
138 let unbound = undeclared tvars tipes in
139 if Set.null unbound
140 then Nothing
141 else Just (decl, Set.toList unbound)
143 report (decl, tvars) =
144 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
145 , P.text "\n"
146 , nest 4 (pretty decl) ]
147 where
148 listing =
149 case tvars of
150 [tvar] -> " " ++ quote tvar ++ " is"
151 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
153 addCommas xs
154 | length xs < 3 = concat xs
155 | otherwise = List.intercalate "," xs
157 addAnd xs
158 | length xs < 2 = xs
159 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
161 quote tvar = "'" ++ tvar ++ "'"
164-- INFINITE TYPE ALIASES
166infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
167infiniteTypeAliases decls =
168 [ report name tvars tipe
169 | D.TypeAlias name tvars tipe <- decls
170 , infiniteType name tipe
171 ]
172 where
173 infiniteType :: String -> T.Type Var.Raw -> Bool
174 infiniteType name tipe =
175 let infinite = infiniteType name in
176 case tipe of
177 T.Lambda a b ->
178 infinite a || infinite b
180 T.Var _ ->
181 False
183 T.Type (Var.Raw name') ->
184 name == name'
186 T.App t ts ->
187 any infinite (t:ts)
189 T.Record fields _ ->
190 any (infinite . snd) fields
192 T.Aliased _ args aliasType ->
193 case aliasType of
194 T.Holey t ->
195 infinite t || any (infinite . snd) args
197 T.Filled t ->
198 infinite t
200 indented :: D.ValidDecl -> Doc
201 indented decl =
202 P.text "\n " <> pretty decl <> P.text "\n"
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:"