@@ -1,108 +1,79 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Transform.Check (mistakes) where
23
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
11−import qualified Data.Map as Map
4+import qualified Data.List as List
125import qualified Data.Maybe as Maybe
136import 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
1415import Text.PrettyPrint as P
1516
1617
17−mistakes :: [D.Declaration t v] -> [Doc]
18+mistakes :: [D.Declaration] -> [Doc]
1819mistakes decls =
1920 concat [ infiniteTypeAliases decls
2021 , illFormedTypes decls
2122 , map P.text (duplicateConstructors decls)
22− , map P.text (concatMap findErrors (getLets decls))
23+ , map P.text (duplicates decls)
2324 , badDerivations decls ]
24− where
25− findErrors defs = duplicates defs ++ badOrder defs
2625
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]
58−dups = map head . filter ((>1) . length) . List.group
26+dups :: Ord a => [a] -> [a]
27+dups = map head . filter ((>1) . length) . List.group . List.sort
5928
6029dupErr :: String -> String -> String
6130dupErr err x =
6231 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
6332
64−duplicates :: [Def t v] -> [String]
65−duplicates defs =
66− map defMsg (dups definitions) ++ map annMsg (dups annotations)
67− where
68− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
69− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
70− defMsg = dupErr "definition of"
71− annMsg = dupErr "type annotation for"
33+duplicates :: [D.Declaration] -> [String]
34+duplicates decls =
35+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
36+ case mapM exprDups (portExprs ++ defExprs) of
37+ Left name -> [msg name]
38+ Right _ -> []
7239
73−duplicateConstructors :: [D.Declaration t v] -> [String]
74−duplicateConstructors decls =
75− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
7640 where
77− typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]
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."
41+ msg = dupErr "definition of"
8842
89− go defs =
90− case defs of
91− TypeAnnotation name _ : Def (PVar name') _ : rest
92− | name == name' -> go rest
43+ (defPatterns, defExprs) =
44+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
9345
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)
9551
96− _ : rest -> go rest
52+ getNames = Set.toList . Pattern.boundVars
9753
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
9962
100−badDerivations :: [D.Declaration t v] -> [Doc]
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+
71+badDerivations :: [D.Declaration] -> [Doc]
10172badDerivations decls = concatMap badDerivation derivations
10273 where
10374 derivations =
104− [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++
105− [ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]
75+ [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
76+ [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]
10677
10778 badDerivation (decl, tvars, derives) =
10879 case (tvars, derives) of
@@ -118,7 +89,7 @@ badDerivations decls = concatMap badDerivation derivations
11889 , nest 4 (pretty decl)
11990 ]
12091
121−illFormedTypes :: [D.Declaration t v] -> [Doc]
92+illFormedTypes :: [D.Declaration] -> [Doc]
12293illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
12394 where
12495 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
@@ -154,7 +125,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
154125
155126 addCommas xs
156127 | length xs < 3 = concat xs
157− | otherwise = intercalate "," xs
128+ | otherwise = List.intercalate "," xs
158129
159130 addAnd xs
160131 | length xs < 2 = xs
@@ -163,12 +134,13 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
163134 quote tvar = "'" ++ tvar ++ "'"
164135
165136
166−infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
137+infiniteTypeAliases :: [D.Declaration] -> [Doc]
167138infiniteTypeAliases 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 ]
169141 where
170− isInfinite name tipe =
171− let infinite = isInfinite name in
142+ infiniteType name tipe =
143+ let infinite = infiniteType name in
172144 case tipe of
173145 T.Lambda a b -> infinite a || infinite b
174146 T.Var _ -> False
@@ -176,16 +148,17 @@ infiniteTypeAliases decls =
176148 T.EmptyRecord -> False
177149 T.Record fields ext -> infinite ext || any (infinite . snd) fields
178150
179− report decl@(D.TypeAlias name args tipe derivations) =
151+ indented :: D.Declaration -> Doc
152+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"
153+
154+ report name args tipe derivations =
180155 P.vcat [ P.text $ eightyCharLines 0 msg1
181− , indented decl
156+ , indented $ D.TypeAlias name args tipe derivations
182157 , P.text $ eightyCharLines 0 msg2
183− , indented (D.Datatype name args [(name,[tipe])] derivations)
158+ , indented $ D.Datatype name args [(name,[tipe])] derivations
184159 , P.text $ eightyCharLines 0 msg3 ++ "\n"
185160 ]
186161 where
187− indented decl = P.text "\n " <> pretty decl <> P.text "\n"
188−
189162 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
190163 "Notice that it appears in its own definition, so when \
191164 \you expand it, it just keeps getting bigger:"