git.iko.soy/elk
on db31fe2 help sign in
elk/src/Transform/Check.hs
177 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
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 "Naming Error: 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 "Naming Error: There can only be one type named '" ++ name ++ "'"
91dupCtorError :: String -> String
92dupCtorError name =
93 "Naming Error: There can only be one type or record constructor named '" ++ name ++ "'"
96illFormedTypes :: [D.ValidDecl] -> [Doc]
97illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
98 where
99 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
100 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
102 freeVars tipe =
103 case tipe of
104 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
105 T.Var x -> Set.singleton x
106 T.Type _ -> Set.empty
107 T.App t ts -> Set.unions (map freeVars (t:ts))
108 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
109 where ext' = maybe Set.empty freeVars ext
110 T.Aliased _ t -> freeVars t
112 undeclared tvars tipes = Set.difference used declared
113 where
114 used = Set.unions (map freeVars tipes)
115 declared = Set.fromList tvars
117 isIllFormed (decl, tvars, tipes) =
118 let unbound = undeclared tvars tipes in
119 if Set.null unbound then Nothing
120 else Just (decl, Set.toList unbound)
122 report (decl, tvars) =
123 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
124 , P.text "\n"
125 , nest 4 (pretty decl) ]
126 where
127 listing =
128 case tvars of
129 [tvar] -> " " ++ quote tvar ++ " is"
130 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
132 addCommas xs
133 | length xs < 3 = concat xs
134 | otherwise = List.intercalate "," xs
136 addAnd xs
137 | length xs < 2 = xs
138 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
140 quote tvar = "'" ++ tvar ++ "'"
143infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
144infiniteTypeAliases decls =
145 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
146 , infiniteType name tipe ]
147 where
148 infiniteType :: String -> T.Type Var.Raw -> Bool
149 infiniteType name tipe =
150 let infinite = infiniteType name in
151 case tipe of
152 T.Lambda a b -> infinite a || infinite b
153 T.Var _ -> False
154 T.Type (Var.Raw name') -> name == name'
155 T.App t ts -> any infinite (t:ts)
156 T.Record fields _ -> any (infinite . snd) fields
157 T.Aliased _ t -> infinite t
159 indented :: D.ValidDecl -> Doc
160 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
162 report name args tipe =
163 P.vcat [ P.text $ eightyCharLines 0 msg1
164 , indented $ D.TypeAlias name args tipe
165 , P.text $ eightyCharLines 0 msg2
166 , indented $ D.Datatype name args [(name,[tipe])]
167 , P.text $ eightyCharLines 0 msg3 ++ "\n"
168 ]
169 where
170 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
171 "Notice that it appears in its own definition, so when \
172 \you expand it, it just keeps getting bigger:"
173 msg2 = "Try this instead:"
174 msg3 = "It looks very similar, but an algebraic data type (ADT) \
175 \actually creates a new type. Unlike with a type alias, this \
176 \freshly created type is meaningful on its own, so an ADT \
177 \does not need to be expanded."