f1d159a · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1398 from purescript/1391-misleading-type-import

f1d159aGary Burgess11 years ago

src/Language/PureScript/Docs/ParseAndDesugar.hs+3−1

compare with golang

unifiedsplit

@@ -11,6 +11,7 @@ import Control.Monad

11import Control.Applicative

13import Control.Monad.Trans.Except

14+import Control.Monad.Writer (WriterT(), runWriterT)

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

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

15import Control.Monad.IO.Class (MonadIO(..))

16import Control.Monad.IO.Class (MonadIO(..))

@@ -118,7 +119,8 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

118desugar = P.evalSupplyT 0 . desugar'

119desugar = P.evalSupplyT 0 . desugar'

119 where

120 where

120 desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

121 desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

121− desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports

122+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports

123+ ignoreWarnings m = liftM fst (runWriterT m)

122

124

123parseFile :: FilePath -> IO (FilePath, String)

125parseFile :: FilePath -> IO (FilePath, String)

124parseFile input' = (,) input' <$> readFile input'

126parseFile input' = (,) input' <$> readFile input'

src/Language/PureScript/Errors.hs+12−5

@@ -134,6 +134,7 @@ data SimpleErrorMessage

134 | NotExhaustivePattern [[Binder]] Bool

135 | OverlappingPattern [[Binder]] Bool

136 | ClassOperator ProperName Ident

137+ | MisleadingEmptyTypeImport ModuleName ProperName

137 deriving (Show)

138 deriving (Show)

138

139

139-- |

140-- |

@@ -256,6 +257,7 @@ errorCode em = case unwrapErrorMessage em of

256 NotExhaustivePattern{} -> "NotExhaustivePattern"

257 NotExhaustivePattern{} -> "NotExhaustivePattern"

257 OverlappingPattern{} -> "OverlappingPattern"

258 OverlappingPattern{} -> "OverlappingPattern"

258 ClassOperator{} -> "ClassOperator"

259 ClassOperator{} -> "ClassOperator"

260+ MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

259

261

260-- |

262-- |

261-- A stack trace for an error

263-- A stack trace for an error

@@ -606,6 +608,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

606 , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

608 , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

607 , indent $ line $ show opName ++ " = someMember"

609 , indent $ line $ show opName ++ " = someMember"

608 ]

610 ]

611+ goSimple (MisleadingEmptyTypeImport mn name) =

612+ line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors"

609 goSimple (WildcardInferredType ty) =

613 goSimple (WildcardInferredType ty) =

610 line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

614 line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

611 goSimple (NotExhaustivePattern bs b) =

615 goSimple (NotExhaustivePattern bs b) =

@@ -845,11 +849,14 @@ rethrow f = flip catchError $ \e -> throwError (f e)

845-- Rethrow an error with source position information

849-- Rethrow an error with source position information

846--

850--

847rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

851rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

848−rethrowWithPosition pos = rethrow (onErrorMessages withPosition)

852+rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))

849− where

853+

854+warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a

855+warnWithPosition pos = censor (onErrorMessages (withPosition pos))

856+

850− withPosition :: ErrorMessage -> ErrorMessage

857+withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

851− withPosition (PositionedError _ err) = withPosition err

858+withPosition _ (PositionedError pos err) = withPosition pos err

852− withPosition err = PositionedError pos err

859+withPosition pos err = PositionedError pos err

853

860

854-- |

861-- |

855-- Collect errors in in parallel

862-- Collect errors in in parallel

src/Language/PureScript/Sugar.hs+3−2

@@ -20,7 +20,8 @@ module Language.PureScript.Sugar (desugar, module S) where

20import Control.Monad

21import Control.Category ((>>>))

22import Control.Applicative

23−import Control.Monad.Error.Class (MonadError(..))

23+import Control.Monad.Error.Class (MonadError())

24+import Control.Monad.Writer.Class (MonadWriter())

24import Control.Monad.Supply.Class

25import Control.Monad.Supply.Class

26import Language.PureScript.AST

