Combine multiple export refs for types

garyb · garyb · commit b42f9cfda650 · 2016-05-24T00:17:56.000+01:00
diff --git a/examples/passing/2138.purs b/examples/passing/2138.purs
@@ -0,0 +1,7 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+import Lib (A(B,C))
+
+main = log "Done"
diff --git a/examples/passing/2138/Lib.purs b/examples/passing/2138/Lib.purs
@@ -0,0 +1,3 @@
+module Lib (A(..), A) where
+
+data A = B | C
diff --git a/purescript.cabal b/purescript.cabal
@@ -21,6 +21,7 @@ tested-with: GHC==7.10.3
 
 extra-source-files: examples/passing/*.purs
                   , examples/passing/2018/*.purs
+                  , examples/passing/2138/*.purs
                   , examples/passing/ClassRefSyntax/*.purs
                   , examples/passing/DctorOperatorAlias/*.purs
                   , examples/passing/ExplicitImportReExport/*.purs
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -577,7 +577,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
       paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn
             , line "It either does not exist or the module does not export it."
             ]
-    renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) =
+    renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
       line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
     renderSimpleErrorMessage (UnknownExport name) =
       line $ "Cannot export unknown " ++ printName (Qualified Nothing name)
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -219,19 +219,20 @@ exportType
 exportType exps name dctors mn = do
   let exTypes = exportedTypes exps
   let exClasses = exportedTypeClasses exps
-  case name `M.lookup` exTypes of
-    Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name
-    _ -> return ()
+  forM_ (name `M.lookup` exTypes) $ \(_, mn') ->
+    when (mn /= mn') $ throwConflictError ConflictingTypeDecls name
   when (coerceProperName name `M.member` exClasses) $
     throwConflictError TypeConflictsWithClass name
   forM_ dctors $ \dctor -> do
     when (dctorExists (coerceProperName dctor) `any` exTypes) $
       throwConflictError ConflictingCtorDecls dctor
     when (coerceProperName dctor `M.member` exClasses) $
       throwConflictError CtorConflictsWithClass dctor
-  return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes }
+  return $ exps { exportedTypes = M.alter updateOrInsert name exTypes }
   where
   dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors'
+  updateOrInsert Nothing = Just (dctors, mn)
+  updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn)
 
 -- |
 -- Safely adds a type operator to some exports, returning an error if a
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -9,8 +9,9 @@ import Control.Monad
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Error.Class (MonadError(..))
 
+import Data.Function (on)
 import Data.Foldable (traverse_)
-import Data.List (intersect)
+import Data.List (intersect, groupBy, sortBy)
 import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Map as M
 
@@ -224,7 +225,7 @@ filterModule
   -> [DeclarationRef]
   -> m Exports
 filterModule mn exps refs = do
-  types <- foldM filterTypes M.empty refs
+  types <- foldM filterTypes M.empty (combineTypeRefs refs)
   typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs
   classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs
   values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs
@@ -239,6 +240,18 @@ filterModule mn exps refs = do
 
   where
 
+  -- Takes the list of exported refs, filters out any non-TypeRefs, then
+  -- combines any duplicate type exports to ensure that all constructors
+  -- listed for the type are covered. Without this, only the data constructor
+  -- listing for the last ref would be used.
+  combineTypeRefs :: [DeclarationRef] -> [DeclarationRef]
+  combineTypeRefs
+    = fmap (uncurry TypeRef)
+    . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2))
+    . groupBy ((==) `on` fst)
+    . sortBy (compare `on` fst)
+    . mapMaybe getTypeRef
+
   filterTypes
     :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
     -> DeclarationRef

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+module Lib (A(..), A) where`
	`2`	`+`
	`3`	`+data A = B \| C`
Original file line number	Diff line number	Diff line change
`@@ -577,7 +577,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap`
`577`	`577`	`paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn`
`578`	`578`	`, line "It either does not exist or the module does not export it."`
`579`	`579`	`]`
`580`		`- renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) =`
	`580`	`+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =`
`581`	`581`	`line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon`
`582`	`582`	`renderSimpleErrorMessage (UnknownExport name) =`
`583`	`583`	`line $ "Cannot export unknown " ++ printName (Qualified Nothing name)`