Add suggestion framework with "Did you mean composition" example

mjgpy3 · mjgpy3 · commit e65645ea0a32 · 2015-05-04T22:54:04.000-04:00
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
@@ -62,16 +62,16 @@ runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
 makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
 makeIO f io = do
   e <- liftIO $ tryIOError io
-  either (throwError . P.errorMessage . f) return e
+  either (throwError . P.singleError . f) return e
 
 instance P.MonadMake Make where
-  getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
+  getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
     exists <- doesFileExist path
     traverse (const $ getModificationTime path) $ guard exists
-  readTextFile path = makeIO (const (P.CannotReadFile path))$ do
+  readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
     putStrLn $ "Reading " ++ path
     readFile path
-  writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
+  writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
     mkdirp path
     putStrLn $ "Writing " ++ path
     writeFile path text
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
@@ -221,14 +221,14 @@ runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
 makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
 makeIO f io = do
   e <- liftIO $ tryIOError io
-  either (throwError . P.errorMessage . f) return e
+  either (throwError . P.singleError . f) return e
 
 instance P.MonadMake Make where
-  getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
+  getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
     exists <- doesFileExist path
     traverse (const $ getModificationTime path) $ guard exists
-  readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path
-  writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
+  readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
+  writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
     mkdirp path
     writeFile path text
   progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -220,6 +220,14 @@ tyArray = primTy "Array"
 tyObject :: Type
 tyObject = primTy "Object"
 
+-- |
+-- Check whether a type is an object
+--
+isObject :: Type -> Bool
+isObject = (==) tyObject . extract
+  where extract (TypeApp t _) = t
+        extract t = t
+
 -- |
 -- Smart constructor for function types
 --
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
@@ -142,7 +142,7 @@ addValue env mn name = updateExportedModule env mn $ \m -> do
 -- Adds an entry to a list of exports unless it is already present, in which case an error is
 -- returned.
 --
-addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]
+addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]
 addExport what exports name =
   if name `elem` exports
   then throwConflictError what name
@@ -279,7 +279,7 @@ renameInModule imports exports (Module coms mn decls exps) =
 
   -- Update names so unqualified references become qualified, and locally qualified references
   -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
-  update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)
+  update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)
                             -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
                             -> (Exports -> a -> Bool)
                             -> Qualified a
@@ -529,7 +529,7 @@ resolveImport currentModule importModule exps imps impQual =
   checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
 
   -- Check that an explicitly imported item exists in the module it is being imported from
-  checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a
+  checkImportExists :: (Eq a, Show a) => (Qualified a -> SimpleErrorMessage) -> [a] -> a -> m a
   checkImportExists unknown exports item =
       if item `elem` exports
       then return item
@@ -538,5 +538,5 @@ resolveImport currentModule importModule exps imps impQual =
 -- |
 -- Raises an error for when there is more than one definition for something.
 --
-throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b
+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
 throwConflictError conflict = throwError . errorMessage . conflict
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -88,7 +88,7 @@ skolemEscapeCheck root@TypedValue{} =
   let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
   in case f root of
        [] -> return ()
-       ((binding, val) : _) -> throwError . errorMessage . ErrorInExpression val $ EscapedSkolem binding
+       ((binding, val) : _) -> throwError . singleError $ ErrorInExpression val $ SimpleErrorWrapper $ EscapedSkolem binding
   where
   def s _ = (s, [])
 
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -46,7 +46,7 @@ buildTypeSubstitution name n = go n []
   where
   go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
   go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
-  go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ PartiallyAppliedSynonym name
+  go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym name
   go m args (TypeApp f arg) = go (m - 1) (arg:args) f
   go _ _ _ = return Nothing
 
@@ -87,7 +87,7 @@ replaceAllTypeSynonyms' env d =
 replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
 replaceAllTypeSynonyms d = do
   env <- getEnv
-  either (throwError . errorMessage) return $ replaceAllTypeSynonyms' env d
+  either (throwError . singleError) return $ replaceAllTypeSynonyms' env d
 
 -- |
 -- Replace a type synonym and its arguments with the aliased type
@@ -103,7 +103,7 @@ expandTypeSynonym' env name args =
 expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
 expandTypeSynonym name args = do
   env <- getEnv
-  either (throwError . errorMessage) return $ expandTypeSynonym' env name args
+  either (throwError . singleError) return $ expandTypeSynonym' env name args
 
 expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
 expandAllTypeSynonyms = everywhereOnTypesTopDownM go
