a1168e3 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge pull request #2157 from garyb/2138

Combine multiple export refs for types

commita1168e3eb41e7efd879219f4de2c721acf5779c1 authorGary Burgess <gary.burgess@gmail.com> dateTue 24 May 2016, 00:48 (10 years ago) parent4ad29a9 b42f9cf

6 files changed+32−7

compare with golang

unifiedsplit

examples/passing/2138.purs+7 examples/passing/2138/Lib.purs+3 purescript.cabal+1 src/Language/PureScript/Errors.hs+1−1 src/Language/PureScript/Sugar/Names/Env.hs+5−4 src/Language/PureScript/Sugar/Names/Exports.hs+15−2

examples/passing/2138.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+import Control.Monad.Eff.Console (log)

5+import Lib (A(B,C))

7+main = log "Done"

examples/passing/2138/Lib.pursnew file+3

@@ -0,0 +1,3 @@

1+module Lib (A(..), A) where

3+data A = B | C

purescript.cabal+1

@@ -21,6 +21,7 @@ tested-with: GHC==7.10.3

2121

2222extra-source-files: examples/passing/*.purs

2323 , examples/passing/2018/*.purs

24+ , examples/passing/2138/*.purs

2425 , examples/passing/ClassRefSyntax/*.purs

2526 , examples/passing/DctorOperatorAlias/*.purs

2627 , examples/passing/ExplicitImportReExport/*.purs

src/Language/PureScript/Errors.hs+1−1

@@ -577,7 +577,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

577577 paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn

578578 , line "It either does not exist or the module does not export it."

579579 ]

580− renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) =

580+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

581581 line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

582582 renderSimpleErrorMessage (UnknownExport name) =

583583 line $ "Cannot export unknown " ++ printName (Qualified Nothing name)

src/Language/PureScript/Sugar/Names/Env.hs+5−4

@@ -219,9 +219,8 @@ exportType

219219exportType exps name dctors mn = do

220220 let exTypes = exportedTypes exps

221221 let exClasses = exportedTypeClasses exps

222− case name `M.lookup` exTypes of

223− Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name

224− _ -> return ()

222+ forM_ (name `M.lookup` exTypes) $ \(_, mn') ->

223+ when (mn /= mn') $ throwConflictError ConflictingTypeDecls name

225224 when (coerceProperName name `M.member` exClasses) $

226225 throwConflictError TypeConflictsWithClass name

227226 forM_ dctors $ \dctor -> do

@@ -229,9 +228,11 @@ exportType exps name dctors mn = do

229228 throwConflictError ConflictingCtorDecls dctor

230229 when (coerceProperName dctor `M.member` exClasses) $

231230 throwConflictError CtorConflictsWithClass dctor

232− return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes }

231+ return $ exps { exportedTypes = M.alter updateOrInsert name exTypes }

233232 where

234233 dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors'

234+ updateOrInsert Nothing = Just (dctors, mn)

235+ updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn)

235236

236237-- |

237238-- Safely adds a type operator to some exports, returning an error if a

src/Language/PureScript/Sugar/Names/Exports.hs+15−2

@@ -9,8 +9,9 @@ import Control.Monad

99import Control.Monad.Writer.Class (MonadWriter(..))

1010import Control.Monad.Error.Class (MonadError(..))

1111

12+import Data.Function (on)

1213import Data.Foldable (traverse_)

13−import Data.List (intersect)

14+import Data.List (intersect, groupBy, sortBy)

1415import Data.Maybe (fromMaybe, mapMaybe)

1516import qualified Data.Map as M

1617

@@ -224,7 +225,7 @@ filterModule

224225 -> [DeclarationRef]

225226 -> m Exports

226227filterModule mn exps refs = do

227− types <- foldM filterTypes M.empty refs

228+ types <- foldM filterTypes M.empty (combineTypeRefs refs)

228229 typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs

229230 classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs

230231 values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs

@@ -239,6 +240,18 @@ filterModule mn exps refs = do

239240

240241 where

241242

243+ -- Takes the list of exported refs, filters out any non-TypeRefs, then

244+ -- combines any duplicate type exports to ensure that all constructors

245+ -- listed for the type are covered. Without this, only the data constructor

246+ -- listing for the last ref would be used.

247+ combineTypeRefs :: [DeclarationRef] -> [DeclarationRef]

248+ combineTypeRefs

249+ = fmap (uncurry TypeRef)

250+ . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2))

251+ . groupBy ((==) `on` fst)

252+ . sortBy (compare `on` fst)

253+ . mapMaybe getTypeRef

254+

242255 filterTypes

243256 :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)

244257 -> DeclarationRef