https://www.hackerrank.com/challenges/while-language-fp

While.hs

import Control.Applicative
import Control.Monad.State
import Text.ParserCombinators.Parsec hiding ((<|>), State)
import qualified Data.Map as M

data OpA = (:+:) | (:-:) | (:*:) | (:/:) deriving (Eq,Show)
data OpB = And | Or deriving (Eq,Show)
data OpR = (:>) | (:<) deriving (Eq,Show)
newtype Var = Var String deriving (Eq,Ord,Show)
data AExp = VarExp Var | Numeral Integer | ApplyA OpA AExp AExp
  deriving (Eq,Show)
data BExp = WTrue | WFalse | ApplyB OpB BExp BExp | ApplyR OpR AExp AExp
  deriving (Eq,Show)
data Stmt = Subst Var AExp | (:.) Stmt Stmt | If BExp Stmt Stmt | While BExp Stmt deriving (Eq,Show)
type WL = State (M.Map String Integer)

applyA :: AExp -> WL Integer
applyA (ApplyA (:+:) a b) = (+) <$> applyA a <*> applyA b
applyA (ApplyA (:-:) a b) = (-) <$> applyA a <*> applyA b
applyA (ApplyA (:*:) a b) = (*) <$> applyA a <*> applyA b
applyA (ApplyA (:/:) a b) = div <$> applyA a <*> applyA b
applyA (VarExp (Var v)) = (M.! v) <$> get
applyA (Numeral n) = return n

applyB :: BExp -> WL Bool
applyB WTrue = return $ True
applyB WFalse = return $ False
applyB (ApplyB And a b) = (&&) <$> applyB a <*> applyB b
applyB (ApplyB Or a b) = (||) <$> applyB a <*> applyB b
applyB (ApplyR (:>) a b) = (>) <$> applyA a <*> applyA b
applyB (ApplyR (:<) a b) = (<) <$> applyA a <*> applyA b

eval :: Stmt -> WL ()
eval (Subst (Var v) e) = do
  u <- applyA e
  modify $ M.insert v u
eval (s :. t) = eval s >> eval t
eval (If b t e) = applyB b >>= \tf -> if tf then eval t else eval e
eval w@(While b t) = do
  tf <- applyB b
  if tf then eval t >> eval w else return ()

symbol s = spaces >> string s >> spaces
parseVar = Var <$> many1 letter

parseAExp :: Parser AExp
parseAExp = spaces >> (term `chainl1` parseAdd) where
  term = factor `chainl1` parseMul
  factor = try parseParen <|> try parseNumerals <|> try parseVarExp

  parseVarExp = VarExp <$> parseVar
  parseNumerals = Numeral . read <$> many1 digit
  parseParen = between (symbol "(") (symbol ")") parseAExp
  parseAdd = do
    try (symbol "+" *> return (ApplyA (:+:)))
    <|> try (symbol "-" *> return (ApplyA (:-:)))
  parseMul = do
    try (symbol "*" *> return (ApplyA (:*:)))
    <|> try (symbol "/" *> return (ApplyA (:/:)))

parseBExp :: Parser BExp
parseBExp = spaces >> (term `chainl1` try parseOr) where
  term = factor `chainl1` try parseAnd
  factor = try parseParen <|> try parseApplyR <|> try parseBoolean

  parseBoolean = do
    try (const WTrue <$> symbol "true")
    <|> try (const WFalse <$> symbol "false")
  parseParen = between (symbol "(") (symbol ")") parseBExp
  parseApplyR = do
    try (ApplyR (:<) <$> parseAExp <*> (symbol "<" *> parseAExp))
    <|> try (ApplyR (:>) <$> parseAExp <*> (symbol ">" *> parseAExp))
  parseOr = symbol "or" *> return (ApplyB Or)
  parseAnd = symbol "and" *> return (ApplyB And)

parseStmt :: Parser Stmt
parseStmt = spaces >> (try parseSubst <|> try parseIf <|> try parseWhile) where
  parseSubst = do
    a <- parseVar
    Subst a <$> (symbol ":=" *> parseAExp)
  parseIf = do
    b <- symbol "if" *> parseBExp
    If b
      <$> (symbol "then" *> between (symbol "{") (symbol "}") parseWL) 
      <*> (symbol "else" *> between (symbol "{") (symbol "}") parseWL)
  parseWhile = do
    b <- symbol "while" *> parseBExp
    While b <$> (symbol "do" *> between (symbol "{") (symbol "}") parseWL)

parseWL :: Parser Stmt
parseWL = spaces >> (try parseComma <|> parseStmt) where
  parseComma = do
    a <- parseStmt
    (a :.) <$> (symbol ";" *> parseWL)

main = do
  code <- getContents
  case parse parseWL "" code of
    Left err -> print err
    Right w -> mapM_ (putStrLn . (\(x,y) -> x ++ " " ++ show y)) $ M.assocs $ execState (eval w) M.empty