wtk-0.2: Text/Calculator.hs

---------------------------------------------------------
--
-- Module        : Caclulator
-- Copyright     : Bartosz Wójcik (2012)
-- License       : BSD3
--
-- Maintainer    : bartek@sudety.it
-- Stability     : Unstable
-- Portability   : portable
--
-- Module is part of Wojcik Tool Kit package.
-- | Simple calculator. Evaluates arithmetic formulas.
---------------------------------------------------------
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction #-}
module Text.Calculator (
       evaluate     -- Evaluates arithmetic formula.       
      ,evaluateInt  -- Evaluates arithmetic formula on @Integer@s.
                  )
where

import Control.Monad
import Control.Monad.Trans.Error
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.Char
import Data.Either
import Text.WtkParser



-- | State contains just operator
type State1 a = (a -> a -> a)

-- | Only limited operators are available, 
--   they are shown using some trick.
instance (Num a) => Show (State1 a) where
   show f | 3 `f` 2 == 6 = "*"
          | 3 `f` 2 == 5 = "+"
          | 3 `f` 2 == 1 = "-"
          | 3 `f` 2 == 8 = "^"
          | otherwise    = "/"

-- | Calculator parser is just simple wtk parser with added state.
--   State keeps not yet consumed operator.
type Parser1 a = StateT (State1 a) Parser a

runParser1 :: (Num a) => State1 a -> Parser1 a -> String -> Either String (String, (a, (State1 a)))
runParser1 st e = runParser $ runStateT e st

-- | Evaluates arithmetic formula. In case formula cannot be parsed
--   returns error message.
evaluate :: (Floating a, RealFrac a, Ord a) => String -> Either String a
evaluate x = case runParser1 (+) arithmetic x of
             Left err          -> Left err
             Right (_,(res,_)) -> Right res

-- | Integer version of @evaluate@.
evaluateInt :: String -> Either String Integer
evaluateInt x = case runParser1 (+) arithmeticInt x of
                     Left err          -> Left err
                     Right (_,(res,_)) -> Right res

char1  = lift . lexeme . char

finito n = (char1 '=' >> lift eof) `mplus` lift eof >> return n

arithmetic = lift skipSpaces >> expression1 >>= finito
arithmeticInt = lift skipSpaces >> expressionInt >>= finito

-- "runStateT p f" transforms "Parser1 a" to "Parser (a,s)"
-- "liftM fst" changes it to "Parser a" which gives us proper type
-- for manyF function. Then in turn we lift result of manyF from "Parser a"
-- to "Parser1 a".
manyF11 :: (Num a) => Parser1 a -> a -> Parser1 a
manyF11 p n = do
         f <- get
         lift $ manyF f (liftM fst (runStateT p f)) n

manyF1 :: (Num a) => Parser1 a -> a -> Parser1 a
manyF1 p n = StateT many'
   where many' f = Parser many''
         many'' x =
            case runParser1 (-) p x of
               Left err -> Right (x,(n,(-)))
               Right (x',(a,f)) -> do
                  let Right (x'',(rest,_)) = many'' x'
                  Right (x'',(rest `f` a,f))

myPut :: (Monad m) => s -> a -> StateT s m a
myPut s a = StateT $ \_ -> return (a, s)

expression1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
expression1 = term1 >>= manyF1 (tMinus1 `mplus` tPlus1)

tMinus1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tMinus1 = char1 '-' >> term1 >>= myPut (-)

tPlus1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tPlus1 = char1 '+' >> term1 >>= myPut (+)

term1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
term1 = tPower1 >>= manyF1 (tMult1 `mplus` tDiv1)

tMult1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tMult1 = char1 '*' >> tPower1 >>= myPut (*)

tDiv1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tDiv1 = char1 '/' >> tPower1 >>= myPut (/)

tPower1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tPower1 = tFactorial1 >>= manyF1 tPow1

tPow1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tPow1 = char1 '^' >> tFactorial1 >>= myPut (**)

tFactorial1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
tFactorial1 = phrase1 >>= manyF1 tFact1

tFact1 :: (RealFrac a, Ord a) => Parser1 a
tFact1 = char1 '!' >> return 1 >>= myPut (\a b -> fromIntegral (product [1 .. round a]))

phrase1 :: (Floating a, RealFrac a, Ord a) => Parser1 a
phrase1 = (do
            char1 '('
            v <- expression1
            char1 ')'
            return v)
         `mplus` lift (lexeme real)

expressionInt = termInt >>= manyF1 (tMinusInt `mplus` tPlusInt)

tMinusInt = char1 '-' >> termInt >>= myPut (-)

tPlusInt = char1 '+' >> termInt >>= myPut (+)

termInt = tPowerInt >>= manyF1 (tMultInt `mplus` tDivInt)

tMultInt = char1 '*' >> tPowerInt >>= myPut (*)

tDivInt = char1 '/' >> tPowerInt >>= myPut div

tPowerInt = tFactorialInt >>= manyF1 tPowInt

tPowInt = char1 '^' >> tFactorialInt >>= myPut (^)

tFactorialInt = phraseInt >>= manyF1 tFactInt

tFactInt = char1 '!' >> return 1 >>= myPut (\a b -> product [1 .. a])

phraseInt = (do
            char1 '('
            v <- expressionInt
            char1 ')'
            return v)
         `mplus` lift (lexeme intSigned)