gistfile1.hs

module Main where
import Data.Maybe
import Data.Monoid
import Control.Applicative
import Control.Monad.State
import Control.Lens
import Text.Trifecta

main :: IO ()
main = do
  putStrLn "-------------------------------------"
  putStrLn "Please input expression or \"exit\": "
  input <- getLine 
  if input=="exit"
    then return ()
    else do
      exp <- return . parseString (expression <* eof) mempty $ input
      case exp of
        Success e -> showResult (rpnCalc . rpnTrans $ e)
        Failure d -> putStrLn $ show d
      main

showResult :: Maybe Double -> IO ()
showResult Nothing = putStrLn "Unexpected error"
showResult (Just x) = putStrLn $ "Result : " ++ show x

-----------------------------
--パーサー

--型定義
data Operator = Add | Sub | Div | Mul deriving (Show, Read, Eq, Ord)
data Term = TVal Double | TOpe Operator | TNest Expression deriving (Show, Read, Eq, Ord)
type Expression = [Term]

--数値リテラル
numLit :: Parser Term 
numLit = toVal <$> integerOrDouble <?> "value"
  where
    toVal :: Either Integer Double -> Term
    toVal (Left x)  = TVal . fromIntegral $ x
    toVal (Right x) = TVal x

--演算子
operator :: Parser Term
operator = TOpe <$> (ope Add '+' <|> ope Sub '-' <|> ope Mul '*' <|> ope Div '/') <?> "operator"
  where
    ope o c = o <$ word (char c)

--かっこによるネスト
nest :: Parser Term
nest = TNest <$> parens expression

--式全体
expression :: Parser Expression
expression = (numLit <|> nest) <:> (try (operator <:> expression) <|> pure [])

--------

infixr 5 <:> 
(<:>) :: Applicative f => f a -> f [a] -> f [a]
x <:> y = (:) <$> x <*> y

word :: Parser a -> Parser a
word p = spaces *> p <* spaces

-----------------------------
-- 逆ポーランド変換

-- 型定義
data RPN = RVal Double | ROpe Operator deriving (Show, Read, Eq, Ord)

-- RPN変換作業用Stateモナド
type RPNState = State ([RPN], [Operator])

tpush :: Operator -> RPNState ()
tpush x = _2 %= (x:)

tpop :: RPNState (Maybe Operator)
tpop = do
  x <- use _2
  _2 .= safetail x
  return $ listToMaybe x

write :: RPN -> RPNState ()
write x = _1 %= (x:)

-- RPN変換
rpnTrans :: Expression -> [RPN]
rpnTrans x  = reverse . fst . snd . runState (rpnTranslate x) $ ([], [])

rpnTranslate :: Expression -> RPNState ()
rpnTranslate [] = do
  p <- tpop
  case p of
    Nothing -> return () 
    Just  x -> (write $ ROpe x) >> rpnTranslate []
rpnTranslate (TVal  x :xs) = write (RVal x) >> rpnTranslate xs
rpnTranslate (TOpe  x :xs) = do
  p <- tpop
  case p of
    Nothing -> tpush x >> rpnTranslate xs
    Just  y -> if y < x
      then tpush y >> tpush x >> rpnTranslate xs
      else tpush x >> write (ROpe y) >> rpnTranslate xs
rpnTranslate (TNest x :xs) = do
  (res, _) <- return . snd . runState (rpnTranslate x) $ ([], [])
  _1 %= (res++)
  rpnTranslate xs

-----------------------------
-- RPN計算

-- 型定義
type RPNCalc = State [Double]

cpush :: Double -> RPNCalc ()
cpush x = modify (x:)

cpop :: RPNCalc (Maybe Double)
cpop = do
  x <- get
  modify safetail
  return $ listToMaybe x

-- 計算実行
rpnCalc :: [RPN] -> Maybe Double
rpnCalc xs = listToMaybe . snd . runState (rpnCalcurator xs) $ []

rpnCalcurator :: [RPN] -> RPNCalc ()
rpnCalcurator []     = return ()
rpnCalcurator (RVal x: xs) = cpush x >> rpnCalcurator xs
rpnCalcurator (ROpe o: xs) = do
    x <- cpop
    y <- cpop
    res <- return $ ope2Func o <$> y <*> x
    case res of
      Nothing -> put [] >> return ()
      Just val -> cpush val >> rpnCalcurator xs

ope2Func :: Fractional a => Operator -> (a -> a -> a)
ope2Func Add = (+)
ope2Func Sub = (-)
ope2Func Mul = (*)
ope2Func Div = (/)

-----------------------------
-- Helper

safetail :: [a] -> [a]
safetail [] = []
safetail (_:xs) = xs