Simple Haskell calculator

calculator.cabal

cabal-version:  3.4
name:           calculator
version:        0.0.0
build-type:     Simple

executable calculator
  main-is: calculator.hs
  build-depends:
    , base >=4.7 && <5
    , containers
    , mtl
    , parsec
    , text
    , unordered-containers
  default-language: Haskell2010
  ghc-options:
    -Wall -Wcompat -Widentities -Wincomplete-uni-patterns
    -Winvalid-haddock -Wpartial-fields -Wredundant-constraints -Wtabs
    -Wunused-packages -fhide-source-paths

calculator.hs

-- run with:
--   cabal build
--   cabal run calculator -- --debug

{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}

module Main where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Foldable
import Data.Function        ((&))
import Data.HashMap.Strict  as HashMap
import Data.List            qualified as List
import Data.Sequence        as Seq
import Data.Text            as Text
import Data.Text.IO         as Text
import System.Environment
import System.Exit
import System.IO            (hFlush, stdout)
import Text.Parsec
import Text.Printf          (printf)


--------------------------------------------------------------------------------
-- types

data AppConfig = AppConfig
  { debugMode :: Bool
  }

type VarName = Text

type Variables = HashMap VarName Int

data Statement
  = SetVariable VarName Expression
  | ComputeExpression Expression
  | ClearVariables
  | ListVariables
  | Quit

data Expression
  = Literal        Int
  | Variable       VarName
  | Addition       Expression Expression
  | Subtraction    Expression Expression
  | Multiplication Expression Expression
  | Division       Expression Expression
  | Modulo         Expression Expression


type AppMonad =
  ExceptT Text (
    WriterT (Seq Text) (
      ReaderT AppConfig (
        StateT Variables (
          IO
  ))))


--------------------------------------------------------------------------------
-- evaluation

evaluate :: Expression -> AppMonad Int
evaluate = \case
  Literal lit ->
    pure lit
  Variable varName -> do
    variables <- get
    case HashMap.lookup varName variables of
      Nothing ->
        throwError $ "variable not found: " <> varName
      Just value -> do
        debugLog $ printf ": %s = %d" varName value
        pure value
  Addition lhs rhs -> do
    lhsValue <- evaluate lhs
    rhsValue <- evaluate rhs
    process (+) "+" lhsValue rhsValue
  Subtraction lhs rhs -> do
    lhsValue <- evaluate lhs
    rhsValue <- evaluate rhs
    process (-) "-" lhsValue rhsValue
  Multiplication lhs rhs -> do
    lhsValue <- evaluate lhs
    rhsValue <- evaluate rhs
    process (*) "*" lhsValue rhsValue
  Division lhs rhs -> do
    lhsValue <- evaluate lhs
    rhsValue <- evaluate rhs
    when (rhsValue == 0) $
      throwError "division by zero"
    process div "/" lhsValue rhsValue
  Modulo lhs rhs -> do
    lhsValue <- evaluate lhs
    rhsValue <- evaluate rhs
    when (rhsValue == 0) $
      throwError "division by zero"
    process mod "%" lhsValue rhsValue
  where
    debugLog
      :: String
      -> AppMonad ()
    debugLog line = do
      config <- ask
      when (debugMode config) $
        tell $ Seq.singleton $ Text.pack line

    process
      :: (Int -> Int -> Int)
      -> String
      -> Int
      -> Int
      -> AppMonad Int
    process opFunction opText lhs rhs = do
      let
        result  = lhs `opFunction` rhs
        logLine = printf ": %d %s %d = %d" lhs opText rhs result
      debugLog logLine
      pure result

execute :: Statement -> AppMonad Bool
execute = \case
  SetVariable name expression -> do
    value <- evaluate expression
    modify $ HashMap.insert name value
    pure True
  ComputeExpression expression -> do
    value <- evaluate expression
    tell $ Seq.singleton $ Text.pack $ show value
    pure True
  ListVariables -> do
    variables <- get
    for_ (HashMap.toList variables) \(name, value) -> tell
      $ Seq.singleton
      $ Text.pack
      $ printf "%s = %d" name value
    pure True
  ClearVariables -> do
    put $ HashMap.empty
    pure True
  Quit -> do
    pure False


--------------------------------------------------------------------------------
-- parsing

parseLine :: Text -> AppMonad Statement
parseLine line =
  case parse statement "<interactive>" line of
    Right parsedStatement -> pure parsedStatement
    Left  parseError      -> throwError $ Text.pack $ show parseError
  where
    -- statements
    statement = choice
      [ quit
      , list
      , clear
      , assign
      , expr
      ]
    quit   = Quit           <$ (symbol ":quit"  <|> symbol ":q")
    list   = ListVariables  <$ (symbol ":list"  <|> symbol ":l")
    clear  = ClearVariables <$ (symbol ":clear" <|> symbol ":c")
    expr   = ComputeExpression <$> expression
    assign = try do
      v <- identifier
      void $ symbol "="
      e <- expression
      pure $ SetVariable v e

    -- expressions
    expression     = binary addition       "-" Subtraction
    addition       = binary modulo         "+" Addition
    modulo         = binary division       "%" Modulo
    division       = binary multiplication "/" Division
    multiplication = binary term           "*" Multiplication
    term           = choice [variable, literal, parens]
    variable       = Variable <$> identifier
    literal        = Literal  <$> number
    parens         = symbol "(" *> expression <* symbol ")"
    binary operand operator constructor = do
      firstOperand  <- operand
      otherOperands <- many (symbol operator >> operand)
      pure $ List.foldl' constructor firstOperand otherOperands

    -- elements
    symbol s = try (string s <* spaces)
    number = fmap read $ many1 digit <* spaces
    identifier = fmap Text.pack $ many1 lower <* spaces


--------------------------------------------------------------------------------
-- main

runApp
  :: AppConfig
  -> ReaderT AppConfig (StateT Variables IO) ()
  -> IO ()
runApp config action = action
  & flip runReaderT config
  & flip evalStateT HashMap.empty

runStatement
  :: AppMonad Bool
  -> ReaderT AppConfig (StateT Variables IO) Bool
runStatement action = do
  (result, logLines) <- action & runExceptT & runWriterT
  traverse_ (liftIO . Text.putStrLn) logLines
  case result of
    Left errorMsg -> do
      liftIO $ Text.putStrLn errorMsg
      pure True
    Right shouldContinue ->
      pure shouldContinue

usage :: IO ()
usage = do
  progName <- getProgName
  Text.putStrLn $ "usage: " <> Text.pack progName <> " [--debug]"
  exitFailure

main :: IO ()
main = do
  args <- getArgs
  case args of
    []          -> runApp (AppConfig False) go
    ["--debug"] -> runApp (AppConfig True ) go
    _           -> usage
  where
    go = do
      userInput <- liftIO do
        Text.putStr "> "
        hFlush stdout
        Text.strip <$> Text.getLine
      if Text.null userInput
      then go
      else do
        shouldContinue <- runStatement do
          execute =<< parseLine userInput
        when shouldContinue go