git.iko.soy/rowtype-yoga/purescript-native
on e82e607 help sign in
rowtype-yoga/purescript-native/psci/Main.hs
346 lines 12 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Main
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12-- PureScript Compiler Interactive.
13--
14-----------------------------------------------------------------------------
16{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}
18module Main where
20import Commands
22import Control.Applicative
23import Control.Monad
24import Control.Monad.Trans.Class
25import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
26import Control.Monad.Trans.State.Strict
28import Data.List (intercalate, isPrefixOf, nub, sortBy)
29import Data.Maybe (mapMaybe)
30import Data.Foldable (traverse_)
31import Data.Traversable (traverse)
32import Data.Version (showVersion)
34import Parser
36import System.Console.Haskeline
37import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
38import System.Exit
39import System.Environment.XDG.BaseDir
40import System.FilePath ((</>), isPathSeparator)
41import qualified System.Console.CmdTheLine as Cmd
42import System.Process
44import Text.Parsec (ParseError)
46import qualified Data.Map as M
47import qualified Language.PureScript as P
48import qualified Paths_purescript as Paths
49import qualified System.IO.UTF8 as U (print, readFile)
51-- |
52-- The PSCI state.
53-- Holds a list of imported modules, loaded files, and partial let bindings.
54-- The let bindings are partial,
55-- because it makes more sense to apply the binding to the final evaluated expression.
56--
57data PSCiState = PSCiState
58 { psciImportedFilenames :: [FilePath]
59 , psciImportedModuleNames :: [P.ModuleName]
60 , psciLoadedModules :: [P.Module]
61 , psciLetBindings :: [P.Value -> P.Value]
62 }
64-- State helpers
66-- |
67-- Updates the state to have more imported modules.
68--
69updateImportedFiles :: FilePath -> PSCiState -> PSCiState
70updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
72-- |
73-- Updates the state to have more imported modules.
74--
75updateImports :: P.ModuleName -> PSCiState -> PSCiState
76updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
78-- |
79-- Updates the state to have more loaded files.
80--
81updateModules :: [P.Module] -> PSCiState -> PSCiState
82updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
84-- |
85-- Updates the state to have more let bindings.
86--
87updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState
88updateLets name st = st { psciLetBindings = name : psciLetBindings st }
90-- File helpers
91-- |
92-- Load the necessary modules.
93--
94defaultImports :: [P.ModuleName]
95defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
97-- |
98-- Locates the node executable.
99-- Checks for either @nodejs@ or @node@.
100--
101findNodeProcess :: IO (Maybe String)
102findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
103 where names = ["nodejs", "node"]
105-- |
106-- Grabs the filename where the history is stored.
107--
108getHistoryFilename :: IO FilePath
109getHistoryFilename = getUserConfigFile "purescript" "psci_history"
111-- |
112-- Grabs the filename where prelude is.
113--
114getPreludeFilename :: IO FilePath
115getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"
117-- |
118-- Loads a file for use with imports.
119--
120loadModule :: FilePath -> IO (Either String [P.Module])
121loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename
123-- |
124-- Expands tilde in path.
125--
126expandTilde :: FilePath -> IO FilePath
127expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
128expandTilde p = return p
129-- Messages
131-- |
132-- The help message.
133--
134helpMessage :: String
135helpMessage = "The following commands are available:\n\n " ++
136 intercalate "\n " (map (intercalate " ") help)
138-- |
139-- The welcome prologue.
140--
141prologueMessage :: String
142prologueMessage = intercalate "\n"
143 [ " ____ ____ _ _ "
144 , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
145 , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
146 , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
147 , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
148 , " |_| "
149 , ""
150 , ":? shows help"
151 , ""
152 , "Expressions are terminated using Ctrl+D"
153 ]
155-- |
156-- The quit message.
157--
158quitMessage :: String
159quitMessage = "See ya!"
161-- Haskeline completions
163-- |
164-- Loads module, function, and file completions.
165--
166completion :: CompletionFunc (StateT PSCiState IO)
167completion = completeWord Nothing " \t\n\r" findCompletions
168 where
169 findCompletions :: String -> StateT PSCiState IO [Completion]
170 findCompletions str = do
171 ms <- psciLoadedModules <$> get
172 files <- listFiles str
173 let matches = filter (isPrefixOf str) (names ms)
174 return $ sortBy sorter $ map simpleCompletion matches ++ files
175 getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
176 getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident
177 getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident
178 where
179 isExported = any exports exts
180 exports (P.ValueRef ident') = ident == ident'
181 exports (P.PositionedDeclarationRef _ r) = exports r
182 exports _ = False
183 getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
184 getDeclName _ _ = Nothing
185 names :: [P.Module] -> [String]
186 names ms = nub [ show qual
187 | P.Module moduleName ds exts <- ms
188 , ident <- mapMaybe (getDeclName exts) ds
189 , qual <- [ P.Qualified Nothing ident
190 , P.Qualified (Just moduleName) ident]
191 ]
192 sorter :: Completion -> Completion -> Ordering
193 sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2
195-- Compilation
197-- | Compilation options.
198--
199options :: P.Options
200options = P.Options False True False True (Just "Main") True "PS" [] [] False
202-- |
203-- Makes a volatile module to execute the current expression.
204--
205createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module
206createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =
207 let
208 moduleName = P.ModuleName [P.ProperName "Main"]
209 importDecl m = P.ImportDeclaration m Nothing Nothing
210 traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
211 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
212 itValue = foldl (\x f -> f x) value lets
213 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
214 itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue
215 mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue
216 decls = if exec then [itDecl, mainDecl] else [itDecl]
217 in
218 P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
220-- |
221-- Takes a value declaration and evaluates it with the current state.
222--
223handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
224handleDeclaration value st = do
225 let m = createTemporaryModule True st value
226 case P.compile options (psciLoadedModules st ++ [m]) of
227 Left err -> outputStrLn err
228 Right (js, _, _) -> do
229 process <- lift . lift $ findNodeProcess
230 result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
231 case result of
232 Just (ExitSuccess, out, _) -> outputStrLn out
233 Just (ExitFailure _, _, err) -> outputStrLn err
234 Nothing -> outputStrLn "Couldn't find node.js"
236-- |
237-- Takes a value and prints its type
238--
239handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
240handleTypeOf value st = do
241 let m = createTemporaryModule False st value
242 case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
243 Left err -> outputStrLn err
244 Right (_, _, env') ->
245 case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
246 Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty
247 Nothing -> outputStrLn "Could not find type"
249-- Commands
251-- |
252-- Parses the input and returns either a Metacommand or an expression.
253--
254getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
255getCommand = do
256 firstLine <- getInputLine "> "
257 case firstLine of
258 Nothing -> return (Right Nothing)
259 Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command
260 Just s -> either Left (Right . Just) . parseCommand <$> go [s]
261 where
262 go :: [String] -> InputT (StateT PSCiState IO) String
263 go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
265-- |
266-- Performs an action for each meta-command given, and also for expressions..
267--
268handleCommand :: Command -> InputT (StateT PSCiState IO) ()
269handleCommand (Expression val) = lift get >>= handleDeclaration val
270handleCommand Help = outputStrLn helpMessage
271handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
272handleCommand (Let l) = lift $ modify (updateLets l)
273handleCommand (LoadFile filePath) = do
274 absPath <- lift . lift $ expandTilde filePath
275 exists <- lift . lift $ doesFileExist absPath
276 if exists then do
277 lift $ modify (updateImportedFiles absPath)
278 either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)
279 else
280 outputStrLn $ "Couldn't locate: " ++ filePath
281handleCommand Reset = do
282 files <- psciImportedFilenames <$> lift get
283 modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) files
284 case modulesOrFirstError of
285 Left err -> lift . lift $ putStrLn err >> exitFailure
286 Right modules -> lift $ put (PSCiState files defaultImports modules [])
287handleCommand (TypeOf val) = lift get >>= handleTypeOf val
288handleCommand _ = outputStrLn "Unknown command"
290inputFiles :: Cmd.Term [FilePath]
291inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
292 , Cmd.posDoc = "Optional .purs files to load on start" }
294loadUserConfig :: IO (Maybe [Command])
295loadUserConfig = do
296 configFile <- (</> ".psci") <$> getCurrentDirectory
297 exists <- doesFileExist configFile
298 if exists
299 then do
300 ls <- lines <$> U.readFile configFile
301 case mapM parseCommand ls of
302 Left err -> U.print err >> exitFailure
303 Right cs -> return $ Just cs
304 else
305 return Nothing
307-- |
308-- The PSCI main loop.
309--
310loop :: [FilePath] -> IO ()
311loop files = do
312 config <- loadUserConfig
313 preludeFilename <- getPreludeFilename
314 modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)
315 case modulesOrFirstError of
316 Left err -> putStrLn err >> exitFailure
317 Right modules -> do
318 historyFilename <- getHistoryFilename
319 let settings = defaultSettings {historyFile = Just historyFilename}
320 flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
321 outputStrLn prologueMessage
322 traverse_ (mapM_ handleCommand) config
323 go
324 where
325 go :: InputT (StateT PSCiState IO) ()
326 go = do
327 c <- getCommand
328 case c of
329 Left err -> outputStrLn (show err) >> go
330 Right Nothing -> go
331 Right (Just Quit) -> outputStrLn quitMessage
332 Right (Just c') -> handleCommand c' >> go
334term :: Cmd.Term (IO ())
335term = loop <$> inputFiles
337termInfo :: Cmd.TermInfo
338termInfo = Cmd.defTI
339 { Cmd.termName = "psci"
340 , Cmd.version = showVersion Paths.version
341 , Cmd.termDoc = "Interactive mode for PureScript"
342 }
344main :: IO ()
345main = Cmd.run (term, termInfo)