git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Improve error message for duplicate types/dctors
c6008b0Gary Burgess
src/Language/PureScript/Sugar/Names.hs+21−9
compare with golang
unifiedsplit
@@ -54,8 +54,8 @@ data Exports = Exports
54 , exportedTypeClasses :: [ProperName]
54 , exportedTypeClasses :: [ProperName]
55 -- |
55 -- |
56 -- The values exported from each module
56 -- The values exported from each module
57− , exportedValues :: [Ident]
58 --
57 --
58+ , exportedValues :: [Ident]
59 } deriving (Show)
59 } deriving (Show)
60
60
61-- |
61-- |
@@ -105,15 +105,19 @@ addEmptyModule env name =
105--
105--
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+ when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
111+ forM_ dctors $ \dctor ->
112+ when (any (== dctor) exDctors) $ throwMultipleDefError "data constructor" dctor
109− return $ m { exportedTypes = types' }
113+ return $ m { exportedTypes = (name, dctors) : exTypes }
110
114
111-- |
115-- |
112-- Adds a class to the export environment.
116-- Adds a class to the export environment.
113--
117--
114addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
118addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115addTypeClass env mn name = updateExportedModule env mn $ \m -> do
119addTypeClass env mn name = updateExportedModule env mn $ \m -> do
116− classes <- addExport (exportedTypeClasses m) name
120+ classes <- addExport "type class" (exportedTypeClasses m) name
117 return $ m { exportedTypeClasses = classes }
121 return $ m { exportedTypeClasses = classes }
118
122
119-- |
123-- |
@@ -121,17 +125,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
121--
125--
122addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
126addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123addValue env mn name = updateExportedModule env mn $ \m -> do
127addValue env mn name = updateExportedModule env mn $ \m -> do
124− values <- addExport (exportedValues m) name
128+ values <- addExport "value" (exportedValues m) name
125 return $ m { exportedValues = values }
129 return $ m { exportedValues = values }
126
130
127-- |
131-- |
128-- Adds an entry to a list of exports unless it is already present, in which case an error is
132-- Adds an entry to a list of exports unless it is already present, in which case an error is
129-- returned.
133-- returned.
130--
134--
131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
135+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
132−addExport exports name =
136+addExport what exports name =
133 if name `elem` exports
137 if name `elem` exports
134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
138+ then throwMultipleDefError what name
135 else return $ name : exports
139 else return $ name : exports
136
140
137-- |
141-- |
@@ -221,7 +225,7 @@ renameInModule imports exports (Module mn decls exps) =
221 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
225 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222 updateValue (pos, bound) (Let ds val') = do
226 updateValue (pos, bound) (Let ds val') = do
223 let args = mapMaybe letBoundVariable ds
227 let args = mapMaybe letBoundVariable ds
224− unless (length (nub args) == length args) $
228+ unless (length (nub args) == length args) $
225 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
229 throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
226 return ((pos, args ++ bound), Let ds val')
230 return ((pos, args ++ bound), Let ds val')
227 where
231 where
@@ -523,3 +527,11 @@ resolveImport currentModule importModule exps imps impQual =
523 if item `elem` exports
527 if item `elem` exports
524 then return item
528 then return item
525 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
529 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+