diff --git a/Environment.hs b/Environment.hs --- a/Environment.hs +++ b/Environment.hs @@ -2,19 +2,21 @@ module Environment where import qualified Data.ByteString.Char8 as BS -import Data.Char -import Data.List +import Data.Char (isUpper,isSymbol,isAlpha,isDigit) +import qualified Data.List as List import qualified Data.Map as Map data Repl = Repl - { imports :: Map.Map String String + { compilerPath :: FilePath + , flags :: [String] + , imports :: Map.Map String String , adts :: Map.Map String String , defs :: Map.Map String String - , ctrlc :: Bool } deriving Show -empty :: Repl -empty = Repl Map.empty Map.empty (Map.singleton "t_s_o_l_" "t_s_o_l_ = ()") False +empty :: FilePath -> Repl +empty compilerPath = + Repl compilerPath [] Map.empty Map.empty (Map.singleton "t_s_o_l_" "t_s_o_l_ = ()") output :: BS.ByteString output = "deltron3030" @@ -25,14 +27,14 @@ insert :: String -> Repl -> Repl insert str env - | "import " `isPrefixOf` str = + | List.isPrefixOf "import " str = let name = getFirstCap (words str) getFirstCap (token@(c:_):rest) = if isUpper c then token else getFirstCap rest getFirstCap _ = str in noDisplay $ env { imports = Map.insert name str (imports env) } - | "data " `isPrefixOf` str = + | List.isPrefixOf "data " str = let name = takeWhile (/=' ') (drop 5 str) in noDisplay $ env { adts = Map.insert name str (adts env) } @@ -40,7 +42,7 @@ case break (=='=') str of (_,"") -> display str env (beforeEquals, _:c:_) - | isSymbol c || hasLet beforeEquals -> display str env + | isSymbol c || hasLet beforeEquals || hasBrace beforeEquals -> display str env | otherwise -> let name = declName beforeEquals in define name str (display name env) _ -> error "Environment.hs: Case error. Submit bug report." @@ -54,6 +56,8 @@ where isVarChar c = isAlpha c || isDigit c || elem c "_'" token = takeWhile isVarChar . dropWhile (not . isAlpha) + + hasBrace = elem '{' define :: String -> String -> Repl -> Repl define name body env = env { defs = Map.insert name body (defs env) } diff --git a/Evaluator.hs b/Evaluator.hs --- a/Evaluator.hs +++ b/Evaluator.hs @@ -1,27 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} module Evaluator where +import qualified Data.Char as Char import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString as BS -import qualified Language.Elm as Elm -import qualified Environment as Env +import qualified Data.ByteString as BS +import qualified Elm.Internal.Paths as Elm +import qualified Environment as Env +import qualified Data.Map as Map +import Control.Applicative ((<$>), (<*>)) +import Control.Exception +import Control.Monad (unless) +import System.Directory (removeFile) +import System.Exit (ExitCode(..)) +import System.FilePath ((), replaceExtension) import System.IO -import System.IO.Error (isDoesNotExistError) -import System.Directory (removeFile) -import System.Exit (ExitCode(..)) -import System.FilePath ((), replaceExtension) +import System.IO.Error (isDoesNotExistError) import System.Process -import Control.Exception -import Control.Monad (unless) runRepl :: String -> Env.Repl -> IO Env.Repl runRepl "" env = return env runRepl input oldEnv = do writeFile tempElm $ Env.toElm newEnv - success <- run "elm" elmArgs $ \types -> do + success <- runCmdWithCallback (Env.compilerPath newEnv) elmArgs $ \types -> do reformatJS input tempJS - run "node" nodeArgs $ \value' -> + runCmdWithCallback "node" nodeArgs $ \value' -> let value = BSC.init value' tipe = scrapeOutputType types isTooLong = BSC.isInfixOf "\n" value || @@ -39,38 +42,37 @@ tempJS = "build" replaceExtension tempElm "js" nodeArgs = [tempJS] - elmArgs = ["--make", "--only-js", "--print-types", tempElm] - - run name args nextComputation = - do (_, stdout, stderr, handle') <- - createProcess (proc name args) { std_out = CreatePipe - , std_err = CreatePipe } - exitCode <- waitForProcess handle' - case (exitCode, stdout, stderr) of - (ExitSuccess, Just out, Just _) -> - nextComputation =<< BS.hGetContents out - (ExitFailure 127, Just _, Just _) -> failure missingExe - (ExitFailure _, Just out, Just err) -> do e <- BSC.hGetContents err - o <- BSC.hGetContents out - failure (BS.concat [o,e]) - (_, _, _) -> failure "Unknown error!" - where - failure message = BSC.hPutStrLn stderr message >> return False - missingExe = BSC.pack $ unlines $ - [ "Error: '" ++ name ++ "' command not found." - , " Do you have it installed?" - , " Can it be run from anywhere? I.e. is it on your PATH?" ] + elmArgs = Env.flags newEnv ++ ["--make", "--only-js", "--print-types", tempElm] +runCmdWithCallback :: FilePath -> [String] -> (BS.ByteString -> IO Bool) -> IO Bool +runCmdWithCallback name args callback = do + (_, stdout, stderr, handle') <- createProcess (proc name args) { std_out = CreatePipe + , std_err = CreatePipe} + exitCode <- waitForProcess handle' + case (exitCode, stdout, stderr) of + (ExitSuccess, Just out, Just _) -> + callback =<< BS.hGetContents out + (ExitFailure 127, Just _, Just _) -> failure missingExe + (ExitFailure _, Just out, Just err) -> do + e <- BSC.hGetContents err + o <- BSC.hGetContents out + failure (BS.concat [o,e]) + (_, _, _) -> failure "Unknown error!" + where failure message = BSC.hPutStrLn stderr message >> return False + missingExe = BSC.pack $ unlines $ + [ "Error: '" ++ name ++ "' command not found." + , " Do you have it installed?" + , " Can it be run from anywhere? I.e. is it on your PATH?" ] reformatJS :: String -> String -> IO () reformatJS input tempJS = - do rts <- BS.readFile =<< Elm.runtime + do rts <- BS.readFile Elm.runtime src <- BS.readFile tempJS BS.length src `seq` BS.writeFile tempJS (BS.concat [rts,src,out]) where out = BS.concat [ "process.on('uncaughtException', function(err) {\n" - , " process.stderr.write(err);\n" + , " process.stderr.write(err.toString());\n" , " process.exit(1);\n" , "});\n" , "var document = document || {};" @@ -81,21 +83,18 @@ , " console.log(context.Native.Show.values.show(repl.", Env.output, "));" ] scrapeOutputType :: BS.ByteString -> BS.ByteString -scrapeOutputType types - | name == Env.output = tipe - | BS.null rest = "" - | otherwise = scrapeOutputType rest - where - (next,rest) = freshLine types - (name,tipe) = BSC.splitAt (BSC.length Env.output) next +scrapeOutputType = dropName . squashSpace . takeType . dropWhile (not . isOut) . BSC.lines + where isOut = BS.isPrefixOf Env.output + dropName = BS.drop $ BSC.length Env.output + takeType (n:rest) = n : takeWhile isMoreType rest + isMoreType = (&&) <$> not . BS.null <*> (Char.isSpace . BSC.head) + squashSpace = BSC.unwords . BSC.words . BSC.unwords - freshLine str - | BSC.take 2 rest' == "\n " = (BS.append line line', rest'') - | BS.null rest' = (line,"") - | otherwise = (line, BS.tail rest') - where - (line,rest') = BSC.break (=='\n') str - (line',rest'') = freshLine rest' +freshLine :: BS.ByteString -> (BS.ByteString, BS.ByteString) +freshLine str | BS.null rest' = (line,"") + | otherwise = (line, BS.tail rest') + where + (line,rest') = BSC.break (=='\n') str removeIfExists :: FilePath -> IO () removeIfExists fileName = removeFile fileName `Control.Exception.catch` handleExists diff --git a/Flags.hs b/Flags.hs new file mode 100644 --- /dev/null +++ b/Flags.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Flags where + +import System.Console.CmdArgs +import Data.Version (showVersion) +import qualified Paths_elm_repl as This + +version = showVersion This.version + +data Flags = Flags + { compiler :: FilePath + } + deriving (Data,Typeable,Show,Eq) + +flags = Flags + { compiler = "elm" &= typFile + &= help "Provide a path to a specific Elm compiler." + } &= help "Read-eval-print-loop (REPL) for digging deep into Elm projects.\n\ + \More info at " + &= helpArg [explicit, name "help", name "h"] + &= versionArg [explicit, name "version", name "v", summary version] + &= summary ("Elm REPL " ++ version ++ ", (c) Evan Czaplicki 2011-2013") diff --git a/Repl.hs b/Repl.hs --- a/Repl.hs +++ b/Repl.hs @@ -1,35 +1,68 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad import Control.Monad.Trans +import qualified Data.Map as Map +import qualified Data.List as List import System.Console.Haskeline -import qualified Evaluator as Eval -import qualified Environment as Env +import qualified System.Console.CmdArgs as CmdArgs import System.Directory +import System.Environment import System.Exit +import System.FilePath (()) +import Text.Parsec hiding (getInput) +import qualified Evaluator as Eval +import qualified Environment as Env +import qualified Flags + +data Command + = AddFlag String + | RemoveFlag String + | ListFlags + | ClearFlags + | InfoFlags + | Help + | Exit + | Reset + deriving Show + +welcomeMessage :: String +welcomeMessage = + "Elm REPL " ++ Flags.version ++ + " \n\ + \Type :help for help, :exit to exit" + +elmdir :: IO FilePath +elmdir = do + dir <- ( "repl") `fmap` getAppUserDataDirectory "elm" + createDirectoryIfMissing True dir + return dir + +mkSettings :: (MonadIO m) => IO (Settings m) +mkSettings = do + historyFile <- ( "history") `fmap` elmdir + return $ defaultSettings { historyFile = Just historyFile } + main :: IO () main = do + flags <- CmdArgs.cmdArgs Flags.flags buildExisted <- doesDirectoryExist "build" cacheExisted <- doesDirectoryExist "cache" - exitCode <- runInputT defaultSettings $ withInterrupt $ loop Env.empty + settings <- mkSettings + putStrLn welcomeMessage + exitCode <- runInputT settings $ withInterrupt $ loop (Env.empty (Flags.compiler flags)) when (not buildExisted) (removeDirectoryRecursive "build") when (not cacheExisted) (removeDirectoryRecursive "cache") exitWith exitCode loop :: Env.Repl -> InputT IO ExitCode -loop environment@(Env.Repl _ _ _ wasCtrlC) = do - str' <- handleInterrupt (return Nothing) getInput +loop environment = do + str' <- handleInterrupt (return . Just $ "") getInput case str' of - Just input -> - loop =<< liftIO (Eval.runRepl input $ environment {Env.ctrlc = False}) - - Nothing - | wasCtrlC -> return (ExitFailure 130) - | otherwise -> do - lift $ putStrLn "(Ctrl-C again to exit)" - loop $ environment {Env.ctrlc = True} + Just (':':command) -> runCommand environment command + Just input -> loop =<< liftIO (Eval.runRepl input environment) + Nothing -> return ExitSuccess getInput :: InputT IO (Maybe String) getInput = get "> " "" @@ -37,9 +70,92 @@ get str old = do input <- getInputLine str case input of - Nothing -> return $ Just old + Nothing -> return Nothing Just new -> continueWith (old ++ new) continueWith str | null str || last str /= '\\' = return $ Just str | otherwise = get "| " (init str ++ "\n") + +runCommand :: Env.Repl -> String -> InputT IO ExitCode +runCommand env raw = + case parse commands "" raw of + Right command -> handleCommand env command + Left err -> do + liftIO . putStrLn $ "Could not parse command '" ++ raw ++ "':\n" ++ show err + loop env + +handleCommand :: Env.Repl -> Command -> InputT IO ExitCode +handleCommand env command = + let loop' (msg,env') = liftIO (putStrLn msg) >> loop env' in + case command of + Exit -> liftIO exitSuccess + + Reset -> loop' ("Environment Reset", Env.empty (Env.compilerPath env)) + + Help -> loop' (helpInfo, env) + + AddFlag flag -> + if flag `elem` Env.flags env + then loop' ( "Flag already added!", env ) + else loop' ( "Added " ++ flag + , env { Env.flags = Env.flags env ++ [flag] } ) + + RemoveFlag flag -> + if flag `notElem` Env.flags env + then loop' ( "No such flag.", env ) + else loop' ( "Removed flag " ++ flag + , env {Env.flags = List.delete flag $ Env.flags env} ) + + ListFlags -> loop' (List.intercalate "\n" $ Env.flags env, env) + + ClearFlags -> loop' ("All flags cleared", env {Env.flags = []}) + + InfoFlags -> loop' (flagsInfo, env) + +commands :: Parsec String () Command +commands = choice (flags : basics) + where + basics = map basicCommand [ ("exit",Exit), ("reset",Reset), ("help",Help) ] + + basicCommand (name,command) = + string name >> spaces >> eof >> return command + +flags :: Parsec String () Command +flags = do + string "flags" + many space + choice [ do string "add" >> many1 space >> srcDir + , do string "remove" >> many1 space + n <- many1 digit + return $ RemoveFlag (read n) + , do string "list" + return ListFlags + , do string "clear" + return ClearFlags + , return InfoFlags + ] + +srcDir :: Parsec String () Command +srcDir = do + string "--src-dir=" + dir <- manyTill anyChar (choice [ space >> return (), eof ]) + return $ AddFlag $ "--src-dir=" ++ dir + +flagsInfo :: String +flagsInfo = "Usage: flags [operation]\n\ + \\n\ + \ operations:\n\ + \ add --src-dir=FILEPATH\tAdd a compiler flag\n\ + \ remove --src-dir=FILEPATH\tRemove a compiler flag\n\ + \ list\t\t\tList all flags that have been added\n\ + \ clear\t\t\tClears all flags\n" + +helpInfo :: String +helpInfo = "General usage directions: \n\ + \Additional commands available from the prompt:\n\ + \\n\ + \ :help\t\t\tList available commands\n\ + \ :flags\t\tManipulate flags sent to elm compiler\n\ + \ :reset\t\tClears all previous imports\n\ + \ :exit\t\t\tExits elm-repl\n" diff --git a/elm-repl.cabal b/elm-repl.cabal --- a/elm-repl.cabal +++ b/elm-repl.cabal @@ -1,5 +1,5 @@ Name: elm-repl -Version: 0.1.0.2 +Version: 0.2 Synopsis: a REPL for Elm Description: A read-eval-print-loop (REPL) for evaluating Elm expressions, definitions, ADTs, and module imports. This tool is meant to @@ -28,15 +28,19 @@ Executable elm-repl Main-is: Repl.hs other-modules: Environment, - Evaluator + Evaluator, + Flags Build-depends: base >=4.2 && <5, bytestring, + cmdargs, containers >= 0.3, directory, - Elm >= 0.10.0.2, + Elm >= 0.10.1, filepath, haskeline, transformers >= 0.2, mtl >= 2, - process + process, + parsec >= 3.0, + filepath