diff --git a/lib/PureScript/Ide.hs b/lib/PureScript/Ide.hs --- a/lib/PureScript/Ide.hs +++ b/lib/PureScript/Ide.hs @@ -6,7 +6,6 @@ import qualified Data.Map.Lazy as M import Data.Maybe (mapMaybe) import Data.Monoid -import Data.Text (Text ()) import qualified Data.Text as T import PureScript.Ide.Completion import PureScript.Ide.Externs @@ -32,8 +31,13 @@ findType search filters = CompletionResult <$> getExactMatches search filters <$> getAllModules -findPursuitCompletions :: Text -> PscIde [Completion] -findPursuitCompletions = liftIO . searchPursuit +findPursuitCompletions :: PursuitQuery -> PscIde Success +findPursuitCompletions (PursuitQuery q) = + PursuitResult <$> liftIO (searchPursuitForDeclarations q) + +findPursuitPackages :: PursuitQuery -> PscIde Success +findPursuitPackages (PursuitQuery q) = + PursuitResult <$> liftIO (findPackagesForModuleIdent q) loadExtern :: FilePath -> PscIde (Either Error ()) loadExtern fp = runEitherT $ do diff --git a/lib/PureScript/Ide/Command.hs b/lib/PureScript/Ide/Command.hs --- a/lib/PureScript/Ide/Command.hs +++ b/lib/PureScript/Ide/Command.hs @@ -4,8 +4,8 @@ import Control.Monad import Data.Aeson import Data.Maybe -import PureScript.Ide.Matcher import PureScript.Ide.Filter +import PureScript.Ide.Matcher import PureScript.Ide.Types data Command @@ -15,6 +15,8 @@ , typeFilters :: [Filter]} | Complete { completeFilters :: [Filter] , completeMatcher :: Matcher} + | Pursuit { pursuitQuery :: PursuitQuery + , pursuitSearchType :: PursuitSearchType} | List | Cwd | Quit @@ -41,6 +43,11 @@ filters <- params .:? "filters" matcher <- params .:? "matcher" return $ Complete (fromMaybe [] filters) (fromMaybe (Matcher id) matcher) + "pursuit" -> do + params <- o .: "params" + query <- params .: "query" + queryType <- params .: "type" + return $ Pursuit query queryType _ -> mzero instance FromJSON Filter where diff --git a/lib/PureScript/Ide/Completion.hs b/lib/PureScript/Ide/Completion.hs --- a/lib/PureScript/Ide/Completion.hs +++ b/lib/PureScript/Ide/Completion.hs @@ -21,14 +21,13 @@ applyFilters = foldl (\f (Filter g) -> f . g) id completionsFromModules :: [Module] -> [Completion] -completionsFromModules = concat . fmap completionFromModule - -completionFromModule :: Module -> [Completion] -completionFromModule (moduleIdent, decls) = - mapMaybe go decls +completionsFromModules = foldMap completionFromModule where - go (FunctionDecl name type') = Just (Completion (moduleIdent, name, type')) - go (DataDecl name kind) = Just (Completion (moduleIdent, name, kind)) - go (ModuleDecl name _) = Just (Completion ("module", name, "module")) - go _ = Nothing + completionFromModule :: Module -> [Completion] + completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls +completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion +completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type')) +completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind)) +completionFromDecl mi (ModuleDecl name _) = Just (Completion ("module", name, "module")) +completionFromDecl mi _ = Nothing diff --git a/lib/PureScript/Ide/Pursuit.hs b/lib/PureScript/Ide/Pursuit.hs --- a/lib/PureScript/Ide/Pursuit.hs +++ b/lib/PureScript/Ide/Pursuit.hs @@ -1,33 +1,78 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module PureScript.Ide.Pursuit where +import qualified Control.Exception as E import Control.Lens +import Control.Monad +import Data.Aeson import Data.Aeson.Lens -import Data.Either -import Data.Monoid +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import Network.HTTP.Client (HttpException (StatusCodeException)) import Network.Wreq -import PureScript.Ide.Types import PureScript.Ide.Externs (typeParse) +import PureScript.Ide.Types -queryUrl :: Text -queryUrl = "http://pursuit.purescript.org/search?q=" +instance FromJSON PursuitResponse where + parseJSON (Object o) = do + package <- o .: "package" + info <- o .: "info" + (type' :: String) <- info .: "type" + case type' of + "module" -> do + name <- info .: "module" + return + ModuleResponse + { moduleResponseName = name + , moduleResponsePackage = package + } + "declaration" -> do + moduleName <- info .: "module" + Right (ident,declType) <- typeParse <$> o .: "text" + return + DeclarationResponse + { declarationResponseType = declType + , declarationResponseModule = moduleName + , declarationResponseIdent = ident + , declarationResponsePackage = package + } + _ -> mzero + parseJSON _ = mzero -jsonOpts :: Options -jsonOpts = defaults & header "Accept" .~ ["application/json"] +queryUrl :: String +queryUrl = "http://pursuit.purescript.org/search" -myZip :: [a] -> [(b, c)] -> [(a, b, c)] -myZip = zipWith (\a (b, c) -> (a, b, c)) +jsonOpts :: Text -> Options +jsonOpts q = + defaults & header "Accept" .~ ["application/json"] & param "q" .~ [q] -searchPursuit :: Text -> IO [Completion] -searchPursuit query = do - r <- getWith jsonOpts (T.unpack $ queryUrl <> query) - let texts = r ^.. responseBody . values . key "text" . _String - let moduleNames = r ^.. - responseBody . - values . - key "info" . - key "module" . - _String - return . fmap Completion . myZip moduleNames . rights $ typeParse <$> texts +-- We need to remove trailing dots because Pursuit will return a 400 otherwise +-- TODO: remove this when the issue is fixed at Pursuit +queryPursuit q = getWith (jsonOpts (T.dropWhileEnd (== '.') q)) queryUrl + +handler :: HttpException -> IO [a] +handler (StatusCodeException{}) = return [] +handler _ = return [] + +searchPursuitForDeclarations :: Text -> IO [PursuitResponse] +searchPursuitForDeclarations query = + (do r <- queryPursuit query + let results = map fromJSON (r ^.. responseBody . values) + return (mapMaybe isDeclarationResponse results)) `E.catch` + handler + where + isDeclarationResponse (Success a@(DeclarationResponse{})) = Just a + isDeclarationResponse _ = Nothing + +findPackagesForModuleIdent :: Text -> IO [PursuitResponse] +findPackagesForModuleIdent query = + (do r <- queryPursuit query + let results = map fromJSON (r ^.. responseBody . values) + return (mapMaybe isModuleResponse results)) `E.catch` + handler + where + isModuleResponse (Success a@(ModuleResponse{})) = Just a + isModuleResponse _ = Nothing diff --git a/lib/PureScript/Ide/Types.hs b/lib/PureScript/Ide/Types.hs --- a/lib/PureScript/Ide/Types.hs +++ b/lib/PureScript/Ide/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} module PureScript.Ide.Types where import Control.Monad @@ -53,6 +54,7 @@ data Success = CompletionResult [Completion] | TextResult Text + | PursuitResult [PursuitResponse] deriving(Show, Eq) encodeSuccess :: (ToJSON a) => a -> Value @@ -64,6 +66,43 @@ instance ToJSON Success where toJSON (CompletionResult cs) = encodeSuccess cs toJSON (TextResult t) = encodeSuccess t + toJSON (PursuitResult resp) = encodeSuccess resp newtype Filter = Filter ([Module] -> [Module]) newtype Matcher = Matcher ([Completion] -> [Completion]) + +newtype PursuitQuery = PursuitQuery Text + deriving (Show, Eq) + +data PursuitSearchType = Package | Identifier + deriving (Show, Eq) + +instance FromJSON PursuitSearchType where + parseJSON (String t) = case t of + "package" -> return Package + "completion" -> return Identifier + _ -> mzero + parseJSON _ = mzero + +instance FromJSON PursuitQuery where + parseJSON o = fmap PursuitQuery (parseJSON o) + +data PursuitResponse + = ModuleResponse { moduleResponseName :: Text + , moduleResponsePackage :: Text} + | DeclarationResponse { declarationResponseType :: Text + , declarationResponseModule :: Text + , declarationResponseIdent :: Text + , declarationResponsePackage :: Text + } + deriving (Show,Eq) + +instance ToJSON PursuitResponse where + toJSON (ModuleResponse{moduleResponseName = name, moduleResponsePackage = package}) = + object ["module" .= name, "package" .= package] + toJSON (DeclarationResponse{..}) = + object + [ "module" .= declarationResponseModule + , "ident" .= declarationResponseIdent + , "type" .= declarationResponseType + , "package" .= declarationResponsePackage] 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.2.0.0 +version: 0.3.0.0 synopsis: Language support for the PureScript programming language description: Please see README.md homepage: http://github.com/kRITZCREEK/psc-ide @@ -28,16 +28,17 @@ build-depends: aeson , base >= 4.7 && < 5 , containers + , directory + , either + , filepath + , http-client , lens , lens-aeson , mtl , parsec - , directory - , filepath , regex-tdfa , text , wreq - , either default-extensions: OverloadedStrings ghc-options: -O2 @@ -57,7 +58,6 @@ hs-source-dirs: server main-is: Main.hs default-language: Haskell2010 - ghc-options: -threaded build-depends: base >= 4.7 && < 5 , mtl , network @@ -65,7 +65,7 @@ , directory , psc-ide , text - ghc-options: -O2 -Wall + ghc-options: -threaded -O2 -Wall test-suite spec type: exitcode-stdio-1.0 diff --git a/server/Main.hs b/server/Main.hs --- a/server/Main.hs +++ b/server/Main.hs @@ -1,16 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Exception (bracketOnError) import Control.Monad -import Control.Exception (bracketOnError) import Control.Monad.State.Lazy -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Network hiding (socketPort) -import Network.BSD (getProtocolNumber) -import Network.Socket hiding (PortNumber, Type, accept, - sClose) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Network hiding (socketPort) +import Network.BSD (getProtocolNumber) +import Network.Socket hiding (PortNumber, Type, accept, + sClose) import Options.Applicative import PureScript.Ide import PureScript.Ide.CodecJSON @@ -91,6 +91,10 @@ Right <$> findType search filters handleCommand (Complete filters matcher) = Right <$> findCompletions filters matcher +handleCommand (Pursuit query Package) = + Right <$> findPursuitPackages query +handleCommand (Pursuit query Identifier) = + Right <$> findPursuitCompletions query handleCommand List = Right <$> printModules handleCommand Cwd =