module PocketCalculators where
import TooSimpleParseLib
import Control.Applicative
import Data.Char

run :: (Show t) => Parser Char t  -> String-> IO ()
run p c = do  putStrLn ("Expected: " ++ c ++ " or (q) to quit")
              inp <- getLine
              if inp == "q" then return ()
                else  do  case runParser p (filter (/= ' ') inp) of
                           ((v, ""):_)  ->  putStrLn ("Result is: " ++ show v)
                           _            ->  putStrLn "Incorrect input"
                          run p c

-- the first calculator just return the digit we type
c1 =  run pDigit "Digit"
      where pDigit  =  pSatisfy (\x -> ord '0' <= ord x && ord x <= ord '9')

-- the second calculator acts te same, but really computes an integer

c2=  run pDigAsInt "Digit"
     where  pDigAsInt  =  f <$> pDigit
            f c = ord c - ord '0'

-- the third calcaluator accepts a complete natural number

c3 =  run pNatural "Natural Number"
      where pNatural  =  foldl (\a b -> a*10 + b) 0 <$> some pDigAsInt

-- the number may also be negative

c4 =  run pInteger "Integer (possibly negative)"
      where pInteger  =  (negate <$ (pToken "-") `opt` id ) <*>  pNatural 

-- the sum of two numbers

c5  =  run pPlus "e.g. 2+-5"
       where  pPlus = (+)  <$>  pInteger 
                           <*   pToken "+" 
                           <*>  pInteger

-- the next parser does the same but evaluates the additions in a left to right order

c6  = run pPlus' "e.g. 2+-5"
      where  pPlus' = applyall <$> pInteger <*> many ( (+) <$ pToken "+" <*> pInteger)

applyall x (f:fs)  =  applyall (f x) fs
applyall x []      =  x

-- we can now also handle subtractions, but have to make sure that the argumnets end up at the correct side of
-- the operator

c7  =  run pMinus' "e.g. 5-3-2"
       where  pMinus' = applyall  <$> pInteger 
                                  <*> many ((flip (-)  <$ pToken "-") 
                                                       <*> pInteger
                                            )
-- flip f x y = f y x

-- we now extend the case so that we can handle both addition and subtraction

c8   =  run pPlusMinus " e.g. 2+3-5"
        where  pPlusMinus  =  applyall  <$> pInteger 
                                  <*> many (  (  flip (-)  <$ pToken "-"
                                                  <|>
                                                  flip (+)  <$ pToken "+"
                                               )  
                                                       <*> pInteger
                                            )

-- we define a new combinaor chainl which takes two arguments
-- 1) the seporator, which returns a function
-- 2) the elements between the separators

pChainL s p  = applyall <$> p <*> many ( flip <$> s <*> p) 

c9   =  run pPlusMinus' " e.g. 2+3-5"
        where  pPlusMinus'  =  pChainL  (  (-)  <$ pToken "-"
                                        <|>
                                           (+)  <$ pToken "+"
                                        )  pInteger


-- we abstract over the procise list of operators we can expect

c10  =  run pPlusMinus'' " e.g. 2+3-5"
        where  pPlusMinus''  = pChainL addops pInteger
               addops  = anyof  [((+), "+"), ((-), "-")]

anyof   = foldr (\ (op, sym) rest -> op <$ pToken sym <|> rest)  empty 

-- we also want to be able to multiply

c11 =  run pPlusMinusTimes "e.g. 2*3-5"
       where   pPlusMinusTimes  =  pChainL addops  pTimes
               pTimes           =  pChainL mulops  pInteger         
               mulops           =  anyof [((*), "*")]
               addops           =  anyof [((+), "+"), ((-), "-")]
 
--  suppose now we have many more operators with prorities

c12 =  run pPlusMinusTimes "e.g. 2*3-5"
       where   pPlusMinusTimes  =  pChainL addops  (pChainL mulops pInteger)        

mulops           =  anyof [((*), "*")]
addops           =  anyof [((+), "+"), ((-), "-")]

-- or using a foldr

c13 =  run pPlusMinusTimes "e.g. 2*3-5"
       where   pPlusMinusTimes  =  foldr pChainL pInteger [addops, mulops]        

-- now we add parentheses in expressions

