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