parse.hs

import Control.Monad (fail)
import Control.Monad.Trans (lift, liftIO)
import Text.Parsec ((<|>), (<?>))
import Text.Read (readMaybe)
import System.IO (hFlush, stdout)

import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.HashMap.Strict as HashMap
import qualified Text.Parsec as P

-- This program demonstrates how *not* to write a parser.
-- Haskell is cool because it forces you to separate the pure parts
-- of your program (like parsing) from the parts that perform I/O
-- and modify state and whatnot.
--
-- It would be easy to jump to the conclusion that Haskell makes
-- it impossible to mix stateful and pure code, but this is not the case.
-- It simply makes it more difficult.
--
-- This program implements a simple interactive calculator. If you download
-- this file
-- and run it with `runhaskell parse.hs` (note dependencies) you'll see
-- a prompt, like the one below, which you can type simple arithmetic
-- expressions into.
--
--   > 1 + 1
--   2
--   > 2+3*(5+4)
--   29
--   >
--
-- You can also assign and use variables
--
--   > a = 6
--   > b = a * 7
--   > b - a/3
--   40
--   >
--
-- If you reference a non-existing variable or input invalid syntax,
-- you'll get an error and the program will exit. This is because we
-- aren't actually reading the input line-by-line, but rather
-- parsing the entire input at once.
-- I couldn't find any way in to recover the parse while also hanging on to the
-- parse error,
-- but this is more of a shortcoming of the Parsec library than Haskell;
-- in particular, it looks like Megaparsec could do it.
--
--   > z
--   parse.hs: user error (undefined variable z)
--
--   > 1 & 2
--   1
--   (line 1, column 3):
--   unexpected '&'
--   expecting " ", operator or newline

-- Required packages:
--   parsec
--   transformers


type Parser = P.ParsecT String () (State.StateT Env IO)
type Env = HashMap.HashMap String Integer

prog :: Parser ()
prog = do
    P.sepEndBy (do { prompt; spaces; stmt }) newline
    P.eof <?> ""

prompt :: Parser ()
prompt = liftIO $ do
    putStr "> "
    hFlush stdout

stmt :: Parser ()
stmt = assignment <|> exprStmt <|> emptyStmt where
    emptyStmt = do
        P.lookAhead P.anyToken
        return ()
    exprStmt = do
        e <- expr
        liftIO $ print e
    assignment = do
        v <- P.try $ do
            v <- lvar
            token '='
            return v
        e <- expr
        lift . State.modify $ HashMap.insert v e

expr :: Parser Integer
expr = expr1 where
    expr1 = P.chainl1 expr2 addop
    expr2 = P.chainl1 expr3 mulop
    expr3 = val <|> rvar <|> parenExpr
    parenExpr = P.between (token '(') (token ')') expr

    mulop = do { token '*'; return (*) }
        <|> do { token '/'; return (div) }
        <?> "operator"
    addop = do { token '+'; return (+) }
        <|> do { token '-'; return (-) }
        <?> "operator"

token :: Char -> Parser Char
token c = do
    c <- P.char c
    spaces
    return c

val :: Parser Integer
val = do
    v <- P.many1 P.digit <?> "number"
    spaces
    case readMaybe v of
        Just x -> return x
        Nothing -> fail "not a number"

lvar :: Parser String
lvar = do
    v <- P.many1 P.letter <?> "variable"
    spaces
    return v

rvar :: Parser Integer
rvar = do
    v <- P.many1 P.letter <?> "variable"
    spaces
    lift $ do
        env <- State.get
        case HashMap.lookup v env of
            Just x -> return x
            Nothing -> fail $ "undefined variable " ++ v

spaces :: Parser ()
spaces = P.skipMany (P.char ' ') <?> "whitespace"

newline :: Parser ()
newline = do
    P.optional (P.char '\r')
    P.char '\n'
    return ()
    <?> "newline"

main = do
    input <- getContents
    let state = P.runParserT prog () "" input
    result <- State.evalStateT state HashMap.empty
    case result of
        Left err -> print err
        Right () -> putStr "\n"