Merge pull request #1516 from purescript/hints

Hints

.gitignore

@@ -15,3 +15,4 @@ node_modules
 tmp/
 .stack-work/
 tests/support/flattened/
+output

psci/PSCi.hs

@@ -464,7 +464,7 @@ handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
     Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
 handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
   foreignsOrError <- psciIO . runMake $ do
-    foreignFile <- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile absPath)) (readFile absPath)
+    foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
     P.parseForeignModulesFromFiles [(absPath, foreignFile)]
   case foreignsOrError of
     Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
@@ -533,7 +533,7 @@ loop PSCiOptions{..} = do
       historyFilename <- getHistoryFilename
       let settings = defaultSettings { historyFile = Just historyFilename }
       foreignsOrError <- runMake $ do
-        foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile))
+        foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
         P.parseForeignModulesFromFiles foreignFilesContent
       case foreignsOrError of
         Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

src/Language/PureScript/Linter.hs

@@ -40,7 +40,7 @@ import Language.PureScript.Linter.Exhaustive as L
 -- |
 -- | Right now, this pass only performs a shadowing check.
 lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
-lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
+lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
   where
   moduleNames :: S.Set Ident
   moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
@@ -58,9 +58,9 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_
     let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
 
         f' :: Declaration -> MultipleErrors
-        f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec)
-        f' dec@(ValueDeclaration name _ _ _) = onErrorMessages (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)
-        f' (TypeDeclaration name ty) = onErrorMessages (ErrorInTypeDeclaration name) (checkTypeVars ty)
+        f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)
+        f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)
+        f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
         f' dec = f dec <> checkTypeVarsInDecl dec
 
     in tell (f' d)

src/Language/PureScript/Linter/Exhaustive.hs

@@ -46,8 +46,6 @@ import Language.PureScript.Kinds
 import Language.PureScript.Types as P
 import Language.PureScript.Errors
 
-import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
-
 -- | There are two modes of failure for the redudancy check:
 --
 -- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
@@ -273,28 +271,39 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
 -- Exhaustivity checking over a list of declarations
 --
 checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
-checkExhaustiveDecls env mn ds =
-  let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
+checkExhaustiveDecls env mn = mapM_ onDecl
+  where
+  onDecl :: Declaration -> m ()
+  onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs
+    where
+    convert :: (Ident, NameKind, Expr) -> Declaration
+    convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
+  onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
+  onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
+  onDecl _ = return ()
 
-      f' :: Declaration -> m Declaration
-      f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
-        where
-        convert :: (Ident, NameKind, Expr) -> Declaration
-        convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
-      f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d
-      f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec)
-      -- Don't generate two warnings for desugared dictionaries.
-      f' d@TypeInstanceDeclaration{} = return d
-      f' d = f d
+  onExpr :: Expr -> m ()
+  onExpr (UnaryMinus e) = onExpr e
+  onExpr (ArrayLiteral es) = mapM_ onExpr es
+  onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
+  onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
+  onExpr (Accessor _ e) = onExpr e
+  onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
+  onExpr (Abs _ e) = onExpr e
+  onExpr (App e1 e2) = onExpr e1 >> onExpr e2
+  onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
+  onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
+  onExpr (TypedValue _ e _) = onExpr e
+  onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
+  onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
+  onExpr _ = return ()
 
-  in mapM_ f' ds
-  where
-  checkExpr :: Expr -> m Expr
-  checkExpr c@(Case expr cas)  = checkExhaustive env mn (length expr) cas >> return c
-  checkExpr other = return other
+  onCaseAlternative :: CaseAlternative -> m ()
+  onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
+  onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
 
 -- |
 -- Exhaustivity checking over a single module
 --
 checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
-checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
+checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

src/Language/PureScript/Make.hs

@@ -305,15 +305,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   requiresForeign = not . null . CF.moduleForeign
 
   getTimestamp :: FilePath -> Make (Maybe UTCTime)
-  getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
+  getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
     exists <- doesFileExist path
     traverse (const $ getModificationTime path) $ guard exists
 
   readTextFile :: FilePath -> Make B.ByteString
-  readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path
+  readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
 
   writeTextFile :: FilePath -> B.ByteString -> Make ()
-  writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
+  writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
     mkdirp path
     B.writeFile path text
     where

src/Language/PureScript/Parser/Declarations.hs

@@ -293,7 +293,7 @@ parseModulesFromFiles toFilePath input = do
   collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
 
 toPositionedError :: P.ParseError -> ErrorMessage
-toPositionedError perr = PositionedError (SourceSpan name start end) (SimpleErrorWrapper (ErrorParsingModule perr))
+toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)
   where
   name   = (P.sourceName . P.errorPos) perr
   start  = (toSourcePos  . P.errorPos) perr

src/Language/PureScript/Pretty/Values.hs

@@ -70,6 +70,7 @@ prettyPrintValue (Do els) =
   text "do " <> vcat left (map prettyPrintDoNotationElement els)
 prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
 prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
+prettyPrintValue (TypedValue _ val _) = prettyPrintValue val
 prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val
 prettyPrintValue expr = prettyPrintValueAtom expr
 
@@ -88,7 +89,7 @@ prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)
 prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)
 prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"
 prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"
-prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValue val
+prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val
 prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val
 prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"
 

src/Language/PureScript/Sugar/BindingGroups.hs

