import DDCI.Core.State import DDCI.Core.Command.Help import DDCI.Core.Command.Set import DDCI.Core.Command.Check import DDCI.Core.Command.Eval import DDCI.Core.Command.Trans import DDCI.Core.Command.Ast import System.Environment import Data.List import Data.Maybe import qualified System.Console.Haskeline as HL import qualified System.Console.Haskeline.IO as HL main :: IO () main = do args <- getArgs case args of [fileName] -> do file <- readFile fileName runBatch file _ -> runInteractive -- Command -------------------------------------------------------------------- -- | The commands that the interpreter supports. data Command = CommandBlank | CommandUnknown | CommandHelp | CommandSet | CommandKind | CommandEquivType | CommandWitType | CommandExpCheck | CommandExpRecon | CommandExpType | CommandExpEffect | CommandExpClosure | CommandEval | CommandTrans | CommandTransEval | CommandAst deriving (Eq, Show) -- | Names used to invoke each command. commands :: [(String, Command)] commands = [ (":help", CommandHelp) , (":?", CommandHelp) , (":set", CommandSet) , (":kind", CommandKind) , (":tequiv", CommandEquivType) , (":wtype", CommandWitType) , (":check", CommandExpCheck) , (":recon", CommandExpRecon) , (":type", CommandExpType) , (":effect", CommandExpEffect) , (":closure", CommandExpClosure) , (":eval", CommandEval) , (":trans", CommandTrans) , (":trun", CommandTransEval) , (":ast", CommandAst) ] -- | Read the command from the front of a string. readCommand :: String -> Maybe (Command, String) readCommand ss | null $ words ss = Just (CommandBlank, ss) | [(cmd, rest)] <- [ (cmd, drop (length str) ss) | (str, cmd) <- commands , isPrefixOf str ss ] = Just (cmd, rest) | ':' : _ <- ss = Just (CommandUnknown, ss) | otherwise = Nothing -- InputState ---------------------------------------------------------------------- -- Interpreter input state data InputState = InputState { -- Command that we're still receiving input for, -- along with the line number it started on. inputCommand :: Maybe (Command, Int) -- Input mode. , _inputMode :: Input -- Current line number, used for parse error messages. , inputLineNumber :: Int -- Accumulation of current input buffer. , _inputAcc :: String } -- | How we're reading the input expression. data Input -- | Read input line-by-line, using a backslash at the end of the -- line to continue to the next. = InputLine -- | Read input as a block terminated by a double semicolon (;;) | InputBlock deriving (Eq, Show) -- | Read the input mode from the front of a string. readInput :: String -> (Input, String) readInput ss | isPrefixOf ".." ss = (InputBlock, drop 2 ss) | otherwise = (InputLine, ss) -- Interactive ---------------------------------------------------------------- -- | Run an interactive session runInteractive :: IO () runInteractive = do putStrLn "DDCi-core, version 0.2.1: http://disciple.ouroborus.net. :? for help" -- Setup terminal mode. loopInteractive -- | The main REPL loop. loopInteractive :: IO () loopInteractive = do hlState <- HL.initializeInput HL.defaultSettings let inputState = InputState Nothing InputLine 1 [] loop initState inputState hlState where loop state inputState hlState = do -- If this isn't the first line then print the prompt. let prompt = if isNothing (inputCommand inputState) then "> " else "" -- Read a line from the user and echo it back. line <- getInput hlState prompt if isPrefixOf ":quit" line then return () else do (state', inputState') <- eatLine state inputState line loop state' inputState' hlState -- | Get an input line from the console, using given prompt getInput :: HL.InputState -> String -> IO String getInput hlState prompt = do line <- HL.queryInput hlState (HL.getInputLine prompt) return (fromMaybe ":quit" line) -- Batch ---------------------------------------------------------------------- runBatch :: String -> IO () runBatch str = do let inputState = InputState Nothing InputLine 1 [] loop initState inputState (lines str) where -- No more lines, we're done. -- There might be a command in the buffer though. loop state inputState [] = do eatLine state inputState [] return () loop state inputState (l:ls) -- Echo comment lines back. | isPrefixOf "--" l = do putStrLn l let inputState' = inputState { inputLineNumber = inputLineNumber inputState + 1 } loop state inputState' ls -- Echo blank lines back if we're between commands. | Nothing <- inputCommand inputState , null l = do putStr "\n" let inputState' = inputState { inputLineNumber = inputLineNumber inputState + 1 } loop state inputState' ls -- Quit the program. | isPrefixOf ":quit" l = do return () -- Handle a line of input. | otherwise = do (state', inputState') <- eatLine state inputState l loop state' inputState' ls -- Eat ------------------------------------------------------------------------ -- Eating input lines. eatLine :: State -> InputState -> String -> IO (State, InputState) eatLine state (InputState mCommand inputMode lineNumber acc) line = do -- If this is the first line then try to read the command and -- input mode from the front so we know how to continue. -- If we can't read an explicit command then assume this is -- an expression to evaluate. let (cmd, lineStart, (input, rest)) = case mCommand of Nothing -> case readCommand line of Just (cmd', rest') -> (cmd', lineNumber, readInput rest') Nothing -> (CommandEval, lineNumber, (InputLine, line)) Just (cmd', lineStart') -> (cmd', lineStart', (inputMode, line)) case input of -- For line-by-line mode, if the line ends with backslash then keep -- reading, otherwise run the command. -- We also convert the backslash to a newline so the source -- position comes out right in parser error messages. InputLine | not $ null rest , last rest == '\\' -> do return ( state , InputState (Just (cmd, lineStart)) input (lineNumber + 1) (acc ++ init rest ++ "\n")) | otherwise -> do state' <- handleCmd state cmd lineStart (acc ++ rest) return ( state' , InputState Nothing InputLine (lineNumber + 1) []) -- For block mode, if the line ends with ';;' then run the command, -- otherwise keep reading. InputBlock | isSuffixOf ";;" rest -> do let rest' = take (length rest - 2) rest state' <- handleCmd state cmd lineStart (acc ++ rest') return ( state' , InputState Nothing InputLine (lineNumber + 1) []) | otherwise -> return ( state , InputState (Just (cmd, lineStart)) input (lineNumber + 1) (acc ++ rest ++ "\n")) -- Commands ------------------------------------------------------------------- -- | Handle a single line of input. handleCmd :: State -> Command -> Int -> String -> IO State handleCmd state CommandBlank _ _ = return state handleCmd state cmd lineStart line = do state' <- handleCmd1 state cmd lineStart line return state' handleCmd1 state cmd lineStart line = case cmd of CommandBlank -> return state CommandUnknown -> do putStr $ unlines [ "unknown command." , "use :? for help." ] return state CommandHelp -> do putStr help return state CommandSet -> do state' <- cmdSet state line return state' CommandKind -> do cmdShowKind state lineStart line return state CommandEquivType -> do cmdTypeEquiv state lineStart line return state CommandWitType -> do cmdShowWType state lineStart line return state CommandExpCheck -> do cmdShowType state ShowTypeAll lineStart line return state CommandExpType -> do cmdShowType state ShowTypeValue lineStart line return state CommandExpEffect -> do cmdShowType state ShowTypeEffect lineStart line return state CommandExpClosure -> do cmdShowType state ShowTypeClosure lineStart line return state CommandExpRecon -> do cmdExpRecon state lineStart line return state CommandEval -> do cmdEval state lineStart line return state CommandTrans -> do cmdTrans state lineStart line return state CommandTransEval -> do cmdTransEval state lineStart line return state CommandAst -> do cmdAst state lineStart line return state