diff --git a/Environment.hs b/Environment.hs new file mode 100644 --- /dev/null +++ b/Environment.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +module Environment where + +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.List +import qualified Data.Map as Map + +data Repl = Repl + { 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 + +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 + | "import " `isPrefixOf` 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 = + 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 -> 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) + +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 diff --git a/Evaluator.hs b/Evaluator.hs new file mode 100644 --- /dev/null +++ b/Evaluator.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +module Evaluator where + +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 System.IO.Error (isDoesNotExistError) +import System.Directory (removeFile) +import System.Exit (ExitCode(..)) +import System.FilePath ((), replaceExtension) +import System.Process +import Control.Exception +import Control.Monad (unless) + +runRepl :: Env.Repl -> IO Bool +runRepl environment = + do writeFile tempElm (Env.toElm environment) + result <- run "elm" elmArgs $ \types -> do + reformatJS tempJS + run "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.putStrLn message + removeIfExists tempElm + return result + where + tempElm = "repl-temp-000.elm" + tempJS = "build" replaceExtension tempElm "js" + + nodeArgs = [tempJS] + elmArgs = ["--make", "--only-js", "--print-types", tempElm] + + run name args nextComputation = + let failure message = BSC.putStrLn message >> return False + missingExe = unlines [ "Error: '" ++ name ++ "' command not found." + , " Do you have it installed?" + , " Can it be run from anywhere? I.e. is it on your PATH?" ] + in + do (_, stdout, _, handle') <- createProcess (proc name args) { std_out = CreatePipe } + exitCode <- waitForProcess handle' + case (exitCode, stdout) of + (ExitFailure 127, _) -> failure $ BSC.pack missingExe + (_, Nothing) -> failure "Unknown error!" + (ExitFailure _, Just out) -> failure =<< BSC.hGetContents out + (ExitSuccess , Just out) -> + do nextComputation =<< BS.hGetContents out + return True + +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 + [ "var context = { inputs:[] };\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 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 + + 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' + +removeIfExists :: FilePath -> IO () +removeIfExists fileName = removeFile fileName `Control.Exception.catch` handleExists + where handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Evan Czaplicki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Evan Czaplicki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Repl.hs b/Repl.hs new file mode 100644 --- /dev/null +++ b/Repl.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad.Trans +import System.Console.Haskeline +import qualified Evaluator as Eval +import qualified Environment as Env +import System.Exit + +main :: IO () +main = runInputT defaultSettings $ withInterrupt $ loop Env.empty + +loop :: Env.Repl -> InputT IO () +loop environment@(Env.Repl _ _ _ wasCtrlC) = do + str' <- handleInterrupt (return Nothing) getInput + let env = environment {Env.ctrlc = False} + case str' of + Nothing -> if wasCtrlC then lift $ exitWith (ExitFailure 130) + else do + lift $ putStrLn "(Ctrl-C again to exit)" + loop $ environment {Env.ctrlc = True} + Just "" -> loop env + Just str -> do + let env' = Env.insert str env + success <- liftIO $ Eval.runRepl env' + loop (if success then env' else env) + +getInput :: InputT IO (Maybe String) +getInput = get "> " "" + where + get str old = do + input <- getInputLine str + case input of + Nothing -> return $ Just old + Just new -> continueWith (old ++ new) + + continueWith str + | null str || last str /= '\\' = return $ Just str + | otherwise = get "| " (init str ++ "\n") diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elm-repl.cabal b/elm-repl.cabal new file mode 100644 --- /dev/null +++ b/elm-repl.cabal @@ -0,0 +1,42 @@ +Name: elm-repl +Version: 0.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 + +License: BSD3 +License-file: LICENSE + +Author: Evan Czaplicki +Maintainer: info@elm-lang.org +Copyright: Copyright: (c) 2011-2013 Evan Czaplicki + +Category: Tool + +Build-type: Simple + +Cabal-version: >=1.8 + +source-repository head + type: git + location: git://github.com/evancz/elm-repl.git + +Executable elm-repl + Main-is: Repl.hs + other-modules: Environment, + Evaluator + + Build-depends: base >=4.2 && <5, + bytestring, + containers >= 0.3, + directory, + Elm >= 0.10, + filepath, + haskeline, + transformers >= 0.2, + mtl >= 2, + process