git.iko.soy/elk
on master help sign in
Get rid of `badOrder` check, which is handled elsewhere. Update for new def and port formats
c883b55Evan Czaplicki
compiler/Transform/Check.hs+61−88
compare with master
unifiedsplit
@@ -1,108 +1,79 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Transform.Check (mistakes) where
2module Transform.Check (mistakes) where
2
3
3−import Transform.SortDefinitions (boundVars)
4−import qualified SourceSyntax.Declaration as D
5−import SourceSyntax.Expression
6−import SourceSyntax.Pattern
7−import SourceSyntax.Location
8−import SourceSyntax.PrettyPrint
9−import qualified SourceSyntax.Type as T
10−import Data.List as List
4+import qualified Data.List as List
11−import qualified Data.Map as Map
12import qualified Data.Maybe as Maybe
5import qualified Data.Maybe as Maybe
13import qualified Data.Set as Set
6import qualified Data.Set as Set
7+
8+import qualified SourceSyntax.Expression as E
9+import qualified SourceSyntax.Declaration as D
10+import qualified SourceSyntax.Pattern as Pattern
11+import qualified SourceSyntax.Type as T
12+import qualified Transform.Expression as Expr
13+
14+import SourceSyntax.PrettyPrint
14import Text.PrettyPrint as P
15import Text.PrettyPrint as P
15
16
16
17
17−mistakes :: [D.Declaration t v] -> [Doc]
18+mistakes :: [D.Declaration] -> [Doc]
18mistakes decls =
19mistakes decls =
19 concat [ infiniteTypeAliases decls
20 concat [ infiniteTypeAliases decls
20 , illFormedTypes decls
21 , illFormedTypes decls
21 , map P.text (duplicateConstructors decls)
22 , map P.text (duplicateConstructors decls)
22− , map P.text (concatMap findErrors (getLets decls))
23+ , map P.text (duplicates decls)
23 , badDerivations decls ]
24 , badDerivations decls ]
24− where
25− findErrors defs = duplicates defs ++ badOrder defs
26
25
27−getLets :: [D.Declaration t v] -> [[Def t v]]
28−getLets decls = defs : concatMap defLets defs
29− where
30− defs = [ d | D.Definition d <- decls ]
31−
32− defLets def =
33− case def of
34− TypeAnnotation _ _ -> []
35− Def _ expr -> exprLets expr
36−
37− exprLets (L _ expr) =
38− case expr of
39− Var _ -> []
40− Lambda p e -> exprLets e
41− Binop op e1 e2 -> exprLets e1 ++ exprLets e2
42− Case e cases -> exprLets e ++ concatMap (exprLets . snd) cases
43− Data name es -> concatMap exprLets es
44− Literal _ -> []
45− Range e1 e2 -> exprLets e1 ++ exprLets e2
46− ExplicitList es -> concatMap exprLets es
47− App e1 e2 -> exprLets e1 ++ exprLets e2
48− MultiIf branches -> concatMap (\(b,e) -> exprLets b ++ exprLets e) branches
49− Access e lbl -> exprLets e
50− Remove e lbl -> exprLets e
51− Insert e lbl v -> exprLets e ++ exprLets v
52− Modify e fields -> exprLets e ++ concatMap (exprLets . snd) fields
53− Record fields -> concatMap (exprLets . snd) fields
54− Markdown uid md es -> []
55− Let defs body -> [defs] ++ exprLets body
56−
57−dups :: Eq a => [a] -> [a]
26+dups :: Ord a => [a] -> [a]
58−dups = map head . filter ((>1) . length) . List.group
27+dups = map head . filter ((>1) . length) . List.group . List.sort
59
28
60dupErr :: String -> String -> String
29dupErr :: String -> String -> String
61dupErr err x =
30dupErr err x =
62 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
31 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
63
32
64−duplicates :: [Def t v] -> [String]
33+duplicates :: [D.Declaration] -> [String]
65−duplicates defs =
34+duplicates decls =
66− map defMsg (dups definitions) ++ map annMsg (dups annotations)
35+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
67− where
36+ case mapM exprDups (portExprs ++ defExprs) of
68− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
37+ Left name -> [msg name]
69− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
38+ Right _ -> []
70− defMsg = dupErr "definition of"
71− annMsg = dupErr "type annotation for"
72
39
73−duplicateConstructors :: [D.Declaration t v] -> [String]
74−duplicateConstructors decls =
75− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
76 where
40 where
77− typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]
41+ msg = dupErr "definition of"
78− dataCtors = List.sort . concat $
79− [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
80− dataMsg = dupErr "definition of data constructor"
81− typeMsg = dupErr "definition of type constructor"
82−
83−badOrder :: [Def t v] -> [String]
84−badOrder defs = go defs
85− where
86− msg x = "Syntax Error: The type annotation for '" ++ x ++
87− "' must be directly above its definition."
88
42
89− go defs =
43+ (defPatterns, defExprs) =
90− case defs of
44+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
91− TypeAnnotation name _ : Def (PVar name') _ : rest
92− | name == name' -> go rest
93
45
94− TypeAnnotation name _ : rest -> [msg name] ++ go rest
46+ (portNames, portExprs) =
47+ unzip $ flip map [ port | D.Port port <- decls ] $ \port ->
48+ case port of
49+ D.Send name expr _ -> (name,expr)
50+ D.Recv name expr _ -> (name,expr)
95
51
96− _ : rest -> go rest
52+ getNames = Set.toList . Pattern.boundVars
97
53
98− _ -> []
54+ exprDups :: E.LExpr -> Either String E.LExpr
55+ exprDups expr = Expr.crawl defsDups expr
56+
57+ defsDups :: [E.Def] -> Either String [E.Def]
58+ defsDups defs =
59+ case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
60+ [] -> Right defs
61+ name:_ -> Left name
99
62
63+duplicateConstructors :: [D.Declaration] -> [String]
64+duplicateConstructors decls =
65+ map (dupErr "definition of type constructor") (dups typeCtors) ++
66+ map (dupErr "definition of data constructor") (dups dataCtors)
67+ where
68+ typeCtors = [ name | D.Datatype name _ _ _ <- decls ]
69+ dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
70+
100−badDerivations :: [D.Declaration t v] -> [Doc]
71+badDerivations :: [D.Declaration] -> [Doc]
101badDerivations decls = concatMap badDerivation derivations
72badDerivations decls = concatMap badDerivation derivations
102 where
73 where
103 derivations =
74 derivations =
104− [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++
75+ [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
105− [ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]
76+ [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]
106
77
107 badDerivation (decl, tvars, derives) =
78 badDerivation (decl, tvars, derives) =
108 case (tvars, derives) of
79 case (tvars, derives) of
@@ -118,7 +89,7 @@ badDerivations decls = concatMap badDerivation derivations
118 , nest 4 (pretty decl)
89 , nest 4 (pretty decl)
119 ]
90 ]
120
91
121−illFormedTypes :: [D.Declaration t v] -> [Doc]
92+illFormedTypes :: [D.Declaration] -> [Doc]
122illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
93illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
123 where
94 where
124 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
95 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
@@ -154,7 +125,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
154
125
155 addCommas xs
126 addCommas xs
156 | length xs < 3 = concat xs
127 | length xs < 3 = concat xs
157− | otherwise = intercalate "," xs
128+ | otherwise = List.intercalate "," xs
158
129
159 addAnd xs
130 addAnd xs
160 | length xs < 2 = xs
131 | length xs < 2 = xs
@@ -163,12 +134,13 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
163 quote tvar = "'" ++ tvar ++ "'"
134 quote tvar = "'" ++ tvar ++ "'"
164
135
165
136
166−infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
137+infiniteTypeAliases :: [D.Declaration] -> [Doc]
167infiniteTypeAliases decls =
138infiniteTypeAliases decls =
168− [ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]
139+ [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls
140+ , infiniteType name tipe ]
169 where
141 where
170− isInfinite name tipe =
142+ infiniteType name tipe =
171− let infinite = isInfinite name in
143+ let infinite = infiniteType name in
172 case tipe of
144 case tipe of
173 T.Lambda a b -> infinite a || infinite b
145 T.Lambda a b -> infinite a || infinite b
174 T.Var _ -> False
146 T.Var _ -> False
@@ -176,16 +148,17 @@ infiniteTypeAliases decls =
176 T.EmptyRecord -> False
148 T.EmptyRecord -> False
177 T.Record fields ext -> infinite ext || any (infinite . snd) fields
149 T.Record fields ext -> infinite ext || any (infinite . snd) fields
178
150
151+ indented :: D.Declaration -> Doc
152+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"
153+
179− report decl@(D.TypeAlias name args tipe derivations) =
154+ report name args tipe derivations =
180 P.vcat [ P.text $ eightyCharLines 0 msg1
155 P.vcat [ P.text $ eightyCharLines 0 msg1
181− , indented decl
156+ , indented $ D.TypeAlias name args tipe derivations
182 , P.text $ eightyCharLines 0 msg2
157 , P.text $ eightyCharLines 0 msg2
183− , indented (D.Datatype name args [(name,[tipe])] derivations)
158+ , indented $ D.Datatype name args [(name,[tipe])] derivations
184 , P.text $ eightyCharLines 0 msg3 ++ "\n"
159 , P.text $ eightyCharLines 0 msg3 ++ "\n"
185 ]
160 ]
186 where
161 where
187− indented decl = P.text "\n " <> pretty decl <> P.text "\n"
188−
189 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
162 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
190 "Notice that it appears in its own definition, so when \
163 "Notice that it appears in its own definition, so when \
191 \you expand it, it just keeps getting bigger:"
164 \you expand it, it just keeps getting bigger:"