git.iko.soy/elk
on defb40c help sign in
elk/src/Transform/Check.hs
158 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 _ _) = Pattern.boundVarList pattern in
62 case dups $ concatMap varsIn defs of
63 [] -> Right defs
64 name:_ -> Left name
67duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
68duplicateTypeDeclarations decls =
69 map dupTypeError (dups (typeNames ++ aliasNames))
70 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
71 where
72 typeNames =
73 [ name | D.Datatype name _ _ <- decls ]
75 aliasNames =
76 [ name | D.TypeAlias name _ _ <- decls ]
78 ctorNames =
79 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
82dupTypeError :: String -> String
83dupTypeError name =
84 "Name Collision: There can only be one type named '" ++ name ++ "'"
87dupCtorError :: String -> String
88dupCtorError name =
89 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
90 ++ " Constructors are created for record type aliases and for union types, so\n"
91 ++ " something should be renamed or moved to a different module."
94-- FREE TYPE VARIABLES IN TYPE DECLARATIONS
96illFormedTypeDecls :: [D.ValidDecl] -> [Doc]
97illFormedTypeDecls decls =
98 map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
99 where
100 aliases =
101 [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
103 adts =
104 [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
106 freeVars tipe =
107 case tipe of
108 T.Lambda t1 t2 ->
109 Set.union (freeVars t1) (freeVars t2)
111 T.Var x ->
112 Set.singleton x
114 T.Type _ ->
115 Set.empty
117 T.App t ts ->
118 Set.unions (map freeVars (t:ts))
120 T.Record fields ext ->
121 let ext' = maybe Set.empty freeVars ext
122 in
123 Set.unions (ext' : map (freeVars . snd) fields)
125 T.Aliased _ args t ->
126 freeVars (T.dealias args t)
128 undeclared tvars tipes =
129 Set.difference used declared
130 where
131 used = Set.unions (map freeVars tipes)
132 declared = Set.fromList tvars
134 isIllFormed (decl, tvars, tipes) =
135 let unbound = undeclared tvars tipes in
136 if Set.null unbound
137 then Nothing
138 else Just (decl, Set.toList unbound)
140 report (decl, tvars) =
141 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
142 , P.text "\n"
143 , nest 4 (pretty decl) ]
144 where
145 listing =
146 case tvars of
147 [tvar] -> " " ++ quote tvar ++ " is"
148 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
150 addCommas xs
151 | length xs < 3 = concat xs
152 | otherwise = List.intercalate "," xs
154 addAnd xs
155 | length xs < 2 = xs
156 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
158 quote tvar = "'" ++ tvar ++ "'"