27import Language.PureScript.AST

@@ -59,7 +60,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

59--

60--

60-- * Group mutually recursive value and data declarations into binding groups.

61-- * Group mutually recursive value and data declarations into binding groups.

61--

62--

62−desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

63+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

63desugar = map removeSignedLiterals

64desugar = map removeSignedLiterals

64 >>> mapM desugarObjectConstructors

65 >>> mapM desugarObjectConstructors

65 >=> mapM desugarOperatorSections

66 >=> mapM desugarOperatorSections

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

@@ -21,11 +21,12 @@ module Language.PureScript.Sugar.Names (

21) where

23import Data.List (find, nub, (\\))

24−import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)

24+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)

26import Control.Applicative (Applicative(..), (<$>), (<*>))

27import Control.Monad

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

29+import Control.Monad.Writer (MonadWriter(..), censor)

30import qualified Data.Map as M

31import qualified Data.Map as M

@@ -160,7 +161,7 @@ addExport what exports name =

160-- |

161-- |

161-- Replaces all local names with qualified names within a set of modules.

162-- Replaces all local names with qualified names within a set of modules.

162--

163--

163−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

164+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]

164desugarImports modules = do

165desugarImports modules = do

165 unfilteredExports <- findExports modules

166 unfilteredExports <- findExports modules

166 exports <- foldM filterModuleExports unfilteredExports modules

167 exports <- foldM filterModuleExports unfilteredExports modules

