git.iko.soy/elk
on f4401ac help sign in
elk/terminal/src/Repl.hs
598 lines 15 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Repl
4 ( Flags(..)
5 , run
6 )
7 where
10import Prelude hiding (lines, read)
11import Control.Applicative ((<|>))
12import Control.Monad.Trans (lift, liftIO)
13import qualified Control.Monad.State.Strict as State
14import qualified Data.ByteString as BS
15import qualified Data.ByteString.Builder as B
16import qualified Data.ByteString.Char8 as BSC
17import qualified Data.ByteString.Lazy as LBS
18import qualified Data.ByteString.UTF8 as BS_UTF8
19import qualified Data.Char as Char
20import qualified Data.List as List
21import qualified Data.Map as Map
22import Data.Monoid ((<>))
23import qualified Data.Name as N
24import qualified System.Console.Haskeline as Repl
25import qualified System.Directory as Dir
26import qualified System.Exit as Exit
27import System.FilePath ((</>))
28import qualified System.IO as IO
29import qualified System.Process as Proc
31import qualified AST.Source as Src
32import qualified Build
33import qualified Elm.Constraint as C
34import qualified Elm.Details as Details
35import qualified Elm.Licenses as Licenses
36import qualified Elm.ModuleName as ModuleName
37import qualified Elm.Outline as Outline
38import qualified Elm.Package as Pkg
39import qualified Elm.Version as V
40import qualified Generate
41import qualified Parse.Expression as PE
42import qualified Parse.Declaration as PD
43import qualified Parse.Module as PM
44import qualified Parse.Primitives as P
45import Parse.Primitives (Row, Col)
46import qualified Reporting
47import qualified Reporting.Annotation as A
48import Reporting.Doc ((<+>))
49import qualified Reporting.Doc as D
50import qualified Reporting.Error.Syntax as ES
51import qualified Reporting.Exit as Exit
52import qualified Reporting.Render.Code as Code
53import qualified Reporting.Report as Report
54import qualified Reporting.Task as Task
55import qualified Stuff
59-- RUN
62data Flags =
63 Flags
64 { _maybeInterpreter :: Maybe FilePath
65 , _noColors :: Bool
66 }
69run :: () -> Flags -> IO ()
70run () flags =
71 do printWelcomeMessage
72 settings <- initSettings
73 env <- initEnv flags
74 let looper = Repl.runInputT settings (Repl.withInterrupt (loop env initialState))
75 exitCode <- State.evalStateT looper initialState
76 Exit.exitWith exitCode
80-- WELCOME
83printWelcomeMessage :: IO ()
84printWelcomeMessage =
85 let
86 vsn = V.toChars V.compiler
87 title = "Elm" <+> D.fromChars vsn
88 dashes = replicate (70 - length vsn) '-'
89 in
90 D.toAnsi IO.stdout $
91 D.vcat
92 [ D.black "----" <+> D.dullcyan title <+> D.black (D.fromChars dashes)
93 , D.black $ D.fromChars $ "Say :help for help and :exit to exit! More at " <> D.makeLink "repl"
94 , D.black "--------------------------------------------------------------------------------"
95 , D.empty
96 ]
100-- ENV
103data Env =
104 Env
105 { _root :: FilePath
106 , _interpreter :: FilePath
107 , _ansi :: Bool
108 }
111initEnv :: Flags -> IO Env
112initEnv (Flags maybeAlternateInterpreter noColors) =
113 do root <- getRoot
114 interpreter <- getInterpreter maybeAlternateInterpreter
115 return $ Env root interpreter (not noColors)
119-- LOOP
122data Outcome
123 = Loop State
124 | End Exit.ExitCode
127type M =
128 State.StateT State IO
131loop :: Env -> State -> Repl.InputT M Exit.ExitCode
132loop env state =
133 do input <- Repl.handleInterrupt (return Skip) read
134 outcome <- liftIO (eval env state input)
135 case outcome of
136 Loop state ->
137 do lift (State.put state)
138 loop env state
140 End exitCode ->
141 return exitCode
145-- READ
148data Input
149 = Import ModuleName.Raw BS.ByteString
150 | Type N.Name BS.ByteString
151 | Port
152 | Decl N.Name BS.ByteString
153 | Expr BS.ByteString
154 --
155 | Reset
156 | Exit
157 | Skip
158 | Help (Maybe String)
161read :: Repl.InputT M Input
162read =
163 do line <- Repl.getInputLine "> "
164 case line of
165 Nothing ->
166 return Exit
168 Just chars ->
169 case categorize chars of
170 Done input -> return input
171 Continue -> readMore chars
174readMore :: [Char] -> Repl.InputT M Input
175readMore previousLines =
176 do input <- Repl.getInputLineWithInitial "| " (" ","")
177 case input of
178 Nothing ->
179 return Skip
181 Just chars ->
182 let
183 allLines = previousLines ++ '\n' : chars
184 in
185 case categorize allLines of
186 Done input -> return input
187 Continue -> readMore allLines
191-- CATEGORIZE INPUT
194data CategorizedInput
195 = Done Input
196 | Continue
199categorize :: [Char] -> CategorizedInput
200categorize chars
201 | all (==' ') chars = Done Skip
202 | startsWithColon chars = Done (toCommand chars)
203 | startsWithKeyword "import" chars = attemptImport chars
204 | otherwise = attemptDeclOrExpr chars
207attemptImport :: [Char] -> CategorizedInput
208attemptImport chars =
209 let
210 src = BS_UTF8.fromString (chars ++ "\n")
211 parser = P.specialize (\_ _ _ -> ()) PM.chompImport
212 in
213 case P.fromByteString parser (\_ _ -> ()) src of
214 Right (Src.Import (A.At _ name) _ _) ->
215 Done (Import name src)
217 Left () ->
218 if endsWithBlankLine chars
219 then Done (Import "ERR" src)
220 else Continue
223attemptDeclOrExpr :: [Char] -> CategorizedInput
224attemptDeclOrExpr chars =
225 let
226 src = BS_UTF8.fromString (chars ++ "\n")
227 exprParser = P.specialize (toExprPosition src) PE.expression
228 declParser = P.specialize (toDeclPosition src) PD.declaration
229 in
230 case P.fromByteString declParser (,) src of
231 Right (decl, _) ->
232 case decl of
233 PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> Done (Decl name src)
234 PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _ )) -> Done (Type name src)
235 PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _ )) -> Done (Type name src)
236 PD.Port _ _ -> Done Port
238 Left declPosition
239 | startsWithKeyword "type" chars ->
240 if endsWithBlankLine chars
241 then Done (Type "ERR" src)
242 else Continue
244 | startsWithKeyword "port" chars ->
245 Done Port
247 | otherwise ->
248 case P.fromByteString exprParser (,) src of
249 Right _ ->
250 Done (Expr src)
252 Left exprPosition ->
253 if endsWithBlankLine chars
254 then Done (if declPosition <= exprPosition then Expr src else Decl "ERR" src)
255 else Continue
258endsWithBlankLine :: [Char] -> Bool
259endsWithBlankLine chars =
260 case reverse (List.lines chars) of
261 [] -> False
262 cs:_ -> all (==' ') cs
265startsWithColon :: [Char] -> Bool
266startsWithColon chars =
267 case dropWhile (==' ') chars of
268 [] -> False
269 c:_ -> c == ':'
272toCommand :: [Char] -> Input
273toCommand chars =
274 case drop 1 $ dropWhile (==' ') chars of
275 "reset" -> Reset
276 "exit" -> Exit
277 "quit" -> Exit
278 "help" -> Help Nothing
279 rest -> Help (Just (takeWhile (/=' ') rest))
282startsWithKeyword :: [Char] -> [Char] -> Bool
283startsWithKeyword keyword line =
284 List.isPrefixOf keyword line &&
285 case drop (length keyword) line of
286 [] -> True
287 c:_ -> not (Char.isAlphaNum c)
290toExprPosition :: BS.ByteString -> ES.Expr -> Row -> Col -> (Row, Col)
291toExprPosition src expr row col =
292 let
293 decl = ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col
294 in
295 toDeclPosition src decl row col
298toDeclPosition :: BS.ByteString -> ES.Decl -> Row -> Col -> (Row, Col)
299toDeclPosition src decl r c =
300 let
301 err = ES.ParseError (ES.Declarations decl r c)
302 report = ES.toReport (Code.toSource src) err
304 (Report.Report _ (A.Region (A.Position row col) _) _ _) = report
305 in
306 (row, col)
310-- STATE
313data State =
314 State
315 { _imports :: Map.Map N.Name B.Builder
316 , _types :: Map.Map N.Name B.Builder
317 , _decls :: Map.Map N.Name B.Builder
318 }
321initialState :: State
322initialState =
323 State Map.empty Map.empty Map.empty
327-- EVAL
330eval :: Env -> State -> Input -> IO Outcome
331eval env state@(State imports types decls) input =
332 Repl.handleInterrupt (putStrLn "<cancelled>" >> return (Loop state)) $
333 case input of
334 Skip ->
335 return (Loop state)
337 Exit ->
338 return (End Exit.ExitSuccess)
340 Reset ->
341 do putStrLn "<reset>"
342 return (Loop initialState)
344 Help maybeUnknownCommand ->
345 do putStrLn (toHelpMessage maybeUnknownCommand)
346 return (Loop state)
348 Import name src ->
349 do let newState = state { _imports = Map.insert name (B.byteString src) imports }
350 Loop <$> attemptEval env state newState OutputNothing
352 Type name src ->
353 do let newState = state { _types = Map.insert name (B.byteString src) types }
354 Loop <$> attemptEval env state newState OutputNothing
356 Port ->
357 do putStrLn "I cannot handle port declarations."
358 return (Loop state)
360 Decl name src ->
361 do let newState = state { _decls = Map.insert name (B.byteString src) decls }
362 Loop <$> attemptEval env state newState (OutputDecl name)
364 Expr src ->
365 Loop <$> attemptEval env state state (OutputExpr src)
369-- ATTEMPT EVAL
372data Output
373 = OutputNothing
374 | OutputDecl N.Name
375 | OutputExpr BS.ByteString
378attemptEval :: Env -> State -> State -> Output -> IO State
379attemptEval (Env root interpreter ansi) oldState newState output =
380 do result <- Task.run $
381 do details <-
382 Task.eio Exit.ReplBadDetails $
383 Details.load Reporting.silent root
385 artifacts <-
386 Task.eio id $
387 Build.fromRepl root details (toByteString newState output)
389 traverse (Task.mapError Exit.ReplBadGenerate . Generate.repl root details ansi artifacts) (toPrintName output)
391 case result of
392 Left exit ->
393 do Exit.toStderr (Exit.replToReport exit)
394 return oldState
396 Right Nothing ->
397 return newState
399 Right (Just javascript) ->
400 do exitCode <- interpret interpreter javascript
401 case exitCode of
402 Exit.ExitSuccess -> return newState
403 Exit.ExitFailure _ -> return oldState
406interpret :: FilePath -> B.Builder -> IO Exit.ExitCode
407interpret interpreter javascript =
408 let
409 createProcess = (Proc.proc interpreter []) { Proc.std_in = Proc.CreatePipe }
410 in
411 Proc.withCreateProcess createProcess $ \(Just stdin) _ _ handle ->
412 do B.hPutBuilder stdin javascript
413 IO.hClose stdin
414 Proc.waitForProcess handle
418-- TO BYTESTRING
421toByteString :: State -> Output -> BS.ByteString
422toByteString (State imports types decls) output =
423 LBS.toStrict $ B.toLazyByteString $
424 mconcat
425 [ "module ", N.toBuilder N.replModule, " exposing (..)\n"
426 , Map.foldr mappend mempty imports
427 , Map.foldr mappend mempty types
428 , Map.foldr mappend mempty decls
429 , outputToBuilder output
430 ]
433outputToBuilder :: Output -> B.Builder
434outputToBuilder output =
435 case output of
436 OutputNothing ->
437 mempty
439 OutputDecl _ ->
440 mempty
442 OutputExpr expr ->
443 N.toBuilder N.replValueToPrint <> " ="
444 <> foldr (\line rest -> "\n " <> B.byteString line <> rest) "\n" (BSC.lines expr)
448-- TO PRINT NAME
451toPrintName :: Output -> Maybe N.Name
452toPrintName output =
453 case output of
454 OutputNothing -> Nothing
455 OutputDecl name -> Just name
456 OutputExpr _ -> Just N.replValueToPrint
460-- HELP MESSAGES
463toHelpMessage :: Maybe String -> String
464toHelpMessage maybeBadCommand =
465 case maybeBadCommand of
466 Nothing ->
467 genericHelpMessage
469 Just command ->
470 "I do not recognize the :" ++ command ++ " command. " ++ genericHelpMessage
473genericHelpMessage :: String
474genericHelpMessage =
475 "Valid commands include:\n\
476 \\n\
477 \ :exit Exit the REPL\n\
478 \ :help Show this information\n\
479 \ :reset Clear all previous imports and definitions\n\
480 \\n\
481 \More info at " ++ D.makeLink "repl" ++ "\n"
485-- GET ROOT
488getRoot :: IO FilePath
489getRoot =
490 do maybeRoot <- Stuff.findRoot
491 case maybeRoot of
492 Just root ->
493 return root
495 Nothing ->
496 do cache <- Stuff.getReplCache
497 let root = cache </> "tmp"
498 Dir.createDirectoryIfMissing True (root </> "src")
499 Outline.write root $ Outline.Pkg $
500 Outline.PkgOutline
501 Pkg.dummyName
502 Outline.defaultSummary
503 Licenses.bsd3
504 V.one
505 (Outline.ExposedList [])
506 (Map.singleton Pkg.core C.anything)
507 Map.empty
508 C.defaultElm
510 return root
514-- GET INTERPRETER
517getInterpreter :: Maybe String -> IO FilePath
518getInterpreter maybeName =
519 case maybeName of
520 Just name ->
521 getInterpreterHelp name (Dir.findExecutable name)
523 Nothing ->
524 getInterpreterHelp "node` or `nodejs" $
525 do exe1 <- Dir.findExecutable "node"
526 exe2 <- Dir.findExecutable "nodejs"
527 return (exe1 <|> exe2)
530getInterpreterHelp :: String -> IO (Maybe FilePath) -> IO FilePath
531getInterpreterHelp name findExe =
532 do maybePath <- findExe
533 case maybePath of
534 Just path ->
535 return path
537 Nothing ->
538 do IO.hPutStrLn IO.stderr (exeNotFound name)
539 Exit.exitFailure
542exeNotFound :: String -> String
543exeNotFound name =
544 "The REPL relies on node.js to execute JavaScript code outside the browser.\n"
545 ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n"
546 ++ "You can install node.js from <http://nodejs.org/>. If it is already installed\n"
547 ++ "but has a different name, use the --interpreter flag."
551-- SETTINGS
554initSettings :: IO (Repl.Settings M)
555initSettings =
556 do cache <- Stuff.getReplCache
557 return $
558 Repl.Settings
559 { Repl.historyFile = Just (cache </> "history")
560 , Repl.autoAddHistory = True
561 , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions
562 }
565lookupCompletions :: String -> M [Repl.Completion]
566lookupCompletions string =
567 do (State imports types decls) <- State.get
568 return $
569 addMatches string False decls $
570 addMatches string False types $
571 addMatches string True imports $
572 addMatches string False commands []
575commands :: Map.Map N.Name ()
576commands =
577 Map.fromList
578 [ (":exit", ())
579 , (":quit", ())
580 , (":reset", ())
581 , (":help", ())
582 ]
585addMatches :: String -> Bool -> Map.Map N.Name v -> [Repl.Completion] -> [Repl.Completion]
586addMatches string isFinished dict completions =
587 Map.foldrWithKey (addMatch string isFinished) completions dict
590addMatch :: String -> Bool -> N.Name -> v -> [Repl.Completion] -> [Repl.Completion]
591addMatch string isFinished name _ completions =
592 let
593 suggestion = N.toChars name
594 in
595 if List.isPrefixOf string suggestion then
596 Repl.Completion suggestion suggestion isFinished : completions
597 else
598 completions