c14 =  run pExpr "e.g. 2*(3-5)"
       where   pExpr    =  foldr pChainL pFactor [addops, mulops]
               pFactor  =  pInteger <|> pParens pExpr       
 
-- we now add if ... then ... else 
-- we represent a boolean value as a function that chooses between its two arguments

c15 =  run pExpr "e.g. if true then 5 else 7 "
       where   pExpr        =  foldr pChainL pFactor [addops, mulops] <|> pIfThenElse
               pFactor      =  pInteger <|> pParens pExpr
               pIfThenElse  =  choose   <$    pToken "if" 
                                        <*>   pBoolExpr 
                                        <*    pToken "then" 
                                        <*>   pExpr 
                                        <*    pToken "else" 
                                        <*>   pExpr 
               pBoolExpr    =       True  <$ pToken "true" 
                               <|>  False <$ pToken "false"     

choose c t e  =  if c then t else e

-- we add relational operators

c16 =  run pExpr "e.g. if 3 <5 && 6 <= 7  then 5 else 7 "
       where   pExpr         =  foldr pChainL pFactor [addops, mulops] <|> pIfThenElse
               pFactor       =  pInteger <|> pParens pExpr
               pIfThenElse   =  choose  <$    pToken "if" 
                                        <*>   pBoolExpr 
                                        <*    pToken "then" 
                                        <*>   pExpr 
                                        <*    pToken "else" 
                                        <*>   pExpr 
               pBoolExpr     =  foldr pChainL  pRelExpr [andops, orops] 
               pRelExpr      =       True  <$ pToken "true" 
                                <|>  False <$ pToken "false"
                                <|>  pExpr <**> (flip <$> pRelOp <*> pExpr)
               p <**> q      = (\pr qr -> qr pr)  <$> p <*> q     
      
andops  =  anyof [  ((&&)  , "&&")]
orops   =  anyof [  ((||)  , "||")]
pRelOp  =  anyof [  ((<=)  , "<="), ((>=)   , ">=" ),
                    ((==)  , "=="), ((/=)   , "/=" ),
                    ((<)   , "<" ), ((>)    , ">"  )]


type Env = [(Char, Int)]

run' :: (Show t) => Parser Char (Env -> t)  -> String -> Env -> IO ()
run' p c env
        = do  putStrLn ("Expected: " ++ c ++ " or (q) to quit or (d) to define")
              inp <- getLine
              case inp of
               "q" -> return ()
               "d" -> do  putStrLn "Variable? "
                          inp <- getLine
                          let var = head inp
                          putStrLn "Value?"
                          inp <- getLine
                          let val = read inp
                          run' p c ((var,val):env)
               _   ->  do case runParser p (filter (/= ' ') inp) of
                               ((v, ""):_)  ->  putStrLn ("Result is: " ++ show (v env))
                               _            ->  putStrLn "Incorrect input"
                          run' p c env


applyall' x fs    env  =  applyall (x env) (map ($env) fs)

pChainL' s p  = applyall' <$> p <*> many ( (\s p env -> flip s (p env)) <$> s <*> p) 

choose' c t e env =  if c env then t env else e env


c17 =  run' pExpr "e.g. if ?x < ?y then ?x else ?y " []
       where   pExpr         =  foldr pChainL' pFactor [addops, mulops] <|> pIfThenElse
               pFactor       =  pInteger' <|> pParens pExpr <|> pVar
               pVar          =  (\ ident env -> case lookup ident env of
                                               Nothing -> error "nonexisting identifier"
                                               Just r  -> r)
                                <$ pSym '?' <*> pChar
               pChar         =  pSatisfy (\x -> 'a' <= x &&  x <= 'z')
               pIfThenElse   =  choose'  <$    pToken "if" 
                                         <*>   pBoolExpr 
                                         <*    pToken "then" 
                                         <*>   pExpr 
                                         <*    pToken "else" 
                                         <*>   pExpr 
               pBoolExpr     =  foldr pChainL'  pRelExpr [andops, orops] 
               pRelExpr      =       const True  <$ pToken "true" 
                                <|>  const False <$ pToken "false"
                                <|>  pExpr <**> ((\ op ex env -> flip op (ex env)) <$> pRelOp <*> pExpr)
               p <**> q      = (\pr qr env -> (qr env) (pr env))  <$> p <*> q 
               pInteger'     = const <$> pInteger