From b42f9cfda650d8964c5084c0c773cef3bd11fe70 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 May 2016 00:17:56 +0100 Subject: [PATCH] Combine multiple export refs for types --- examples/passing/2138.purs | 7 +++++++ examples/passing/2138/Lib.purs | 3 +++ purescript.cabal | 1 + src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 9 +++++---- src/Language/PureScript/Sugar/Names/Exports.hs | 17 +++++++++++++++-- 6 files changed, 32 insertions(+), 7 deletions(-) create mode 100644 examples/passing/2138.purs create mode 100644 examples/passing/2138/Lib.purs diff --git a/examples/passing/2138.purs b/examples/passing/2138.purs new file mode 100644 index 0000000000..1c05373757 --- /dev/null +++ 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 new file mode 100644 index 0000000000..3c433e0b1e --- /dev/null +++ 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 index 234a3c2d44..d9db8a4392 100644 --- 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 index 05a63dc9d7..a438694729 100644 --- 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 index a1426b6769..4b6ce1592a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -219,9 +219,8 @@ 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 @@ -229,9 +228,11 @@ exportType exps name dctors mn = do 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 index 98e9e7d689..5026de3c7f 100644 --- 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