git.iko.soy/elk
on 0d6fcaa help sign in
elk/src/Transform/Check.hs
160 lines 4.5 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 Transform.Expression as Expr
14import AST.PrettyPrint
15import Elm.Utils ((|>))
16import Text.PrettyPrint as P
19mistakes :: [D.ValidDecl] -> [Doc]
20mistakes decls =
21 concat
22 [ illFormedTypeDecls decls
23 , map P.text (duplicateTypeDeclarations decls)
24 , map P.text (duplicateValues decls)
25 ]
28-- DUPLICATES
30dups :: Ord a => [a] -> [a]
31dups names =
32 List.sort names
33 |> List.group
34 |> filter ((>1) . length)
35 |> map head
38duplicateValues :: [D.ValidDecl] -> [String]
39duplicateValues decls =
40 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
41 case mapM exprDups defExprs of
42 Left name -> [msg name]
43 Right _ -> []
45 where
46 msg x =
47 "Name Collision: There can only be one definition of '" ++ x ++ "'."
49 (defPatterns, defExprs) =
50 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]
52 portNames =
53 [ D.validPortName port | D.Port port <- decls ]
55 exprDups :: Valid.Expr -> Either String Valid.Expr
56 exprDups expr =
57 Expr.crawlLet defsDups expr
59 defsDups :: [Valid.Def] -> Either String [Valid.Def]
60 defsDups defs =
61 let varsIn (Valid.Definition pattern _ _) =
62 Pattern.boundVarList pattern
63 in
64 case dups (concatMap varsIn defs) of
65 [] -> Right defs
66 name:_ -> Left name
69duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
70duplicateTypeDeclarations decls =
71 map dupTypeError (dups (typeNames ++ aliasNames))
72 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
73 where
74 typeNames =
75 [ name | D.Datatype name _ _ <- decls ]
77 aliasNames =
78 [ name | D.TypeAlias name _ _ <- decls ]
80 ctorNames =
81 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
84dupTypeError :: String -> String
85dupTypeError name =
86 "Name Collision: There can only be one type named '" ++ name ++ "'"
89dupCtorError :: String -> String
90dupCtorError name =
91 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
92 ++ " Constructors are created for record type aliases and for union types, so\n"
93 ++ " something should be renamed or moved to a different module."
96-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
98illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
99illFormedTypeDecls decls =
100 map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
101 where
102 aliases =
103 [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
105 adts =
106 [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
108 freeVars tipe =
109 case tipe of
110 T.Lambda t1 t2 ->
111 Set.union (freeVars t1) (freeVars t2)
113 T.Var x ->
114 Set.singleton x
116 T.Type _ ->
117 Set.empty
119 T.App t ts ->
120 Set.unions (map freeVars (t:ts))
122 T.Record fields ext ->
123 let ext' = maybe Set.empty freeVars ext
124 in
125 Set.unions (ext' : map (freeVars . snd) fields)
127 T.Aliased _ args t ->
128 freeVars (T.dealias args t)
130 undeclared tvars tipes =
131 Set.difference used declared
132 where
133 used = Set.unions (map freeVars tipes)
134 declared = Set.fromList tvars
136 isIllFormed (decl, tvars, tipes) =
137 let unbound = undeclared tvars tipes in
138 if Set.null unbound
139 then Nothing
140 else Just (decl, Set.toList unbound)
142 report (decl, tvars) =
143 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
144 , P.text "\n"
145 , nest 4 (pretty decl) ]
146 where
147 listing =
148 case tvars of
149 [tvar] -> " " ++ quote tvar ++ " is"
150 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
152 addCommas xs
153 | length xs < 3 = concat xs
154 | otherwise = List.intercalate "," xs
156 addAnd xs
157 | length xs < 2 = xs
158 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
160 quote tvar = "'" ++ tvar ++ "'"