d2dfad0 · rowtype-yoga/purescript-native

examples/failing/DeclConflictClassCtor.pursnew file+6

compare with golang

unifiedsplit

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+data T = Fail

5+

6+class Fail

examples/failing/DeclConflictClassSynonym.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+import Prelude

5+

6+type Fail = Unit

7+

8+class Fail

examples/failing/DeclConflictClassType.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+class Fail

5+

6+data Fail

examples/failing/DeclConflictCtorClass.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+class Fail

5+

6+data T = Fail

examples/failing/DeclConflictCtorCtor.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+data T1 = Fail

5+

6+data T2 = Fail

examples/failing/DeclConflictSynonymClass.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+import Prelude

5+

6+class Fail

7+

8+type Fail = Unit

examples/failing/DeclConflictSynonymType.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+import Prelude

5+

6+data Fail

7+

8+type Fail = Unit

examples/failing/DeclConflictTypeClass.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+class Fail

5+

6+data Fail

examples/failing/DeclConflictTypeSynonym.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+import Prelude

5+

6+type Fail = Unit

7+

8+data Fail

examples/failing/DeclConflictTypeType.pursnew file+6

@@ -0,0 +1,6 @@

1+-- @shouldFailWith DeclConflict

2+module Main where

3+

4+data Fail

5+

6+data Fail

examples/failing/ExportConflictClass.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/ExportConflictClass/A.pursnew file+3

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

1+module A where

2+

3+class X

examples/failing/ExportConflictClass/B.pursnew file+3

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

1+module B where

2+

3+class X

examples/failing/ExportConflictCtor.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/ExportConflictCtor/A.pursnew file+3

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

1+module A where

2+

3+data T1 = X

examples/failing/ExportConflictCtor/B.pursnew file+3

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

1+module B where

2+

3+data T2 = X

examples/failing/ExportConflictType.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/ExportConflictType/A.pursnew file+3

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

1+module A where

2+

3+data T

examples/failing/ExportConflictType/B.pursnew file+3

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

1+module B where

2+

3+data T

examples/failing/ExportConflictTypeOp.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/ExportConflictTypeOp/A.pursnew file+5

@@ -0,0 +1,5 @@

1+module A where

2+

3+type T1 a b = a -> b

4+

5+infixr 4 type T1 as ??

examples/failing/ExportConflictTypeOp/B.pursnew file+5

@@ -0,0 +1,5 @@

1+module B where

2+

3+type T2 a b = a -> b

4+

5+infixr 4 type T2 as ??

examples/failing/ExportConflictValue.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/OverlappingReExport/A.purs → examples/failing/ExportConflictValue/A.pursrenamed+2

@@ -1,2 +1,4 @@

1module A where

2+

3+x :: Boolean

2x = true

4x = true

examples/failing/OverlappingReExport/B.purs → examples/failing/ExportConflictValue/B.pursrenamed+2

@@ -1,2 +1,4 @@

1module B where

2+

3+x :: Boolean

2x = false

4x = false

examples/failing/ExportConflictValueOp.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith ExportConflict

2+module C (module A, module B) where

3+

4+import A as A

5+import B as B

examples/failing/ExportConflictValueOp/A.pursnew file+6

@@ -0,0 +1,6 @@

1+module A where

2+

3+f1 :: forall a b. a -> b -> a

4+f1 x _ = x

5+

6+infix 0 f1 as !!

examples/failing/ExportConflictValueOp/B.pursnew file+6

@@ -0,0 +1,6 @@

1+module B where

2+

3+f2 :: forall a b. a -> b -> a

4+f2 x _ = x

5+

6+infix 0 f2 as !!

examples/failing/OverlappingReExport.pursdeleted−5

@@ -1,5 +0,0 @@

1−-- @shouldFailWith DuplicateValueExport

2−module C (module A, module M2) where

3−

4−import A

5−import B as M2

purescript.cabal+6−1

