Take advantage of multi-span errors (purescript#3273)

garyb · web-flow · commit 96ccf1ebb69d · 2018-03-11T14:18:02.000Z
* Take advantage of multi-span errors

This fixes `CycleInModule ` not having many positions, and adds all
positions for `DuplicateModule` using the usual form rather than
special handling

* Work around Data.Graph not using NELs
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -93,7 +93,7 @@ data SimpleErrorMessage
   | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
   | DeclConflict Name Name
   | ExportConflict (Qualified Name) (Qualified Name)
-  | DuplicateModule ModuleName [SourceSpan]
+  | DuplicateModule ModuleName
   | DuplicateTypeClass (ProperName 'ClassName) SourceSpan
   | DuplicateInstance Ident SourceSpan
   | DuplicateTypeArgument Text
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -197,6 +197,10 @@ errorMessage err = MultipleErrors [ErrorMessage [] err]
 errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors
 errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err]
 
+-- | Create an error set from a single simple error message and source annotations
+errorMessage'' :: NEL.NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
+errorMessage'' sss err = MultipleErrors [ErrorMessage [PositionedError sss] err]
+
 -- | Create an error set from a single error message
 singleError :: ErrorMessage -> MultipleErrors
 singleError = MultipleErrors . pure
@@ -537,10 +541,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
       line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name."
     renderSimpleErrorMessage (ExportConflict new existing) =
       line $ "Export for " <> printName new <> " conflicts with " <> runName existing
-    renderSimpleErrorMessage (DuplicateModule mn ss) =
-      paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:")
-            , indent . paras $ map (line . displaySourceSpan relPath) ss
-            ]
+    renderSimpleErrorMessage (DuplicateModule mn) =
+      line $ "Module " <> markCode (runModuleName mn) <> " has been defined multiple times"
     renderSimpleErrorMessage (DuplicateTypeClass pn ss) =
       paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:")
             , indent $ line $ displaySourceSpan relPath ss
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -38,7 +38,8 @@ import           Data.Aeson (encode, decode)
 import           Data.Either (partitionEithers)
 import           Data.Function (on)
 import           Data.Foldable (for_)
-import           Data.List (foldl', sortBy, groupBy)
+import           Data.List (foldl', sortBy)
+import qualified Data.List.NonEmpty as NEL
 import           Data.Maybe (fromMaybe, catMaybes)
 import           Data.Monoid ((<>))
 import           Data.Time.Clock
@@ -191,13 +192,13 @@ make ma@MakeActions{..} ms = do
   checkModuleNamesAreUnique =
     for_ (findDuplicates getModuleName ms) $ \mss ->
       throwError . flip foldMap mss $ \ms' ->
-        let mn = getModuleName (head ms')
-        in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms')
+        let mn = getModuleName (NEL.head ms')
+        in errorMessage'' (fmap getModuleSourceSpan ms') $ DuplicateModule mn
 
   -- Find all groups of duplicate values in a list based on a projection.
-  findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]]
+  findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
   findDuplicates f xs =
-    case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of
+    case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of
       [] -> Nothing
       xss -> Just xss
 
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
@@ -7,7 +7,7 @@ module Language.PureScript.ModuleDependencies
 import           Protolude hiding (head)
 
 import           Data.Graph
-import           Data.List (head)
+import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Set as S
 import           Language.PureScript.AST
 import qualified Language.PureScript.Constants as C
@@ -59,8 +59,9 @@ usedModules _ = Nothing
 -- | Convert a strongly connected component of the module graph to a module
 toModule :: MonadError MultipleErrors m => SCC Module -> m Module
 toModule (AcyclicSCC m) = return m
+toModule (CyclicSCC []) = internalError "toModule: empty CyclicSCC"
 toModule (CyclicSCC [m]) = return m
-toModule (CyclicSCC ms) =
+toModule (CyclicSCC (m : ms)) =
   throwError
-    . errorMessage' (getModuleSourceSpan (head ms))
+    . errorMessage'' (fmap getModuleSourceSpan (m :| ms))
     $ CycleInModules (map getModuleName ms)