@@ -481,9 +482,10 @@ findImports = foldl (findImports' Nothing) M.empty

481-- |

482-- |

482-- Constructs a local environment for a module.

483-- Constructs a local environment for a module.

483--

484--

484−resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

485+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

485resolveImports env (Module _ _ currentModule decls _) =

486resolveImports env (Module _ _ currentModule decls _) =

487+ censor (onErrorMessages (ErrorInModule currentModule)) $

486− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

488+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

487 where

489 where

488

490

489 -- A Map from module name to the source position for the import, the list of imports from that

491 -- A Map from module name to the source position for the import, the list of imports from that

@@ -507,17 +509,15 @@ resolveImports env (Module _ _ currentModule decls _) =

507-- |

509-- |

508-- Extends the local environment for a module by resolving an import of another module.

510-- Extends the local environment for a module by resolving an import of another module.

509--

511--

510−resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

512+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

511resolveImport currentModule importModule exps imps impQual =

513resolveImport currentModule importModule exps imps impQual =

512 resolveByType

514 resolveByType

513 where

515 where

514

516

515 resolveByType :: ImportDeclarationType -> m ImportEnvironment

517 resolveByType :: ImportDeclarationType -> m ImportEnvironment

516 resolveByType Implicit = importAll importExplicit

518 resolveByType Implicit = importAll importExplicit

517− resolveByType (Explicit explImports) = (checkedRefs >=> foldM importExplicit imps) explImports

519+ resolveByType (Explicit explImports) = checkedRefs explImports >> foldM importExplicit imps explImports

518− resolveByType (Hiding hiddenImports) = do

519− hiddenImports' <- checkedRefs hiddenImports

520− importAll (importNonHidden hiddenImports')

520+ resolveByType (Hiding hiddenImports) = checkedRefs hiddenImports >> importAll (importNonHidden hiddenImports)

521

522 importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment

523 importNonHidden hidden m ref =

@@ -529,6 +529,7 @@ resolveImport currentModule importModule exps imps impQual =

529 isHidden hidden ref@(TypeRef _ _) =

530 let

531 checkTypeRef _ True _ = True

532+ checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h

532 checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

533 checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

533 checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

534 checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

534 checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

535 checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

@@ -546,38 +547,39 @@ resolveImport currentModule importModule exps imps impQual =

546

547

547 -- Import something explicitly

548 -- Import something explicitly

548 importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment

549 importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment

549− importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r

550+ importExplicit imp (PositionedDeclarationRef pos _ r) =

551+ rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r

550 importExplicit imp (ValueRef name) = do

552 importExplicit imp (ValueRef name) = do

551 values' <- updateImports (importedValues imp) name

553 values' <- updateImports (importedValues imp) name

552 return $ imp { importedValues = values' }

554 return $ imp { importedValues = values' }

553 importExplicit imp (TypeRef name dctors) = do

555 importExplicit imp (TypeRef name dctors) = do

554 types' <- updateImports (importedTypes imp) name

556 types' <- updateImports (importedTypes imp) name

555 let allDctors = allExportedDataConstructors name

557 let allDctors = allExportedDataConstructors name

556− dctors' <- maybe (return allDctors) (mapM $ (checkDctorExists name) allDctors) dctors

558+ maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors

559+ when (null allDctors && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

557− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

560+ dctors' <- foldM updateImports (importedDataConstructors imp) (fromMaybe allDctors dctors)

558− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

561+ return $ imp { importedTypes = types', importedDataConstructors = dctors' }

559 importExplicit imp (TypeClassRef name) = do

562 importExplicit imp (TypeClassRef name) = do

560 typeClasses' <- updateImports (importedTypeClasses imp) name

563 typeClasses' <- updateImports (importedTypeClasses imp) name

561 return $ imp { importedTypeClasses = typeClasses' }

564 return $ imp { importedTypeClasses = typeClasses' }

562 importExplicit _ _ = error "Invalid argument to importExplicit"

565 importExplicit _ _ = error "Invalid argument to importExplicit"

563

566

564 -- Check if DeclarationRef points to an existent symbol

567 -- Check if DeclarationRef points to an existent symbol

565− checkedRefs :: [DeclarationRef] -> m [DeclarationRef]

568+ checkedRefs :: [DeclarationRef] -> m ()

566− checkedRefs = mapM check

569+ checkedRefs = mapM_ check

567 where

570 where

568 check (PositionedDeclarationRef pos _ r) =

571 check (PositionedDeclarationRef pos _ r) =

569 rethrowWithPosition pos $ check r

572 rethrowWithPosition pos $ check r

570− check ref@(ValueRef name) =

573+ check (ValueRef name) =

571− checkImportExists UnknownImportValue values name >> return ref

574+ checkImportExists UnknownImportValue values name

572− check ref@(TypeRef name dctors) = do

575+ check (TypeRef name dctors) = do

573− _ <- checkImportExists UnknownImportType availableTypes name

576+ checkImportExists UnknownImportType availableTypes name

574 let allDctors = allExportedDataConstructors name

577 let allDctors = allExportedDataConstructors name

575− _ <- maybe (return allDctors) (mapM $ (checkDctorExists name) allDctors) dctors

578+ maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors

576− return ref

577− check ref@(TypeClassRef name) =

579+ check (TypeClassRef name) =

578− checkImportExists UnknownImportTypeClass classes name >> return ref

580+ checkImportExists UnknownImportTypeClass classes name

579− check ref@(ModuleRef name) =

581+ check (ModuleRef name) =

580− checkImportExists (const UnknownModule) (exportedModules exps) name >> return ref

582+ checkImportExists (const UnknownModule) (exportedModules exps) name

581 check _ = error "Invalid argument to checkRefIsValid"

583 check _ = error "Invalid argument to checkRefIsValid"

582

584

583 -- Find all exported data constructors for a given type

585 -- Find all exported data constructors for a given type

@@ -605,15 +607,13 @@ resolveImport currentModule importModule exps imps impQual =

605

607

606 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

608 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

607 -- from

609 -- from

608− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ProperName

610+ checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

609 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

611 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

610

612

611 -- Check that an explicitly imported item exists in the module it is being imported from

613 -- Check that an explicitly imported item exists in the module it is being imported from

612− checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m a

614+ checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

613 checkImportExists unknown exports item =

615 checkImportExists unknown exports item =

614− if item `elem` exports

615− then return item

616− else throwError . errorMessage $ unknown importModule item

616+ when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

617

618-- |

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