@@ -54,8 +54,8 @@ data Exports = Exports
54 , exportedTypeClasses :: [ProperName]
54 , exportedTypeClasses :: [ProperName]
56 -- The values exported from each module
56 -- The values exported from each module
57− , exportedValues :: [Ident]
58+ , exportedValues :: [Ident]
59 } deriving (Show)
59 } deriving (Show)
@@ -105,15 +105,26 @@ addEmptyModule env name =
106addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
106addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
107addType env mn name dctors = updateExportedModule env mn $ \m -> do
107addType env mn name dctors = updateExportedModule env mn $ \m -> do
108− types' <- addExport (exportedTypes m) (name, dctors)
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
109− return $ m { exportedTypes = types' }
116+ return $ m { exportedTypes = (name, dctors) : exTypes }
112-- Adds a class to the export environment.
119-- Adds a class to the export environment.
114addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
121addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115addTypeClass env mn name = updateExportedModule env mn $ \m -> do
122addTypeClass env mn name = updateExportedModule env mn $ \m -> do
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
116− classes <- addExport (exportedTypeClasses m) name
127+ classes <- addExport "type class" (exportedTypeClasses m) name
117 return $ m { exportedTypeClasses = classes }
128 return $ m { exportedTypeClasses = classes }
@@ -121,17 +132,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
122addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
133addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123addValue env mn name = updateExportedModule env mn $ \m -> do
134addValue env mn name = updateExportedModule env mn $ \m -> do
124− values <- addExport (exportedValues m) name
135+ values <- addExport "value" (exportedValues m) name
125 return $ m { exportedValues = values }
136 return $ m { exportedValues = values }
128-- Adds an entry to a list of exports unless it is already present, in which case an error is
139-- Adds an entry to a list of exports unless it is already present, in which case an error is
129-- returned.
140-- returned.
131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
142+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
132−addExport exports name =
143+addExport what exports name =
133 if name `elem` exports
144 if name `elem` exports
134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
145+ then throwMultipleDefError what name
135 else return $ name : exports
146 else return $ name : exports
@@ -221,7 +232,7 @@ renameInModule imports exports (Module mn decls exps) =
221 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
232 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222 updateValue (pos, bound) (Let ds val') = do
233 updateValue (pos, bound) (Let ds val') = do
223 let args = mapMaybe letBoundVariable ds
234 let args = mapMaybe letBoundVariable ds
224− unless (length (nub args) == length args) $
235+ unless (length (nub args) == length args) $
225 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
236 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
226 return ((pos, args ++ bound), Let ds val')
237 return ((pos, args ++ bound), Let ds val')
@@ -327,7 +338,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
327 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
338 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
328 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
339 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
329 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
340 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
331 addDecl _ env _ = return env
342 addDecl _ env _ = return env
@@ -523,3 +534,19 @@ resolveImport currentModule importModule exps imps impQual =
523 if item `elem` exports
534 if item `elem` exports
524 then return item
535 then return item
525 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
536 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
539+-- Raises an error for when there is more than one definition for something.
541+throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
542+throwMultipleDefError what name = throwError $
543+ mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
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.
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