@@ -0,0 +1,86 @@
1+module Transform.Check (mistakes) where
2+
3+import Transform.SortDefinitions (boundVars)
4+import SourceSyntax.Everything
5+import qualified SourceSyntax.Type as T
6+import Data.List as List
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
9+import Data.Data
10+import Data.Generics.Uniplate.Data
11+
12+
13+mistakes :: (Data t, Data v) => [Declaration t v] -> [String]
14+mistakes decls =
15+ concatMap (\defs -> duplicates defs ++ badOrder defs) (getLets decls)
16+
17+
18+getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
19+getLets decls = defs : concatMap getSubLets defs
20+ where
21+ defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
22+
23+ getSubLets def =
24+ case def of
25+ Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
26+ TypeAnnotation _ _ -> []
27+
28+
29+duplicates :: [Def t v] -> [String]
30+duplicates defs =
31+ map defMsg (dup definition) ++ map annMsg (dup annotation)
32+ where
33+ dup f = map head . filter ((>1) . length) . List.group . List.sort $ concatMap f defs
34+
35+ msg = "Syntax Error: There can only be one "
36+ defMsg x = msg ++ " definition of '" ++ x ++ "'."
37+ annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
38+
39+
40+badOrder :: [Def t v] -> [String]
41+badOrder defs =
42+ map msg $ missings (List.sort $ expectedPairs as ds) (List.sort $ actualPairs defs)
43+ where
44+ msg x = "Syntax Error: The type annotation for '" ++ x ++
45+ "' must be directly above its definition."
46+ as = List.sort $ concatMap annotation defs
47+ ds = List.sort $ concatMap definition defs
48+
49+ expectedPairs :: [String] -> [String] -> [String]
50+ expectedPairs as ds =
51+ case (as,ds) of
52+ (x:xs, y:ys) -> case compare x y of
53+ LT -> expectedPairs xs (y:ys)
54+ EQ -> x : expectedPairs xs ys
55+ GT -> expectedPairs (x:xs) ys
56+ ( _ , _ ) -> []
57+
58+ actualPairs defs =
59+ case defs of
60+ TypeAnnotation name _ : Def (PVar name') _ : rest ->
61+ (if name == name' then [name] else []) ++ actualPairs rest
62+ t:s:rest -> actualPairs (s:rest)
63+ _ -> []
64+
65+ missings :: [String] -> [String] -> [String]
66+ missings expected actual =
67+ case (expected, actual) of
68+ (e:es, a:as) -> case compare e a of
69+ LT -> e : missings es (a:as)
70+ EQ -> missings es as
71+ GT -> a : missings (e:es) as
72+ ( [] , _ ) -> actual
73+ ( _ , [] ) -> expected
74+
75+
76+annotation :: Def t v -> [String]
77+annotation def =
78+ case def of
79+ TypeAnnotation name _ -> [name]
80+ _ -> []
81+
82+definition :: Def t v -> [String]
83+definition def =
84+ case def of
85+ Def pattern _ -> Set.toList (boundVars pattern)
86+ _ -> []