Merge pull request #381 from bcdarwin/master

Add check for duplicate constructors within the same unit

compiler/Transform/Check.hs

@@ -17,11 +17,11 @@ mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
 mistakes decls =
     concat [ infiniteTypeAliases decls
            , illFormedTypes decls
+           , map P.text (duplicateConstructors decls)
            , map P.text (concatMap findErrors (getLets decls)) ]
   where
     findErrors defs = duplicates defs ++ badOrder defs
 
-
 getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
 getLets decls = defs : concatMap getSubLets defs
     where
@@ -32,6 +32,12 @@ getLets decls = defs : concatMap getSubLets defs
             Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
             TypeAnnotation _ _ -> []
 
+dups :: Eq a => [a] -> [a]
+dups  = map head . filter ((>1) . length) . List.group
+
+dupErr :: String -> String -> String
+dupErr err x = 
+  "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
 
 duplicates :: [Def t v] -> [String]
 duplicates defs =
@@ -39,13 +45,18 @@ duplicates defs =
   where
     annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
     definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
+    defMsg = dupErr "definition of"
+    annMsg = dupErr "type annotation for"
 
-    dups = map head . filter ((>1) . length) . List.group
-
-    msg = "Syntax Error: There can only be one "
-    defMsg x = msg ++ "definition of '" ++ x ++ "'."
-    annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
-
+duplicateConstructors :: [Declaration t v] -> [String]
+duplicateConstructors decls = 
+    map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
+  where
+    typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
+    dataCtors = List.sort . concat $
+      [ map fst patterns | Datatype _ _ patterns <- decls ]
+    dataMsg = dupErr "definition of data constructor"
+    typeMsg = dupErr "definition of type constructor"
 
 badOrder :: [Def t v] -> [String]
 badOrder defs = go defs