PageRenderTime 16ms CodeModel.GetById 9ms app.highlight 4ms RepoModel.GetById 1ms app.codeStats 0ms

/src/Main.hs

http://github.com/vito/hummus
Haskell | 81 lines | 62 code | 17 blank | 2 comment | 3 complexity | ba7e117a595c894ecc90a4079a80121a MD5 | raw file
 1{-# LANGUAGE OverloadedStrings, RankNTypes #-}
 2module Main where
 3
 4import Control.Monad.Trans
 5import Data.Attoparsec
 6import Prelude hiding (catch)
 7import System.Console.Haskeline
 8import System.Environment (getArgs, getEnv)
 9import System.FilePath ((</>))
10import qualified Data.ByteString as BS
11
12import Hummus.Types
13import Hummus.Parser
14import Hummus.Runtime
15import qualified Hummus.Prelude as Prelude
16
17
18main :: IO ()
19main = do
20  as <- getArgs
21
22  runVM $ do
23    Prelude.fromGround $ \e -> do
24      case as of
25        [] -> do
26          home <- liftIO (getEnv "HOME")
27          runInputT
28            (defaultSettings { historyFile = Just (home </> ".hummus_history") })
29            (repl "" e)
30
31        [f] -> do
32          s <- liftIO (BS.readFile f)
33          case parseOnly sexps s of
34            Right ss -> mapM_ (evaluate e) ss
35            Left m -> error m
36
37        _ -> error "unknown argument form"
38
39      return Inert
40
41    return ()
42
43-- TODO: super hacky
44instance MonadException (VM ans) where
45  catch x _ = x -- TODO
46  block x = x -- TODO
47  unblock x = x -- TODO
48
49repl :: String -> Value ans -> InputT (VM ans) ()
50repl p e = do
51  mi <- getInputLine (if null p then "Hummus> " else "....... ")
52
53  case mi of
54    Just i ->
55      case parse sexps (BS.pack . map (toEnum . fromEnum) $ p ++ i) of
56        Done _ ss -> finish ss
57
58        Fail rest context message -> do
59          outputStrLn "Parse error!"
60          outputStrLn ("at: " ++ show rest)
61
62          if not (null context)
63            then outputStrLn "Context:"
64            else return ()
65
66          mapM_ (outputStrLn . ("  " ++)) context
67          outputStrLn message
68          repl "" e
69
70        Partial f ->
71          case f "" of
72            Done _ ss -> finish ss
73            _ -> repl (p ++ i ++ "\n") e
74
75    Nothing -> return ()
76  where
77    finish ss = do
78      v <- lift (evaluateSequence e ss)
79      String s <- lift (evaluate e (Pair (Symbol "send") (Pair v (Pair (Symbol "->string") Null))))
80      outputStrLn s
81      repl "" e