将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

在介绍解决方案之前,让我快速解释为什么您的编译器抱怨您当前的代码.为了说明这一点,让我们看一些运算符的类型签名:

(+) :: 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]

它只是使用"最常见的类型",可以说,列表中的函数类型.但是,您不能简单地将Fractionals上的函数与Integrals中的函数混合在同一列表中!

你声明你想要使用"lex return",但这只是一个无类型字符串,你实际上想要使用数字.但是,由于您希望能够使用浮点数和整数,因此总和类型将是一个不错的选择:

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类型已经在存在Attoparsec库,我建议使用它,因为它给你一个解析器和一个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.

Answer 2

感谢 Niklas 的回答，我注意到 (**) 的类型与 (^) 不同，并且适用于我的简单运算符列表。之后我决定为 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') 添加到我的列表中，编译器编译得很好。（并且由于运算符是从字符串中解析的，因此它们也可以保留其原始名称。）