Ensure ExportConflict has source span (purescript#3217)

garyb · kritzcreek · commit d60d0f5436a6 · 2018-01-23T11:44:02.000+01:00
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -214,13 +214,14 @@ data ExportMode = Internal | ReExport
 --
 exportType
   :: MonadError MultipleErrors m
-  => ExportMode
+  => SourceSpan
+  -> ExportMode
   -> Exports
   -> ProperName 'TypeName
   -> [ProperName 'ConstructorName]
   -> ModuleName
   -> m Exports
-exportType exportMode exps name dctors mn = do
+exportType ss exportMode exps name dctors mn = do
   let exTypes = exportedTypes exps
       exClasses = exportedTypeClasses exps
       dctorNameCounts :: [(ProperName 'ConstructorName, Int)]
@@ -242,11 +243,11 @@ exportType exportMode exps name dctors mn = do
     ReExport -> do
       forM_ (name `M.lookup` exTypes) $ \(_, mn') ->
         when (mn /= mn') $
-          throwExportConflict mn mn' (TyName name)
+          throwExportConflict ss mn mn' (TyName name)
       forM_ dctors $ \dctor ->
         forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') ->
           when (mn /= mn') $
-            throwExportConflict mn mn' (DctorName dctor)
+            throwExportConflict ss mn mn' (DctorName dctor)
   return $ exps { exportedTypes = M.alter updateOrInsert name exTypes }
   where
   updateOrInsert Nothing = Just (dctors, mn)
@@ -258,45 +259,48 @@ exportType exportMode exps name dctors mn = do
 --
 exportTypeOp
   :: MonadError MultipleErrors m
-  => Exports
+  => SourceSpan
+  -> Exports
   -> OpName 'TypeOpName
   -> ModuleName
   -> m Exports
-exportTypeOp exps op mn = do
-  typeOps <- addExport TyOpName op mn (exportedTypeOps exps)
+exportTypeOp ss exps op mn = do
+  typeOps <- addExport ss TyOpName op mn (exportedTypeOps exps)
   return $ exps { exportedTypeOps = typeOps }
 
 -- |
 -- Safely adds a class to some exports, returning an error if a conflict occurs.
 --
 exportTypeClass
   :: MonadError MultipleErrors m
-  => ExportMode
+  => SourceSpan
+  -> ExportMode
   -> Exports
   -> ProperName 'ClassName
   -> ModuleName
   -> m Exports
-exportTypeClass exportMode exps name mn = do
+exportTypeClass ss exportMode exps name mn = do
   let exTypes = exportedTypes exps
   when (exportMode == Internal) $ do
     when (coerceProperName name `M.member` exTypes) $
       throwDeclConflict (TyClassName name) (TyName (coerceProperName name))
     when ((elem (coerceProperName name) . fst) `any` exTypes) $
       throwDeclConflict (TyClassName name) (DctorName (coerceProperName name))
-  classes <- addExport TyClassName name mn (exportedTypeClasses exps)
+  classes <- addExport ss TyClassName name mn (exportedTypeClasses exps)
   return $ exps { exportedTypeClasses = classes }
 
 -- |
 -- Safely adds a value to some exports, returning an error if a conflict occurs.
 --
 exportValue
   :: MonadError MultipleErrors m
-  => Exports
+  => SourceSpan
+  -> Exports
   -> Ident
   -> ModuleName
   -> m Exports
-exportValue exps name mn = do
-  values <- addExport IdentName name mn (exportedValues exps)
+exportValue ss exps name mn = do
+  values <- addExport ss IdentName name mn (exportedValues exps)
   return $ exps { exportedValues = values }
 
 -- |
@@ -305,25 +309,27 @@ exportValue exps name mn = do
 --
 exportValueOp
   :: MonadError MultipleErrors m
-  => Exports
+  => SourceSpan
+  -> Exports
   -> OpName 'ValueOpName
   -> ModuleName
   -> m Exports
-exportValueOp exps op mn = do
-  valueOps <- addExport ValOpName op mn (exportedValueOps exps)
+exportValueOp ss exps op mn = do
+  valueOps <- addExport ss ValOpName op mn (exportedValueOps exps)
   return $ exps { exportedValueOps = valueOps }
 
 -- |
 -- Safely adds a kind to some exports, returning an error if a conflict occurs.
 --
 exportKind
   :: MonadError MultipleErrors m
-  => Exports
+  => SourceSpan
+  -> Exports
   -> ProperName 'KindName
   -> ModuleName
   -> m Exports
-exportKind exps name mn = do
-  kinds <- addExport KiName name mn (exportedKinds exps)
+exportKind ss exps name mn = do
+  kinds <- addExport ss KiName name mn (exportedKinds exps)
   return $ exps { exportedKinds = kinds }
 
 -- |
@@ -332,16 +338,17 @@ exportKind exps name mn = do
 --
 addExport
   :: (MonadError MultipleErrors m, Ord a)
-  => (a -> Name)
+  => SourceSpan
+  -> (a -> Name)
   -> a
   -> ModuleName
   -> M.Map a ModuleName
   -> m (M.Map a ModuleName)
-addExport toName name mn exports =
+addExport ss toName name mn exports =
   case M.lookup name exports of
     Just mn'
       | mn == mn' -> return exports
-      | otherwise -> throwExportConflict mn mn' (toName name)
+      | otherwise -> throwExportConflict ss mn mn' (toName name)
     Nothing ->
       return $ M.insert name mn exports
 
@@ -361,12 +368,13 @@ throwDeclConflict new existing =
 --
 throwExportConflict
   :: MonadError MultipleErrors m
-  => ModuleName
+  => SourceSpan
+  -> ModuleName
   -> ModuleName
   -> Name
   -> m a
-throwExportConflict new existing name =
-  throwError . errorMessage $
+throwExportConflict ss new existing name =
+  throwError . errorMessage' ss $
     ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name)
 
 -- |
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -34,27 +34,27 @@ findExportable (Module _ _ mn ds _) =
 
   updateExports :: Exports -> Declaration -> m Exports
   updateExports exps (TypeClassDeclaration (ss, _) tcn _ _ _ ds') = do
-    exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn
+    exps' <- rethrowWithPosition ss $ exportTypeClass ss Internal exps tcn mn
     foldM go exps' ds'
     where
-    go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = rethrowWithPosition ss' $ exportValue exps'' name mn
+    go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name mn
     go _ _ = internalError "Invalid declaration in TypeClassDeclaration"
-  updateExports exps (DataDeclaration _ _ tn _ dcs) =
-    exportType Internal exps tn (map fst dcs) mn
-  updateExports exps (TypeSynonymDeclaration _ tn _ _) =
-    exportType Internal exps tn [] mn
-  updateExports exps (ExternDataDeclaration _ tn _) =
-    exportType Internal exps tn [] mn
+  updateExports exps (DataDeclaration (ss, _) _ tn _ dcs) =
+    exportType ss Internal exps tn (map fst dcs) mn
+  updateExports exps (TypeSynonymDeclaration (ss, _) tn _ _) =
+    exportType ss Internal exps tn [] mn
+  updateExports exps (ExternDataDeclaration (ss, _) tn _) =
+    exportType ss Internal exps tn [] mn
   updateExports exps (ValueDeclaration vd) =
-    exportValue exps (valdeclIdent vd) mn
-  updateExports exps (ValueFixityDeclaration _ _ _ op) =
-    exportValueOp exps op mn
-  updateExports exps (TypeFixityDeclaration _ _ _ op) =
-    exportTypeOp exps op mn
-  updateExports exps (ExternDeclaration _ name _) =
-    exportValue exps name mn
-  updateExports exps (ExternKindDeclaration _ pn) =
-    exportKind exps pn mn
+    exportValue (fst (valdeclSourceAnn vd)) exps (valdeclIdent vd) mn
+  updateExports exps (ValueFixityDeclaration (ss, _) _ _ op) =
+    exportValueOp ss exps op mn
+  updateExports exps (TypeFixityDeclaration (ss, _) _ _ op) =
+    exportTypeOp ss exps op mn
+  updateExports exps (ExternDeclaration (ss, _) name _) =
+    exportValue ss exps name mn
+  updateExports exps (ExternKindDeclaration (ss, _) pn) =
+    exportKind ss exps pn mn
   updateExports exps _ = return exps
 
 -- |
@@ -110,12 +110,12 @@ resolveExports env ss mn imps exps refs =
     reValues <- extract isPseudo name IdentName (importedValues imps)
     reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)
     reKinds <- extract isPseudo name KiName (importedKinds imps)
-    foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
-      >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)
-      >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses)
-      >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)
-      >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)
-      >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds)
+    foldM (\exps' ((tctor, dctors), mn') -> exportType ss' ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
+      >>= flip (foldM (uncurry . exportTypeOp ss')) (map resolveTypeOp reTypeOps)
+      >>= flip (foldM (uncurry . exportTypeClass ss' ReExport)) (map resolveClass reClasses)
+      >>= flip (foldM (uncurry . exportValue ss')) (map resolveValue reValues)
+      >>= flip (foldM (uncurry . exportValueOp ss')) (map resolveValueOp reValueOps)
+      >>= flip (foldM (uncurry . exportKind ss')) (map resolveKind reKinds)
   elaborateModuleExports result _ = return result
 
   -- Extracts a list of values for a module based on a lookup table. If the
