handling Haskell operators as values

Question

I was challenging myself to write a simple version of the calculator discussed to here, and came up with a way to retrieve operators by looking up a string:

ops = [("+", (+)), ("-", (-)), ("*", (*)), ("/", (/))]

This worked fine.
However, when I tried to add either ("^", (^)), ("mod", (mod)) or ("div", (div)) to the list, I was greeted with:

Ambiguous type variable `a0' in the constraints:
  (Fractional a0) arising from a use of `/' at new2.hs:1:50-52
  (Integral a0) arising from a use of `mod' at new2.hs:1:65-67
  (Num a0) arising from a use of `+' at new2.hs:1:14-16
Possible cause: the monomorphism restriction...

Alternatively, grouping the six operators without (/) worked fine as well, but gave me all sorts of errors when I tried to create one function that could return any of the seven operators (by using if-else, or looking up in two different lists, for example). Returning any of the six was fine, or working only with (+), (-), (*) and (/) worked fine too, using the simple function:

findOp op = fromJust $ lookup op ops

What could be a convenient way to store and retrieve any of these seven operators based on a string or something else? Or perhaps I should be thinking of another way to calculate the parsed input-string of the calculator? (I think eval and parsec were excluded from this excercise, and I would prefer not to use -XNoMonomorphismRestriction, if that were an option)

Here's my elementary calculator that can parse +, -, *, and / with correct precedence, and which I was hoping to continue and toy with:

import Data.Maybe

ops = [("+", (+)), ("-", (-)), ("*", (*)), ("/", (/))]

parseLex a = fst $ head a
findOp op = fromJust $ lookup op ops

calculate str accum op memory multiplication
  | operand1 /= "" && nextOp == "" = show (op accum (read operand1) + memory)
  | nextOp == "+" || nextOp == "-" = 
      calculate tailLex (op accum (read operand1) + memory) (findOp nextOp) 0 False
  | nextOp == "*" || nextOp == "/" =
      if multiplication 
         then calculate tailLex (op accum (read operand1)) (findOp nextOp) memory True
         else calculate tailLex (read operand1) (findOp nextOp) accum True
  | otherwise = "Parse error. operand1: " ++ operand1 ++ " nextOp: " ++ nextOp
 where lexemes = head $ lex str
       operand1 = fst lexemes
       nextOp = parseLex $ lex $ snd lexemes
       tailLex = tail $ snd lexemes

main :: IO ()
main = do
  str <- getLine
  case parseLex $ lex str of
    "quit"    -> do putStrLn ""; return ()
    ""        -> main
    otherwise -> do
      putStrLn (calculate str 0 (+) 0 False)
      main

UPDATE:

Here's the more fully developed Haskell caculator, utilizing the answer (with postfix, parenthetical parsing, and variable/function declaration):

import Data.Maybe
import Data.List
import Data.List.Split
import Text.Regex.Posix
import System.Console.ANSI

