module Language.PureScript.Ide where
import Prelude ()
import Prelude.Compat
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import "monad-logger" Control.Monad.Logger
import Control.Monad.Reader.Class
import Data.Foldable
import qualified Data.Map.Lazy as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Language.PureScript.Ide.CaseSplit as CS
import Language.PureScript.Ide.Command
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Pursuit
import Language.PureScript.Ide.Reexports
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import System.Directory
import System.FilePath
import System.Exit
handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
Command -> m Success
handleCommand (Load modules deps) =
loadModulesAndDeps modules deps
handleCommand (Type search filters) =
findType search filters
handleCommand (Complete filters matcher) =
findCompletions filters matcher
handleCommand (Pursuit query Package) =
findPursuitPackages query
handleCommand (Pursuit query Identifier) =
findPursuitCompletions query
handleCommand (List LoadedModules) =
printModules
handleCommand (List AvailableModules) =
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 =
TextResult . T.pack <$> liftIO getCurrentDirectory
handleCommand Quit = liftIO exitSuccess
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 :: (Applicative m, MonadIO m, MonadLogger m) =>
PursuitQuery -> m Success
findPursuitCompletions (PursuitQuery q) =
PursuitResult <$> liftIO (searchPursuitForDeclarations q)
findPursuitPackages :: (Applicative m, 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 :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
FilePath -> m Success
importsForFile fp = do
imports <- getImportsForFile fp
pure (ImportList imports)
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
depModules <- catMaybes <$> mapM getModule deps
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
let reexports = map (\(Export mn) -> mn) exportDeps
$(logDebug) ("Loading reexports for module: " <> fst m <>
" reexports: " <> T.intercalate ", " 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)
maybeToEither :: MonadError e m =>
e
-> Maybe a
-> m a
maybeToEither errorval Nothing = throwError errorval
maybeToEither _ (Just normalval) = return normalval