410fefe · rowtype-yoga/purescript-native

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

Warn on misleading Type(..) imports

commit410fefe85b2763fedc488ead1ddf3528e54c7b1b authorGary Burgess <gary.burgess@gmail.com> dateTue 18 Aug 2015, 00:01 (11 years ago) parentfe6c7de

4 files changed+48−38

compare with golang

unifiedsplit

src/Language/PureScript/Docs/ParseAndDesugar.hs+3−1 src/Language/PureScript/Errors.hs+12−5 src/Language/PureScript/Sugar.hs+3−2 src/Language/PureScript/Sugar/Names.hs+30−30

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

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

1111import Control.Applicative

1212

1313import Control.Monad.Trans.Except

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

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

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

1617

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

118119desugar = P.evalSupplyT 0 . desugar'

119120 where

120121 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)

122124

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

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

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

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

134134 | NotExhaustivePattern [[Binder]] Bool

135135 | OverlappingPattern [[Binder]] Bool

136136 | ClassOperator ProperName Ident

137+ | MisleadingEmptyTypeImport ModuleName ProperName

137138 deriving (Show)

138139

139140-- |

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

256257 NotExhaustivePattern{} -> "NotExhaustivePattern"

257258 OverlappingPattern{} -> "OverlappingPattern"

258259 ClassOperator{} -> "ClassOperator"

260+ MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

259261

260262-- |

261263-- A stack trace for an error

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

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

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

608610 ]

611+ goSimple (MisleadingEmptyTypeImport mn name) =

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

609613 goSimple (WildcardInferredType ty) =

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

611615 goSimple (NotExhaustivePattern bs b) =

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

845849-- Rethrow an error with source position information

846850--

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

848−rethrowWithPosition pos = rethrow (onErrorMessages withPosition)

849− where

850− withPosition :: ErrorMessage -> ErrorMessage

851− withPosition (PositionedError _ err) = withPosition err

852− withPosition err = PositionedError pos err

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

853+

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

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

856+

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

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

859+withPosition pos err = PositionedError pos err

853860

854861-- |

855862-- Collect errors in in parallel

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

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

2020import Control.Monad

2121import Control.Category ((>>>))

2222import Control.Applicative

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

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

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

2425import Control.Monad.Supply.Class

2526

2627import Language.PureScript.AST

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

5960--

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

6162--

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]

6364desugar = map removeSignedLiterals

6465 >>> mapM desugarObjectConstructors

6566 >=> mapM desugarOperatorSections

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

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

2121) where

2222

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

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

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

2525

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

2727import Control.Monad

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

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

2930

3031import qualified Data.Map as M

3132

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

160161-- |

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

162163--

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]

164165desugarImports modules = do

165166 unfilteredExports <- findExports modules

166167 exports <- foldM filterModuleExports unfilteredExports modules

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

481482-- |

482483-- Constructs a local environment for a module.

483484--

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

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

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

487+ censor (onErrorMessages (ErrorInModule currentModule)) $

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

487489 where

488490

489491 -- 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 _) =

507509-- |

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

509511--

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

511513resolveImport currentModule importModule exps imps impQual =

512514 resolveByType

513515 where

514516

515517 resolveByType :: ImportDeclarationType -> m ImportEnvironment

516518 resolveByType Implicit = importAll importExplicit

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

518− resolveByType (Hiding hiddenImports) = do

519− hiddenImports' <- checkedRefs hiddenImports

520− importAll (importNonHidden hiddenImports')

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

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

521521

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

523523 importNonHidden hidden m ref =

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

529529 isHidden hidden ref@(TypeRef _ _) =

530530 let

531531 checkTypeRef _ True _ = True

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

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

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

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

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

546547

547548 -- Import something explicitly

548549 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

550552 importExplicit imp (ValueRef name) = do

551553 values' <- updateImports (importedValues imp) name

552554 return $ imp { importedValues = values' }

553555 importExplicit imp (TypeRef name dctors) = do

554556 types' <- updateImports (importedTypes imp) name

555557 let allDctors = allExportedDataConstructors name

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

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

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

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

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

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

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

559562 importExplicit imp (TypeClassRef name) = do

560563 typeClasses' <- updateImports (importedTypeClasses imp) name

561564 return $ imp { importedTypeClasses = typeClasses' }

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

563566

564567 -- Check if DeclarationRef points to an existent symbol

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

566− checkedRefs = mapM check

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

569+ checkedRefs = mapM_ check

567570 where

568571 check (PositionedDeclarationRef pos _ r) =

569572 rethrowWithPosition pos $ check r

570− check ref@(ValueRef name) =

571− checkImportExists UnknownImportValue values name >> return ref

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

573− _ <- checkImportExists UnknownImportType availableTypes name

573+ check (ValueRef name) =

574+ checkImportExists UnknownImportValue values name >> return ()

575+ check (TypeRef name dctors) = do

576+ checkImportExists UnknownImportType availableTypes name

574577 let allDctors = allExportedDataConstructors name

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

576− return ref

577− check ref@(TypeClassRef name) =

578− checkImportExists UnknownImportTypeClass classes name >> return ref

579− check ref@(ModuleRef name) =

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

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

579+ check (TypeClassRef name) =

580+ checkImportExists UnknownImportTypeClass classes name

581+ check (ModuleRef name) =

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

581583 check _ = error "Invalid argument to checkRefIsValid"

582584

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

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

605607

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

607609 -- from

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

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

609611 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

610612

611613 -- 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 ()

613615 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

617617

618618-- |

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