@@ -54,8 +54,8 @@ data Exports = Exports
5454 , exportedTypeClasses :: [ProperName]
5555 -- |
5656 -- The values exported from each module
57− , exportedValues :: [Ident]
5857 --
58+ , exportedValues :: [Ident]
5959 } deriving (Show)
6060
6161-- |
@@ -105,15 +105,26 @@ addEmptyModule env name =
105105--
106106addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
107107addType env mn name dctors = updateExportedModule env mn $ \m -> do
108− types' <- addExport (exportedTypes m) (name, dctors)
109− return $ m { exportedTypes = types' }
108+ let exTypes = exportedTypes m
109+ let exDctors = snd `concatMap` exTypes
110+ let exClasses = exportedTypeClasses m
111+ when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
112+ when (any (== name) exClasses) $ throwConflictingDefError "Type" "type class" name
113+ forM_ dctors $ \dctor -> do
114+ when (any (== dctor) exDctors) $ throwMultipleDefError "data constructor" dctor
115+ when (any (== dctor) exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
116+ return $ m { exportedTypes = (name, dctors) : exTypes }
110117
111118-- |
112119-- Adds a class to the export environment.
113120--
114121addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115122addTypeClass env mn name = updateExportedModule env mn $ \m -> do
116− classes <- addExport (exportedTypeClasses m) name
123+ let exTypes = exportedTypes m
124+ let exDctors = snd `concatMap` exTypes
125+ when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
126+ when (any (== name) exDctors) $ throwConflictingDefError "Type class" "data constructor" name
127+ classes <- addExport "type class" (exportedTypeClasses m) name
117128 return $ m { exportedTypeClasses = classes }
118129
119130-- |
@@ -121,17 +132,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
121132--
122133addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123134addValue env mn name = updateExportedModule env mn $ \m -> do
124− values <- addExport (exportedValues m) name
135+ values <- addExport "value" (exportedValues m) name
125136 return $ m { exportedValues = values }
126137
127138-- |
128139-- Adds an entry to a list of exports unless it is already present, in which case an error is
129140-- returned.
130141--
131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
132−addExport exports name =
142+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
143+addExport what exports name =
133144 if name `elem` exports
134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
145+ then throwMultipleDefError what name
135146 else return $ name : exports
136147
137148-- |
@@ -221,7 +232,7 @@ renameInModule imports exports (Module mn decls exps) =
221232 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222233 updateValue (pos, bound) (Let ds val') = do
223234 let args = mapMaybe letBoundVariable ds
224− unless (length (nub args) == length args) $
235+ unless (length (nub args) == length args) $
225236 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
226237 return ((pos, args ++ bound), Let ds val')
227238 where
@@ -327,7 +338,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
327338 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
328339 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
329340 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
330− addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d
341+ addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
331342 addDecl _ env _ = return env
332343
333344-- |
@@ -523,3 +534,19 @@ resolveImport currentModule importModule exps imps impQual =
523534 if item `elem` exports
524535 then return item
525536 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
537+
538+-- |
539+-- Raises an error for when there is more than one definition for something.
540+--
541+throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
542+throwMultipleDefError what name = throwError $
543+ mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
544+
545+-- |
546+-- Raises an error for when there is a conflicting definition for something, for example, a type
547+-- class and data constructor of the same name.
548+--
549+throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b
550+throwConflictingDefError what1 what2 name = throwError $
551+ mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
552+