hatt-0.3: src/hatt.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Main
    ( main
    ) where

import Data.Logic.Propositional

import Data.Char (isSpace, toLower)
import System.Console.CmdArgs
import System.IO

data HattOpts = HattOpts
    { evaluate    :: String
    , interactive :: Bool
    , pretty      :: Bool
    } deriving (Show, Data, Typeable)

data Command = Exit
             | Help
             | Eval Expr
             | Error String

hattOpts :: HattOpts
hattOpts = HattOpts
  { evaluate    = "" &= typ  "EXPRESSION"
                     &= help "Print the truth table for the given expression"
  , interactive = False &= help "Enter interactive mode"
  , pretty      = False &= help "Use Unicode logic symbols"
  } &= summary "Hatt 0.3, (c) Benedict Eastaugh 2011"
    &= program "hatt"

main :: IO ()
main = do opts <- cmdArgs hattOpts
          let expStr    = evaluate opts
              interMode = interactive opts
              evalMode  = (not . null) expStr
              printer   = if pretty opts then show else showAscii
          
          -- If the --evaluate flag is passed with an expression, print the
          -- truth table for that expression.
          if evalMode
            then putStr $ eval printer expStr
            else return ()
          
          -- If the --evaluate flag is passed with an expression and
          -- interactive mode is NOT explicitly requested, terminate the
          -- program; otherwise, enter interactive mode.
          if evalMode && not interMode
            then return ()
            else putStrLn replIntroText >> repl printer

repl :: (Expr -> String) -> IO ()
repl p = do putStr "> "
            hFlush stdout
            cmd <- getLine
            case parseCommand cmd of
              Exit        -> return ()
              Help        -> putStr   replHelpText         >> repl p
              (Eval expr) -> putStr   (truthTableP p expr) >> repl p
              (Error err) -> putStrLn ("Error: " ++ err)   >> repl p

eval :: (Expr -> String) -> String -> String
eval p str = case parseExpr "" str of
               Left  err  -> "Parse error at " ++ show err ++ "\n"
               Right expr -> truthTableP p expr

parseCommand :: String -> Command
parseCommand input = case cmd . words . dropWhile isSpace $ input of
                       ""     -> Error "you must enter an expression or a command."
                       "exit" -> Exit
                       "help" -> Help
                       _      -> eval_ input
  where
    cmd []    = ""
    cmd ws    = map toLower . head $ ws
    eval_ str = case parseExpr "" str of
                  Left  err  -> Error $ "parse error at " ++ show err
                  Right expr -> Eval expr

replIntroText :: String
replIntroText = unwords
  [ "Entering interactive mode."
  , "Type `help` if you don't know what to do!"
  ]

replHelpText :: String
replHelpText = unlines
  [ "Hatt's interactive mode has a couple of commands."
  , ""
  , "help"
  , "  Print this help text."
  , ""
  , "exit"
  , "  Quit the program."
  , ""
  , "If you don't type in a command, the program will assume you're writing a"
  , "logical expression to be evaluated and attempt to parse it."
  , ""
  , "For example, if you enter \"(A -> B)\" at the prompt, Hatt will print the"
  , "truth table for that expression. Here's an example console session."
  , ""
  , "    > (A | B)"
  , "    A B | (A ∨ B)"
  , "    -------------"
  , "    T T | T"
  , "    T F | T"
  , "    F T | T"
  , "    F F | F"
  , "    > foobar"
  , "    Error: parse error at (line 1, column 1):"
  , "    unexpected \"f\""
  , "    expecting white space, \"(\" or \"~\""
  , "   > exit"
  , ""
  , "If none of this makes any sense, try reading the README file."
  ]