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