packages feed

psc-ide 0.5.0 → 0.6.0

raw patch · 32 files changed

+1539/−1094 lines, 32 filesdep +edit-distancedep +fsnotifydep +monad-loggerdep ~purescript

Dependencies added: edit-distance, fsnotify, monad-logger, stm

Dependency ranges changed: purescript

Files

+ client/Main.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Control.Exception+import           Data.Maybe          (fromMaybe)+import           Data.Text           (Text)+import qualified Data.Text           as T+import qualified Data.Text.IO        as T+import           Data.Version        (showVersion)+import           Network+import           Options.Applicative+import           System.Exit+import           System.IO++import qualified Paths_psc_ide       as Paths++data Options = Options+    { optionsPort :: Maybe Int+    }++main :: IO ()+main = do+    Options port <- execParser opts+    let port' = PortNumber . fromIntegral $ fromMaybe 4242 port+    client port'+  where+    parser =+        Options <$>+          optional (option auto (long "port" <> short 'p'))+    opts = info (version <*> parser) mempty+    version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden++client :: PortID -> IO ()+client port = do+    h <-+        connectTo "localhost" port `catch`+        (\(SomeException e) ->+              putStrLn+                  ("Couldn't connect to psc-ide-server on port: " +++                   show port ++ " Error: " ++ show e) >>+              exitFailure)+    cmd <- T.getLine+    -- Temporary fix for emacs windows bug+    let cleanedCmd = removeSurroundingTicks cmd+    --+    T.hPutStrLn h cleanedCmd+    res <- T.hGetLine h+    putStrLn (T.unpack res)+    hFlush stdout+    hClose h++++-- TODO: Fix this in the emacs plugin by using a real process over shellcommands+removeSurroundingTicks :: Text -> Text+removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'')
− lib/PureScript/Ide.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE TupleSections #-}-module PureScript.Ide where--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, catMaybes)-import           Data.Monoid-import qualified Data.Text  as T-import           PureScript.Ide.Completion-import           PureScript.Ide.Externs-import           PureScript.Ide.Pursuit-import           PureScript.Ide.Error-import           PureScript.Ide.Types-import           PureScript.Ide.SourceFile-import           PureScript.Ide.Reexports-import           System.FilePath-import           System.Directory--type PscIde = StateT PscState IO--getPscIdeState :: PscIde (M.Map ModuleIdent [ExternDecl])-getPscIdeState = pscStateModules <$> get--getAllDecls :: PscIde [ExternDecl]-getAllDecls = concat <$> getPscIdeState--getAllModules :: PscIde [Module]-getAllModules = M.toList <$> getPscIdeState--getAllModulesWithReexports :: PscIde [Module]-getAllModulesWithReexports = do-  mis <- M.keys <$> getPscIdeState-  ms  <- traverse getModuleWithReexports mis-  return (catMaybes ms)--getModule :: ModuleIdent -> PscIde (Maybe Module)-getModule m = do-  modules <- getPscIdeState-  return ((m,) <$> M.lookup m modules)--getModuleWithReexports :: ModuleIdent -> PscIde (Maybe Module)-getModuleWithReexports mi = do-  m <- getModule mi-  db <- getPscIdeState-  case m of-    Just m' -> do-      resolved <- resolveReexports m' db-      return (Just resolved)-    Nothing -> return Nothing-  where-    resolveReexports m db = do-      let replaced = replaceReexports m db-      -- Maybe add logging for statements like these-      -- liftIO $ print (getReexports replaced)-      if null . getReexports $ replaced-        then return replaced-        else resolveReexports replaced db--insertModule :: Module -> PscIde ()-insertModule (name, decls) =-  modify (\x -> x { pscStateModules = M.insert name decls (pscStateModules x)})--findCompletions :: [Filter] -> Matcher -> PscIde Success-findCompletions filters matcher =-  CompletionResult <$> getCompletions filters matcher <$> getAllModulesWithReexports--findType :: DeclIdent -> [Filter] -> PscIde Success-findType search filters =-  CompletionResult <$> getExactMatches search filters <$> getAllModulesWithReexports--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-  m <- EitherT . liftIO $ readExternFile fp-  lift (insertModule m)--printModules :: PscIde Success-printModules = do-  modules <- M.keys <$> getPscIdeState-  return (ModuleList modules)--listAvailableModules :: PscIde Success-listAvailableModules = liftIO $ do-  cwd <- getCurrentDirectory-  modules <- getDirectoryContents (cwd </> "output")-  let cleanedModules = filter (`notElem` [".", ".."]) modules-  return (ModuleList (map T.pack cleanedModules))--importsForFile :: FilePath -> PscIde (Either Error Success)-importsForFile fp = do-  imports <- liftIO (getImportsForFile fp)-  return (ImportList <$> imports)---- | The first argument is a set of modules to load. The second argument---   denotes modules for which to load dependencies-loadModulesAndDeps :: [ModuleIdent] -> [ModuleIdent] -> PscIde (Either Error Success)-loadModulesAndDeps mods deps = do-  r1 <- mapM loadModule (mods ++ deps)-  r2 <- mapM loadModuleDependencies deps-  return $ do-    moduleResults <- fmap T.concat (sequence r1)-    dependencyResults <- fmap T.concat (sequence r2)-    return (TextResult (moduleResults <> ", " <> dependencyResults))--loadModuleDependencies :: ModuleIdent -> PscIde (Either Error T.Text)-loadModuleDependencies moduleName = do-  m <- getModule moduleName-  case getDependenciesForModule <$> m of-    Just deps -> do-      mapM_ loadModule deps-      -- We need to load the modules, that get reexported from the dependencies-      depModules <- catMaybes <$> mapM getModule deps-      -- What to do with errors here? This basically means a reexported dependency-      -- doesn't exist in the output/ folder-      _ <- traverse loadReexports depModules-      return (Right ("Dependencies for " <> moduleName <> " loaded."))-    Nothing -> return (Left (ModuleNotFound moduleName))--loadReexports :: Module -> PscIde (Either Error [ModuleIdent])-loadReexports m = case getReexports m of-  [] -> return (Right [])-  exportDeps -> runEitherT $ do-    -- I'm fine with this crashing on a failed pattern match.-    -- If this ever fails I'll need to look at GADTs-    let reexports = map (\(Export mn) -> mn) exportDeps-    -- liftIO $ print reexports-    _ <- traverse (EitherT . loadModule) reexports-    exportDepsModules <- lift $ catMaybes <$> traverse getModule reexports-    exportDepDeps <- traverse (EitherT . loadReexports) exportDepsModules-    return $ concat exportDepDeps--getDependenciesForModule :: Module -> [ModuleIdent]-getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls-  where getDependencyName (Dependency dependencyName _) = Just dependencyName-        getDependencyName _ = Nothing--loadModule :: ModuleIdent -> PscIde (Either Error T.Text)-loadModule mn = runEitherT $ do-  path <- EitherT . liftIO $ filePathFromModule "json" mn-  EitherT (loadExtern path)-  return ("Loaded extern file at: " <> T.pack path)--filePathFromModule :: String -> ModuleIdent -> IO (Either Error FilePath)-filePathFromModule extension moduleName = do-  cwd <- getCurrentDirectory-  let path = cwd </> "output" </> T.unpack moduleName </> "externs." ++ extension-  ex <- doesFileExist path-  return $-    if ex-    then Right path-    else Left (ModuleFileNotFound moduleName)---- | Taken from Data.Either.Utils-maybeToEither :: MonadError e m =>-                 e                      -- ^ (Left e) will be returned if the Maybe value is Nothing-              -> Maybe a                -- ^ (Right a) will be returned if this is (Just a)-              -> m a-maybeToEither errorval Nothing = throwError errorval-maybeToEither _ (Just normalval) = return normalval
− lib/PureScript/Ide/CodecJSON.hs 
@@ -1,13 +0,0 @@-module PureScript.Ide.CodecJSON where--import Data.Aeson-import Data.Text (Text())-import Data.Text.Lazy (toStrict, fromStrict)-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)--encodeT :: (ToJSON a) => a -> Text-encodeT = toStrict . decodeUtf8 . encode--decodeT :: (FromJSON a) => Text -> Maybe a-decodeT = decode . encodeUtf8 . fromStrict-
− lib/PureScript/Ide/Command.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module PureScript.Ide.Command where--import           Control.Monad-import           Data.Aeson-import           Data.Maybe-import           PureScript.Ide.Filter-import           PureScript.Ide.Matcher-import           PureScript.Ide.Types--data Command-    = Load { loadModules      :: [ModuleIdent]-           , loadDependencies :: [ModuleIdent]}-    | Type { typeSearch  :: DeclIdent-           , typeFilters :: [Filter]}-    | Complete { completeFilters :: [Filter]-               , completeMatcher :: Matcher}-    | Pursuit { pursuitQuery      :: PursuitQuery-              , pursuitSearchType :: PursuitSearchType}-    | List {listType :: ListType}-    | Cwd-    | Quit--data ListType = LoadedModules | Imports FilePath | AvailableModules--instance FromJSON ListType where-  parseJSON = withObject "ListType" $ \o -> do-    (listType' :: String) <- o .: "type"-    case listType' of-      "import" -> do-        fp <- o .: "file"-        return (Imports fp)-      "loadedModules" -> return LoadedModules-      "availableModules" -> return AvailableModules-      _ -> mzero--instance FromJSON Command where-  parseJSON = withObject "command" $ \o -> do-    (command :: String) <- o .: "command"-    case command of-      "list" -> do-        listType' <- o .:? "params"-        return $ List (fromMaybe LoadedModules listType')-      "cwd"  -> return Cwd-      "quit" -> return Quit-      "load" -> do-        params <- o .: "params"-        mods <- params .:? "modules"-        deps <- params .:? "dependencies"-        return $ Load (fromMaybe [] mods) (fromMaybe [] deps)-      "type" -> do-        params <- o .: "params"-        search <- params .: "search"-        filters <- params .: "filters"-        return $ Type search filters-      "complete" -> do-        params <- o .: "params"-        filters <- params .:? "filters"-        matcher <- params .:? "matcher"-        return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)-      "pursuit" -> do-        params <- o .: "params"-        query <- params .: "query"-        queryType <- params .: "type"-        return $ Pursuit query queryType-      _ -> mzero--instance FromJSON Filter where-  parseJSON = withObject "filter" $ \o -> do-    (filter' :: String) <- o .: "filter"-    case filter' of-      "exact" -> do-        params <- o .: "params"-        search <- params .: "search"-        return $ equalityFilter search-      "prefix" -> do-        params <- o.: "params"-        search <- params .: "search"-        return $ prefixFilter search-      "modules" -> do-        params <- o .: "params"-        modules <- params .: "modules"-        return $ moduleFilter modules-      "dependencies" -> do-        params <- o .: "params"-        deps <- params .: "modules"-        return $ dependencyFilter deps-      _ -> mzero--instance FromJSON Matcher where-  parseJSON = withObject "matcher" $ \o -> do-    (matcher :: Maybe String) <- o .:? "matcher"-    case matcher of-      Just "flex" -> do-        params <- o .: "params"-        search <- params .: "search"-        return $ flexMatcher search-      Just "helm" -> error "Helm matcher not implemented yet."-      Just "distance" -> error "Distance matcher not implemented yet."-      Just _ -> mzero-      Nothing -> return mempty
− lib/PureScript/Ide/Completion.hs 
@@ -1,31 +0,0 @@-module PureScript.Ide.Completion-       (getCompletions, getExactMatches)-       where--import           Data.Maybe            (mapMaybe)-import           PureScript.Ide.Filter-import           PureScript.Ide.Matcher-import           PureScript.Ide.Types---- | Applies the CompletionFilters and the Matcher to the given Modules---   and sorts the found Completions according to the Matching Score-getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]-getCompletions filters matcher modules =-    runMatcher matcher $ completionsFromModules (applyFilters filters modules)--getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]-getExactMatches search filters modules =-    completionsFromModules $-    applyFilters (equalityFilter search : filters) modules--completionsFromModules :: [Module] -> [Completion]-completionsFromModules = foldMap completionFromModule-    where-        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 _ (ModuleDecl name _)        = Just (Completion ("module", name, "module"))-completionFromDecl _ _                          = Nothing
− lib/PureScript/Ide/Error.hs 
@@ -1,42 +0,0 @@-module PureScript.Ide.Error-       (ErrorMsg, Error(..), textError, first)-       where--import           Data.Aeson-import           Data.Monoid-import           Data.Text              (Text, pack)-import           PureScript.Ide.Types   (ModuleIdent)-import qualified Text.Parsec.Error      as P--type ErrorMsg = String--data Error-    = GeneralError ErrorMsg-    | NotFound Text-    | ModuleNotFound ModuleIdent-    | ModuleFileNotFound ModuleIdent-    | ParseError P.ParseError ErrorMsg-    deriving (Show, Eq)--instance ToJSON Error where-  toJSON err = object-               [-                 "resultType" .= ("error" :: Text),-                 "result" .= textError err-               ]--textError :: Error -> Text-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
− lib/PureScript/Ide/Externs.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module PureScript.Ide.Externs-  (-    ExternDecl(..),-    ModuleIdent,-    DeclIdent,-    Type,-    Fixity(..),-    readExternFile-  ) where---import           Data.Maybe                  (mapMaybe)-import qualified Data.Text                   as T-import qualified Data.Text.IO                as T-import qualified Language.PureScript.Externs as PE-import qualified Language.PureScript.AST.Declarations as D-import qualified Language.PureScript.Names   as N-import qualified Language.PureScript.Pretty  as PP-import           PureScript.Ide.CodecJSON-import           PureScript.Ide.Error        (Error (..))-import           PureScript.Ide.Types--readExternFile :: FilePath -> IO (Either Error Module)-readExternFile fp = do-   (parseResult :: Maybe PE.ExternsFile) <- decodeT <$> T.readFile fp-   case parseResult of-     Nothing -> return . Left . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"-     Just externs -> return (Right (convertExterns externs))--moduleNameToText :: N.ModuleName -> T.Text-moduleNameToText = T.pack . N.runModuleName--properNameToText :: N.ProperName -> T.Text-properNameToText = T.pack . N.runProperName--identToText :: N.Ident -> T.Text-identToText  = T.pack . N.runIdent--convertExterns :: PE.ExternsFile -> Module-convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)-  where-    moduleName = moduleNameToText (PE.efModuleName ef)-    importDecls = convertImport <$> PE.efImports ef-    exportDecls = mapMaybe convertExport (PE.efExports ef)-    -- Ignoring operator fixities for now since we're not using them-    -- operatorDecls = convertOperator <$> PE.efFixities ef-    otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)--convertImport :: PE.ExternsImport -> ExternDecl-convertImport ei = Dependency (moduleNameToText (PE.eiModule ei)) []--convertExport :: D.DeclarationRef -> Maybe ExternDecl-convertExport (D.ModuleRef mn) = Just (Export (T.pack $ N.runModuleName mn))-convertExport _ = Nothing--convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl-convertDecl (PE.EDType{..}) = Just $-  DataDecl-  (properNameToText edTypeName)-  (T.pack (PP.prettyPrintKind edTypeKind))-convertDecl (PE.EDTypeSynonym{..}) = Just $-  DataDecl-  (properNameToText edTypeSynonymName)-  (T.pack (PP.prettyPrintType edTypeSynonymType))-convertDecl (PE.EDDataConstructor{..}) = Just $-  DataDecl-  (properNameToText edDataCtorName)-  (T.pack (PP.prettyPrintType edDataCtorType))-convertDecl (PE.EDValue{..}) = Just $-  FunctionDecl-  (identToText edValueName)-  (T.pack (PP.prettyPrintType edValueType))-convertDecl _ = Nothing
− lib/PureScript/Ide/Filter.hs 
@@ -1,79 +0,0 @@-module PureScript.Ide.Filter-       (moduleFilter, prefixFilter, equalityFilter, dependencyFilter,-        runFilter, applyFilters)-       where--import           Data.Foldable-import           Data.Maybe           (listToMaybe, mapMaybe)-import           Data.Monoid-import           Data.Text            (Text, isPrefixOf)-import           PureScript.Ide.Types--mkFilter :: ([Module] -> [Module]) -> Filter-mkFilter = Filter . Endo---- | Only keeps the given Modules-moduleFilter :: [ModuleIdent] -> Filter-moduleFilter =-    mkFilter . moduleFilter'--moduleFilter' :: [ModuleIdent] -> [Module] -> [Module]-moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)---- | Only keeps the given Modules and all of their dependencies-dependencyFilter :: [ModuleIdent] -> Filter-dependencyFilter = mkFilter . dependencyFilter'--dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module]-dependencyFilter' moduleIdents mods =-  moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods-  where-    getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent]-    getDepForModule ms moduleIdent =-      moduleIdent : maybe [] extractDeps (findModule moduleIdent ms)--    findModule :: ModuleIdent -> [Module] -> Maybe Module-    findModule i ms = listToMaybe $ filter go ms-      where go (mn, _) = i == mn--    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-prefixFilter :: Text -> Filter-prefixFilter "" = mkFilter id-prefixFilter t = mkFilter $ identFilter prefix t-  where-    prefix :: ExternDecl -> Text -> Bool-    prefix (FunctionDecl name _) search = search `isPrefixOf` name-    prefix (DataDecl name _) search = search `isPrefixOf` name-    prefix (ModuleDecl name _) search = search `isPrefixOf` name-    prefix _ _ = False----- | Only keeps Identifiers that are equal to the search string-equalityFilter :: Text -> Filter-equalityFilter = mkFilter . identFilter equality-  where-    equality :: ExternDecl -> Text -> Bool-    equality (FunctionDecl name _) prefix = prefix == name-    equality (DataDecl name _) prefix = prefix == name-    equality _ _ = False---identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]-identFilter predicate search =-    filter (not . null . snd) . fmap filterModuleDecls-  where-    filterModuleDecls :: Module -> Module-    filterModuleDecls (moduleIdent,decls) =-        (moduleIdent, filter (`predicate` search) decls)--runFilter :: Filter -> [Module] -> [Module]-runFilter (Filter f)= appEndo f--applyFilters :: [Filter] -> [Module] -> [Module]-applyFilters = runFilter . fold
− lib/PureScript/Ide/Matcher.hs 
@@ -1,60 +0,0 @@-module PureScript.Ide.Matcher (flexMatcher, runMatcher) where--import           Data.Function        (on)-import           Data.List            (sortBy)-import           Data.Maybe           (mapMaybe)-import           Data.Monoid-import qualified Data.Text            as T-import qualified Data.Text.Encoding   as TE-import           PureScript.Ide.Types-import           Text.Regex.TDFA      ((=~))---type ScoredCompletion = (Completion, Double)---- | Matches any occurence of the search string with intersections--- |--- | The scoring measures how far the matches span the string where--- | closer is better.--- | Examples:--- |   flMa matches flexMatcher. Score: 14.28--- |   sons matches sortCompletions. Score: 6.25-flexMatcher :: T.Text -> Matcher-flexMatcher pattern = mkMatcher (flexMatch pattern)--mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher-mkMatcher matcher = Matcher . Endo  $ fmap fst . sortCompletions . matcher--runMatcher :: Matcher -> [Completion] -> [Completion]-runMatcher (Matcher m)= appEndo m--sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]-sortCompletions = sortBy (flip compare `on` snd)--flexMatch :: T.Text -> [Completion] -> [ScoredCompletion]-flexMatch pattern = mapMaybe (flexRate pattern)--flexRate :: T.Text -> Completion -> Maybe ScoredCompletion-flexRate pattern c@(Completion (_,ident,_)) = do-    score <- flexScore pattern ident-    return (c, score)---- FlexMatching ala Sublime.--- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/------ By string =~ pattern we'll get the start of the match and the length of--- the matchas a (start, length) tuple if there's a match.--- If match fails then it would be (-1,0)-flexScore :: T.Text -> DeclIdent -> Maybe Double-flexScore "" _ = Nothing-flexScore pat str =-    case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of-        (-1,0) -> Nothing-        (start,len) -> Just $ calcScore start (start + len)-  where-    Just (first,pattern) = T.uncons pat-    -- This just interleaves the search string with .*-    -- abcd -> a.*b.*c.*d-    pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern-    calcScore start end =-        100.0 / fromIntegral ((1 + start) * (end - start + 1))
− lib/PureScript/Ide/Pursuit.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}--module PureScript.Ide.Pursuit where--import qualified Control.Exception    as E-import           Control.Lens         hiding (noneOf)-import           Control.Monad-import           Data.Aeson-import           Data.Aeson.Lens-import           Data.ByteString.Lazy (ByteString)-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           Text.Parsec-import           Text.Parsec.Text--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--queryUrl :: String-queryUrl = "http://pursuit.purescript.org/search"--jsonOpts :: Text -> Options-jsonOpts q =-    defaults & header "Accept" .~ ["application/json"] & param "q" .~ [q]---- We need to remove trailing dots because Pursuit will return a 400 otherwise--- TODO: remove this when the issue is fixed at Pursuit--queryPursuit :: Text -> IO (Response ByteString)-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--parseType :: Parser (String, String)-parseType = do-  name <- identifier-  _ <- string "::"-  spaces-  type' <- many1 anyChar-  return (T.unpack name, type')--typeParse :: Text -> Either Text (Text, Text)-typeParse t = case parse parseType "" t of-  Right (x,y) -> Right (T.pack x, T.pack y)-  Left err -> Left (T.pack (show err))--identifier :: Parser Text-identifier = do-  spaces-  ident <--      -- necessary for being able to parse the following ((++), concat)-      between (char '(') (char ')') (many1 (noneOf ", )")) <|>-      many1 (noneOf ", )")-  spaces-  return (T.pack ident)
− lib/PureScript/Ide/Reexports.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE TupleSections #-}-module PureScript.Ide.Reexports where--import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map-import Data.List (union)-import PureScript.Ide.Types--getReexports :: Module -> [ExternDecl]-getReexports (mn, decls)= mapMaybe getExport decls-  where getExport e@(Export mn')-          | mn /= mn' = Just e-          | otherwise = Nothing-        getExport _ = Nothing--replaceReexport :: ExternDecl -> Module -> Module -> Module-replaceReexport e@(Export _) (m, decls) (_, newDecls) =-  (m, filter (/= e) decls `union` newDecls)-replaceReexport _ _ _ = error "Should only get Exports here."--emptyModule :: Module-emptyModule = ("Empty", [])--isExport :: ExternDecl -> Bool-isExport (Export _) = True-isExport _ = False--removeExportDecls :: Module -> Module-removeExportDecls = fmap (filter (not . isExport))--replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module-replaceReexports m db = result-  where reexports = getReexports m-        result = foldl go (removeExportDecls m) reexports--        go :: Module -> ExternDecl -> Module-        go m' re@(Export name) = replaceReexport re m' (getModule name)--        getModule :: ModuleIdent -> Module-        getModule name = clean res-          where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db-                -- we have to do this because keeping self exports in will result in-                -- infinite loops-                clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
− lib/PureScript/Ide/SourceFile.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module PureScript.Ide.SourceFile where--import           Data.Maybe                           (mapMaybe)-import           Data.Monoid-import qualified Data.Text                            as T-import qualified Language.PureScript.AST.Declarations as D-import qualified Language.PureScript.Parser           as P-import           PureScript.Ide.Error-import           PureScript.Ide.Types-import qualified Language.PureScript.AST.SourcePos    as SP-import qualified Language.PureScript.Names            as N-import           System.Directory--parseModuleFromFile :: FilePath -> IO (Either Error D.Module)-parseModuleFromFile fp = do-  exists <- doesFileExist fp-  if exists-    then do-      content <- readFile fp-      let m = do tokens <- P.lex fp content-                 P.runTokenParser "" P.parseModule tokens-      return (first (`ParseError` "File could not be parsed.") m)-    else return $ Left (NotFound "File does not exist.")---- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])--getDeclarations :: D.Module -> [D.Declaration]-getDeclarations (D.Module _ _ _ declarations _) = declarations--getImports :: D.Module -> [D.Declaration]-getImports (D.Module _ _ _ declarations _) =-  mapMaybe isImport declarations-  where-    isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i-    isImport _ = Nothing--getImportsForFile :: FilePath -> IO (Either Error [ModuleImport])-getImportsForFile fp = do-  module' <- parseModuleFromFile fp-  let imports = getImports <$> module'-  return (fmap (mkModuleImport . unwrapPositionedImport) <$> imports)-  where mkModuleImport (D.ImportDeclaration mn importType' qualifier) =-          ModuleImport-            (T.pack (N.runModuleName mn))-            importType'-            (T.pack . N.runModuleName <$> qualifier)-        mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"-        unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) =-          D.ImportDeclaration mn (unwrapImportType importType') qualifier-        unwrapPositionedImport x = x-        unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)-        unwrapImportType (D.Hiding decls)   = D.Hiding (map unwrapPositionedRef decls)-        unwrapImportType D.Implicit         = D.Implicit--getPositionedImports :: D.Module -> [D.Declaration]-getPositionedImports (D.Module _ _ _ declarations _) =-  mapMaybe isImport declarations-  where-    isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i-    isImport _ = Nothing--unwrapPositioned :: D.Declaration -> D.Declaration-unwrapPositioned (D.PositionedDeclaration _ _ x) = x-unwrapPositioned x = x--unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef-unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x-unwrapPositionedRef x = x--getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan-getDeclPosition m ident =-  let decls = getDeclarations m-  in getFirst (foldMap (match ident) decls)-     where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl-                                                                then Just ss-                                                                else Nothing)-           match _ _ = First Nothing--           go q (D.DataDeclaration _ name _ constructors)  =-             properEqual name q || any (\(x,_) -> properEqual x q) constructors-           go q (D.DataBindingGroupDeclaration decls)      = any (go q) decls-           go q (D.TypeSynonymDeclaration name _ _)        = properEqual name q-           go q (D.TypeDeclaration ident' _)               = identEqual ident' q-           go q (D.ValueDeclaration ident' _ _ _)          = identEqual ident' q-           go q (D.ExternDeclaration ident' _)             = identEqual ident' q-           go q (D.ExternDataDeclaration name _)           = properEqual name q-           go q (D.TypeClassDeclaration name _ _ members)  =-             properEqual name q || any (go q . unwrapPositioned) members-           go q (D.TypeInstanceDeclaration ident' _ _ _ _) =-             identEqual ident' q-           go _ _ = False--           properEqual x q = N.runProperName x == q-           identEqual x q = N.runIdent x == q--goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)-goToDefinition q fp = do-  m <- parseModuleFromFile fp-  case m of-    Right module' -> return $ getDeclPosition module' q-    Left _ -> return Nothing
− lib/PureScript/Ide/Types.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards            #-}--module PureScript.Ide.Types where--import           Control.Monad-import           Data.Aeson-import           Data.Map.Lazy                        as M-import           Data.Maybe                           (maybeToList)-import           Data.Monoid-import           Data.Text                            (Text ())-import qualified Language.PureScript.AST.Declarations as D-import qualified Language.PureScript.Names            as N--type ModuleIdent = Text-type DeclIdent   = Text-type Type        = Text--data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)--data ExternDecl-    = FunctionDecl { functionName :: DeclIdent-                   , functionType :: Type}-    | FixityDeclaration Fixity-                        Int-                        DeclIdent-    | Dependency { dependencyModule :: ModuleIdent-                 , dependencyNames  :: [Text]}-    | ModuleDecl ModuleIdent-                 [DeclIdent]-    | DataDecl DeclIdent-               Text-    | Export ModuleIdent-    deriving (Show,Eq,Ord)--instance ToJSON ExternDecl where-  toJSON (FunctionDecl n t)        = object ["name" .= n, "type" .= t]-  toJSON (ModuleDecl   n t)        = object ["name" .= n, "type" .= t]-  toJSON (DataDecl     n t)        = object ["name" .= n, "type" .= t]-  toJSON (Dependency   n names)    = object ["module" .= n, "names" .= names]-  toJSON (FixityDeclaration f p n) = object ["name" .= n-                                            , "fixity" .= show f-                                            , "precedence" .= p]-  toJSON (Export _) = object []--type Module = (ModuleIdent, [ExternDecl])--data PscState = PscState-    { pscStateModules :: M.Map Text [ExternDecl]-    } deriving (Show,Eq)--emptyPscState :: PscState-emptyPscState = PscState M.empty--newtype Completion =-    Completion (ModuleIdent, DeclIdent, Type)-    deriving (Show,Eq)--data ModuleImport = ModuleImport {-  importModuleName :: ModuleIdent,-  importType       :: D.ImportDeclarationType,-  importQualifier  :: Maybe Text} deriving(Show)--instance Eq ModuleImport where-  mi1 == mi2 = importModuleName mi1 == importModuleName mi2-               && importQualifier mi1 == importQualifier mi2--instance ToJSON ModuleImport where-  toJSON (ModuleImport mn D.Implicit qualifier) =-    object $  ["module" .= mn-              , "importType" .= ("implicit" :: Text)-              ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)-  toJSON (ModuleImport mn (D.Explicit refs) _) =-    object ["module" .= mn-           , "importType" .= ("explicit" :: Text)-           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]-  toJSON (ModuleImport mn (D.Hiding refs) _) =-    object ["module" .= mn-           , "importType" .= ("hiding" :: Text)-           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]--identifierFromDeclarationRef :: D.DeclarationRef -> String-identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name-identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident-identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name-identifierFromDeclarationRef _ = ""--instance FromJSON Completion where-    parseJSON (Object o) = do-        m <- o .: "module"-        d <- o .: "identifier"-        t <- o .: "type"-        return $ Completion (m, d, t)-    parseJSON _ = mzero--instance ToJSON Completion where-    toJSON (Completion (m,d,t)) =-        object ["module" .= m, "identifier" .= d, "type" .= t]--data Success =-  CompletionResult [Completion]-  | TextResult Text-  | PursuitResult [PursuitResponse]-  | ImportList [ModuleImport]-  | ModuleList [ModuleIdent]-  deriving(Show, Eq)--encodeSuccess :: (ToJSON a) => a -> Value-encodeSuccess res =-    object ["resultType" .= ("success" :: Text), "result" .= res]--instance ToJSON Success where-  toJSON (CompletionResult cs) = encodeSuccess cs-  toJSON (TextResult t) = encodeSuccess t-  toJSON (PursuitResult resp) = encodeSuccess resp-  toJSON (ImportList decls) = encodeSuccess decls-  toJSON (ModuleList modules) = encodeSuccess modules--newtype Filter = Filter (Endo [Module]) deriving(Monoid)-newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)--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]
psc-ide.cabal view
@@ -1,5 +1,5 @@ name:                psc-ide-version:             0.5.0+version:             0.6.0 synopsis:            Language support for the PureScript programming language description:         Please see README.md homepage:            http://github.com/kRITZCREEK/psc-ide@@ -13,7 +13,7 @@ cabal-version:       >=1.10  library-  hs-source-dirs:        lib+  hs-source-dirs:        src   exposed-modules:       PureScript.Ide                        , PureScript.Ide.Command                        , PureScript.Ide.Externs@@ -24,7 +24,10 @@                        , PureScript.Ide.Matcher                        , PureScript.Ide.Filter                        , PureScript.Ide.Types+                       , PureScript.Ide.State+                       , PureScript.Ide.CaseSplit                        , PureScript.Ide.SourceFile+                       , PureScript.Ide.Watcher                        , PureScript.Ide.Reexports   default-language:      Haskell2010   build-depends:         aeson@@ -32,22 +35,26 @@                        , bytestring                        , containers                        , directory+                       , edit-distance                        , either                        , filepath+                       , fsnotify                        , http-client                        , lens                        , lens-aeson+                       , monad-logger                        , mtl                        , parsec-                       , purescript+                       , purescript >= 0.8.0.0                        , regex-tdfa+                       , stm                        , text                        , wreq   default-extensions:    OverloadedStrings   ghc-options:         -O2  executable psc-ide-  hs-source-dirs:      src+  hs-source-dirs:      client   main-is:             Main.hs   default-language:    Haskell2010   build-depends:       base >= 4.7 && < 5@@ -56,6 +63,7 @@                      , text                      , optparse-applicative                      , network+  other-modules: Paths_psc_ide   ghc-options:         -O2 -Wall  executable psc-ide-server@@ -63,12 +71,16 @@   main-is:             Main.hs   default-language:    Haskell2010   build-depends:     base >= 4.7 && < 5+                   , directory+                   , filepath+                   , monad-logger                    , mtl                    , network                    , optparse-applicative-                   , directory                    , psc-ide+                   , stm                    , text+  other-modules: Paths_psc_ide   ghc-options:         -threaded -O2 -Wall  test-suite spec@@ -82,7 +94,9 @@                      , PureScript.Ide.MatcherSpec                      , PureScript.Ide.ReexportsSpec   build-depends:       base    >= 4.7 && < 5-                     , psc-ide-                     , mtl-                     , hspec                      , containers+                     , hspec+                     , monad-logger+                     , mtl+                     , psc-ide+                     , stm
server/Main.hs view
@@ -1,12 +1,19 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports    #-}+{-# LANGUAGE TemplateHaskell   #-} module Main where +import           Control.Concurrent       (forkFinally)+import           Control.Concurrent.STM import           Control.Exception        (bracketOnError) import           Control.Monad-import           Control.Monad.State.Lazy-import           Data.Maybe               (fromMaybe)+import           "monad-logger" Control.Monad.Logger+import           Control.Monad.Reader+import           Control.Monad.Except import qualified Data.Text                as T import qualified Data.Text.IO             as T+import           Data.Version             (showVersion) import           Network                  hiding (socketPort) import           Network.BSD              (getProtocolNumber) import           Network.Socket           hiding (PortNumber, Type, accept,@@ -17,90 +24,131 @@ import           PureScript.Ide.Command import           PureScript.Ide.Error import           PureScript.Ide.Types+import           PureScript.Ide.Watcher import           System.Directory import           System.Exit+import           System.FilePath import           System.IO +import qualified Paths_psc_ide            as Paths++-- "Borrowed" from the Idris Compiler -- Copied from upstream impl of listenOn -- bound to localhost interface instead of iNADDR_ANY listenOnLocalhost :: PortID -> IO Socket listenOnLocalhost (PortNumber port) = do-    proto <- getProtocolNumber "tcp"-    localhost <- inet_addr "127.0.0.1"-    bracketOnError-        (socket AF_INET Stream proto)-        sClose-        (\sock ->-              do setSocketOption sock ReuseAddr 1-                 bindSocket sock (SockAddrInet port localhost)-                 listen sock maxListenQueue-                 return sock)+  proto <- getProtocolNumber "tcp"+  localhost <- inet_addr "127.0.0.1"+  bracketOnError+    (socket AF_INET Stream proto)+    sClose+    (\sock -> do+      setSocketOption sock ReuseAddr 1+      bindSocket sock (SockAddrInet port localhost)+      listen sock maxListenQueue+      pure sock) listenOnLocalhost _ = error "Wrong Porttype"  data Options = Options-    { optionsDirectory :: Maybe FilePath-    , optionsPort      :: Maybe Int-    , optionsDebug     :: Bool-    }+  { optionsDirectory  :: Maybe FilePath+  , optionsOutputPath :: FilePath+  , optionsPort       :: Int+  , optionsDebug      :: Bool+  }  main :: IO () main = do-    Options dir port debug <- execParser opts-    maybe (return ()) setCurrentDirectory dir-    startServer (PortNumber . fromIntegral $ fromMaybe 4242 port) debug emptyPscState+  Options dir outputPath port debug  <- execParser opts+  maybe (pure ()) setCurrentDirectory dir+  serverState <- newTVarIO emptyPscState+  cwd <- getCurrentDirectory+  _ <- forkFinally (watcher serverState (cwd </> outputPath)) print+  let conf =+        Configuration+        {+          confDebug = debug+        , confOutputPath = outputPath+        }+  let env =+        PscEnvironment+        {+          envStateVar = serverState+        , envConfiguration = conf+        }+  startServer (PortNumber (fromIntegral port)) env   where     parser =-        Options <$>-          optional (strOption (long "directory" <> short 'd')) <*>-          optional (option auto (long "port" <> short 'p')) <*>-          switch (long "debug")-    opts = info parser mempty-+      Options <$>+        optional (strOption (long "directory" <> short 'd')) <*>+        strOption (long "output-directory" <> value "output/") <*>+        option auto (long "port" <> short 'p' <> value 4242) <*>+        switch (long "debug")+    opts = info (version <*> parser) mempty+    version = abortOption+      (InfoMsg (showVersion Paths.version))+      (long "version" <> help "Show the version number") -startServer :: PortID -> Bool -> PscState -> IO ()-startServer port debug st_in =-    withSocketsDo $-    do sock <- listenOnLocalhost port-       evalStateT (forever (loop sock)) st_in+startServer :: PortID -> PscEnvironment -> IO ()+startServer port env = withSocketsDo $ do+  sock <- listenOnLocalhost port+  runLogger (runReaderT (forever (loop sock)) env)   where-    acceptCommand sock = do-        (h,_,_) <- accept sock-        hSetEncoding h utf8-        cmd <- T.hGetLine h-        when debug (T.putStrLn cmd)-        return (cmd, h)-    loop :: Socket -> PscIde ()+    runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))++    loop :: (PscIde m, MonadLogger m) => Socket -> m ()     loop sock = do-        (cmd,h) <- liftIO $ acceptCommand sock-        case decodeT cmd of-            Just cmd' -> do-                result <- handleCommand cmd'-                when debug $ liftIO $ T.putStrLn ("Answer was: " <> (T.pack . show $ result)) >> hFlush stdout-                case result of-                  -- What function can I use to clean this up?-                  Right r  -> liftIO $ T.hPutStrLn h (encodeT r)-                  Left err -> liftIO $ T.hPutStrLn h (encodeT err)-            Nothing ->-                liftIO $ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) >> hFlush stdout-        liftIO $ hClose h+      (cmd,h) <- acceptCommand sock+      case decodeT cmd of+        Just cmd' -> do+          result <- runExceptT (handleCommand cmd')+          $(logDebug) ("Answer was: " <> T.pack (show result))+          liftIO (hFlush stdout)+          case result of+            -- What function can I use to clean this up?+            Right r  -> liftIO $ T.hPutStrLn h (encodeT r)+            Left err -> liftIO $ T.hPutStrLn h (encodeT err)+        Nothing -> do+          $(logDebug) ("Parsing the command failed. Command: " <> cmd)+          liftIO $ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) >> hFlush stdout+      liftIO (hClose h) -handleCommand :: Command -> PscIde (Either Error Success)++acceptCommand :: (MonadIO m, MonadLogger m) => Socket -> m (T.Text, Handle)+acceptCommand sock = do+  h <- acceptConnection+  $(logDebug) "Accepted a connection"+  cmd <- liftIO (T.hGetLine h)+  $(logDebug) cmd+  pure (cmd, h)+  where+   acceptConnection = liftIO $ do+     (h,_,_) <- accept sock+     hSetEncoding h utf8+     hSetBuffering h LineBuffering+     pure h++handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                 Command -> m Success handleCommand (Load modules deps) =     loadModulesAndDeps modules deps handleCommand (Type search filters) =-    Right <$> findType search filters+    findType search filters handleCommand (Complete filters matcher) =-    Right <$> findCompletions filters matcher+    findCompletions filters matcher handleCommand (Pursuit query Package) =-    Right <$> findPursuitPackages query+    findPursuitPackages query handleCommand (Pursuit query Identifier) =-    Right <$> findPursuitCompletions query+    findPursuitCompletions query handleCommand (List LoadedModules) =-    Right <$> printModules+    printModules handleCommand (List AvailableModules) =-    Right <$> listAvailableModules+    listAvailableModules handleCommand (List (Imports fp)) =     importsForFile fp+handleCommand (CaseSplit l b e wca t) =+    caseSplit l b e wca t+handleCommand (AddClause l wca) =+    pure $ addClause l wca handleCommand Cwd =-    Right . TextResult . T.pack <$> liftIO getCurrentDirectory-handleCommand Quit = Right <$> liftIO exitSuccess+    TextResult . T.pack <$> liftIO getCurrentDirectory+handleCommand Quit = liftIO exitSuccess
− src/Main.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where--import           Control.Exception-import           Data.Maybe          (fromMaybe)-import qualified Data.Text           as T-import qualified Data.Text.IO        as T-import           Network-import           Options.Applicative-import           System.IO-import           System.Exit--data Options = Options-    { optionsPort :: Maybe Int-    }--main :: IO ()-main = do-    Options port <- execParser opts-    let port' = PortNumber . fromIntegral $ fromMaybe 4242 port-    client port'-  where-    parser =-        Options <$> optional (option auto (long "port" <> short 'p'))-    opts = info parser mempty--client :: PortID -> IO ()-client port = do-    h <--        connectTo "localhost" port `catch`-        (\(SomeException e) ->-              putStrLn-                  ("Couldn't connect to psc-ide-server on port: " ++-                   show port ++ " Error: " ++ show e) >>-              exitFailure)-    cmd <- T.getLine-    T.hPutStrLn h cmd-    res <- T.hGetLine h-    putStrLn (T.unpack res)-    hFlush stdout-    hClose h-
+ src/PureScript/Ide.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}++module PureScript.Ide where+++import           Control.Monad.Except+import           Control.Monad.Reader.Class+import           "monad-logger" Control.Monad.Logger+import           Data.Foldable+import qualified Data.Map.Lazy            as M+import           Data.Maybe               (mapMaybe, catMaybes)+import           Data.Monoid+import           Data.Text (Text)+import qualified Data.Text  as T+import           PureScript.Ide.Completion+import           PureScript.Ide.Externs+import           PureScript.Ide.Pursuit+import           PureScript.Ide.Error+import           PureScript.Ide.Types+import           PureScript.Ide.SourceFile+import           PureScript.Ide.State+import           PureScript.Ide.Filter+import           PureScript.Ide.Matcher+import           PureScript.Ide.Reexports+import qualified PureScript.Ide.CaseSplit as CS+import           System.FilePath+import           System.Directory++findCompletions :: (PscIde m, MonadLogger m) =>+                   [Filter] -> Matcher -> m Success+findCompletions filters matcher =+  CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports++findType :: (PscIde m, MonadLogger m) =>+            DeclIdent -> [Filter] -> m Success+findType search filters =+  CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports++findPursuitCompletions :: (MonadIO m, MonadLogger m) =>+                          PursuitQuery -> m Success+findPursuitCompletions (PursuitQuery q) =+  PursuitResult <$> liftIO (searchPursuitForDeclarations q)++findPursuitPackages :: (MonadIO m, MonadLogger m) =>+                       PursuitQuery -> m Success+findPursuitPackages (PursuitQuery q) =+  PursuitResult <$> liftIO (findPackagesForModuleIdent q)++loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>+             FilePath -> m ()+loadExtern fp = do+  m <- readExternFile fp+  insertModule m++printModules :: (PscIde m) => m Success+printModules = printModules' <$> getPscIdeState++printModules' :: M.Map ModuleIdent [ExternDecl] -> Success+printModules' = ModuleList . M.keys++listAvailableModules :: PscIde m => m Success+listAvailableModules = do+  outputPath <- confOutputPath . envConfiguration <$> ask+  liftIO $ do+    cwd <- getCurrentDirectory+    dirs <- getDirectoryContents (cwd </> outputPath)+    return (ModuleList (listAvailableModules' dirs))++listAvailableModules' :: [FilePath] -> [Text]+listAvailableModules' dirs =+  let cleanedModules = filter (`notElem` [".", ".."]) dirs+  in map T.pack cleanedModules++caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+  Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success+caseSplit l b e csa t = do+  patterns <- CS.makePattern l b e csa <$> CS.caseSplit t+  pure (MultilineTextResult patterns)++addClause :: Text -> CS.WildcardAnnotations -> Success+addClause t wca = MultilineTextResult (CS.addClause t wca)++importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>+                  FilePath -> m Success+importsForFile fp = do+  imports <- getImportsForFile fp+  pure (ImportList imports)++-- | The first argument is a set of modules to load. The second argument+--   denotes modules for which to load dependencies+loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                     [ModuleIdent] -> [ModuleIdent] -> m Success+loadModulesAndDeps mods deps = do+  r1 <- mapM loadModule (mods ++ deps)+  r2 <- mapM loadModuleDependencies deps+  let moduleResults = T.concat r1+  let dependencyResults = T.concat r2+  pure (TextResult (moduleResults <> ", " <> dependencyResults))++loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                         ModuleIdent -> m Text+loadModuleDependencies moduleName = do+  m <- getModule moduleName+  case getDependenciesForModule <$> m of+    Just deps -> do+      mapM_ loadModule deps+      -- We need to load the modules, that get reexported from the dependencies+      depModules <- catMaybes <$> mapM getModule deps+      -- What to do with errors here? This basically means a reexported dependency+      -- doesn't exist in the output/ folder+      traverse_ loadReexports depModules+      pure ("Dependencies for " <> moduleName <> " loaded.")+    Nothing -> throwError (ModuleNotFound moduleName)++loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                Module -> m [ModuleIdent]+loadReexports m = case getReexports m of+  [] -> pure []+  exportDeps -> do+    -- I'm fine with this crashing on a failed pattern match.+    -- If this ever fails I'll need to look at GADTs+    let reexports = map (\(Export mn) -> mn) exportDeps+    $(logDebug) ("Loading reexports for module: " <> fst m <>+                 " reexports: " <> T.concat reexports)+    traverse_ loadModule reexports+    exportDepsModules <- catMaybes <$> traverse getModule reexports+    exportDepDeps <- traverse loadReexports exportDepsModules+    return $ concat exportDepDeps++getDependenciesForModule :: Module -> [ModuleIdent]+getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls+  where getDependencyName (Dependency dependencyName _) = Just dependencyName+        getDependencyName _ = Nothing++loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+              ModuleIdent -> m Text+loadModule "Prim" = pure "Prim won't be loaded"+loadModule mn = do+  path <- filePathFromModule mn+  loadExtern path+  $(logDebug) ("Loaded extern file at: " <> T.pack path)+  pure ("Loaded extern file at: " <> T.pack path)++filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>+                      ModuleIdent -> m FilePath+filePathFromModule moduleName = do+  outputPath <- confOutputPath . envConfiguration <$> ask+  cwd <- liftIO getCurrentDirectory+  let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"+  ex <- liftIO $ doesFileExist path+  if ex+    then pure path+    else throwError (ModuleFileNotFound moduleName)++-- | Taken from Data.Either.Utils+maybeToEither :: MonadError e m =>+                 e                      -- ^ (Left e) will be returned if the Maybe value is Nothing+              -> Maybe a                -- ^ (Right a) will be returned if this is (Just a)+              -> m a+maybeToEither errorval Nothing = throwError errorval+maybeToEither _ (Just normalval) = return normalval
+ src/PureScript/Ide/CaseSplit.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports   #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE LambdaCase       #-}+++module PureScript.Ide.CaseSplit+       ( WildcardAnnotations()+       , explicitAnnotations+       , noAnnotations+       , makePattern+       , addClause+       , caseSplit+       ) where++import           "monad-logger" Control.Monad.Logger+import           Control.Monad.Except+import           Data.List (find)+import           Data.Monoid+import           Data.Text                   (Text)+import qualified Data.Text                   as T+import Language.PureScript.AST+import           Language.PureScript.Externs+import           Language.PureScript.Names+import           Language.PureScript.Types+import           Language.PureScript.Pretty+import           Language.PureScript.Environment+import           Language.PureScript.Parser.Types+import           Language.PureScript.Parser.Declarations+import           Language.PureScript.Parser.Lexer (lex)+import           Language.PureScript.Parser.Common (runTokenParser)+import           Prelude hiding (lex)+import           PureScript.Ide.Error+import           PureScript.Ide.State+import           PureScript.Ide.Types hiding (Type)+import           PureScript.Ide.SourceFile (unwrapPositioned)+import           Text.Parsec as P++type Constructor = (ProperName 'ConstructorName, [Type])++newtype WildcardAnnotations = WildcardAnnotations Bool++explicitAnnotations :: WildcardAnnotations+explicitAnnotations = WildcardAnnotations True++noAnnotations :: WildcardAnnotations+noAnnotations = WildcardAnnotations False++caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+             Text -> m [Constructor]+caseSplit q = do+  (tc, args) <- splitTypeConstructor (parseType' (T.unpack q))+  (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc+  let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))+  let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors+  pure appliedCtors++{- ["EDType {+     edTypeName = ProperName {runProperName = \"Either\"}+   , edTypeKind = FunKind Star (FunKind Star Star)+   , edTypeDeclarationKind =+       DataType [(\"a\",Just Star),(\"b\",Just Star)]+                [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"])+                ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"]+-}++findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>+                         ProperName 'TypeName -> m ExternsDeclaration+findTypeDeclaration q = do+  efs <- getExternFiles+  let m = getAlt $ foldMap (findTypeDeclaration' q) efs+  case m of+    Just mn -> pure mn+    Nothing -> throwError (GeneralError "Not Found")++findTypeDeclaration' ::+  ProperName 'TypeName+  -> ExternsFile+  -> Alt Maybe ExternsDeclaration+findTypeDeclaration' t ExternsFile{..} =+  Alt $ find (\case+            EDType tn _ _ -> tn == t+            _ -> False) efDeclarations++splitTypeConstructor :: (MonadError PscIdeError m) =>+                        Type -> m (ProperName 'TypeName, [Type])+splitTypeConstructor = go []+  where+    go acc (TypeApp ty arg) = go (arg : acc) ty+    go acc (TypeConstructor tc) = pure (disqualify tc, acc)+    go _ _ = throwError (GeneralError "Failed to read TypeConstructor")++prettyCtor :: WildcardAnnotations -> Constructor -> Text+prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)+prettyCtor wsa (ctorName, ctorArgs) =+  "("<> T.pack (runProperName ctorName) <> " "+  <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"++prettyPrintWildcard :: WildcardAnnotations -> Type -> Text+prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard+prettyPrintWildcard (WildcardAnnotations False) = const "_"++prettyWildcard :: Type -> Text+prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"++makePattern ::+  Text -> -- ^ current line+  Int -> -- ^ begin of the split+  Int -> -- ^ end of the split+  WildcardAnnotations -> -- ^ Whether to explicitly type the splits+  [Constructor] -> -- ^ constructors to split+  [Text]+makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)+  where+    makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)++addClause :: Text -> WildcardAnnotations -> [Text]+addClause s wca =+  let (fName, fType) = parseTypeDeclaration' (T.unpack s)+      (args, _) = splitFunctionType fType+      template = T.pack (runIdent fName) <> " " <>+        T.unwords (map (prettyPrintWildcard wca) args) <>+        " = ?" <> (T.strip . T.pack . runIdent $ fName)+  in [s, template]++parseType' :: String -> Type+parseType' s = let (Right t) = do+                     ts <- lex "" s+                     runTokenParser "" (parseType <* P.eof) ts+               in t++parseTypeDeclaration' :: String -> (Ident, Type)+parseTypeDeclaration' s =+  let x = do+        ts <- lex "" s+        runTokenParser "" (parseDeclaration <* P.eof) ts+  in+    case unwrapPositioned <$> x of+      Right (TypeDeclaration i t) -> (i, t)+      y -> error (show y)++splitFunctionType :: Type -> ([Type], Type)+splitFunctionType t = (arguments, returns)+  where+    returns = last splitted+    arguments = init splitted+    splitted = splitType' t+    splitType' (ForAll _ t' _) = splitType' t'+    splitType' (ConstrainedType _ t') = splitType' t'+    splitType' (TypeApp (TypeApp t' lhs) rhs)+          | t' == tyFunction = lhs : splitType' rhs+    splitType' t' = [t']
+ src/PureScript/Ide/CodecJSON.hs view
@@ -0,0 +1,13 @@+module PureScript.Ide.CodecJSON where++import Data.Aeson+import Data.Text (Text())+import Data.Text.Lazy (toStrict, fromStrict)+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)++encodeT :: (ToJSON a) => a -> Text+encodeT = toStrict . decodeUtf8 . encode++decodeT :: (FromJSON a) => Text -> Maybe a+decodeT = decode . encodeUtf8 . fromStrict+
+ src/PureScript/Ide/Command.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables #-}+module PureScript.Ide.Command where++import           Control.Monad+import           Data.Aeson+import           Data.Text (Text)+import           Data.Maybe+import           PureScript.Ide.Filter+import           PureScript.Ide.Matcher+import           PureScript.Ide.Types+import           PureScript.Ide.CaseSplit++data Command+    = Load { loadModules      :: [ModuleIdent]+           , loadDependencies :: [ModuleIdent]}+    | Type { typeSearch  :: DeclIdent+           , typeFilters :: [Filter]}+    | Complete { completeFilters :: [Filter]+               , completeMatcher :: Matcher}+    | Pursuit { pursuitQuery      :: PursuitQuery+              , pursuitSearchType :: PursuitSearchType}+    | List {listType :: ListType}+    | CaseSplit {+      caseSplitLine :: Text+      , caseSplitBegin :: Int+      , caseSplitEnd :: Int+      , caseSplitAnnotations :: WildcardAnnotations+      , caseSplitType :: Type}+    | AddClause {+      addClauseLine :: Text+      , addClauseAnnotations :: WildcardAnnotations}+    | Cwd+    | Quit++data ListType = LoadedModules | Imports FilePath | AvailableModules++instance FromJSON ListType where+  parseJSON = withObject "ListType" $ \o -> do+    (listType' :: String) <- o .: "type"+    case listType' of+      "import" -> do+        fp <- o .: "file"+        return (Imports fp)+      "loadedModules" -> return LoadedModules+      "availableModules" -> return AvailableModules+      _ -> mzero++instance FromJSON Command where+  parseJSON = withObject "command" $ \o -> do+    (command :: String) <- o .: "command"+    case command of+      "list" -> do+        listType' <- o .:? "params"+        return $ List (fromMaybe LoadedModules listType')+      "cwd"  -> return Cwd+      "quit" -> return Quit+      "load" -> do+        params <- o .: "params"+        mods <- params .:? "modules"+        deps <- params .:? "dependencies"+        return $ Load (fromMaybe [] mods) (fromMaybe [] deps)+      "type" -> do+        params <- o .: "params"+        search <- params .: "search"+        filters <- params .: "filters"+        return $ Type search filters+      "complete" -> do+        params <- o .: "params"+        filters <- params .:? "filters"+        matcher <- params .:? "matcher"+        return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)+      "pursuit" -> do+        params <- o .: "params"+        query <- params .: "query"+        queryType <- params .: "type"+        return $ Pursuit query queryType+      "caseSplit" -> do+        params <- o .: "params"+        line <- params .: "line"+        begin <- params .: "begin"+        end <- params .: "end"+        annotations <- params .: "annotations"+        type' <- params .: "type"+        return $ CaseSplit line begin end (if annotations+                                           then explicitAnnotations+                                           else noAnnotations) type'+      "addClause" -> do+        params <- o .: "params"+        line <- params .: "line"+        annotations <- params .: "annotations"+        return $ AddClause line (if annotations+                                 then explicitAnnotations+                                 else noAnnotations)+      _ -> mzero+
+ src/PureScript/Ide/Completion.hs view
@@ -0,0 +1,31 @@+module PureScript.Ide.Completion+       (getCompletions, getExactMatches)+       where++import           Data.Maybe            (mapMaybe)+import           PureScript.Ide.Filter+import           PureScript.Ide.Matcher+import           PureScript.Ide.Types++-- | Applies the CompletionFilters and the Matcher to the given Modules+--   and sorts the found Completions according to the Matching Score+getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]+getCompletions filters matcher modules =+    runMatcher matcher $ completionsFromModules (applyFilters filters modules)++getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]+getExactMatches search filters modules =+    completionsFromModules $+    applyFilters (equalityFilter search : filters) modules++completionsFromModules :: [Module] -> [Completion]+completionsFromModules = foldMap completionFromModule+    where+        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 _ (ModuleDecl name _)        = Just (Completion ("module", name, "module"))+completionFromDecl _ _                          = Nothing
+ src/PureScript/Ide/Error.hs view
@@ -0,0 +1,42 @@+module PureScript.Ide.Error+       (ErrorMsg, PscIdeError(..), textError, first)+       where++import           Data.Aeson+import           Data.Monoid+import           Data.Text              (Text, pack)+import           PureScript.Ide.Types   (ModuleIdent)+import qualified Text.Parsec.Error      as P++type ErrorMsg = String++data PscIdeError+    = GeneralError ErrorMsg+    | NotFound Text+    | ModuleNotFound ModuleIdent+    | ModuleFileNotFound ModuleIdent+    | ParseError P.ParseError ErrorMsg+    deriving (Show, Eq)++instance ToJSON PscIdeError where+  toJSON err = object+               [+                 "resultType" .= ("error" :: Text),+                 "result" .= textError err+               ]++textError :: PscIdeError -> Text+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
+ src/PureScript/Ide/Externs.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module PureScript.Ide.Externs+  (+    ExternDecl(..),+    ModuleIdent,+    DeclIdent,+    Type,+    Fixity(..),+    readExternFile,+    convertExterns+  ) where+++import           Data.Maybe                  (mapMaybe)+import           Control.Monad.Except+import           Data.Text (Text)+import qualified Data.Text                   as T+import qualified Data.Text.IO                as T+import qualified Language.PureScript.Externs as PE+import qualified Language.PureScript.AST.Declarations as D+import qualified Language.PureScript.Names   as N+import qualified Language.PureScript.Pretty  as PP+import           PureScript.Ide.CodecJSON+import           PureScript.Ide.Error        (PscIdeError (..))+import           PureScript.Ide.Types++readExternFile :: (MonadIO m, MonadError PscIdeError m) =>+                  FilePath -> m PE.ExternsFile+readExternFile fp = do+   parseResult <- liftIO (decodeT <$> T.readFile fp)+   case parseResult of+     Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"+     Just externs -> pure externs++moduleNameToText :: N.ModuleName -> Text+moduleNameToText = T.pack . N.runModuleName++properNameToText :: N.ProperName a -> Text+properNameToText = T.pack . N.runProperName++identToText :: N.Ident -> Text+identToText  = T.pack . N.runIdent++convertExterns :: PE.ExternsFile -> Module+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)+  where+    moduleName = moduleNameToText (PE.efModuleName ef)+    importDecls = convertImport <$> PE.efImports ef+    exportDecls = mapMaybe convertExport (PE.efExports ef)+    -- Ignoring operator fixities for now since we're not using them+    -- operatorDecls = convertOperator <$> PE.efFixities ef+    otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)++convertImport :: PE.ExternsImport -> ExternDecl+convertImport ei = Dependency (moduleNameToText (PE.eiModule ei)) []++convertExport :: D.DeclarationRef -> Maybe ExternDecl+convertExport (D.ModuleRef mn) = Just (Export (T.pack $ N.runModuleName mn))+convertExport _ = Nothing++convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl+convertDecl PE.EDType{..} = Just $+  DataDecl+  (properNameToText edTypeName)+  (packAndStrip (PP.prettyPrintKind edTypeKind))+convertDecl PE.EDTypeSynonym{..} = Just $+  DataDecl+  (properNameToText edTypeSynonymName)+  (packAndStrip (PP.prettyPrintType edTypeSynonymType))+convertDecl PE.EDDataConstructor{..} = Just $+  DataDecl+  (properNameToText edDataCtorName)+  (packAndStrip (PP.prettyPrintType edDataCtorType))+convertDecl PE.EDValue{..} = Just $+  FunctionDecl+  (identToText edValueName)+  (packAndStrip (PP.prettyPrintType edValueType))+convertDecl _ = Nothing++packAndStrip :: String -> Text+packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack
+ src/PureScript/Ide/Filter.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+module PureScript.Ide.Filter+       (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter,+        runFilter, applyFilters)+       where++import           Control.Monad+import           Data.Aeson+import           Data.Foldable+import           Data.Maybe           (listToMaybe, mapMaybe)+import           Data.Monoid+import           Data.Text            (Text, isPrefixOf)+import           PureScript.Ide.Types++newtype Filter = Filter (Endo [Module]) deriving(Monoid)++mkFilter :: ([Module] -> [Module]) -> Filter+mkFilter = Filter . Endo++-- | Only keeps the given Modules+moduleFilter :: [ModuleIdent] -> Filter+moduleFilter =+    mkFilter . moduleFilter'++moduleFilter' :: [ModuleIdent] -> [Module] -> [Module]+moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)++-- | Only keeps the given Modules and all of their dependencies+dependencyFilter :: [ModuleIdent] -> Filter+dependencyFilter = mkFilter . dependencyFilter'++dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module]+dependencyFilter' moduleIdents mods =+  moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods+  where+    getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent]+    getDepForModule ms moduleIdent =+      moduleIdent : maybe [] extractDeps (findModule moduleIdent ms)++    findModule :: ModuleIdent -> [Module] -> Maybe Module+    findModule i ms = listToMaybe $ filter go ms+      where go (mn, _) = i == mn++    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+prefixFilter :: Text -> Filter+prefixFilter "" = mkFilter id+prefixFilter t = mkFilter $ identFilter prefix t+  where+    prefix :: ExternDecl -> Text -> Bool+    prefix (FunctionDecl name _) search = search `isPrefixOf` name+    prefix (DataDecl name _) search = search `isPrefixOf` name+    prefix (ModuleDecl name _) search = search `isPrefixOf` name+    prefix _ _ = False+++-- | Only keeps Identifiers that are equal to the search string+equalityFilter :: Text -> Filter+equalityFilter = mkFilter . identFilter equality+  where+    equality :: ExternDecl -> Text -> Bool+    equality (FunctionDecl name _) prefix = prefix == name+    equality (DataDecl name _) prefix = prefix == name+    equality _ _ = False+++identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]+identFilter predicate search =+    filter (not . null . snd) . fmap filterModuleDecls+  where+    filterModuleDecls :: Module -> Module+    filterModuleDecls (moduleIdent,decls) =+        (moduleIdent, filter (`predicate` search) decls)++runFilter :: Filter -> [Module] -> [Module]+runFilter (Filter f)= appEndo f++applyFilters :: [Filter] -> [Module] -> [Module]+applyFilters = runFilter . fold++instance FromJSON Filter where+  parseJSON = withObject "filter" $ \o -> do+    (filter' :: String) <- o .: "filter"+    case filter' of+      "exact" -> do+        params <- o .: "params"+        search <- params .: "search"+        return $ equalityFilter search+      "prefix" -> do+        params <- o.: "params"+        search <- params .: "search"+        return $ prefixFilter search+      "modules" -> do+        params <- o .: "params"+        modules <- params .: "modules"+        return $ moduleFilter modules+      "dependencies" -> do+        params <- o .: "params"+        deps <- params .: "modules"+        return $ dependencyFilter deps+      _ -> mzero
+ src/PureScript/Ide/Matcher.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+module PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where++import           Control.Monad+import           Data.Aeson+import           Data.Function        (on)+import           Data.List            (sortBy)+import           Data.Maybe           (mapMaybe)+import           Data.Monoid+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding   as TE+import           PureScript.Ide.Types+import           Text.Regex.TDFA      ((=~))+import           Text.EditDistance+++type ScoredCompletion = (Completion, Double)++newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)++instance FromJSON Matcher where+  parseJSON = withObject "matcher" $ \o -> do+    (matcher :: Maybe String) <- o .:? "matcher"+    case matcher of+      Just "flex" -> do+        params <- o .: "params"+        search <- params .: "search"+        pure $ flexMatcher search+      Just "distance" -> do+        params <- o .: "params"+        search <- params .: "search"+        maxDist <- params .: "maximumDistance"+        pure $ distanceMatcher search maxDist+      Just _ -> mzero+      Nothing -> return mempty++-- | Matches any occurence of the search string with intersections+-- |+-- | The scoring measures how far the matches span the string where+-- | closer is better.+-- | Examples:+-- |   flMa matches flexMatcher. Score: 14.28+-- |   sons matches sortCompletions. Score: 6.25+flexMatcher :: Text -> Matcher+flexMatcher pattern = mkMatcher (flexMatch pattern)++distanceMatcher :: Text -> Int -> Matcher+distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)++distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]+distanceMatcher' q maxDist = mapMaybe go+  where+    go c@(Completion (_, y, _)) = let d = dist (T.unpack y)+                                  in if d <= maxDist+                                     then Just (c, 1 / fromIntegral d)+                                     else Nothing+    dist = levenshteinDistance defaultEditCosts (T.unpack q)++mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher+mkMatcher matcher = Matcher . Endo  $ fmap fst . sortCompletions . matcher++runMatcher :: Matcher -> [Completion] -> [Completion]+runMatcher (Matcher m)= appEndo m++sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]+sortCompletions = sortBy (flip compare `on` snd)++flexMatch :: Text -> [Completion] -> [ScoredCompletion]+flexMatch pattern = mapMaybe (flexRate pattern)++flexRate :: Text -> Completion -> Maybe ScoredCompletion+flexRate pattern c@(Completion (_,ident,_)) = do+    score <- flexScore pattern ident+    return (c, score)++-- FlexMatching ala Sublime.+-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/+--+-- By string =~ pattern we'll get the start of the match and the length of+-- the matchas a (start, length) tuple if there's a match.+-- If match fails then it would be (-1,0)+flexScore :: Text -> DeclIdent -> Maybe Double+flexScore "" _ = Nothing+flexScore pat str =+    case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of+        (-1,0) -> Nothing+        (start,len) -> Just $ calcScore start (start + len)+  where+    Just (first,pattern) = T.uncons pat+    -- This just interleaves the search string with .*+    -- abcd -> a.*b.*c.*d+    pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern+    calcScore start end =+        100.0 / fromIntegral ((1 + start) * (end - start + 1))
+ src/PureScript/Ide/Pursuit.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PureScript.Ide.Pursuit where++import qualified Control.Exception    as E+import           Control.Lens         hiding (noneOf)+import           Control.Monad+import           Data.Aeson+import           Data.Aeson.Lens+import           Data.ByteString.Lazy (ByteString)+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           Text.Parsec+import           Text.Parsec.Text++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++queryUrl :: String+queryUrl = "http://pursuit.purescript.org/search"++jsonOpts :: Text -> Options+jsonOpts q =+    defaults & header "Accept" .~ ["application/json"] & param "q" .~ [q]++-- We need to remove trailing dots because Pursuit will return a 400 otherwise+-- TODO: remove this when the issue is fixed at Pursuit++queryPursuit :: Text -> IO (Response ByteString)+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++parseType :: Parser (String, String)+parseType = do+  name <- identifier+  _ <- string "::"+  spaces+  type' <- many1 anyChar+  return (T.unpack name, type')++typeParse :: Text -> Either Text (Text, Text)+typeParse t = case parse parseType "" t of+  Right (x,y) -> Right (T.pack x, T.pack y)+  Left err -> Left (T.pack (show err))++identifier :: Parser Text+identifier = do+  spaces+  ident <-+      -- necessary for being able to parse the following ((++), concat)+      between (char '(') (char ')') (many1 (noneOf ", )")) <|>+      many1 (noneOf ", )")+  spaces+  return (T.pack ident)
+ src/PureScript/Ide/Reexports.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TupleSections #-}+module PureScript.Ide.Reexports where++import           Data.List            (union)+import           Data.Map             (Map)+import qualified Data.Map             as Map+import           Data.Maybe+import           PureScript.Ide.Types++getReexports :: Module -> [ExternDecl]+getReexports (mn, decls)= mapMaybe getExport decls+  where getExport e@(Export mn')+          | mn /= mn' = Just e+          | otherwise = Nothing+        getExport _ = Nothing++replaceReexport :: ExternDecl -> Module -> Module -> Module+replaceReexport e@(Export _) (m, decls) (_, newDecls) =+  (m, filter (/= e) decls `union` newDecls)+replaceReexport _ _ _ = error "Should only get Exports here."++emptyModule :: Module+emptyModule = ("Empty", [])++isExport :: ExternDecl -> Bool+isExport (Export _) = True+isExport _ = False++removeExportDecls :: Module -> Module+removeExportDecls = fmap (filter (not . isExport))++replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module+replaceReexports m db = result+  where reexports = getReexports m+        result = foldl go (removeExportDecls m) reexports++        go :: Module -> ExternDecl -> Module+        go m' re@(Export name) = replaceReexport re m' (getModule name)+        go _ _ = error "partiality! woohoo"++        getModule :: ModuleIdent -> Module+        getModule name = clean res+          where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db+                -- we have to do this because keeping self exports in will result in+                -- infinite loops+                clean (mn, decls) = (mn,) (filter (/= Export mn) decls)++resolveReexports :: Map ModuleIdent [ExternDecl] -> Module ->  Module+resolveReexports modules m = do+  let replaced = replaceReexports m modules+  if null . getReexports $ replaced+    then replaced+    else resolveReexports modules replaced
+ src/PureScript/Ide/SourceFile.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts #-}+module PureScript.Ide.SourceFile where++import Control.Monad.Except+import           Data.Maybe                           (mapMaybe)+import           Data.Monoid+import qualified Data.Text                            as T+import qualified Language.PureScript.AST.Declarations as D+import qualified Language.PureScript.Parser           as P+import           PureScript.Ide.Error+import           PureScript.Ide.Types+import qualified Language.PureScript.AST.SourcePos    as SP+import qualified Language.PureScript.Names            as N+import           System.Directory++parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) =>+                       FilePath -> m D.Module+parseModuleFromFile fp = do+  exists <- liftIO (doesFileExist fp)+  if exists+    then do+      content <- liftIO (readFile fp)+      let m = do tokens <- P.lex fp content+                 P.runTokenParser "" P.parseModule tokens+      either (throwError . (`ParseError` "File could not be parsed.")) pure m+    else throwError (NotFound "File does not exist.")++-- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])++getDeclarations :: D.Module -> [D.Declaration]+getDeclarations (D.Module _ _ _ declarations _) = declarations++getImports :: D.Module -> [D.Declaration]+getImports (D.Module _ _ _ declarations _) =+  mapMaybe isImport declarations+  where+    isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i+    isImport _ = Nothing++getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>+                     FilePath -> m [ModuleImport]+getImportsForFile fp = do+  module' <- parseModuleFromFile fp+  let imports = getImports module'+  pure (mkModuleImport . unwrapPositionedImport <$> imports)+  where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =+          ModuleImport+            (T.pack (N.runModuleName mn))+            importType'+            (T.pack . N.runModuleName <$> qualifier)+        mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"+        unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =+          D.ImportDeclaration mn (unwrapImportType importType') qualifier b+        unwrapPositionedImport x = x+        unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)+        unwrapImportType (D.Hiding decls)   = D.Hiding (map unwrapPositionedRef decls)+        unwrapImportType D.Implicit         = D.Implicit++getPositionedImports :: D.Module -> [D.Declaration]+getPositionedImports (D.Module _ _ _ declarations _) =+  mapMaybe isImport declarations+  where+    isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i+    isImport _ = Nothing++unwrapPositioned :: D.Declaration -> D.Declaration+unwrapPositioned (D.PositionedDeclaration _ _ x) = x+unwrapPositioned x = x++unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef+unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x+unwrapPositionedRef x = x++getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan+getDeclPosition m ident =+  let decls = getDeclarations m+  in getFirst (foldMap (match ident) decls)+     where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl+                                                                then Just ss+                                                                else Nothing)+           match _ _ = First Nothing++           go q (D.DataDeclaration _ name _ constructors)  =+             properEqual name q || any (\(x,_) -> properEqual x q) constructors+           go q (D.DataBindingGroupDeclaration decls)      = any (go q) decls+           go q (D.TypeSynonymDeclaration name _ _)        = properEqual name q+           go q (D.TypeDeclaration ident' _)               = identEqual ident' q+           go q (D.ValueDeclaration ident' _ _ _)          = identEqual ident' q+           go q (D.ExternDeclaration ident' _)             = identEqual ident' q+           go q (D.ExternDataDeclaration name _)           = properEqual name q+           go q (D.TypeClassDeclaration name _ _ members)  =+             properEqual name q || any (go q . unwrapPositioned) members+           go q (D.TypeInstanceDeclaration ident' _ _ _ _) =+             identEqual ident' q+           go _ _ = False++           properEqual x q = N.runProperName x == q+           identEqual x q = N.runIdent x == q++goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)+goToDefinition q fp = do+  m <- runExceptT (parseModuleFromFile fp)+  case m of+    Right module' -> return $ getDeclPosition module' q+    Left _ -> return Nothing
+ src/PureScript/Ide/State.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports   #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE TupleSections    #-}+module PureScript.Ide.State where++import           Control.Concurrent.STM+import           Control.Monad.Except+import           "monad-logger" Control.Monad.Logger+import           Control.Monad.Reader.Class+import qualified Data.Map.Lazy               as M+import           Data.Maybe                  (catMaybes)+import           Data.Monoid+import qualified Data.Text                   as T+import           Language.PureScript.Externs+import           Language.PureScript.Names+import           PureScript.Ide.Externs+import           PureScript.Ide.Reexports+import           PureScript.Ide.Types++getPscIdeState :: PscIde m =>+                  m (M.Map ModuleIdent [ExternDecl])+getPscIdeState = do+  stateVar <- envStateVar <$> ask+  liftIO $ pscStateModules <$> readTVarIO stateVar++getExternFiles :: (PscIde m) =>+                  m (M.Map ModuleName ExternsFile)+getExternFiles = do+  stateVar <- envStateVar <$> ask+  liftIO (externsFiles <$> readTVarIO stateVar)++getAllDecls :: PscIde m => m [ExternDecl]+getAllDecls = concat <$> getPscIdeState++getAllModules :: PscIde m => m [Module]+getAllModules = M.toList <$> getPscIdeState++getAllModulesWithReexports :: (PscIde m, MonadLogger m) =>+                              m [Module]+getAllModulesWithReexports = do+  mis <- M.keys <$> getPscIdeState+  ms  <- traverse getModuleWithReexports mis+  return (catMaybes ms)++getModule :: (PscIde m, MonadLogger m) =>+             ModuleIdent -> m (Maybe Module)+getModule m = do+  modules <- getPscIdeState+  return ((m,) <$> M.lookup m modules)++getModuleWithReexports :: (PscIde m, MonadLogger m) =>+                          ModuleIdent -> m (Maybe Module)+getModuleWithReexports mi = do+  m <- getModule mi+  modules <- getPscIdeState+  pure $ resolveReexports modules <$> m++insertModule ::(PscIde m, MonadLogger m) =>+               ExternsFile -> m ()+insertModule externsFile = do+  env <- ask+  let moduleName = efModuleName externsFile+  $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName))+  liftIO . atomically $ insertModule' (envStateVar env) externsFile++insertModule' :: TVar PscState -> ExternsFile -> STM ()+insertModule' st ef = do+    modifyTVar (st) $ \x ->+      x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)+          , pscStateModules = let (mn, decls ) = convertExterns ef+                              in M.insert mn decls (pscStateModules x)+        }
+ src/PureScript/Ide/Types.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}++module PureScript.Ide.Types where++import           Control.Concurrent.STM+import           Control.Monad+import           Control.Monad.Reader.Class+import           Control.Monad.Trans+import           Data.Aeson+import           Data.Map.Lazy                        as M+import           Data.Maybe                           (maybeToList)+import           Data.Text                            (Text ())+import qualified Language.PureScript.AST.Declarations as D+import           Language.PureScript.Externs+import           Language.PureScript.Names+import qualified Language.PureScript.Names            as N++type ModuleIdent = Text+type DeclIdent   = Text+type Type        = Text++data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)++data ExternDecl+    = FunctionDecl { functionName :: DeclIdent+                   , functionType :: Type}+    | FixityDeclaration Fixity+                        Int+                        DeclIdent+    | Dependency { dependencyModule :: ModuleIdent+                 , dependencyNames  :: [Text]}+    | ModuleDecl ModuleIdent+                 [DeclIdent]+    | DataDecl DeclIdent+               Text+    | Export ModuleIdent+    deriving (Show,Eq,Ord)++instance ToJSON ExternDecl where+  toJSON (FunctionDecl n t)        = object ["name" .= n, "type" .= t]+  toJSON (ModuleDecl   n t)        = object ["name" .= n, "type" .= t]+  toJSON (DataDecl     n t)        = object ["name" .= n, "type" .= t]+  toJSON (Dependency   n names)    = object ["module" .= n, "names" .= names]+  toJSON (FixityDeclaration f p n) = object ["name" .= n+                                            , "fixity" .= show f+                                            , "precedence" .= p]+  toJSON (Export _) = object []++type Module = (ModuleIdent, [ExternDecl])++data Configuration =+  Configuration {+    confOutputPath :: FilePath+  , confDebug      :: Bool+  }++data PscEnvironment =+  PscEnvironment {+    envStateVar      :: TVar PscState+  , envConfiguration :: Configuration+  }++type PscIde m = (MonadIO m, MonadReader PscEnvironment m)++data PscState =+  PscState {+    pscStateModules :: M.Map Text [ExternDecl]+  , externsFiles    :: M.Map ModuleName ExternsFile+  } deriving Show++emptyPscState :: PscState+emptyPscState = PscState M.empty M.empty++newtype Completion =+    Completion (ModuleIdent, DeclIdent, Type)+    deriving (Show,Eq)++data ModuleImport =+  ModuleImport {+    importModuleName :: ModuleIdent+  , importType       :: D.ImportDeclarationType+  , importQualifier  :: Maybe Text+  } deriving(Show)++instance Eq ModuleImport where+  mi1 == mi2 = importModuleName mi1 == importModuleName mi2+               && importQualifier mi1 == importQualifier mi2++instance ToJSON ModuleImport where+  toJSON (ModuleImport mn D.Implicit qualifier) =+    object $  ["module" .= mn+              , "importType" .= ("implicit" :: Text)+              ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)+  toJSON (ModuleImport mn (D.Explicit refs) _) =+    object ["module" .= mn+           , "importType" .= ("explicit" :: Text)+           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]+  toJSON (ModuleImport mn (D.Hiding refs) _) =+    object ["module" .= mn+           , "importType" .= ("hiding" :: Text)+           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]++identifierFromDeclarationRef :: D.DeclarationRef -> String+identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name+identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident+identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name+identifierFromDeclarationRef _ = ""++instance FromJSON Completion where+    parseJSON (Object o) = do+        m <- o .: "module"+        d <- o .: "identifier"+        t <- o .: "type"+        return $ Completion (m, d, t)+    parseJSON _ = mzero++instance ToJSON Completion where+    toJSON (Completion (m,d,t)) =+        object ["module" .= m, "identifier" .= d, "type" .= t]++data Success =+  CompletionResult [Completion]+  | TextResult Text+  | MultilineTextResult [Text]+  | PursuitResult [PursuitResponse]+  | ImportList [ModuleImport]+  | ModuleList [ModuleIdent]+  deriving(Show, Eq)++encodeSuccess :: (ToJSON a) => a -> Value+encodeSuccess res =+    object ["resultType" .= ("success" :: Text), "result" .= res]++instance ToJSON Success where+  toJSON (CompletionResult cs) = encodeSuccess cs+  toJSON (TextResult t) = encodeSuccess t+  toJSON (MultilineTextResult ts) = encodeSuccess ts+  toJSON (PursuitResult resp) = encodeSuccess resp+  toJSON (ImportList decls) = encodeSuccess decls+  toJSON (ModuleList modules) = encodeSuccess modules++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]
+ src/PureScript/Ide/Watcher.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE RecordWildCards #-}+module PureScript.Ide.Watcher where++import           Control.Concurrent          (threadDelay)+import           Control.Concurrent.STM+import           Control.Monad.Except+import qualified Data.Map                    as M+import           Data.Maybe                  (isJust)+import           Language.PureScript.Externs+import           PureScript.Ide.Externs+import           PureScript.Ide.State+import           PureScript.Ide.Types+import           System.FilePath+import           System.FSNotify+++reloadFile :: TVar PscState -> FilePath -> IO ()+reloadFile stateVar fp = do+  (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp+  reloaded <- atomically $ do+    st <- readTVar stateVar+    if isLoaded efModuleName st+      then+        insertModule' stateVar ef *> pure True+      else+        pure False+  when reloaded $ putStrLn $ "Reloaded File at: " ++ fp+  where+    isLoaded name st = isJust (M.lookup name (externsFiles st))++watcher :: TVar PscState -> FilePath -> IO ()+watcher stateVar fp = withManager $ \mgr -> do+  _ <- watchTree mgr fp+    (\ev -> takeFileName (eventPath ev) == "externs.json")+    (reloadFile stateVar . eventPath)+  forever (threadDelay 10000)
test/PureScript/IdeSpec.hs view
@@ -1,23 +1,34 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports    #-} module PureScript.IdeSpec where -import           Control.Monad.State+import           Control.Concurrent.STM+import           Control.Monad.Reader import           Data.List-import qualified Data.Map             as Map+import qualified Data.Map               as Map import           PureScript.Ide import           PureScript.Ide.Types import           Test.Hspec  testState :: PscState-testState = PscState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])])+testState = PscState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) (Map.empty) +defaultConfig =+  Configuration+  {+    confOutputPath = "output/"+  , confDebug = False+  }+ spec :: SpecWith () spec = do   describe "list" $ do     describe "loadedModules" $ do       it "returns an empty list when no modules are loaded" $ do-       result <- evalStateT printModules emptyPscState+       st <- newTVarIO emptyPscState+       result <- runReaderT printModules (PscEnvironment st defaultConfig)        result `shouldBe` ModuleList []       it "returns the list of loaded modules" $ do-        ModuleList result <- evalStateT printModules testState+        st <- newTVarIO testState+        ModuleList result <- runReaderT printModules (PscEnvironment st defaultConfig)         sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]