@@ -184,7 +184,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
   cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
   cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
   cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n
-  cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []
+  cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []
   cycleError _ _ = error "Expected ValueDeclaration"
 
 toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

src/Language/PureScript/Sugar/CaseDeclarations.hs

@@ -50,7 +50,7 @@ isLeft (Right _) = False
 --
 desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
 desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
-  rethrow (onErrorMessages (ErrorInModule name)) $
+  rethrow (addHint (ErrorInModule name)) $
     Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
 
 desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

src/Language/PureScript/Sugar/Names.hs

@@ -98,7 +98,7 @@ desugarImports externs modules = do
 
   renameInModule' :: Env -> Module -> m Module
   renameInModule' env m@(Module _ _ mn _ _) =
-    rethrow (onErrorMessages (ErrorInModule mn)) $ do
+    rethrow (addHint (ErrorInModule mn)) $ do
       let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env
       elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)
 

src/Language/PureScript/Sugar/Names/Exports.hs

@@ -43,7 +43,7 @@ import Language.PureScript.Sugar.Names.Env
 --
 findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports
 findExportable (Module _ _ mn ds _) =
-  rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds
+  rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
   where
   updateExports :: Exports -> Declaration -> m Exports
   updateExports exps (TypeClassDeclaration tcn _ _ ds') = do
@@ -67,7 +67,7 @@ findExportable (Module _ _ mn ds _) =
 --
 resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
 resolveExports env mn imps exps refs =
-  rethrow (onErrorMessages (ErrorInModule mn)) $ do
+  rethrow (addHint (ErrorInModule mn)) $ do
     filtered <- filterModule mn exps refs
     foldM elaborateModuleExports filtered refs
 

src/Language/PureScript/Sugar/Names/Imports.hs

@@ -64,7 +64,7 @@ findImports = foldM (go Nothing) M.empty
 --
 resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
 resolveImports env (Module _ _ currentModule decls _) =
-  censor (onErrorMessages (ErrorInModule currentModule)) $ do
+  censor (addHint (ErrorInModule currentModule)) $ do
     scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls
     foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)
 

src/Language/PureScript/Sugar/Operators.hs

@@ -102,7 +102,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
   go [] = return ()
   go [_] = return ()
   go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
-    rethrow (onErrorMessages (ErrorInModule mn)) $
+    rethrow (addHint (ErrorInModule mn)) $
       rethrowWithPosition pos $
         throwError . errorMessage $ MultipleFixities name
   go (_ : rest) = go rest

src/Language/PureScript/Sugar/TypeClasses.hs

@@ -243,7 +243,7 @@ unit = TypeApp tyObject REmpty
 
 typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
 typeInstanceDictionaryDeclaration name mn deps className tys decls =
-  rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
+  rethrow (addHint (ErrorInInstance className tys)) $ do
   m <- get
 
   -- Lookup the type arguments and member types for the type class

src/Language/PureScript/Sugar/TypeDeclarations.hs

@@ -15,18 +15,19 @@
 -----------------------------------------------------------------------------
 
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 
 module Language.PureScript.Sugar.TypeDeclarations (
-    desugarTypeDeclarations,
     desugarTypeDeclarationsModule
 ) where
 
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative
 #endif
-import Control.Monad (forM)
+import Control.Monad (forM, when)
 import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(tell))
 
 import Language.PureScript.AST
 import Language.PureScript.Names
@@ -37,36 +38,39 @@ import Language.PureScript.Traversals
 -- |
 -- Replace all top level type declarations in a module with type annotations
 --
-desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
 desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
-  rethrow (onErrorMessages (ErrorInModule name)) $
-    Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
-
--- |
--- Replace all top level type declarations with type annotations
---
-desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
-desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
-  (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
-  return (PositionedDeclaration pos com d' : ds')
-desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
-  (_, nameKind, val) <- fromValueDeclaration d
-  desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
+  rethrow (addHint (ErrorInModule name)) $
+    Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps
   where
-  fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
-  fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
-  fromValueDeclaration (PositionedDeclaration pos com d') = do
-    (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
-    return (ident, nameKind, PositionedValue pos com val)
-  fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
-desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
-desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
-  let (_, f, _) = everywhereOnValuesTopDownM return go return
-      f' (Left gs) = Left <$> mapM (pairM return f) gs
-      f' (Right v) = Right <$> f v
-  (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
-  where
-  go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
-  go other = return other
-desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
-desugarTypeDeclarations [] = return []
+
+  desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]
+  desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do
+    (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)
+    return (PositionedDeclaration pos com d' : ds')
+  desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do
+    (_, nameKind, val) <- fromValueDeclaration d
+    desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
+    where
+    fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
+    fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
+    fromValueDeclaration (PositionedDeclaration pos com d') = do
+      (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
+      return (ident, nameKind, PositionedValue pos com val)
+    fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
+  desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
+  desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do
+    -- At the top level, match a type signature or emit a warning.
+    when reqd $ case val of
+                  Right TypedValue{} -> return ()
+                  Left _ -> error "desugarTypeDeclarations: cases were not desugared"
+                  _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)
+    let (_, f, _) = everywhereOnValuesTopDownM return go return
+        f' (Left gs) = Left <$> mapM (pairM return f) gs
+        f' (Right v) = Right <$> f v
+    (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest
+    where
+    go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'
+    go other = return other
+  desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds
+  desugarTypeDeclarations _ [] = return []