git.iko.soy/elk
on abb9633 help sign in
elk/src/Transform/Check.hs
216 lines 6.3 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 name maybeExpr _ -> (name, maybeExpr)
64 exprDups :: Valid.Expr -> Either String Valid.Expr
65 exprDups expr = Expr.crawlLet defsDups expr
67 defsDups :: [Valid.Def] -> Either String [Valid.Def]
68 defsDups defs =
69 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
70 case dups $ concatMap varsIn defs of
71 [] -> Right defs
72 name:_ -> Left name
75duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
76duplicateTypeDeclarations decls =
77 map dupTypeError (dups (typeNames ++ aliasNames))
78 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
79 where
80 typeNames =
81 [ name | D.Datatype name _ _ <- decls ]
83 aliasNames =
84 [ name | D.TypeAlias name _ _ <- decls ]
86 ctorNames =
87 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
90dupTypeError :: String -> String
91dupTypeError name =
92 "Name Collision: There can only be one type named '" ++ name ++ "'"
95dupCtorError :: String -> String
96dupCtorError name =
97 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
98 ++ " Constructors are created for record type aliases and for union types, so\n"
99 ++ " something should be renamed or moved to a different module."
102-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
104illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
105illFormedTypeDecls decls =
106 map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
107 where
108 aliases =
109 [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
111 adts =
112 [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
114 freeVars tipe =
115 case tipe of
116 T.Lambda t1 t2 ->
117 Set.union (freeVars t1) (freeVars t2)
119 T.Var x ->
120 Set.singleton x
122 T.Type _ ->
123 Set.empty
125 T.App t ts ->
126 Set.unions (map freeVars (t:ts))
128 T.Record fields ext ->
129 let ext' = maybe Set.empty freeVars ext
130 in
131 Set.unions (ext' : map (freeVars . snd) fields)
133 T.Aliased _ t ->
134 freeVars t
136 undeclared tvars tipes =
137 Set.difference used declared
138 where
139 used = Set.unions (map freeVars tipes)
140 declared = Set.fromList tvars
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)
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"
158 addCommas xs
159 | length xs < 3 = concat xs
160 | otherwise = List.intercalate "," xs
162 addAnd xs
163 | length xs < 2 = xs
164 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
166 quote tvar = "'" ++ tvar ++ "'"
169-- INFINITE TYPE ALIASES
171infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
172infiniteTypeAliases decls =
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
185 T.Var _ ->
186 False
188 T.Type (Var.Raw name') ->
189 name == name'
191 T.App t ts ->
192 any infinite (t:ts)
194 T.Record fields _ ->
195 any (infinite . snd) fields
197 T.Aliased _ 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:"