diff --git a/lib/PureScript/Ide.hs b/lib/PureScript/Ide.hs --- a/lib/PureScript/Ide.hs +++ b/lib/PureScript/Ide.hs @@ -2,6 +2,7 @@ import Control.Monad.Except import Control.Monad.State.Lazy (StateT (..), get, modify) +import Control.Monad.Trans.Either import qualified Data.Map.Lazy as M import Data.Maybe (mapMaybe) import Data.Monoid @@ -34,23 +35,17 @@ findPursuitCompletions :: Text -> PscIde [Completion] findPursuitCompletions = liftIO . searchPursuit --- TODO: Introduce the Either Monad to clean this up loadExtern :: FilePath -> PscIde (Either Error ()) -loadExtern fp = do - parseResult <- liftIO $ readExternFile fp - case parseResult of - Right decls -> - case moduleFromDecls decls of - Right (name, decls') -> Right <$> modify - (\x -> - x - { pscStateModules = M.insert - name - decls' - (pscStateModules x) - }) - Left err -> return $ Left err - Left e -> return . Left . ParseError e $ "The module at" ++ fp ++ "could not be parsed" +loadExtern fp = runEitherT $ do + decls <- EitherT . liftIO $ readExternFile fp + (name, decls') <- EitherT . return $ moduleFromDecls decls + modify (\x -> + x + { pscStateModules = M.insert + name + decls' + (pscStateModules x) + }) getDependenciesForModule :: ModuleIdent -> PscIde (Maybe [ModuleIdent]) getDependenciesForModule m = do @@ -99,22 +94,18 @@ loadModule mn = do path <- liftIO $ filePathFromModule mn case path of - Just p -> do - res <- loadExtern p - case res of - Right _ -> return (Right $ "Loaded extern file at: " <> T.pack p) - Left err -> return (Left err) - Nothing -> return (Left . GeneralError $ "Could not load module " <> T.unpack mn) + Right p -> loadExtern p >> return (Right $ "Loaded extern file at: " <> T.pack p) + Left err -> return (Left err) -filePathFromModule :: ModuleIdent -> IO (Maybe FilePath) +filePathFromModule :: ModuleIdent -> IO (Either Error FilePath) filePathFromModule moduleName = do cwd <- getCurrentDirectory let path = cwd "output" T.unpack moduleName "externs.purs" ex <- doesFileExist path return $ if ex - then Just path - else Nothing + then Right path + else Left (ModuleFileNotFound moduleName) -- | Taken from Data.Either.Utils maybeToEither :: MonadError e m => diff --git a/lib/PureScript/Ide/Error.hs b/lib/PureScript/Ide/Error.hs --- a/lib/PureScript/Ide/Error.hs +++ b/lib/PureScript/Ide/Error.hs @@ -1,11 +1,11 @@ module PureScript.Ide.Error - (ErrorMsg, Error(..), textError) + (ErrorMsg, Error(..), textError, first) where import Data.Aeson import Data.Monoid import Data.Text (Text, pack) -import PureScript.Ide.Externs (ModuleIdent) +import PureScript.Ide.Types (ModuleIdent) import qualified Text.Parsec.Error as P type ErrorMsg = String @@ -14,6 +14,7 @@ = GeneralError ErrorMsg | NotFound Text | ModuleNotFound ModuleIdent + | ModuleFileNotFound ModuleIdent | ParseError P.ParseError ErrorMsg deriving (Show, Eq) @@ -28,8 +29,14 @@ textError (GeneralError msg) = pack msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." +textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError) where -- escape newlines and other special chars so we can send the error over the socket as a single line escape :: P.ParseError -> String escape = show + +-- | Specialized version of `first` from `Data.Bifunctors` +first :: (a -> b) -> Either a r -> Either b r +first f (Left x) = Left (f x) +first _ (Right r2) = Right r2 diff --git a/lib/PureScript/Ide/Externs.hs b/lib/PureScript/Ide/Externs.hs --- a/lib/PureScript/Ide/Externs.hs +++ b/lib/PureScript/Ide/Externs.hs @@ -3,7 +3,6 @@ module PureScript.Ide.Externs ( - ExternParse, ExternDecl(..), ModuleIdent, DeclIdent, @@ -22,14 +21,13 @@ import PureScript.Ide.Types import Text.Parsec import Text.Parsec.Text - -type ExternParse = Either ParseError [ExternDecl] +import PureScript.Ide.Error (Error(..), first) -- | Parses an extern file into the ExternDecl format. -readExternFile :: FilePath -> IO ExternParse +readExternFile :: FilePath -> IO (Either Error [ExternDecl]) readExternFile fp = readExtern . T.lines <$> T.readFile fp -readExtern :: [Text] -> ExternParse +readExtern :: [Text] -> Either Error [ExternDecl] readExtern strs = mapM parseExtern clean where clean = removeComments strs @@ -37,14 +35,16 @@ removeComments :: [Text] -> [Text] removeComments = filter (not . T.isPrefixOf "--") -parseExtern :: Text -> Either ParseError ExternDecl -parseExtern = parse parseExternDecl "" +parseExtern :: Text -> Either Error ExternDecl +parseExtern = first (flip ParseError $ "") . parse parseExternDecl "" parseExternDecl :: Parser ExternDecl parseExternDecl = try parseDependency <|> try parseFixityDecl <|> try parseFunctionDecl <|> try parseDataDecl <|> try parseModuleDecl <|> + try parseTypeDecl <|> + try parseNewtypeDecl <|> return (ModuleDecl "" []) parseDependency :: Parser ExternDecl @@ -138,6 +138,28 @@ name <- identifier exports <- identifierList return (ModuleDecl name exports) + +parseNewtypeDecl :: Parser ExternDecl +parseNewtypeDecl = do + string "newtype" + name <- identifier + _ <- many (noneOf "=") + char '=' + identifier + type' <- many anyChar + eof + return (DataDecl name (T.pack type')) + +parseTypeDecl :: Parser ExternDecl +parseTypeDecl = do + string "type" + name <- identifier + _ <- many (noneOf "=") + char '=' + spaces + type' <- many anyChar + eof + return (DataDecl name (T.pack type')) parseType :: Parser (String, String) parseType = do diff --git a/lib/PureScript/Ide/Filter.hs b/lib/PureScript/Ide/Filter.hs --- a/lib/PureScript/Ide/Filter.hs +++ b/lib/PureScript/Ide/Filter.hs @@ -34,6 +34,7 @@ extractDeps :: Module -> [ModuleIdent] extractDeps = mapMaybe extractDep . snd where extractDep (Dependency n _) = Just n + extractDep (ModuleDecl _ _) = Nothing extractDep _ = Nothing -- | Only keeps Identifiers that start with the given prefix diff --git a/psc-ide.cabal b/psc-ide.cabal --- a/psc-ide.cabal +++ b/psc-ide.cabal @@ -1,5 +1,5 @@ name: psc-ide -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Language support for the PureScript programming language description: Please see README.md homepage: http://github.com/kRITZCREEK/psc-ide @@ -37,7 +37,9 @@ , regex-tdfa , text , wreq + , either default-extensions: OverloadedStrings + ghc-options: -O2 executable psc-ide hs-source-dirs: src @@ -49,6 +51,7 @@ , text , optparse-applicative , network + ghc-options: -O2 -Wall executable psc-ide-server hs-source-dirs: server @@ -62,6 +65,7 @@ , directory , psc-ide , text + ghc-options: -O2 -Wall test-suite spec type: exitcode-stdio-1.0 diff --git a/test/PureScript/Ide/ExternsSpec.hs b/test/PureScript/Ide/ExternsSpec.hs --- a/test/PureScript/Ide/ExternsSpec.hs +++ b/test/PureScript/Ide/ExternsSpec.hs @@ -35,5 +35,12 @@ it "parses a foreign data declaration" $ parseExtern "foreign import data STArray :: * -> * -> *" `shouldBe` Right (DataDecl "STArray" "* -> * -> *") + describe "Parsing type declarations" $ do + it "parses a newtype declaration" $ + parseExtern "newtype Component (eff :: # !) (s :: *) (t :: *) = Component (s -> SYM.Handler eff t -> Prim.Array React.ReactElement)" `shouldBe` + Right (DataDecl "Component" "(s -> SYM.Handler eff t -> Prim.Array React.ReactElement)") + it "parses a type declaration" $ + parseExtern "type Player = { age :: Prim.Number, name :: Prim.String }" `shouldBe` + Right (DataDecl "Player" "{ age :: Prim.Number, name :: Prim.String }")