git.iko.soy/rowtype-yoga/purescript-native
on d2dfad0 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Ide.hs
245 lines 10 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.Ide
4-- Description : Interface for the psc-ide-server
5-- Copyright : Christoph Hegemann 2016
6-- License : MIT (http://opensource.org/licenses/MIT)
7--
8-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
9-- Stability : experimental
10--
11-- |
12-- Interface for the psc-ide-server
13-----------------------------------------------------------------------------
15{-# LANGUAGE OverloadedStrings #-}
16{-# LANGUAGE PackageImports #-}
17{-# LANGUAGE TemplateHaskell #-}
19module Language.PureScript.Ide
20 ( handleCommand
21 -- for tests
22 , printModules
23 ) where
25import Prelude ()
26import Prelude.Compat
28import Control.Monad (unless)
29import Control.Monad.Error.Class
30import Control.Monad.IO.Class
31import "monad-logger" Control.Monad.Logger
32import Control.Monad.Reader.Class
33import Data.Foldable
34import qualified Data.Map.Lazy as M
35import Data.Maybe (catMaybes, mapMaybe)
36import Data.Monoid
37import Data.Text (Text)
38import qualified Data.Text as T
39import qualified Language.PureScript as P
40import qualified Language.PureScript.Ide.CaseSplit as CS
41import Language.PureScript.Ide.Command
42import Language.PureScript.Ide.Completion
43import Language.PureScript.Ide.Error
44import Language.PureScript.Ide.Externs
45import Language.PureScript.Ide.Filter
46import Language.PureScript.Ide.Imports hiding (Import)
47import Language.PureScript.Ide.Matcher
48import Language.PureScript.Ide.Pursuit
49import Language.PureScript.Ide.Rebuild
50import Language.PureScript.Ide.Reexports
51import Language.PureScript.Ide.SourceFile
52import Language.PureScript.Ide.State
53import Language.PureScript.Ide.Types
54import Language.PureScript.Ide.Util
55import System.Directory
56import System.Exit
57import System.FilePath
59handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
60 Command -> m Success
61handleCommand (Load [] []) = loadAllModules
62handleCommand (Load modules deps) =
63 loadModulesAndDeps modules deps
64handleCommand (Type search filters currentModule) =
65 findType search filters currentModule
66handleCommand (Complete filters matcher currentModule) =
67 findCompletions filters matcher currentModule
68handleCommand (Pursuit query Package) =
69 findPursuitPackages query
70handleCommand (Pursuit query Identifier) =
71 findPursuitCompletions query
72handleCommand (List LoadedModules) =
73 printModules
74handleCommand (List AvailableModules) =
75 listAvailableModules
76handleCommand (List (Imports fp)) =
77 importsForFile fp
78handleCommand (CaseSplit l b e wca t) =
79 caseSplit l b e wca t
80handleCommand (AddClause l wca) =
81 pure $ addClause l wca
82handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do
83 rs <- addImplicitImport fp mn
84 answerRequest outfp rs
85handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do
86 rs <- addImportForIdentifier fp ident filters
87 case rs of
88 Right rs' -> answerRequest outfp rs'
89 Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question)
90handleCommand (Rebuild file) =
91 rebuildFile file
92handleCommand Cwd =
93 TextResult . T.pack <$> liftIO getCurrentDirectory
94handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.")
95handleCommand Quit = liftIO exitSuccess
97findCompletions :: (PscIde m, MonadLogger m) =>
98 [Filter] -> Matcher -> Maybe P.ModuleName -> m Success
99findCompletions filters matcher currentModule = do
100 modules <- getAllModulesWithReexportsAndCache currentModule
101 pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules
103findType :: (PscIde m, MonadLogger m) =>
104 DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success
105findType search filters currentModule = do
106 modules <- getAllModulesWithReexportsAndCache currentModule
107 pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules
109findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
110 PursuitQuery -> m Success
111findPursuitCompletions (PursuitQuery q) =
112 PursuitResult <$> liftIO (searchPursuitForDeclarations q)
114findPursuitPackages :: (MonadIO m, MonadLogger m) =>
115 PursuitQuery -> m Success
116findPursuitPackages (PursuitQuery q) =
117 PursuitResult <$> liftIO (findPackagesForModuleIdent q)
119loadExtern :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
120 FilePath -> m ()
121loadExtern fp = do
122 m <- readExternFile fp
123 insertModule m
125printModules :: (PscIde m) => m Success
126printModules = printModules' . pscIdeStateModules <$> getPscIdeState
128printModules' :: M.Map ModuleIdent [ExternDecl] -> Success
129printModules' = ModuleList . M.keys
131listAvailableModules :: PscIde m => m Success
132listAvailableModules = do
133 outputPath <- confOutputPath . envConfiguration <$> ask
134 liftIO $ do
135 cwd <- getCurrentDirectory
136 dirs <- getDirectoryContents (cwd </> outputPath)
137 return (ModuleList (listAvailableModules' dirs))
139listAvailableModules' :: [FilePath] -> [Text]
140listAvailableModules' dirs =
141 let cleanedModules = filter (`notElem` [".", ".."]) dirs
142 in map T.pack cleanedModules
144caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
145 Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
146caseSplit l b e csa t = do
147 patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
148 pure (MultilineTextResult patterns)
150addClause :: Text -> CS.WildcardAnnotations -> Success
151addClause t wca = MultilineTextResult (CS.addClause t wca)
153importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
154 FilePath -> m Success
155importsForFile fp = do
156 imports <- getImportsForFile fp
157 pure (ImportList imports)
159-- | The first argument is a set of modules to load. The second argument
160-- denotes modules for which to load dependencies
161loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
162 [ModuleIdent] -> [ModuleIdent] -> m Success
163loadModulesAndDeps mods deps = do
164 r1 <- mapM loadModule (mods ++ deps)
165 r2 <- mapM loadModuleDependencies deps
166 let moduleResults = T.concat r1
167 let dependencyResults = T.concat r2
168 pure (TextResult (moduleResults <> ", " <> dependencyResults))
170loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
171 ModuleIdent -> m Text
172loadModuleDependencies moduleName = do
173 m <- getModule moduleName
174 case getDependenciesForModule <$> m of
175 Just deps -> do
176 mapM_ loadModule deps
177 -- We need to load the modules, that get reexported from the dependencies
178 depModules <- catMaybes <$> mapM getModule deps
179 -- What to do with errors here? This basically means a reexported dependency
180 -- doesn't exist in the output/ folder
181 traverse_ loadReexports depModules
182 pure ("Dependencies for " <> moduleName <> " loaded.")
183 Nothing -> throwError (ModuleNotFound moduleName)
185loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
186 Module -> m [ModuleIdent]
187loadReexports m = case getReexports m of
188 [] -> pure []
189 exportDeps -> do
190 -- I'm fine with this crashing on a failed pattern match.
191 -- If this ever fails I'll need to look at GADTs
192 let reexports = map (\(Export mn) -> mn) exportDeps
193 $(logDebug) ("Loading reexports for module: " <> fst m <>
194 " reexports: " <> T.intercalate ", " reexports)
195 traverse_ loadModule reexports
196 exportDepsModules <- catMaybes <$> traverse getModule reexports
197 exportDepDeps <- traverse loadReexports exportDepsModules
198 return $ concat exportDepDeps
200getDependenciesForModule :: Module -> [ModuleIdent]
201getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls
202 where getDependencyName (Dependency dependencyName _ _) = Just dependencyName
203 getDependencyName _ = Nothing
205loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
206 ModuleIdent -> m Text
207loadModule "Prim" = pure "Prim won't be loaded"
208loadModule mn = do
209 path <- filePathFromModule mn
210 loadExtern path
211 $(logDebug) ("Loaded extern file at: " <> T.pack path)
212 pure ("Loaded extern file at: " <> T.pack path)
214loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success
215loadAllModules = do
216 outputPath <- confOutputPath . envConfiguration <$> ask
217 cwd <- liftIO getCurrentDirectory
218 let outputDirectory = cwd </> outputPath
219 liftIO (doesDirectoryExist outputDirectory)
220 >>= flip unless (throwError (GeneralError "Couldn't locate your output directory"))
221 liftIO (getDirectoryContents outputDirectory)
222 >>= liftIO . traverse (getExternsPath outputDirectory)
223 >>= traverse_ loadExtern . catMaybes
224 pure (TextResult "All modules loaded.")
225 where
226 getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath)
227 getExternsPath outputDirectory d
228 | d `elem` [".", ".."] = pure Nothing
229 | otherwise = do
230 let file = outputDirectory </> d </> "externs.json"
231 ex <- doesFileExist file
232 if ex
233 then pure (Just file)
234 else pure Nothing
236filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
237 ModuleIdent -> m FilePath
238filePathFromModule moduleName = do
239 outputPath <- confOutputPath . envConfiguration <$> ask
240 cwd <- liftIO getCurrentDirectory
241 let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"
242 ex <- liftIO $ doesFileExist path
243 if ex
244 then pure path
245 else throwError (ModuleFileNotFound moduleName)