packages feed

elm-repl 0.2 → 0.2.1

raw patch · 16 files changed

+667/−368 lines, 16 filesdep +HUnitdep +QuickCheckdep +bytestring-triedep ~Elm

Dependencies added: HUnit, QuickCheck, bytestring-trie, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: Elm

Files

− Environment.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Environment where--import qualified Data.ByteString.Char8 as BS-import Data.Char (isUpper,isSymbol,isAlpha,isDigit)-import qualified Data.List as List-import qualified Data.Map as Map--data Repl = Repl-    { compilerPath :: FilePath-    , flags :: [String]-    , imports :: Map.Map String String-    , adts :: Map.Map String String-    , defs :: Map.Map String String-    } deriving Show--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"--toElm :: Repl -> String-toElm env = unlines $ "module Repl where" : decls-    where decls = concatMap Map.elems [ imports env, adts env, defs env ]--insert :: String -> Repl -> Repl-insert str env-    | 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) }--    | List.isPrefixOf "data " str =-        let name = takeWhile (/=' ') (drop 5 str)-        in  noDisplay $ env { adts = Map.insert name str (adts env) }-            -    | otherwise =-        case break (=='=') str of-          (_,"") -> display str env-          (beforeEquals, _:c:_)-              | 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."-        where-          declName pattern =-              case takeWhile isSymbol . dropWhile (not . isSymbol) $ pattern of-                "" -> takeWhile (/=' ') pattern-                op -> op--          hasLet = elem "let" . map token . words-              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) }--display :: String -> Repl -> Repl-display = define output' . format-    where format body = output' ++ " =" ++ concatMap ("\n  "++) (lines body)-          output' = BS.unpack output--noDisplay :: Repl -> Repl-noDisplay env = env { defs = Map.delete output' (defs env) }-    where output' = BS.unpack output
− Evaluator.hs 
@@ -1,103 +0,0 @@-{-# 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 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.Process--runRepl :: String -> Env.Repl -> IO Env.Repl-runRepl "" env = return env-runRepl input oldEnv =-  do writeFile tempElm $ Env.toElm newEnv-     success <- runCmdWithCallback (Env.compilerPath newEnv) elmArgs $ \types -> do-       reformatJS input tempJS-       runCmdWithCallback "node" nodeArgs $ \value' ->-           let value = BSC.init value'-               tipe = scrapeOutputType types-               isTooLong = BSC.isInfixOf "\n" value ||-                           BSC.isInfixOf "\n" tipe ||-                           BSC.length value + BSC.length tipe > 80   -               message = BS.concat [ if isTooLong then value' else value, tipe ]-           in  do unless (BSC.null value') $ BSC.hPutStrLn stdout message-                  return True-     removeIfExists tempElm-     return $ if success then newEnv else oldEnv-  where-    newEnv = Env.insert input oldEnv--    tempElm = "repl-temp-000.elm"-    tempJS  = "build" </> replaceExtension tempElm "js"-    -    nodeArgs = [tempJS]-    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-     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.toString());\n"-          , "  process.exit(1);\n"-          , "});\n"-          , "var document = document || {};"-          , "var window = window || {};"-          , "var context = { inputs:[], addListener:function(){}, node:{} };\n"-          , "var repl = Elm.Repl.make(context);\n"-          , "if ('", Env.output, "' in repl)\n"-          , "  console.log(context.Native.Show.values.show(repl.", Env.output, "));" ]--scrapeOutputType :: BS.ByteString -> BS.ByteString-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 :: 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-  where handleExists e-          | isDoesNotExistError e = return ()-          | otherwise = throwIO e
− Flags.hs 
@@ -1,22 +0,0 @@-{-# 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 <https://github.com/evancz/elm-repl#elm-repl>"-    &= helpArg [explicit, name "help", name "h"]-    &= versionArg [explicit, name "version", name "v", summary version]-    &= summary ("Elm REPL " ++ version ++ ", (c) Evan Czaplicki 2011-2013")
− Repl.hs 
@@ -1,161 +0,0 @@-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 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 ++-    " <https://github.com/evancz/elm-repl#elm-repl>\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"-  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 = do-  str' <- handleInterrupt (return . Just $ "") getInput-  case str' of-    Just (':':command) -> runCommand environment command-    Just input         -> loop =<< liftIO (Eval.runRepl input environment)-    Nothing            -> return ExitSuccess--getInput :: InputT IO (Maybe String)-getInput = get "> " ""-    where-      get str old = do-        input <- getInputLine str-        case input of-          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: <https://github.com/evancz/elm-repl#elm-repl>\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"
+ changelog.txt view
@@ -0,0 +1,21 @@+Upcoming Release+================+Features:+  * Basic auto-completion.+  * Better error messages.++Bug Fixes:+  * Fix error when running consecutive commands quickly.++Release 0.2+===========+Features:+  * Compiler flag control.+  * Repl commands: help, manipulate flags, clear environment, exit.+  * Exit on EOF.+  * Interrupt on Ctrl-c.++Bug fixes:+  * Fix infinite loop when printing long types.+  * Fix node.js type error when errors are thrown.+  * Top-level record literals work.
elm-repl.cabal view
@@ -1,46 +1,78 @@ Name:                elm-repl-Version:             0.2+Version:             0.2.1 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                      help you play with small expressions and interact with                      functions deep inside of larger projects. -Homepage:            https://github.com/evancz/elm-repl#elm-repl+Homepage:            https://github.com/elm-lang/elm-repl#elm-repl  License:             BSD3 License-file:        LICENSE  Author:              Evan Czaplicki Maintainer:          info@elm-lang.org-Copyright:           Copyright: (c) 2011-2013 Evan Czaplicki+Copyright:           Copyright: (c) 2011-2014 Evan Czaplicki  Category:            Tool  Build-type:          Simple-+Extra-source-files:  changelog.txt Cabal-version:       >=1.8  source-repository head   type:     git-  location: git://github.com/evancz/elm-repl.git+  location: git://github.com/elm-lang/elm-repl.git  Executable elm-repl+  ghc-options:         -W+  Hs-Source-Dirs:      src   Main-is:             Repl.hs-  other-modules:       Environment,+  other-modules:       Action,+                       Command,+                       Completion,+                       Environment,                        Evaluator,-                       Flags+                       Flags,+                       Monad,+                       Parse    Build-depends:       base >=4.2 && <5,                        bytestring,+                       bytestring-trie,                        cmdargs,                        containers >= 0.3,                        directory,-                       Elm >= 0.10.1,+                       Elm >= 0.12,                        filepath,                        haskeline,-                       transformers >= 0.2,                        mtl >= 2,+                       parsec >= 3.0,                        process,+                       transformers >= 0.2+++Test-Suite test+  Type:                exitcode-stdio-1.0+  ghc-options:         -W+  Hs-Source-Dirs:      tests, src+  Main-is:             Main.hs+  build-depends:       test-framework,+                       test-framework-hunit,+                       test-framework-quickcheck2 >= 0.3,+                       HUnit,+                       QuickCheck,+                       base >=4.2 && <5,+                       bytestring,+                       bytestring-trie,+                       cmdargs,+                       containers >= 0.3,+                       directory,+                       Elm >= 0.10.1,+                       filepath,+                       haskeline,+                       mtl >= 2,                        parsec >= 3.0,-                       filepath+                       process,+                       transformers >= 0.2
+ src/Action.hs view
@@ -0,0 +1,24 @@+module Action where++data Action = Command Command+            | Code Term+            | Skip+            deriving (Show, Eq)++data Command = AddFlag String+             | RemoveFlag String+             | ListFlags+             | ClearFlags+               -- Just if this was triggered by an error+             | InfoFlags (Maybe String)+             | Help (Maybe String)+             | Exit+             | Reset+             deriving (Show, Eq)++type Term = (String, Maybe Def)++data Def = VarDef  String+         | DataDef String+         | Import  String+         deriving (Show, Eq)
+ src/Command.hs view
@@ -0,0 +1,67 @@+module Command where++import Data.Functor             ((<$>), (<$))+import Control.Monad.Trans      (liftIO)+import Control.Monad.State      (get, modify)+import System.Exit              (ExitCode, exitSuccess)++import qualified Data.List   as List++import Action (Command(..))+import qualified Environment as Env+import Monad (ReplM)++run :: Command -> ReplM (Maybe ExitCode)+run cmd =+  case cmd of+    Exit         -> Just <$> liftIO exitSuccess+    Help m       -> displayErr "Bad command\n" m >> display helpInfo+    InfoFlags m  -> displayErr "Bad flag\n" m    >> display flagsInfo+    ListFlags    -> display . unlines . Env.flags =<< get++    AddFlag flag -> modifyIfPresent True flag "Added " "Flag already added!" $ \env ->+        env { Env.flags = Env.flags env ++ [flag] }++    RemoveFlag flag -> modifyIfPresent False flag "Removed flag " "No such flag." $ \env ->+      env {Env.flags = List.delete flag $ Env.flags env}++    Reset -> modifyAlways "Environment Reset" (Env.empty . Env.compilerPath)+    ClearFlags -> modifyAlways "All flags cleared" $ \env ->+      env {Env.flags = []}++  where display msg = Nothing <$ (liftIO . putStrLn $ msg)+        displayErr msg m = case m of+          Nothing -> return ()+          Just err -> liftIO . putStrLn $ (msg ++ err)+        modifyIfPresent b flag msgSuc msgFail mod = do+          env <- get+          if not b `xor` (flag `elem` Env.flags env)+            then display msgFail+            else Nothing <$ do+          liftIO . putStrLn $ msgSuc ++ flag+          modify mod+        modifyAlways msg mod = Nothing <$ do+          liftIO . putStrLn $ msg+          modify mod++xor :: Bool -> Bool -> Bool+xor True  = not+xor False = id++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: <https://github.com/elm-lang/elm-repl#elm-repl>\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"
+ src/Completion.hs view
@@ -0,0 +1,35 @@+module Completion (complete)+       where++import Data.Functor        ((<$>))+import Data.Trie           (Trie)+import Control.Monad.State (get)+import System.Console.Haskeline.Completion++import qualified Data.ByteString.Char8 as BS+import qualified Data.Trie             as Trie++import Monad (ReplM)++import qualified Environment as Env++complete, completeIdentifier :: CompletionFunc ReplM+complete = completeQuotedWord Nothing "\"\'" (const $ return [] ) completeIdentifier+completeIdentifier = completeWord Nothing " \t" lookupCompletions++lookupCompletions :: String -> ReplM [Completion]+lookupCompletions s = completions s . removeReserveds . Env.defs <$> get+    where removeReserveds = Trie.delete Env.firstVar . Trie.delete Env.lastVar++completions :: String -> Trie a  -> [Completion]+completions s = Trie.lookupBy go (BS.pack s)+  where go :: Maybe a -> Trie a -> [Completion]+        go isElem suffixesTrie = maybeCurrent ++ suffixCompletions+          where maybeCurrent = case isElem of+                  Nothing -> []+                  Just _  -> [current]+                current = Completion s s True++                suffixCompletions = map (suffixCompletion . BS.unpack) . Trie.keys $ suffixesTrie+                suffixCompletion suf = Completion full full False+                  where full = s ++ suf
+ src/Environment.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+module Environment where++import Data.ByteString (ByteString)+import Data.Monoid     ((<>))+import qualified Data.ByteString.Char8 as BS+-- | TODO: Switch to a Char-based trie.+import Data.Trie       (Trie)+import qualified Data.Trie             as Trie++import Action (Term, Def(..))++data Repl = Repl+    { compilerPath :: FilePath+    , flags :: [String]+    , imports :: Trie String+    , adts :: Trie String+    , defs :: Trie String+    } deriving Show++empty :: FilePath -> Repl+empty compilerPath =+    Repl compilerPath [] Trie.empty Trie.empty (Trie.singleton firstVar (BS.unpack firstVar <> " = ()"))++firstVar :: ByteString+firstVar = "tsol"++lastVar :: ByteString+lastVar = "deltron3030"++toElm :: Repl -> String+toElm env = unlines $ "module Repl where" : decls+    where decls = concatMap Trie.elems [ imports env, adts env, defs env ]++insert :: Term -> Repl -> Repl+insert (src, def) env = case def of+  Nothing -> display src env+  Just (Import mport) -> noDisplay $ env { imports = Trie.insert (BS.pack mport) src (imports env) }+  Just (DataDef def)  -> noDisplay $ env { adts    = Trie.insert (BS.pack def)   src (adts env) }+  Just (VarDef var)   -> define (BS.pack var) src . display var $ env++define :: ByteString -> String -> Repl -> Repl+define name body env = env { defs = Trie.insert name body (defs env) }++display :: String -> Repl -> Repl+display = define lastVar . format+  where format body = (BS.unpack lastVar) ++ " =" ++ concatMap ("\n  "++) (lines body)++noDisplay :: Repl -> Repl+noDisplay env = env { defs = Trie.delete lastVar (defs env) }
+ src/Evaluator.hs view
@@ -0,0 +1,106 @@+{-# 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 Elm.Internal.Paths    as Elm+import qualified Environment           as Env++import Control.Applicative ((<$>), (<*>))+import Control.Monad       (unless)+import Control.Monad.RWS   (get, modify, MonadState)+import Control.Monad.Trans (liftIO)+import System.Directory    (doesFileExist, removeFile)+import System.Exit         (ExitCode(..))+import System.FilePath     ((</>), replaceExtension)+import System.IO+import System.Process++import Monad+import Action++evalPrint :: Term -> ReplM ()+evalPrint term =+  do modify $ Env.insert term +     env <- get+     liftIO $ writeFile tempElm $ Env.toElm env+     let elmArgs = Env.flags env ++ ["--make", "--only-js", "--print-types", tempElm]+     liftIO . runCmdWithCallback (Env.compilerPath env) elmArgs $ \types -> do+       reformatJS tempJS+       runCmdWithCallback "node" nodeArgs $ \value' ->+           let value = BSC.init value'+               tipe = scrapeOutputType types+               isTooLong = BSC.isInfixOf "\n" value ||+                           BSC.isInfixOf "\n" tipe ||+                           BSC.length value + BSC.length tipe > 80   +               message = BS.concat [ if isTooLong then value' else value, tipe ]+           in  unless (BSC.null value') $ BSC.hPutStrLn stdout message+     liftIO $ removeIfExists tempElm+     return ()+  where++    tempElm = "repl-temp-000.elm"+    tempJS  = "build" </> replaceExtension tempElm "js"+    +    nodeArgs = [tempJS]++runCmdWithCallback :: FilePath -> [String] -> (BS.ByteString -> IO ()) -> IO ()+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+       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 -> IO ()+reformatJS tempJS =+  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.toString());\n"+          , "  process.exit(1);\n"+          , "});\n"+          , "var document = document || {};"+          , "var window = window || {};"+          , "var context = { inputs:[], addListener:function(){}, node:{} };\n"+          , "var repl = Elm.Repl.make(context);\n"+          , "if ('", Env.lastVar, "' in repl)\n"+          , "  console.log(context.Native.Show.values.show(repl.", Env.lastVar, "));" ]++scrapeOutputType :: BS.ByteString -> BS.ByteString+scrapeOutputType = dropName . squashSpace . takeType . dropWhile (not . isOut) . BSC.lines+  where isOut    = (||) <$> (BS.isPrefixOf Env.lastVar) <*> (BS.isPrefixOf (BS.append "Repl." Env.lastVar))+        dropName = BSC.cons ' ' . BSC.dropWhile (/= ':')+        takeType (n:rest) = n : takeWhile isMoreType rest+        takeType []       = error "Internal error in elm-repl (takeType): Please report this bug to https://github.com/elm-lang/elm-repl/issues/"+        isMoreType = (&&) <$> not . BS.null <*> (Char.isSpace . BSC.head)+        squashSpace = BSC.unwords . BSC.words . BSC.unwords++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 = do+  exists <- doesFileExist fileName+  if exists+    then removeFile fileName+    else return ()
+ src/Flags.hs view
@@ -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 <https://github.com/elm-lang/elm-repl#elm-repl>"+    &= helpArg [explicit, name "help", name "h"]+    &= versionArg [explicit, name "version", name "v", summary version]+    &= summary ("Elm REPL " ++ version ++ ", (c) Evan Czaplicki 2011-2013")
+ src/Monad.hs view
@@ -0,0 +1,16 @@+module Monad (ReplM, runReplM)+       where++import Data.Functor ((<$>))+import Control.Monad.RWS++import Flags (Flags)+import qualified Environment as Env++-- Reader: Build Flags+-- State:  Current Environment+type ReplT = RWST Flags () Env.Repl+type ReplM = ReplT IO++runReplM :: Flags -> Env.Repl -> ReplM a -> IO a+runReplM fs repl m = (\(x,_,_) -> x) <$> runRWST m fs repl
+ src/Parse.hs view
@@ -0,0 +1,96 @@+module Parse where++import Data.Functor ((<$), (<$>))+import Text.Parsec++import qualified Data.Char as Char+import qualified Data.List as List++import Action++type Parser = Parsec String ()++input :: String -> Action+input inp = case parse result "" inp of+  Left err  -> Command . Help . Just . show $ err+  Right act -> act++result :: Parser Action+result = do+  spaces+  skip <|> cmd <|> term+  where+    skip = Skip <$ eof+    cmd  = char ':' >> Command <$> command+    term = Code . mkTerm <$> many anyChar++command :: Parser Command+command = do+  flag <- many1 notSpace+  spaces+  case flag of+    "exit"  -> basicCommand Exit+    "reset" -> basicCommand Reset+    "help"  -> basicCommand $ Help Nothing+    "flags" -> basicCommand (InfoFlags Nothing) <|> flags+    _       -> return $ Help . Just $ flag+  where basicCommand cmd = cmd <$ eof++flags :: Parser Command+flags = do+  flag <- many1 notSpace+  case flag of+    "add"    -> srcDirFlag AddFlag+    "remove" -> srcDirFlag RemoveFlag+    "list"   -> return ListFlags+    "clear"  -> return ClearFlags+    _        -> return $ InfoFlags . Just $ flag+  where srcDirFlag ctor = do+          many1 space+          ctor <$> srcDir++notSpace :: Parser Char+notSpace = satisfy $ not . Char.isSpace++srcDir :: Parser String+srcDir = do+  string "--src-dir="+  dir <- manyTill anyChar (choice [ space >> return (), eof ])+  return $ "--src-dir=" ++ dir++mkTerm :: String -> Term+mkTerm src = (src, mkCode src)++mkCode :: String -> Maybe Def+mkCode src+  | List.isPrefixOf "import " src = +    let name = getFirstCap . words $ src+        getFirstCap (tok@(c:_):rest) = if Char.isUpper c+                                       then tok+                                       else getFirstCap rest+        getFirstCap _ = src+    in Just $ Import name++  | List.isPrefixOf "data " src =+      let name = takeWhile (/=' ') . drop 5 $ src+      in  Just $ DataDef name++  | otherwise = case break (=='=') src of+        (_,"") -> Nothing+        (beforeEquals, _:c:_)+          | Char.isSymbol c || hasLet beforeEquals || hasBrace beforeEquals ->+            Nothing+          | otherwise -> Just . VarDef $ declName beforeEquals+        _ -> error "Parse.hs: Case error. Please submit bug report to https://github.com/elm-lang/elm-repl/issues."+        where+          declName pattern =+              case takeWhile Char.isSymbol . dropWhile (not . Char.isSymbol) $ pattern of+                "" -> takeWhile (/=' ') pattern+                op -> op++          hasLet = elem "let" . map token . words+            where+              isVarChar c = Char.isAlpha c || Char.isDigit c || elem c "_'"+              token = takeWhile isVarChar . dropWhile (not . Char.isAlpha)++          hasBrace = elem '{'
+ src/Repl.hs view
@@ -0,0 +1,84 @@+module Main where++import Control.Monad+import Control.Monad.Trans+import Data.Functor ((<$))+import System.Console.Haskeline hiding (handle)+import System.Directory+import System.Exit+import System.FilePath ((</>))++import qualified System.Console.CmdArgs as CmdArgs++import Monad++import qualified Action      as Act+import qualified Command     as Cmd+import qualified Completion+import qualified Evaluator   as Eval+import qualified Environment as Env+import qualified Flags+import qualified Parse++main :: IO ()+main = do+  flags <- CmdArgs.cmdArgs Flags.flags+  buildExisted <- doesDirectoryExist "build"+  cacheExisted <- doesDirectoryExist "cache"+  settings     <- mkSettings+  putStrLn welcomeMessage+  let mt = Env.empty (Flags.compiler flags)+  exitCode <- runReplM flags mt . runInputT settings . withInterrupt $ repl+  unless buildExisted (removeDirectoryRecursive "build")+  unless cacheExisted (removeDirectoryRecursive "cache")+  exitWith exitCode++repl :: InputT ReplM ExitCode+repl = do+  str' <- handleInterrupt (return . Just $ "") getInput+  case str' of+    Nothing -> return ExitSuccess+    Just str -> do+      let act = Parse.input str+      m <- lift $ handle act+      case m of+        Just exit -> return exit+        Nothing   -> repl++handle :: Act.Action -> ReplM (Maybe ExitCode)+handle (Act.Command cmd) = Cmd.run cmd+handle (Act.Code src)    = Nothing <$ Eval.evalPrint src+handle (Act.Skip)        = return Nothing++getInput :: (MonadException m) => InputT m (Maybe String)+getInput = go "> " ""+    where+      go str old = do+        input <- getInputLine str+        case input of+          Nothing  -> return Nothing+          Just new -> continueWith (old ++ new)++      continueWith str+        | null str || last str /= '\\' = return $ Just str+        | otherwise = go "| " (init str ++ "\n")++welcomeMessage :: String+welcomeMessage =+    "Elm REPL " ++ Flags.version +++    " <https://github.com/elm-lang/elm-repl#elm-repl>\n\+    \Type :help for help, :exit to exit"++elmdir :: IO FilePath+elmdir = do+  dir <- (</> "repl") `fmap` getAppUserDataDirectory "elm"+  createDirectoryIfMissing True dir+  return dir++mkSettings :: IO (Settings ReplM)+mkSettings = do+  historyFile <- (</> "history") `fmap` elmdir+  return $ Settings { historyFile    = Just historyFile+                    , autoAddHistory = True+                    , complete       = Completion.complete+                    }
+ tests/Main.hs view
@@ -0,0 +1,104 @@+module Main where++import qualified Data.Char as Char+import qualified Data.List as List+import Data.Maybe (isJust)+import Test.Framework+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import qualified Test.HUnit.Base as HUnit+import Test.QuickCheck++import Action+import qualified Parse++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [ testGroup "Parse tests" [+             testGroup "Command parse tests" cmdParseTests+             , testGroup "Code parse tests"  codeParseTests+             , testGroup "Whitespace parse tests" skipTests+             ]+        ]++cmdParseTests = [+  testGroup "Good commands tests" [+     testCase ":help parses"                      $ cmdParses (Help Nothing) ":help"+     , testCase ":reset parses after whitespace"  $ cmdParses Reset "  :reset"+     , testCase ":exit parses before whitespace"  $ cmdParses Exit ":exit   "+     ]+  , testGroup ":flags parse tests" [+     testCase ":flags parses with Info"           $ cmdParses (InfoFlags Nothing) ":flags"+     , testCase ":flags + space parses with Info" $ cmdParses (InfoFlags Nothing) ":flags    "+     , testCase ":flags list parses"              $ cmdParses ListFlags ":flags list"+     , testCase ":flags clear parses w/ whitespace between" $+         cmdParses ClearFlags ":flags     clear"+     , testCase ":flags add source parses" $+         cmdParses (AddFlag "--src-dir=\"\"") ":flags add --src-dir=\"\""+     , testCase ":flags remove source parses" $+         cmdParses (RemoveFlag "--src-dir=bleh") ":flags remove --src-dir=bleh"+     ]++  , testGroup "Bad commands tests" [+     testCase ":flagsgrbl triggers help" $ helpErr ":flagsg"+     , testProperty "bad :commands trigger help" badCommandHelp+     ]+  ]+  where cmdParses cmd = actionParses (Action.Command cmd)+        helpErr   cmd = case Parse.input cmd of+          Action.Command (Help m) -> HUnit.assert $ isJust m+          res                     ->+            HUnit.assertFailure+            ("Should display help with an error message, instead got: "+             ++ show res)++codeParseTests = [+  testCase "number parses" $ codeParses Nothing "3"+  , testCase "number parses after newlines" $ codeParses Nothing "\n\n3"+  , testCase "data def parses"  $ codeParses (Just $ DataDef "Baz")  "data Baz = B { }"+  , testCase "var def parses" $ codeParses (Just $ VarDef "x") "x = 3"+  , testCase "var fun def parses" $ codeParses (Just $ VarDef "f") "f x = x"+  ]++skipTests = [+  testCase "empty is skipped"       $ skipped ""+  , testCase "newlines are skipped" $ skipped "\n\n\n"+  , testProperty "skip all whitespace"       skipAllSpace+  , testProperty "never skip non-whitespace" dontSkipNonSpace+  ]+  where skipped = actionParses Action.Skip++-- | Test Helpers+codeParses :: Maybe Def -> String -> HUnit.Assertion+codeParses code src = actionParses (Action.Code (trimSpace src, code)) src+  where trimSpace = dropWhile Char.isSpace++actionParses :: Action.Action -> String -> HUnit.Assertion+actionParses v s = v @=? Parse.input s++badCommandHelp :: Property+badCommandHelp = forAll nonFlags helpParses+  where nonFlags = oneof [ arbitrary `suchThat` notFlag+                         , badFlag+                         ]+        helpParses s = case Parse.input (':':s) of+          Command (Help (Just _)) -> True+          _             -> False+        -- | TODO: things like help3+        notFlag s = not . any (s `List.isPrefixOf`) $ flags+        badFlag = do+          flag <- elements flags+          c <- arbitrary `suchThat` (not . Char.isSpace)+          return $ flag ++ [c]+        flags = ["help", "reset", "flags", "exit"]++skipAllSpace :: Property+skipAllSpace = forAll spaces $ (==Action.Skip) . Parse.input+  where spaces = listOf . elements . filter Char.isSpace $ [toEnum 0..]++dontSkipNonSpace :: Property+dontSkipNonSpace = forAll notAllSpace $ (/= Action.Skip) . Parse.input+  where notAllSpace = arbitrary `suchThat` (not . all Char.isSpace)