hackerrank_while_language_implementation.hs

{-
  sources:
    https://mukeshiiitm.wordpress.com/2014/01/30/while-interpreter/
    http://www.stephendiehl.com/llvm/
    https://hackage.haskell.org/package/while-lang-parser-0.1.0.0/docs/src/Language-While-Parser.html
    https://github.com/m00nlight/hackerrank/blob/master/functional/Interpreter-and-Compiler/While-Language/main.hs
-}


import System.IO
import Control.Monad
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as Token
import qualified Data.Map                            as M


-- a ::= x | n | -a | a opa a
-- b ::= true | false | not b | b opb b | a opr a
-- opa ::= + | - | * | /
-- opb ::= and | or
-- opr ::= > | <
-- S ::= x := a | skip | S1; S2 | ( S ) | if b then S1 else S2 | while b do S


data BExpr = BoolConst Bool
           | Not BExpr
           | BBinary BBinOp BExpr BExpr
           | RBinary RBinOp AExpr AExpr
           deriving (Show)

data BBinOp = And | Or deriving (Show)

data RBinOp = Greater | Less deriving (Show)

data AExpr = Var String
           | IntConst Integer
           | Neg AExpr
           | ABinary ABinOp AExpr AExpr
           deriving (Show)

data ABinOp = Add
            | Subtract
            | Multiply
            | Divide
            deriving (Show)

data Stmt = Seq [Stmt]
          | Assign String AExpr
          | If BExpr Stmt Stmt
          | While BExpr Stmt
          | Skip
          deriving (Show)

languageDef =
  emptyDef { Token.commentStart    = "/*"
           , Token.commentEnd      = "*/"
           , Token.commentLine     = "//"
           , Token.identStart      = letter
           , Token.identLetter     = alphaNum
           , Token.reservedNames   = [ "if"
                                     , "then"
                                     , "else"
                                     , "while"
                                     , "do"
                                     , "skip"
                                     , "true"
                                     , "false"
                                     , "not"
                                     , "and"
                                     , "or"
                                     ]
           , Token.reservedOpNames = [ "+", "-", "*", "/", ":="
                                     , "<", ">", "and", "or", "not"
                                     ]
           }

  
lexer      = Token.makeTokenParser languageDef
identifier = Token.identifier lexer
reserved   = Token.reserved   lexer
reservedOp = Token.reservedOp lexer
parens     = Token.parens     lexer
braces     = Token.braces     lexer
integer    = Token.integer    lexer
semi       = Token.semi       lexer
whiteSpace = Token.whiteSpace lexer


whileParser :: Parser Stmt
whileParser = whiteSpace >> statement


statement :: Parser Stmt
statement =   parens statement
          <|> braces statement
          <|> sequenceOfStmt


sequenceOfStmt = do
  list <- (sepBy1 statement' semi)
  return $ if length list == 1 then head list else Seq list


statement' :: Parser Stmt 
statement' = ifStmt
          <|> whileStmt
          <|> skipStmt
          <|> assignStmt


ifStmt :: Parser Stmt
ifStmt = do
  reserved "if"
  cond <- bExpression
  reserved "then"
  stmt1 <- statement
  reserved "else"
  stmt2 <- statement
  return $ If cond stmt1 stmt2


whileStmt :: Parser Stmt
whileStmt = do
  reserved "while"
  cond <- bExpression
  reserved "do"
  stmt <- statement
  return $ While cond stmt


assignStmt :: Parser Stmt
assignStmt = do
  var <- identifier
  reservedOp ":="
  expr <- aExpression
  return $ Assign var expr


skipStmt :: Parser Stmt
skipStmt = reserved "skip" >> return Skip


aExpression :: Parser AExpr
aExpression = buildExpressionParser aOperators aTerm


bExpression :: Parser BExpr
bExpression = buildExpressionParser bOperators bTerm


aOperators = [ [Prefix (reservedOp "-" >> return (Neg             ))          ]
             , [Infix  (reservedOp "*" >> return (ABinary Multiply)) AssocLeft,
                Infix  (reservedOp "/" >> return (ABinary Divide  )) AssocLeft]
             , [Infix  (reservedOp "+" >> return (ABinary Add     )) AssocLeft,
                Infix  (reservedOp "-" >> return (ABinary Subtract)) AssocLeft]
             ]

bOperators = [ [Prefix (reservedOp "not" >> return (Not        ))          ]
             , [Infix  (reservedOp "and" >> return (BBinary And)) AssocLeft,
                Infix  (reservedOp "or"  >> return (BBinary Or )) AssocLeft]
             ]


aTerm =   parens aExpression
      <|> braces aExpression
      <|> liftM Var identifier
      <|> liftM IntConst integer

      
bTerm =   parens bExpression
      <|> braces bExpression
      <|> (reserved "true"  >> return (BoolConst True))
      <|> (reserved "false" >> return (BoolConst False))
      <|> rExpression


rExpression = do
  a1 <- aExpression
  op <- relation
  a2 <- aExpression
  return $ RBinary op a1 a2


relation =   (reservedOp ">" >> return Greater)
         <|> (reservedOp "<" >> return Less)


parseString :: String -> Stmt
parseString str = case
  parse whileParser "" str of
  Left e  -> error $ show e
  Right r -> r


parseFile :: String -> IO Stmt
parseFile file = do
  program <- readFile file
  case
    parse whileParser "" program of
    Left e  -> print e >> fail "parse error"
    Right r -> return r


type Env = M.Map String Integer


evalA :: AExpr -> Env -> Integer
evalA (Var v)            env = M.findWithDefault 0 v env
evalA (IntConst n)       _   = n
evalA (Neg e)            env = -(evalA e env)
evalA (ABinary op e1 e2) env = 
  case op of
    Add      -> evalA e1 env + evalA e2 env
    Subtract -> evalA e1 env - evalA e2 env
    Multiply -> evalA e1 env * evalA e2 env
    Divide   -> (evalA e1 env) `div` (evalA e2 env)


evalB :: BExpr -> Env -> Bool
evalB (BoolConst b)      _   = b
evalB (Not e)            env = not $ evalB e env
evalB (BBinary op e1 e2) env = 
  case op of 
    And -> evalB e1 env && evalB e2 env
    _   -> evalB e1 env || evalB e2 env
evalB (RBinary op e1 e2) env = 
  case op of
    Greater -> evalA e1 env > evalA e2 env
    _       -> evalA e1 env < evalA e2 env


interpreter :: Stmt -> Env -> Env
interpreter (Assign v expr) env = M.insert v (evalA expr env) env
interpreter (Seq [])        env = env
interpreter (Seq (x:xs))    env = interpreter (Seq xs) (interpreter x env)
interpreter (If e st1 st2) env
          | evalB e env = interpreter st1 env
          | otherwise   = interpreter st2 env
interpreter (While e st) env
          | not (evalB e env) = env
          | otherwise         = interpreter (While e st) newEnv
  where
    newEnv = interpreter st env


main :: IO()
main = do
  ast <- fmap parseString getContents
  mapM_ (\(x, y) -> putStrLn $ x ++ " " ++ (show y)) $  M.toList $ interpreter ast M.empty