git.iko.soy/elk
on 8036fca help sign in
elk/src/Transform/Check.hs
217 lines 6.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Check (mistakes) where
4import qualified Control.Arrow as Arrow
5import qualified Data.List as List
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
9import qualified AST.Expression.Valid as Valid
10import qualified AST.Declaration as D
11import qualified AST.Pattern as Pattern
12import qualified AST.Type as T
13import qualified AST.Variable as Var
14import qualified Transform.Expression as Expr
15import qualified Transform.Canonicalize.Setup as Setup
17import AST.PrettyPrint
18import Elm.Utils ((|>))
19import Text.PrettyPrint as P
22mistakes :: [D.ValidDecl] -> [Doc]
23mistakes decls =
24 concat
25 [ infiniteTypeAliases decls
26 , illFormedTypeDecls decls
27 , map P.text (duplicateTypeDeclarations decls)
28 , map P.text (duplicateValues decls)
29 ]
32-- DUPLICATES
34dups :: Ord a => [a] -> [a]
35dups names =
36 List.sort names
37 |> List.group
38 |> filter ((>1) . length)
39 |> map head
42duplicateValues :: [D.ValidDecl] -> [String]
43duplicateValues decls =
44 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
45 case mapM exprDups (portExprs ++ defExprs) of
46 Left name -> [msg name]
47 Right _ -> []
49 where
50 msg x =
51 "Name Collision: There can only be one definition of '" ++ x ++ "'."
53 (defPatterns, defExprs) =
54 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
56 (portNames, portExprs) =
57 Arrow.second Maybe.catMaybes $ unzip $
58 flip map [ wire | D.Wire wire <- decls ] $ \wire ->
59 case wire of
60 D.Input name _ -> (name, Nothing)
61 D.Output name expr _ -> (name, Just expr)
62 D.Loopback (D.ValidLoopback name maybeExpr _) -> (name, maybeExpr)
64 exprDups :: Valid.Expr -> Either String Valid.Expr
65 exprDups expr =
66 Expr.crawlLet defsDups expr
68 defsDups :: [Valid.Def] -> Either String [Valid.Def]
69 defsDups defs =
70 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
71 case dups $ concatMap varsIn defs of
72 [] -> Right defs
73 name:_ -> Left name
76duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
77duplicateTypeDeclarations decls =
78 map dupTypeError (dups (typeNames ++ aliasNames))
79 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
80 where
81 typeNames =
82 [ name | D.Datatype name _ _ <- decls ]
84 aliasNames =
85 [ name | D.TypeAlias name _ _ <- decls ]
87 ctorNames =
88 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
91dupTypeError :: String -> String
92dupTypeError name =
93 "Name Collision: There can only be one type named '" ++ name ++ "'"
96dupCtorError :: String -> String
97dupCtorError name =
98 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
99 ++ " Constructors are created for record type aliases and for union types, so\n"
100 ++ " something should be renamed or moved to a different module."
103-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
105illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
106illFormedTypeDecls decls =
107 map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
108 where
109 aliases =
110 [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
112 adts =
113 [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
115 freeVars tipe =
116 case tipe of
117 T.Lambda t1 t2 ->
118 Set.union (freeVars t1) (freeVars t2)
120 T.Var x ->
121 Set.singleton x
123 T.Type _ ->
124 Set.empty
126 T.App t ts ->
127 Set.unions (map freeVars (t:ts))
129 T.Record fields ext ->
130 let ext' = maybe Set.empty freeVars ext
131 in
132 Set.unions (ext' : map (freeVars . snd) fields)
134 T.Aliased _ args t ->
135 freeVars (T.dealias args t)
137 undeclared tvars tipes =
138 Set.difference used declared
139 where
140 used = Set.unions (map freeVars tipes)
141 declared = Set.fromList tvars
143 isIllFormed (decl, tvars, tipes) =
144 let unbound = undeclared tvars tipes in
145 if Set.null unbound
146 then Nothing
147 else Just (decl, Set.toList unbound)
149 report (decl, tvars) =
150 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
151 , P.text "\n"
152 , nest 4 (pretty decl) ]
153 where
154 listing =
155 case tvars of
156 [tvar] -> " " ++ quote tvar ++ " is"
157 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
159 addCommas xs
160 | length xs < 3 = concat xs
161 | otherwise = List.intercalate "," xs
163 addAnd xs
164 | length xs < 2 = xs
165 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
167 quote tvar = "'" ++ tvar ++ "'"
170-- INFINITE TYPE ALIASES
172infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
173infiniteTypeAliases decls =
174 [ report name tvars tipe
175 | D.TypeAlias name tvars tipe <- decls
176 , infiniteType name tipe
177 ]
178 where
179 infiniteType :: String -> T.Type Var.Raw -> Bool
180 infiniteType name tipe =
181 let infinite = infiniteType name in
182 case tipe of
183 T.Lambda a b ->
184 infinite a || infinite b
186 T.Var _ ->
187 False
189 T.Type (Var.Raw name') ->
190 name == name'
192 T.App t ts ->
193 any infinite (t:ts)
195 T.Record fields _ ->
196 any (infinite . snd) fields
198 T.Aliased _ args t ->
199 infinite t || any (infinite . snd) args
201 indented :: D.ValidDecl -> Doc
202 indented decl =
203 P.text "\n " <> pretty decl <> P.text "\n"
205 report name args tipe =
206 P.vcat
207 [ P.text $ eightyCharLines 0 msg1
208 , indented $ D.TypeAlias name args tipe
209 , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
210 , indented $ D.Datatype name args [(name,[tipe])]
211 , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
212 ]
213 where
214 msg1 =
215 "Type alias '" ++ name ++ "' is an infinite type. " ++
216 "Notice that it appears in its own definition, so when \
217 \you expand it, it just keeps getting bigger:"