module Main where
import "monads-fd" Control.Monad.Cont
import "monads-fd" Control.Monad.Error
import Data.Char (isSpace)
import Prelude hiding (catch)
import System.Console.Haskeline
import System.Directory (getHomeDirectory)
import System.Environment (getArgs)
import System.FilePath
import Atomo.Environment
import Atomo.Load
import Atomo.Parser
import Atomo.PrettyVM
import Atomo.Run
import Atomo.Types
main :: IO ()
main = do
args <- getArgs
case args of
r | null r || r == ["-d"] ->
exec (repl (r == ["-d"]))
("-e":expr:_) -> exec $ do
ast <- continuedParse expr ""
r <- evalAll ast
p <- prettyVM r
liftIO (print p)
return (particle "ok")
("-s":expr:_) -> exec $ do
ast <- continuedParse expr ""
evalAll ast
repl False
("-l":fn:_) -> exec $ do
loadFile fn
repl False
(fn:_) | not (head fn == '-') ->
exec (loadFile fn)
_ -> putStrLn . unlines $
[ "usage:"
, "\tatomo\t\tstart the REPL"
, "\tatomo -d\tstart the REPL in quiet mode"
, "\tatomo -e EXPR\tevaluate EXPR and output the result"
, "\tatomo -s EXPR\tevaluate EXPR and start the REPL"
, "\tatomo -l FILE\tload FILENAME and start the REPL"
, "\tatomo FILE\texecute FILE"
]
repl :: Bool -> VM Value
repl quiet = do
home <- liftIO getHomeDirectory
repl' "" $ runInput home . withInterrupt
where
escape Interrupt = return Nothing
runInput home = runInputT defaultSettings
{ historyFile = Just (home > ".atomo_history")
}
repl' input r = do
me <- liftIO (catch (r $ getInputLine prompt) escape)
case me of
Just blank | null (dropWhile isSpace blank) -> repl' input r
Just part | not (bracesBalanced $ input ++ part) ->
repl' (input ++ part) r
Just expr -> do
catchError
(evaluate expr >>= prettyVM >>= liftIO . print)
printError
repl' "" r
Nothing -> askQuit (repl' input r)
where
evaluate expr = parseInput (input ++ expr) >>= evalAll
prompt
| quiet = ""
| null input = "> "
| otherwise = ". "
askQuit c = do
r <- liftIO . runInputT defaultSettings $
getInputChar "really quit? (y/n) "
case r of
Just 'y' -> return (particle "ok")
Just 'n' -> c
_ -> askQuit c
bracesBalanced s = hangingBraces s == 0
where
hangingBraces :: String -> Int
hangingBraces [] = 0
hangingBraces (b:ss)
| b == '"' = hangingBraces (tail $ dropWhile (/= '"') ss)
| b == '\'' = hangingBraces (tail $ dropWhile (/= '\'') ss)
| b `elem` "([{" = 1 + hangingBraces ss
| b `elem` ")]}" = hangingBraces ss - 1
| otherwise = hangingBraces ss