git.iko.soy/elk
on ff9acf5 help sign in
elk/src/Transform/Check.hs
179 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
16import AST.PrettyPrint
17import Elm.Utils ((|>))
18import Text.PrettyPrint as P
21mistakes :: [D.ValidDecl] -> [Doc]
22mistakes decls =
23 concat
24 [ infiniteTypeAliases decls
25 , illFormedTypes decls
26 , map P.text (duplicateTypeDeclarations decls)
27 , map P.text (duplicateValues decls)
28 ]
31dups :: Ord a => [a] -> [a]
32dups names =
33 List.sort names
34 |> List.group
35 |> filter ((>1) . length)
36 |> map head
39duplicateValues :: [D.ValidDecl] -> [String]
40duplicateValues decls =
41 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
42 case mapM exprDups (portExprs ++ defExprs) of
43 Left name -> [msg name]
44 Right _ -> []
46 where
47 msg x =
48 "Name Collision: There can only be one definition of '" ++ x ++ "'."
50 (defPatterns, defExprs) =
51 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
53 (portNames, portExprs) =
54 Arrow.second concat $ unzip $
55 flip map [ port | D.Port port <- decls ] $ \port ->
56 case port of
57 D.Out name expr _ -> (name, [expr])
58 D.In name _ -> (name, [])
60 exprDups :: Valid.Expr -> Either String Valid.Expr
61 exprDups expr = Expr.crawlLet defsDups expr
63 defsDups :: [Valid.Def] -> Either String [Valid.Def]
64 defsDups defs =
65 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
66 case dups $ concatMap varsIn defs of
67 [] -> Right defs
68 name:_ -> Left name
71duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
72duplicateTypeDeclarations decls =
73 map dupTypeError (dups (typeNames ++ aliasNames))
74 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
75 where
76 typeNames =
77 [ name | D.Datatype name _ _ <- decls ]
79 aliasNames =
80 [ name | D.TypeAlias name _ _ <- decls ]
82 ctorNames =
83 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
86dupTypeError :: String -> String
87dupTypeError name =
88 "Name Collision: There can only be one type named '" ++ name ++ "'"
91dupCtorError :: String -> String
92dupCtorError name =
93 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
94 ++ " Constructors are created for record type aliases and for union types, so\n"
95 ++ " something should be renamed or moved to a different module."
98illFormedTypes :: [D.ValidDecl] -> [Doc]
99illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
100 where
101 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
102 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
104 freeVars tipe =
105 case tipe of
106 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
107 T.Var x -> Set.singleton x
108 T.Type _ -> Set.empty
109 T.App t ts -> Set.unions (map freeVars (t:ts))
110 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
111 where ext' = maybe Set.empty freeVars ext
112 T.Aliased _ t -> freeVars t
114 undeclared tvars tipes = Set.difference used declared
115 where
116 used = Set.unions (map freeVars tipes)
117 declared = Set.fromList tvars
119 isIllFormed (decl, tvars, tipes) =
120 let unbound = undeclared tvars tipes in
121 if Set.null unbound then Nothing
122 else Just (decl, Set.toList unbound)
124 report (decl, tvars) =
125 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
126 , P.text "\n"
127 , nest 4 (pretty decl) ]
128 where
129 listing =
130 case tvars of
131 [tvar] -> " " ++ quote tvar ++ " is"
132 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
134 addCommas xs
135 | length xs < 3 = concat xs
136 | otherwise = List.intercalate "," xs
138 addAnd xs
139 | length xs < 2 = xs
140 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
142 quote tvar = "'" ++ tvar ++ "'"
145infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
146infiniteTypeAliases decls =
147 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
148 , infiniteType name tipe ]
149 where
150 infiniteType :: String -> T.Type Var.Raw -> Bool
151 infiniteType name tipe =
152 let infinite = infiniteType name in
153 case tipe of
154 T.Lambda a b -> infinite a || infinite b
155 T.Var _ -> False
156 T.Type (Var.Raw name') -> name == name'
157 T.App t ts -> any infinite (t:ts)
158 T.Record fields _ -> any (infinite . snd) fields
159 T.Aliased _ t -> infinite t
161 indented :: D.ValidDecl -> Doc
162 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
164 report name args tipe =
165 P.vcat [ P.text $ eightyCharLines 0 msg1
166 , indented $ D.TypeAlias name args tipe
167 , P.text $ eightyCharLines 0 msg2
168 , indented $ D.Datatype name args [(name,[tipe])]
169 , P.text $ eightyCharLines 0 msg3 ++ "\n"
170 ]
171 where
172 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
173 "Notice that it appears in its own definition, so when \
174 \you expand it, it just keeps getting bigger:"
175 msg2 = "Try this instead:"
176 msg3 = "It looks very similar, but an algebraic data type (ADT) \
177 \actually creates a new type. Unlike with a type alias, this \
178 \freshly created type is meaningful on its own, so an ADT \
179 \does not need to be expanded."