@@ -59,6 +59,12 @@ extra-source-files: examples/passing/*.purs

59 , examples/failing/ConflictingImports2/*.purs

60 , examples/failing/ConflictingQualifiedImports/*.purs

61 , examples/failing/ConflictingQualifiedImports2/*.purs

62+ , examples/failing/ExportConflictClass/*.purs

63+ , examples/failing/ExportConflictCtor/*.purs

64+ , examples/failing/ExportConflictType/*.purs

65+ , examples/failing/ExportConflictTypeOp/*.purs

66+ , examples/failing/ExportConflictValue/*.purs

67+ , examples/failing/ExportConflictValueOp/*.purs

62 , examples/failing/ExportExplicit1/*.purs

68 , examples/failing/ExportExplicit1/*.purs

63 , examples/failing/ExportExplicit3/*.purs

69 , examples/failing/ExportExplicit3/*.purs

64 , examples/failing/ImportExplicit/*.purs

70 , examples/failing/ImportExplicit/*.purs

@@ -67,7 +73,6 @@ extra-source-files: examples/passing/*.purs

67 , examples/failing/ImportModule/*.purs

73 , examples/failing/ImportModule/*.purs

68 , examples/failing/InstanceExport/*.purs

74 , examples/failing/InstanceExport/*.purs

69 , examples/failing/OrphanInstance/*.purs

75 , examples/failing/OrphanInstance/*.purs

70− , examples/failing/OverlappingReExport/*.purs

71 , examples/warning/*.purs

76 , examples/warning/*.purs

72 , examples/warning/*.js

77 , examples/warning/*.js

73 , examples/docs/bower_components/purescript-prelude/src/*.purs

78 , examples/docs/bower_components/purescript-prelude/src/*.purs

src/Language/PureScript/Errors.hs+37−57

@@ -65,17 +65,9 @@ data SimpleErrorMessage

65 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

66 | ScopeConflict Name [ModuleName]

67 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]

68− | ConflictingTypeDecls (ProperName 'TypeName)

68+ | DeclConflict Name Name

69− | ConflictingCtorDecls (ProperName 'ConstructorName)

69+ | ExportConflict (Qualified Name) (Qualified Name)

70− | TypeConflictsWithClass (ProperName 'TypeName)

71− | CtorConflictsWithClass (ProperName 'ConstructorName)

72− | ClassConflictsWithType (ProperName 'ClassName)

73− | ClassConflictsWithCtor (ProperName 'ClassName)

74 | DuplicateModuleName ModuleName

70 | DuplicateModuleName ModuleName

75− | DuplicateClassExport (ProperName 'ClassName)

76− | DuplicateValueExport Ident

77− | DuplicateValueOpExport (OpName 'ValueOpName)

78− | DuplicateTypeOpExport (OpName 'TypeOpName)

79 | DuplicateTypeArgument String

71 | DuplicateTypeArgument String

80 | InvalidDoBind

72 | InvalidDoBind

81 | InvalidDoLet

73 | InvalidDoLet

@@ -234,17 +226,9 @@ errorCode em = case unwrapErrorMessage em of

234 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

226 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

235 ScopeConflict{} -> "ScopeConflict"

227 ScopeConflict{} -> "ScopeConflict"

236 ScopeShadowing{} -> "ScopeShadowing"

228 ScopeShadowing{} -> "ScopeShadowing"

237− ConflictingTypeDecls{} -> "ConflictingTypeDecls"

229+ DeclConflict{} -> "DeclConflict"

238− ConflictingCtorDecls{} -> "ConflictingCtorDecls"

230+ ExportConflict{} -> "ExportConflict"

239− TypeConflictsWithClass{} -> "TypeConflictsWithClass"

240− CtorConflictsWithClass{} -> "CtorConflictsWithClass"

241− ClassConflictsWithType{} -> "ClassConflictsWithType"

242− ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"

243 DuplicateModuleName{} -> "DuplicateModuleName"

231 DuplicateModuleName{} -> "DuplicateModuleName"

244− DuplicateClassExport{} -> "DuplicateClassExport"

245− DuplicateValueExport{} -> "DuplicateValueExport"

246− DuplicateValueOpExport{} -> "DuplicateValueOpExport"

247− DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"

248 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

232 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

249 InvalidDoBind -> "InvalidDoBind"

233 InvalidDoBind -> "InvalidDoBind"

250 InvalidDoLet -> "InvalidDoLet"

234 InvalidDoLet -> "InvalidDoLet"

@@ -479,7 +463,7 @@ colorCodeBox codeColor b = case codeColor of

479 Just cc

463 Just cc

480 | Box.rows b == 1 ->

464 | Box.rows b == 1 ->

481 Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset

465 Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset

482−

466+

483 | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards

467 | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards

484 [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc

468 [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc

485 , b

469 , b

@@ -648,28 +632,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

648 Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."

632 Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."

649 Nothing -> "local declaration will be used."

633 Nothing -> "local declaration will be used."

650 ]

634 ]

651− renderSimpleErrorMessage (ConflictingTypeDecls nm) =

635+ renderSimpleErrorMessage (DeclConflict new existing) =

652− line $ "Conflicting type declarations for " ++ markCode (runProperName nm)

636+ line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."

653− renderSimpleErrorMessage (ConflictingCtorDecls nm) =

654− line $ "Conflicting data constructor declarations for " ++ markCode (runProperName nm)

655− renderSimpleErrorMessage (TypeConflictsWithClass nm) =

656− line $ "Type " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name."

657− renderSimpleErrorMessage (CtorConflictsWithClass nm) =

658− line $ "Data constructor " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name."

659− renderSimpleErrorMessage (ClassConflictsWithType nm) =

637+ renderSimpleErrorMessage (ExportConflict new existing) =

660− line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a type declaration with the same name."

638+ line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing

661− renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

662− line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a data constructor declaration with the same name."

663 renderSimpleErrorMessage (DuplicateModuleName mn) =

639 renderSimpleErrorMessage (DuplicateModuleName mn) =

664 line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."

640 line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."

665− renderSimpleErrorMessage (DuplicateClassExport nm) =

666− line $ "Duplicate export declaration for type class " ++ markCode (runProperName nm)

667− renderSimpleErrorMessage (DuplicateValueExport nm) =

668− line $ "Duplicate export declaration for value " ++ markCode (showIdent nm)

669− renderSimpleErrorMessage (DuplicateValueOpExport op) =

670− line $ "Duplicate export declaration for operator " ++ markCode (showOp op)

671− renderSimpleErrorMessage (DuplicateTypeOpExport op) =

672− line $ "Duplicate export declaration for type operator " ++ markCode (showOp op)

673 renderSimpleErrorMessage (CycleInDeclaration nm) =

641 renderSimpleErrorMessage (CycleInDeclaration nm) =

674 line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."

642 line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."

675 renderSimpleErrorMessage (CycleInModules mns) =

643 renderSimpleErrorMessage (CycleInModules mns) =

@@ -1096,22 +1064,34 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1096 ]

1064 ]

1097

1065

1098 printName :: Qualified Name -> String

1066 printName :: Qualified Name -> String

1099− printName (Qualified mn (IdentName name)) =

1067+ printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

1100− "value " ++ markCode (showQualified showIdent (Qualified mn name))

1068+

1101− printName (Qualified mn (ValOpName op)) =

1069+ nameType :: Name -> String

1102− "operator " ++ markCode (showQualified showOp (Qualified mn op))

1070+ nameType (IdentName _) = "value"

1103− printName (Qualified mn (TyName name)) =

1071+ nameType (ValOpName _) = "operator"

1104− "type " ++ markCode (showQualified runProperName (Qualified mn name))

1072+ nameType (TyName _) = "type"

1105− printName (Qualified mn (TyOpName op)) =

1073+ nameType (TyOpName _) = "type operator"

1106− "type operator " ++ markCode (showQualified showOp (Qualified mn op))

1074+ nameType (DctorName _) = "data constructor"

1107− printName (Qualified mn (DctorName name)) =

1075+ nameType (TyClassName _) = "type class"

1108− "data constructor " ++ markCode (showQualified runProperName (Qualified mn name))

1076+ nameType (ModName _) = "module"

1109− printName (Qualified mn (TyClassName name)) =

1077+

1110− "type class " ++ markCode (showQualified runProperName (Qualified mn name))

1078+ runName :: Qualified Name -> String

1111− printName (Qualified Nothing (ModName name)) =

1079+ runName (Qualified mn (IdentName name)) =

1080+ showQualified showIdent (Qualified mn name)

1081+ runName (Qualified mn (ValOpName op)) =

1082+ showQualified showOp (Qualified mn op)

1083+ runName (Qualified mn (TyName name)) =

1084+ showQualified runProperName (Qualified mn name)

1085+ runName (Qualified mn (TyOpName op)) =

1086+ showQualified showOp (Qualified mn op)

1087+ runName (Qualified mn (DctorName name)) =

1088+ showQualified runProperName (Qualified mn name)

1089+ runName (Qualified mn (TyClassName name)) =

1090+ showQualified runProperName (Qualified mn name)

1091+ runName (Qualified Nothing (ModName name)) =

1112− "module " ++ markCode (runModuleName name)

1092+ runModuleName name

1113− printName (Qualified _ ModName{}) =

1093+ runName (Qualified _ ModName{}) =

1114− internalError "qualified ModName in printName"

1094+ internalError "qualified ModName in runName"

1115

1095

1116 valueDepth :: Int

1096 valueDepth :: Int

1117 valueDepth | full = 1000

1097 valueDepth | full = 1000

src/Language/PureScript/Sugar/Names/Env.hs+67−30

@@ -10,6 +10,7 @@ module Language.PureScript.Sugar.Names.Env

10 , envModuleSourceSpan

11 , envModuleImports

12 , envModuleExports

13+ , ExportMode(..)

13 , exportType

14 , exportType

14 , exportTypeOp

15 , exportTypeOp

15 , exportTypeClass

16 , exportTypeClass

@@ -26,6 +27,7 @@ import Control.Monad.Error.Class (MonadError(..))

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

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

27

28

28import Data.Function (on)

29import Data.Function (on)

30+import Data.Foldable (find)

29import Data.List (groupBy, sortBy, delete)

31import Data.List (groupBy, sortBy, delete)

30import Data.Maybe (fromJust, mapMaybe)

32import Data.Maybe (fromJust, mapMaybe)

31import qualified Data.Map as M

33import qualified Data.Map as M

@@ -205,32 +207,51 @@ primEnv = M.singleton

205 primModuleName

207 primModuleName

206 (internalModuleSourceSpan "<Prim>", nullImports, primExports)

208 (internalModuleSourceSpan "<Prim>", nullImports, primExports)

207

209

210+-- |

211+-- When updating the `Exports` the behaviour is slightly different depending

212+-- on whether we are exporting values defined within the module or elaborating

213+-- re-exported values. This type is used to indicate which behaviour should be

214+-- used.

215+--

216+data ExportMode = Internal | ReExport

217+ deriving (Eq, Show)

218+

208-- |

219-- |

209-- Safely adds a type and its data constructors to some exports, returning an

220-- Safely adds a type and its data constructors to some exports, returning an

210-- error if a conflict occurs.

221-- error if a conflict occurs.

211--

222--

212exportType

223exportType

213 :: MonadError MultipleErrors m

224 :: MonadError MultipleErrors m

225+ => ExportMode

214− => Exports

226+ -> Exports

215 -> ProperName 'TypeName

227 -> ProperName 'TypeName

216 -> [ProperName 'ConstructorName]

228 -> [ProperName 'ConstructorName]

217 -> ModuleName

229 -> ModuleName

218 -> m Exports

230 -> m Exports

219−exportType exps name dctors mn = do

231+exportType exportMode exps name dctors mn = do

220 let exTypes = exportedTypes exps

232 let exTypes = exportedTypes exps

221 let exClasses = exportedTypeClasses exps

233 let exClasses = exportedTypeClasses exps

234+ case exportMode of

235+ Internal -> do

236+ when (name `M.member` exTypes) $

237+ throwDeclConflict (TyName name) (TyName name)

238+ when (coerceProperName name `M.member` exClasses) $

239+ throwDeclConflict (TyName name) (TyClassName (coerceProperName name))

240+ forM_ dctors $ \dctor -> do

241+ when ((elem dctor . fst) `any` exTypes) $

242+ throwDeclConflict (DctorName dctor) (DctorName dctor)

243+ when (coerceProperName dctor `M.member` exClasses) $

244+ throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor))

245+ ReExport -> do

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

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

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

247+ when (mn /= mn') $

224− when (coerceProperName name `M.member` exClasses) $

248+ throwExportConflict mn mn' (TyName name)

225− throwConflictError TypeConflictsWithClass name

226− forM_ dctors $ \dctor -> do

249+ forM_ dctors $ \dctor ->

227− when (dctorExists (coerceProperName dctor) `any` exTypes) $

250+ forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') ->

228− throwConflictError ConflictingCtorDecls dctor

251+ when (mn /= mn') $

229− when (coerceProperName dctor `M.member` exClasses) $

252+ throwExportConflict mn mn' (DctorName dctor)

230− throwConflictError CtorConflictsWithClass dctor

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

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

232 where

254 where

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

234 updateOrInsert Nothing = Just (dctors, mn)

255 updateOrInsert Nothing = Just (dctors, mn)

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

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

236

257

@@ -245,7 +266,7 @@ exportTypeOp

245 -> ModuleName

266 -> ModuleName

246 -> m Exports

267 -> m Exports

247exportTypeOp exps op mn = do

268exportTypeOp exps op mn = do

248− typeOps <- addExport DuplicateTypeOpExport op mn (exportedTypeOps exps)

269+ typeOps <- addExport TyOpName op mn (exportedTypeOps exps)

249 return $ exps { exportedTypeOps = typeOps }

270 return $ exps { exportedTypeOps = typeOps }

250

271

251-- |

272-- |

@@ -253,17 +274,19 @@ exportTypeOp exps op mn = do

253--

274--

254exportTypeClass

275exportTypeClass

255 :: MonadError MultipleErrors m

276 :: MonadError MultipleErrors m

277+ => ExportMode

256− => Exports

278+ -> Exports

257 -> ProperName 'ClassName

279 -> ProperName 'ClassName

258 -> ModuleName

280 -> ModuleName

259 -> m Exports

281 -> m Exports

260−exportTypeClass exps name mn = do

282+exportTypeClass exportMode exps name mn = do

261 let exTypes = exportedTypes exps

283 let exTypes = exportedTypes exps

284+ when (exportMode == Internal) $ do

262− when (coerceProperName name `M.member` exTypes) $

285+ when (coerceProperName name `M.member` exTypes) $

263− throwConflictError ClassConflictsWithType name

286+ throwDeclConflict (TyClassName name) (TyName (coerceProperName name))

264− when ((elem (coerceProperName name) . fst) `any` exTypes) $

287+ when ((elem (coerceProperName name) . fst) `any` exTypes) $

265− throwConflictError ClassConflictsWithCtor name

288+ throwDeclConflict (TyClassName name) (DctorName (coerceProperName name))

266− classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

289+ classes <- addExport TyClassName name mn (exportedTypeClasses exps)

267 return $ exps { exportedTypeClasses = classes }

290 return $ exps { exportedTypeClasses = classes }

268

291

269-- |

292-- |

@@ -276,7 +299,7 @@ exportValue

276 -> ModuleName

299 -> ModuleName

277 -> m Exports

300 -> m Exports

278exportValue exps name mn = do

301exportValue exps name mn = do

279− values <- addExport DuplicateValueExport name mn (exportedValues exps)

302+ values <- addExport IdentName name mn (exportedValues exps)

280 return $ exps { exportedValues = values }

303 return $ exps { exportedValues = values }

281

304

282-- |

305-- |

@@ -290,7 +313,7 @@ exportValueOp

290 -> ModuleName

313 -> ModuleName

291 -> m Exports

314 -> m Exports

292exportValueOp exps op mn = do

315exportValueOp exps op mn = do

293− valueOps <- addExport DuplicateValueOpExport op mn (exportedValueOps exps)

316+ valueOps <- addExport ValOpName op mn (exportedValueOps exps)

294 return $ exps { exportedValueOps = valueOps }

317 return $ exps { exportedValueOps = valueOps }

295

318

296-- |

319-- |

@@ -299,28 +322,42 @@ exportValueOp exps op mn = do

299--

322--

300addExport

323addExport

301 :: (MonadError MultipleErrors m, Ord a)

324 :: (MonadError MultipleErrors m, Ord a)

302− => (a -> SimpleErrorMessage)

325+ => (a -> Name)

303 -> a

326 -> a

304 -> ModuleName

327 -> ModuleName

305 -> M.Map a ModuleName

328 -> M.Map a ModuleName

306 -> m (M.Map a ModuleName)

329 -> m (M.Map a ModuleName)

307−addExport what name mn exports =

330+addExport toName name mn exports =

308 case M.lookup name exports of

331 case M.lookup name exports of

309 Just mn'

332 Just mn'

310 | mn == mn' -> return exports

333 | mn == mn' -> return exports

311− | otherwise -> throwConflictError what name

334+ | otherwise -> throwExportConflict mn mn' (toName name)

312 Nothing ->

335 Nothing ->

313 return $ M.insert name mn exports

336 return $ M.insert name mn exports

314

337

315-- |

338-- |

316-- Raises an error for when there is more than one definition for something.

339-- Raises an error for when there is more than one definition for something.

317--

340--

318−throwConflictError

341+throwDeclConflict

319 :: MonadError MultipleErrors m

342 :: MonadError MultipleErrors m

320− => (a -> SimpleErrorMessage)

343+ => Name

321− -> a

344+ -> Name

345+ -> m a

346+throwDeclConflict new existing =

347+ throwError . errorMessage $ DeclConflict new existing

348+

349+-- |

350+-- Raises an error for when there are conflicting names in the exports.

351+--

352+throwExportConflict

353+ :: MonadError MultipleErrors m

354+ => ModuleName

355+ -> ModuleName

356+ -> Name

322− -> m b

357+ -> m a

358+throwExportConflict new existing name =

323−throwConflictError conflict = throwError . errorMessage . conflict

359+ throwError . errorMessage $

360+ ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name)

324

361

325-- |

362-- |

326-- Gets the exports for a module, or raise an error if the module doesn't exist.

363-- Gets the exports for a module, or raise an error if the module doesn't exist.

src/Language/PureScript/Sugar/Names/Exports.hs+19−11

@@ -31,20 +31,28 @@ findExportable (Module _ _ mn ds _) =

31 where

32 updateExports :: Exports -> Declaration -> m Exports

33 updateExports exps (TypeClassDeclaration tcn _ _ ds') = do

34− exps' <- exportTypeClass exps tcn mn

34+ exps' <- exportTypeClass Internal exps tcn mn

35 foldM go exps' ds'

36 where

37 go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

38 go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

39 go _ _ = internalError "Invalid declaration in TypeClassDeclaration"

40− updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

40+ updateExports exps (DataDeclaration _ tn _ dcs) =

41+ exportType Internal exps tn (map fst dcs) mn

41− updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

42+ updateExports exps (TypeSynonymDeclaration tn _ _) =

43+ exportType Internal exps tn [] mn

42− updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

44+ updateExports exps (ExternDataDeclaration tn _) =

45+ exportType Internal exps tn [] mn

43− updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

46+ updateExports exps (ValueDeclaration name _ _ _) =

47+ exportValue exps name mn

44− updateExports exps (ValueFixityDeclaration _ _ op) = exportValueOp exps op mn

48+ updateExports exps (ValueFixityDeclaration _ _ op) =

49+ exportValueOp exps op mn

45− updateExports exps (TypeFixityDeclaration _ _ op) = exportTypeOp exps op mn

50+ updateExports exps (TypeFixityDeclaration _ _ op) =

51+ exportTypeOp exps op mn

46− updateExports exps (ExternDeclaration name _) = exportValue exps name mn

52+ updateExports exps (ExternDeclaration name _) =

53+ exportValue exps name mn

47− updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

54+ updateExports exps (PositionedDeclaration pos _ d) =

55+ rethrowWithPosition pos $ updateExports exps d

48 updateExports exps _ = return exps

56 updateExports exps _ = return exps

49

57

50-- |

58-- |

@@ -99,9 +107,9 @@ resolveExports env ss mn imps exps refs =

99 reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)

107 reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)

100 reValues <- extract isPseudo name IdentName (importedValues imps)

108 reValues <- extract isPseudo name IdentName (importedValues imps)

101 reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)

109 reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)

102− foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

110+ foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

103 >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)

111 >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)

104− >>= flip (foldM (uncurry . exportTypeClass)) (map resolveClass reClasses)

112+ >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses)

105 >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)

113 >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)

106 >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)

114 >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)

107 elaborateModuleExports result _ = return result

115 elaborateModuleExports result _ = return result