git.iko.soy/elk
on 3470b36 help sign in
elk/src/Transform/Check.hs
177 lines 6.1 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 , illFormedTypes decls
27 , map P.text (duplicateTypeDeclarations decls)
28 , map P.text (duplicateValues decls)
29 ]
32dups :: Ord a => [a] -> [a]
33dups names =
34 List.sort names
35 |> List.group
36 |> filter ((>1) . length)
37 |> map head
40duplicateValues :: [D.ValidDecl] -> [String]
41duplicateValues decls =
42 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
43 case mapM exprDups (portExprs ++ defExprs) of
44 Left name -> [msg name]
45 Right _ -> []
47 where
48 msg x =
49 "Name Collision: There can only be one definition of '" ++ x ++ "'."
51 (defPatterns, defExprs) =
52 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
54 (portNames, portExprs) =
55 Arrow.second concat $ unzip $
56 flip map [ port | D.Port port <- decls ] $ \port ->
57 case port of
58 D.Out name expr _ -> (name, [expr])
59 D.In name _ -> (name, [])
61 exprDups :: Valid.Expr -> Either String Valid.Expr
62 exprDups expr = Expr.crawlLet defsDups expr
64 defsDups :: [Valid.Def] -> Either String [Valid.Def]
65 defsDups defs =
66 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
67 case dups $ concatMap varsIn defs of
68 [] -> Right defs
69 name:_ -> Left name
72duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
73duplicateTypeDeclarations decls =
74 map dupTypeError (dups (typeNames ++ aliasNames))
75 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
76 where
77 typeNames =
78 [ name | D.Datatype name _ _ <- decls ]
80 aliasNames =
81 [ name | D.TypeAlias name _ _ <- decls ]
83 ctorNames =
84 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
87dupTypeError :: String -> String
88dupTypeError name =
89 "Name Collision: There can only be one type named '" ++ name ++ "'"
92dupCtorError :: String -> String
93dupCtorError name =
94 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
95 ++ " Constructors are created for record type aliases and for union types, so\n"
96 ++ " something should be renamed or moved to a different module."
99illFormedTypes :: [D.ValidDecl] -> [Doc]
100illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
101 where
102 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
103 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
105 freeVars tipe =
106 case tipe of
107 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
108 T.Var x -> Set.singleton x
109 T.Type _ -> Set.empty
110 T.App t ts -> Set.unions (map freeVars (t:ts))
111 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
112 where ext' = maybe Set.empty freeVars ext
113 T.Aliased _ t -> freeVars t
115 undeclared tvars tipes = Set.difference used declared
116 where
117 used = Set.unions (map freeVars tipes)
118 declared = Set.fromList tvars
120 isIllFormed (decl, tvars, tipes) =
121 let unbound = undeclared tvars tipes in
122 if Set.null unbound then Nothing
123 else Just (decl, Set.toList unbound)
125 report (decl, tvars) =
126 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
127 , P.text "\n"
128 , nest 4 (pretty decl) ]
129 where
130 listing =
131 case tvars of
132 [tvar] -> " " ++ quote tvar ++ " is"
133 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
135 addCommas xs
136 | length xs < 3 = concat xs
137 | otherwise = List.intercalate "," xs
139 addAnd xs
140 | length xs < 2 = xs
141 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
143 quote tvar = "'" ++ tvar ++ "'"
146infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
147infiniteTypeAliases decls =
148 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
149 , infiniteType name tipe ]
150 where
151 infiniteType :: String -> T.Type Var.Raw -> Bool
152 infiniteType name tipe =
153 let infinite = infiniteType name in
154 case tipe of
155 T.Lambda a b -> infinite a || infinite b
156 T.Var _ -> False
157 T.Type (Var.Raw name') -> name == name'
158 T.App t ts -> any infinite (t:ts)
159 T.Record fields _ -> any (infinite . snd) fields
160 T.Aliased _ t -> infinite t
162 indented :: D.ValidDecl -> Doc
163 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
165 report name args tipe =
166 P.vcat
167 [ P.text $ eightyCharLines 0 msg1
168 , indented $ D.TypeAlias name args tipe
169 , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
170 , indented $ D.Datatype name args [(name,[tipe])]
171 , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
172 ]
173 where
174 msg1 =
175 "Type alias '" ++ name ++ "' is an infinite type. " ++
176 "Notice that it appears in its own definition, so when \
177 \you expand it, it just keeps getting bigger:"