@@ -13,9 +13,8 @@ import Text.PrettyPrint as P
1313
1414mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
1515mistakes decls =
16− map prettify $ concatMap findErrors (getLets decls)
16+ map P.text $ concatMap findErrors (getLets decls)
1717 where
18− prettify = P.sep . map P.text . words
1918 findErrors defs = duplicates defs ++ badOrder defs
2019
2120
@@ -32,9 +31,12 @@ getLets decls = defs : concatMap getSubLets defs
3231
3332duplicates :: [Def t v] -> [String]
3433duplicates defs =
35− map defMsg (dup definition) ++ map annMsg (dup annotation)
34+ map defMsg (dups definitions) ++ map annMsg (dups annotations)
3635 where
37− dup f = map head . filter ((>1) . length) . List.group . List.sort $ concatMap f defs
36+ annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
37+ definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
38+
39+ dups = map head . filter ((>1) . length) . List.group
3840
3941 msg = "Syntax Error: There can only be one "
4042 defMsg x = msg ++ " definition of '" ++ x ++ "'."
@@ -42,49 +44,20 @@ duplicates defs =
4244
4345
4446badOrder :: [Def t v] -> [String]
45−badOrder defs =
46− map msg $ missings (List.sort $ expectedPairs as ds) (List.sort $ actualPairs defs)
47+badOrder defs = go defs
4748 where
4849 msg x = "Syntax Error: The type annotation for '" ++ x ++
4950 "' must be directly above its definition."
50− as = List.sort $ concatMap annotation defs
51− ds = List.sort $ concatMap definition defs
52−
53− expectedPairs :: [String] -> [String] -> [String]
54− expectedPairs as ds =
55− case (as,ds) of
56− (x:xs, y:ys) -> case compare x y of
57− LT -> expectedPairs xs (y:ys)
58− EQ -> x : expectedPairs xs ys
59− GT -> expectedPairs (x:xs) ys
60− ( _ , _ ) -> []
61−
62− actualPairs defs =
51+
52+ go defs =
6353 case defs of
64− TypeAnnotation name _ : Def (PVar name') _ : rest ->
65− (if name == name' then [name] else []) ++ actualPairs rest
66− t:s:rest -> actualPairs (s:rest)
54+ TypeAnnotation name _ : Def (PVar name') _ : rest
55+ | name == name' -> go rest
56+
57+ TypeAnnotation name _ : rest -> [msg name] ++ go rest
58+
59+ _ : rest -> go rest
60+
6761 _ -> []
6862
69− missings :: [String] -> [String] -> [String]
70− missings expected actual =
71− case (expected, actual) of
72− (e:es, a:as) -> case compare e a of
73− LT -> e : missings es (a:as)
74− EQ -> missings es as
75− GT -> a : missings (e:es) as
76− ( [] , _ ) -> actual
77− ( _ , [] ) -> expected
78−
79−
80−annotation :: Def t v -> [String]
81−annotation def =
82− case def of
83− TypeAnnotation name _ -> [name]
84− _ -> []
85−
86−definition :: Def t v -> [String]
87−definition def =
88− case def of
89− Def pattern _ -> Set.toList (boundVars pattern)
90− _ -> []
63+