@@ -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,19 @@ 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+ when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
111+ forM_ dctors $ \dctor ->
112+ when (any (== dctor) exDctors) $ throwMultipleDefError "data constructor" dctor
113+ return $ m { exportedTypes = (name, dctors) : exTypes }
110114
111115-- |
112116-- Adds a class to the export environment.
113117--
114118addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115119addTypeClass env mn name = updateExportedModule env mn $ \m -> do
116− classes <- addExport (exportedTypeClasses m) name
120+ classes <- addExport "type class" (exportedTypeClasses m) name
117121 return $ m { exportedTypeClasses = classes }
118122
119123-- |
@@ -121,17 +125,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
121125--
122126addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123127addValue env mn name = updateExportedModule env mn $ \m -> do
124− values <- addExport (exportedValues m) name
128+ values <- addExport "value" (exportedValues m) name
125129 return $ m { exportedValues = values }
126130
127131-- |
128132-- Adds an entry to a list of exports unless it is already present, in which case an error is
129133-- returned.
130134--
131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
132−addExport exports name =
135+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
136+addExport what exports name =
133137 if name `elem` exports
134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
138+ then throwMultipleDefError what name
135139 else return $ name : exports
136140
137141-- |
@@ -221,7 +225,7 @@ renameInModule imports exports (Module mn decls exps) =
221225 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222226 updateValue (pos, bound) (Let ds val') = do
223227 let args = mapMaybe letBoundVariable ds
224− unless (length (nub args) == length args) $
228+ unless (length (nub args) == length args) $
225229 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
226230 return ((pos, args ++ bound), Let ds val')
227231 where
@@ -523,3 +527,11 @@ resolveImport currentModule importModule exps imps impQual =
523527 if item `elem` exports
524528 then return item
525529 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
530+
531+-- |
532+-- Raises an error for when there is more than one definition for something.
533+--
534+throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
535+throwMultipleDefError what name = throwError $
536+ mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
537+