git.iko.soy/rowtype-yoga/purescript-native
on f1dfe1e help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Ide.hs
199 lines 8.0 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE PackageImports #-}
6{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TupleSections #-}
9module Language.PureScript.Ide where
11import Prelude ()
12import Prelude.Compat
14import Control.Monad.Error.Class
15import Control.Monad.IO.Class
16import "monad-logger" Control.Monad.Logger
17import Control.Monad.Reader.Class
18import Data.Foldable
19import qualified Data.Map.Lazy as M
20import Data.Maybe (catMaybes, mapMaybe)
21import Data.Monoid
22import Data.Text (Text)
23import qualified Data.Text as T
24import qualified Language.PureScript.Ide.CaseSplit as CS
25import Language.PureScript.Ide.Command
26import Language.PureScript.Ide.Completion
27import Language.PureScript.Ide.Error
28import Language.PureScript.Ide.Externs
29import Language.PureScript.Ide.Filter
30import Language.PureScript.Ide.Matcher
31import Language.PureScript.Ide.Pursuit
32import Language.PureScript.Ide.Reexports
33import Language.PureScript.Ide.SourceFile
34import Language.PureScript.Ide.State
35import Language.PureScript.Ide.Types
36import System.Directory
37import System.FilePath
38import System.Exit
41handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
42 Command -> m Success
43handleCommand (Load modules deps) =
44 loadModulesAndDeps modules deps
45handleCommand (Type search filters) =
46 findType search filters
47handleCommand (Complete filters matcher) =
48 findCompletions filters matcher
49handleCommand (Pursuit query Package) =
50 findPursuitPackages query
51handleCommand (Pursuit query Identifier) =
52 findPursuitCompletions query
53handleCommand (List LoadedModules) =
54 printModules
55handleCommand (List AvailableModules) =
56 listAvailableModules
57handleCommand (List (Imports fp)) =
58 importsForFile fp
59handleCommand (CaseSplit l b e wca t) =
60 caseSplit l b e wca t
61handleCommand (AddClause l wca) =
62 pure $ addClause l wca
63handleCommand Cwd =
64 TextResult . T.pack <$> liftIO getCurrentDirectory
65handleCommand Quit = liftIO exitSuccess
67findCompletions :: (PscIde m, MonadLogger m) =>
68 [Filter] -> Matcher -> m Success
69findCompletions filters matcher =
70 CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports
72findType :: (PscIde m, MonadLogger m) =>
73 DeclIdent -> [Filter] -> m Success
74findType search filters =
75 CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports
77findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
78 PursuitQuery -> m Success
79findPursuitCompletions (PursuitQuery q) =
80 PursuitResult <$> liftIO (searchPursuitForDeclarations q)
82findPursuitPackages :: (MonadIO m, MonadLogger m) =>
83 PursuitQuery -> m Success
84findPursuitPackages (PursuitQuery q) =
85 PursuitResult <$> liftIO (findPackagesForModuleIdent q)
87loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
88 FilePath -> m ()
89loadExtern fp = do
90 m <- readExternFile fp
91 insertModule m
93printModules :: (PscIde m) => m Success
94printModules = printModules' <$> getPscIdeState
96printModules' :: M.Map ModuleIdent [ExternDecl] -> Success
97printModules' = ModuleList . M.keys
99listAvailableModules :: PscIde m => m Success
100listAvailableModules = do
101 outputPath <- confOutputPath . envConfiguration <$> ask
102 liftIO $ do
103 cwd <- getCurrentDirectory
104 dirs <- getDirectoryContents (cwd </> outputPath)
105 return (ModuleList (listAvailableModules' dirs))
107listAvailableModules' :: [FilePath] -> [Text]
108listAvailableModules' dirs =
109 let cleanedModules = filter (`notElem` [".", ".."]) dirs
110 in map T.pack cleanedModules
112caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
113 Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
114caseSplit l b e csa t = do
115 patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
116 pure (MultilineTextResult patterns)
118addClause :: Text -> CS.WildcardAnnotations -> Success
119addClause t wca = MultilineTextResult (CS.addClause t wca)
121importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
122 FilePath -> m Success
123importsForFile fp = do
124 imports <- getImportsForFile fp
125 pure (ImportList imports)
127-- | The first argument is a set of modules to load. The second argument
128-- denotes modules for which to load dependencies
129loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
130 [ModuleIdent] -> [ModuleIdent] -> m Success
131loadModulesAndDeps mods deps = do
132 r1 <- mapM loadModule (mods ++ deps)
133 r2 <- mapM loadModuleDependencies deps
134 let moduleResults = T.concat r1
135 let dependencyResults = T.concat r2
136 pure (TextResult (moduleResults <> ", " <> dependencyResults))
138loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
139 ModuleIdent -> m Text
140loadModuleDependencies moduleName = do
141 m <- getModule moduleName
142 case getDependenciesForModule <$> m of
143 Just deps -> do
144 mapM_ loadModule deps
145 -- We need to load the modules, that get reexported from the dependencies
146 depModules <- catMaybes <$> mapM getModule deps
147 -- What to do with errors here? This basically means a reexported dependency
148 -- doesn't exist in the output/ folder
149 traverse_ loadReexports depModules
150 pure ("Dependencies for " <> moduleName <> " loaded.")
151 Nothing -> throwError (ModuleNotFound moduleName)
153loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
154 Module -> m [ModuleIdent]
155loadReexports m = case getReexports m of
156 [] -> pure []
157 exportDeps -> do
158 -- I'm fine with this crashing on a failed pattern match.
159 -- If this ever fails I'll need to look at GADTs
160 let reexports = map (\(Export mn) -> mn) exportDeps
161 $(logDebug) ("Loading reexports for module: " <> fst m <>
162 " reexports: " <> T.intercalate ", " reexports)
163 traverse_ loadModule reexports
164 exportDepsModules <- catMaybes <$> traverse getModule reexports
165 exportDepDeps <- traverse loadReexports exportDepsModules
166 return $ concat exportDepDeps
168getDependenciesForModule :: Module -> [ModuleIdent]
169getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls
170 where getDependencyName (Dependency dependencyName _ _) = Just dependencyName
171 getDependencyName _ = Nothing
173loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
174 ModuleIdent -> m Text
175loadModule "Prim" = pure "Prim won't be loaded"
176loadModule mn = do
177 path <- filePathFromModule mn
178 loadExtern path
179 $(logDebug) ("Loaded extern file at: " <> T.pack path)
180 pure ("Loaded extern file at: " <> T.pack path)
182filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
183 ModuleIdent -> m FilePath
184filePathFromModule moduleName = do
185 outputPath <- confOutputPath . envConfiguration <$> ask
186 cwd <- liftIO getCurrentDirectory
187 let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"
188 ex <- liftIO $ doesFileExist path
189 if ex
190 then pure path
191 else throwError (ModuleFileNotFound moduleName)
193-- | Taken from Data.Either.Utils
194maybeToEither :: MonadError e m =>
195 e -- ^ (Left e) will be returned if the Maybe value is Nothing
196 -> Maybe a -- ^ (Right a) will be returned if this is (Just a)
197 -> m a
198maybeToEither errorval Nothing = throwError errorval
199maybeToEither _ (Just normalval) = return normalval