将Haskell运算符作为值处理

Question

我在为这里编写一个简单版本的计算器，并想出了一种通过查找字符串来检索操作符的方法：

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

这个效果很好。

但是，当我试图将("^“、(^))、("mod”、(mod))或("div“、(div))添加到列表中时，我的回答是：

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...

或者，将没有(/)的六个操作符分组也很好，但是当我尝试创建一个函数来返回这七个运算符中的任何一个时(例如，使用if-else或查找两个不同的列表)，会给我带来各种各样的错误。返回六个中的任何一个都很好，或者只使用(+)、(-)、(*)和(/)也可以，使用简单的函数：

findOp op = fromJust $ lookup op ops

基于字符串或其他东西存储和检索这七个操作符中的任何一个的方便方法是什么？或者我应该考虑另一种方法来计算计算机的解析输入字符串？(我认为eval和parsec被排除在这个节目单之外，如果这是一种选择，我宁愿不使用-XNoMonomorphismRestriction )。

下面是我的基本计算器，它可以解析+、-、*和/并具有正确的优先级，我希望继续并使用它：

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

更新：

下面是更充分开发的Haskell计算器，利用答案(带有后缀、括号分析和变量/函数声明)：

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

由于尼可拉斯的回答，我注意到(**)的类型与(^)不同，并使用我的简单运算符列表。之后，我决定为div和mod编写简短的替代定义，如下所示：

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

将(**)、(mod')和(div')添加到我的列表中，编译器编译得很好。(由于运算符是从字符串中解析出来的，所以它们也可以保留它们的原始名称。)

Answer 2

在提出解决方案之前，让我快速解释一下为什么您的编译器在抱怨当前的代码。为了说明这一点，让我们看看一些运算符的类型签名：

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

正如您所看到的，Haskell有几种不同类型的数字，它使用类型类对它们进行分类：Num是您可以加、减、乘等的东西，Fractionals是具有定义良好的除法的数字，Integral是类似整数的数字。此外，Fractional和Integral都是Num的子类。这就是为什么这两项工作：

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

它只对列表中的函数类型使用“最大的公共类型”。但是，您不能简单地将Fractional上的函数与Integral上的函数混合在同一个列表中！

您声明您希望使用“任何lex返回的内容”，但这只是一个未键入的字符串，实际上您希望处理数字。但是，由于您希望能够使用浮点数和整数，所以和型是一个很好的选择：

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

现在，您面临的问题是，定义操作符的合理实例非常麻烦。由于Number类型已经存在于阿托帕塞特库中，我建议使用它，因为它为您免费提供了一个解析器和一个Num实例。当然，如果您愿意的话，您可以随时提交自己的代码。

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

您现在可以在定义良好的输入集上定义任何您想要的操作。当然，现在您还必须处理像1.333 mod 5.3这样的类型错误，但是这是一个很好的选择！编译器强迫您做正确的事情:)

通过避免部分read函数，您还必须显式地检查输入错误。您的原始程序只会在像a + a这样的输入上崩溃。