git.iko.soy/elk
on 09d86de help sign in
elk/src/Transform/Check.hs
178 lines 6.2 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 Maybe.catMaybes $ unzip $
56 flip map [ wire | D.Wire wire <- decls ] $ \wire ->
57 case wire of
58 D.Input name _ -> (name, Nothing)
59 D.Output name expr _ -> (name, Just expr)
60 D.Loopback name maybeExpr _ -> (name, maybeExpr)
62 exprDups :: Valid.Expr -> Either String Valid.Expr
63 exprDups expr = Expr.crawlLet defsDups expr
65 defsDups :: [Valid.Def] -> Either String [Valid.Def]
66 defsDups defs =
67 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
68 case dups $ concatMap varsIn defs of
69 [] -> Right defs
70 name:_ -> Left name
73duplicateTypeDeclarations :: [D.ValidDecl] -> [String]
74duplicateTypeDeclarations decls =
75 map dupTypeError (dups (typeNames ++ aliasNames))
76 ++ map dupCtorError (dups (ctorNames ++ aliasNames))
77 where
78 typeNames =
79 [ name | D.Datatype name _ _ <- decls ]
81 aliasNames =
82 [ name | D.TypeAlias name _ _ <- decls ]
84 ctorNames =
85 concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
88dupTypeError :: String -> String
89dupTypeError name =
90 "Name Collision: There can only be one type named '" ++ name ++ "'"
93dupCtorError :: String -> String
94dupCtorError name =
95 "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n"
96 ++ " Constructors are created for record type aliases and for union types, so\n"
97 ++ " something should be renamed or moved to a different module."
100illFormedTypes :: [D.ValidDecl] -> [Doc]
101illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
102 where
103 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
104 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
106 freeVars tipe =
107 case tipe of
108 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
109 T.Var x -> Set.singleton x
110 T.Type _ -> Set.empty
111 T.App t ts -> Set.unions (map freeVars (t:ts))
112 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
113 where ext' = maybe Set.empty freeVars ext
114 T.Aliased _ t -> freeVars t
116 undeclared tvars tipes = Set.difference used declared
117 where
118 used = Set.unions (map freeVars tipes)
119 declared = Set.fromList tvars
121 isIllFormed (decl, tvars, tipes) =
122 let unbound = undeclared tvars tipes in
123 if Set.null unbound then Nothing
124 else Just (decl, Set.toList unbound)
126 report (decl, tvars) =
127 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
128 , P.text "\n"
129 , nest 4 (pretty decl) ]
130 where
131 listing =
132 case tvars of
133 [tvar] -> " " ++ quote tvar ++ " is"
134 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
136 addCommas xs
137 | length xs < 3 = concat xs
138 | otherwise = List.intercalate "," xs
140 addAnd xs
141 | length xs < 2 = xs
142 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
144 quote tvar = "'" ++ tvar ++ "'"
147infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
148infiniteTypeAliases decls =
149 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
150 , infiniteType name tipe ]
151 where
152 infiniteType :: String -> T.Type Var.Raw -> Bool
153 infiniteType name tipe =
154 let infinite = infiniteType name in
155 case tipe of
156 T.Lambda a b -> infinite a || infinite b
157 T.Var _ -> False
158 T.Type (Var.Raw name') -> name == name'
159 T.App t ts -> any infinite (t:ts)
160 T.Record fields _ -> any (infinite . snd) fields
161 T.Aliased _ t -> infinite t
163 indented :: D.ValidDecl -> Doc
164 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
166 report name args tipe =
167 P.vcat
168 [ P.text $ eightyCharLines 0 msg1
169 , indented $ D.TypeAlias name args tipe
170 , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
171 , indented $ D.Datatype name args [(name,[tipe])]
172 , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
173 ]
174 where
175 msg1 =
176 "Type alias '" ++ name ++ "' is an infinite type. " ++
177 "Notice that it appears in its own definition, so when \
178 \you expand it, it just keeps getting bigger:"