ops :: [([Char], Float -> Float -> Float)]
ops = [ ("+", (+)) 
       ,("-", (-)) 
       ,("*", (*)) 
       ,("/", (/)) 
       ,("**", (**))
       ,("^", (**))
       ,("^^", (**)) 
       ,("logbase", (logBase))
       ,("div", (div'))
       ,("mod", (mod')) 
       ,("%", (mod'))
       ,("rem", (rem'))
       ,("max", (max))
       ,("min", (min))]

unaryOps :: [([Char], Float -> Float)]
unaryOps = [ ("abs", (abs))
            ,("sqrt", (sqrt))
            ,("floor", (floor'))
            ,("ceil", (ceiling'))
            ,("round", (round'))
            ,("log", (log))
            ,("cos", (cos))
            ,("sin", (sin))
            ,("tan", (tan))
            ,("asin", (asin))
            ,("acos", (acos))
            ,("atan", (atan))
            ,("exp", (exp))
            ,("!", (factorial)) ]

opsPrecedence :: [([Char], Integer)]
opsPrecedence = [ ("+", 1) 
                 ,("-", 1) 
                 ,("*", 2) 
                 ,("/", 2) 
                 ,("**", 3) 
                 ,("^", 3)
                 ,("^^", 3) 
                 ,("logbase", 3)
                 ,("div", 4) 
                 ,("mod", 4) 
                 ,("%", 4) 
                 ,("rem", 4)
                 ,("max", 4)
                 ,("min", 4)                 
                 ,("abs", 7)
                 ,("sqrt", 7)
                 ,("floor", 7)
                 ,("ceil", 7)
                 ,("round", 7) 
                 ,("log", 7)
                 ,("cos", 7)
                 ,("sin", 7)
                 ,("tan", 7)
                 ,("asin", 7)
                 ,("acos", 7)
                 ,("atan", 7)
                 ,("exp", 7)
                 ,("!", 7) ]            

floor' :: Float -> Float
floor' a = fromIntegral $ floor a

ceiling' :: Float -> Float
ceiling' a = fromIntegral $ ceiling a

mod' :: Float -> Float -> Float
mod' a b = a - b * floor' (a / b)

div' :: (Num b, RealFrac a) => a -> a -> b
div' a b = fromIntegral $ truncate (a / b)

rem' :: Float -> Float -> Float
rem' a b = a - (fromIntegral (truncate (a / b)) * b)

round' :: Float -> Float
round' a = fromIntegral $ round a

factorial :: Float -> Float
factorial n = foldl (*) 1 [1..n]

{-Op Detection and Lookup-}

isOp :: [Char] -> Bool
isOp op = case lookup op ops of
            Just _  -> True
            Nothing -> False

isUnaryOp :: [Char] -> Bool
isUnaryOp op = case lookup op unaryOps of
                 Just _  -> True
                 Nothing -> False

opPrecedence :: [Char] -> [([Char],[Char])] -> Integer
opPrecedence op env
  | not (null $ isInEnv op env) = 6
  | otherwise               = fromJust $ lookup op opsPrecedence

findOp :: [Char] -> Float -> Float -> Float
findOp op = fromJust $ lookup op ops

findUnaryOp :: [Char] -> Float -> Float
findUnaryOp op = fromJust $ lookup op unaryOps

{-String Parsing Functions-}

trim :: [Char] -> [Char]
trim str = dropWhile (==' ') (reverse $ dropWhile (==' ') (reverse str))

fstLex :: [Char] -> [Char]
fstLex a = fst $ head (lex a)

sndLex :: [Char] -> [Char]
sndLex a = snd $ head (lex a)

lexWords :: [Char] -> [[Char]] 
lexWords xs =
  lexWords' xs []
    where lexWords' ys temp
            | null ys   = temp
            | otherwise = let word = fstLex ys
                          in lexWords' (trim $ sndLex ys) (temp ++ [word])

{-Mathematical Expression Parsing Functions-}

toPostfix :: [Char] -> [([Char],[Char])] -> [[Char]]
toPostfix expression env = toPostfix' expression [] [] "" env
  where toPostfix' expression stack result previous env
          | null expression && null stack                              = result
          | null expression && not (null stack)                        = result ++ stack
          | ch == ","                                                  = toPostfix' right stack result ch env
          | ch == "("                                                  = toPostfix' right (ch:stack) result ch env
          | ch == ")"                                                  =
              let popped = takeWhile (/="(") stack
              in toPostfix' right (drop (length popped + 1) stack) (result ++ popped) ch env
          | not (null $ isInEnv ch env) 
            && (length $ words $ fst $ head (isInEnv ch env)) == 1     =
              let variable = head $ isInEnv ch env
              in toPostfix' (snd variable ++ " " ++ right) stack result ch env
          | (null $ isInEnv ch env) && not (isOp ch || isUnaryOp ch)   = 
              if take 1 ch =~ "(^[a-zA-Z_])"
                 then words ("Parse error : not in scope, " ++ "'" ++ ch ++ "'")
                 else let number = reads ch :: [(Double, String)]
                      in if not (null number) && (null $ snd $ head number)
                            then toPostfix' right stack (result ++ [ch]) ch env
                            else words ("Parse error : " ++ "'" ++ ch ++ "'")
          | otherwise                                                  =
              if null result && ch == "-" || (isOp previous || isUnaryOp previous) && ch == "-"
                 then let negative = '-' : (fstLex right)
                          right' = sndLex right
                      in toPostfix' right' stack (result ++ [negative]) (fstLex right) env
                 else toPostfix' right (ch : (drop (length popped') stack)) (result ++ popped') ch env
         where ch = fstLex expression
               right = trim (sndLex expression)
               popped' = popStack ch stack
                  where popStack ch stack'
                          | null stack' = []
                          | head stack' /= "(" && opPrecedence ch env <= opPrecedence (head stack') env=
                              take 1 stack' ++ popStack ch (drop 1 stack')
                          | otherwise  = []

evaluate :: [Char] -> [[Char]] -> [Char]
evaluate op operands = 
  let operand1 = head operands
      operand1' = reads operand1 :: [(Double, String)]
      errorMsg = "Parse error in evaluation."
  in if not (null operand1') && null (snd $ head operand1')
        then case length operands of
               1         -> show (findUnaryOp op (read operand1))
               otherwise -> let operand2 = head (drop 1 operands)
                                operand2' = reads operand2 :: [(Double, String)]
                            in if not (null operand2') && null (snd $ head operand2')
                                  then show (findOp op (read operand1) (read operand2))
                                  else errorMsg
     else errorMsg

evalDef :: ([Char],[Char]) -> [[Char]] -> [([Char],[Char])] -> [Char]
evalDef def args env = 
  evalPostfix (toPostfix (replaceParams (drop 1 $ words (fst def)) args (snd def) "") env) env
    where replaceParams params values exp temp
            | length params /= length values = "Parse error : function parameters do not match."
            | null exp                       = init temp
            | otherwise                      = 
                let word = fstLex exp
                    replaced = if elem word params
                                  then temp++ values!!(fromJust $ elemIndex word params) ++ " " 
                                  else temp++ word ++ " " 
                in  replaceParams params values (drop (length word) (trim exp)) replaced

evalPostfix :: [[Char]] -> [([Char],[Char])] -> [Char]
evalPostfix postfix env
  | elem "error" postfix = unwords postfix
  | otherwise = head $ evalPostfix' postfix [] env
      where evalPostfix' postfix stack env
              | null postfix = stack
              | null (isInEnv (head postfix) env) && not (isOp (head postfix) || isUnaryOp (head postfix)) 
                             = evalPostfix' (drop 1 postfix) (head postfix : stack) env
              | otherwise    =
                  let op = head postfix
                      numOperands = if isOp op 
                                       then 2
                                       else if isUnaryOp op
                                               then 1
                                               else let def = isInEnv op env
                                                    in length (words $ fst $ head def) - 1
                  in if length stack >= numOperands
                        then let retVal = 
                                   if isOp op || isUnaryOp op
                                      then evaluate op (reverse $ take numOperands stack)
                                      else let def = isInEnv op env
                                           in evalDef (head def) (reverse $ take numOperands stack) env
                             in if not (isInfixOf "error" retVal)
                                   then evalPostfix' (drop 1 postfix) (retVal : drop numOperands stack) env
                                   else [retVal]
                        else ["Parse error."]

{-Environment Setting Functions-}

isInEnv :: [Char] -> [([Char],[Char])] -> [([Char],[Char])]
isInEnv first []     = []
isInEnv first (x:xs)
  | fstLex first == fstLex (fst x) = [x]
  | otherwise                      = isInEnv first xs

setEnv :: [Char] -> ([Char], [Char])
setEnv str =
  if elem '=' str 
     then let nameAndParams = let function = takeWhile (/='=') str
                              in unwords $ filter (\x -> x/="(" && x/="," && x/=")") (lexWords function)
              expression = unwords $ lexWords (tail (dropWhile (/='=') str))
          in if not (null nameAndParams)
                then if fstLex nameAndParams =~ "(^[a-zA-Z_])"
                        then (nameAndParams, expression)
                        else ("error", "Parse error : illegal first character in variable name.")
                else ("error", "Parse error : null variable name.")
     else ("error", "Parse error.")

declare :: [Char] -> [([Char], [Char])] -> IO ()
declare str env =
  let which = if str =~ "(^ *[a-zA-z_][a-zA-Z0-9_]* *=)" :: Bool
                 then "var"
                 else "def"
      declarationList = case which of
                          "var" -> splitOn "," str
                          "def" -> [str]
  in declare' declarationList env which
    where declare' [] _ _           = mainLoop env 
          declare' (x:xs) env which =
            let result = setEnv x
            in if fst result /= "error"
                  then let match = isInEnv (fst result) env
                           env' = if not (null match)
                                         then deleteBy (\x -> (==head match)) (head match) env 
                                         else env
                           newList = if not (null $ snd result)
                                        then (result : env')
                                        else env'
                       in case which of
                            "def"     -> mainLoop newList
                            otherwise -> if null xs 
                                            then mainLoop newList
                                            else declare' xs newList which
                  else do putStrLn $ snd result
                          mainLoop env

{-Main Calculation Function-}

calculate :: [Char] -> [([Char],[Char])] -> [Char]
calculate str env = 
  evalPostfix (toPostfix str env) env

helpContents = "\nTo declare variables, type:\n[var] VARIABLE_NAME = VALUE [, more variable declarations..]\n"
               ++ "Functions and partial functions may be assigned to variables.\n\n"
               ++ "To declare functions, type:\n"
               ++ "FUNCTION_NAME VARIABLE_1 [variable_2..] = EXPRESSION\n\n"
               ++ "Supported math functions:\n"
               ++ "+, -, *, /, ^, **, ^^\n"
               ++ "sqrt, exp, log, logbase BASE OPERAND\n"
               ++ "abs, div, mod, %, rem, floor, ceil, round\n"
               ++ "pi, sin, cos, tan, asin, acos, atan\n"
               ++ "! (factorial), min, max and parentheses: ()\n\n"
               ++ "Type env to see a list of environment variables\nand functions. Type cls to clear screen, quit to quit\n" 

main :: IO ()
main = do putStrLn "calc v2.0 (c) 2013 Diagonal Productions\nPlease enter an expression:\n"
          mainLoop [("pi", show pi), ("min a b", "min a b"), ("max a b", "max a b")]

mainLoop :: [([Char], [Char])] -> IO ()
mainLoop env = do
  str <- getLine
  if elem '=' str
     then declare str env
     else case fstLex str of
          "quit"    -> do putStrLn ""; return ()
          ""        -> mainLoop env
          "env"     -> do putStrLn ("\nEnvironment:\n" ++ show env ++ "\n")
                          mainLoop env
          "cls"     -> do clearScreen
                          setCursorPosition 0 0
                          mainLoop env
          "help"    -> do putStrLn helpContents
                          mainLoop env
          otherwise -> do
            putStrLn $ calculate str env
            mainLoop env

Answer 1

The problem is that the types of (/), mod, and (+) are all very different as the error message states: (/) works on Fractionals like Float and Double while mod works on Integrals such as Int and Integer. On the other hand (+) can be used with any Num. These operators are not interchangeable within the same context.

Edit:

Now that I can see some code, it looks like the problem is caused by the Haskell compiler trying to infer the type of the ops list. Let's look at the types of the elements of this list:

Prelude> :t ("+", (+))
("+", (+)) :: Num a => ([Char], a -> a -> a)
Prelude> :t ("/", (/))
("/", (/)) :: Fractional a => ([Char], a -> a -> a)
Prelude> :t ("mod", mod)
("mod", mod) :: Integral a => ([Char], a -> a -> a)
Prelude>

Notice that each of these pairs has a different type. But I'm just repeating my original answer. One possible solution is to give an explicit type for ops so that Haskell doesn't try to infer one.

The Bad News:

I can't find a simple type signature that will fix the problem. I tried

ops :: Num a => [(String, a -> a -> a)]

which gives different errors that are obviously rooted in the same cause.

Answer 2

Thanks to Niklas' answer, I noticed that (**) has a different type than (^) and works with my simple operator list. After that I decided to write out short alternative definitions for div and mod, like so:

mod' :: Float -> Float -> Float
mod' a b = a - b * floor' (a / b)

div' :: (Num b, RealFrac a) => a -> a -> b
div' a b = fromIntegral $ truncate (a / b)

floor' :: Float -> Float
floor' a = fromIntegral $ floor a

Adding (**), (mod') and (div') to my list, the compiler compiled fine. (And since the operators are parsed from a string, they could keep their original names, too.)

Answer 3

Before presenting a solution, let me quickly explain why your compiler is complaining about your current code. To illustrate this, let's look at the type signatures of some operators:

(+) :: Num a => a -> a -> a
(/) :: Fractional a => a -> a -> a
(mod) :: Integral a => a -> a -> a

As you can see, Haskell has several different types of numbers and it classifies them using type classes: Num is something you can add, subtract, multiply and so on, Fractionals are numbers with well-defined division, Integral are integer-like numbers. Moreover, Fractional and Integral are both subclasses of Num. This is why both of these work:

[(+), (mod)] :: Integral a => [a -> a -> a]
[(+), (/)] :: Fractional a => [a -> a -> a]

It just uses the "greatest common type", so to speak, for the type of the functions in the list. You can not simply mix functions on Fractionals with functions on Integrals in the same list, though!

You state that you want to work with "whatever lex returns", but that's just an untyped string, and you actually want to work with numbers. However, since you want to be able to use floating point number and integers, a sum type would be a good option:

import Safe (readMay)

data Number = I Integer | D Double

parseNumber :: String -> Maybe Number
parseNumber str =
    if '.' `elem` str then fmap I $ readMay str
                      else fmap D $ readMay str

Now you have the problem that it's rather cumbersome to define sensible instances of your operators. Since the Number type already exists in the Attoparsec library, I suggest using it, as it gives you a parser and a Num instance for free. Of course you can always roll your own code for that, if you prefer.

import qualified Data.Attoparsec.Text as P
import qualified Data.Attoparsec.Number as P
import qualified Data.Text as T

parseNumber :: String -> Maybe P.Number
parseNumber str =
    either (const Nothing) Just $ P.parseOnly P.number (T.pack str)

myMod :: P.Number -> P.Number -> Maybe P.Number
myMod (P.I a) (P.I b) = Just . P.I $ a `mod` b
myMod _ _ = Nothing -- type error!

myPow :: P.Number -> P.Number -> Maybe P.Number
myPow x (P.I b) = Just $ x ^ b
myPow (P.D a) (P.D b) = Just . P.D $ a ** b
myPow (P.I a) (P.D b) = Just . P.D $ (fromIntegral a) ** b

ops :: [(String, (P.Number -> P.Number -> Maybe P.Number))]
ops = [ ("+", liftNum (+))
      , ("-", liftNum (-))
      , ("*", liftNum (*))
      , ("/", liftNum (/))
      , ("mod", myMod)
      , ("^", myPow)
      ]
      where liftNum op a b = Just $ a `op` b

You can now define any operation you want on your well-defined set of inputs. Of course now you also have to handle type errors like 1.333 mod 5.3, but that's a good! The compiler forced you to do the right thing :)

By avoiding the partial read function, you will also have to check for input errors explicitly. Your original program would have just crashed on an input like a + a.