Обработка операторов Haskell в качестве значений

Мне было сложно написать простую версию калькулятора, обсуждаемую в здесь, и придумал способ получить операторов, просмотрев строку:

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

UPDATE:

Здесь более полно разработанный каскатор 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

Ответ 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') в мой список, компилятор скомпилирован в порядке. (И поскольку операторы анализируются из строки, они также могут сохранять свои исходные имена.)

Ответ 2

Прежде чем представить решение, позвольте мне быстро объяснить, почему ваш компилятор жалуется на ваш текущий код. Чтобы проиллюстрировать это, рассмотрим типы сигнатур некоторых операторов:

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

Как вы можете видеть, Haskell имеет несколько разных типов чисел и классифицирует их с помощью классов типов: Num - это то, что вы можете добавить, вычесть, умножить и т.д., Fractional - это номера с четко определенным делением, 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 уже существует в библиотеке 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.

Ответ 3

Проблема заключается в том, что типы (/), mod и (+) все очень разные, как указано в сообщении об ошибке: (/) работает на Fractional как Float и Double, а mod работает на Integrals, например Int и Integer. С другой стороны, (+) можно использовать с любым Num. Эти операторы не являются взаимозаменяемыми в одном контексте.

Edit:

Теперь, когда я вижу некоторый код, похоже, что проблема вызвана компилятором Haskell, пытающимся вывести тип списка ops. Давайте рассмотрим типы элементов этого списка:

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>

Обратите внимание, что каждая из этих пар имеет другой тип. Но я просто повторяю свой первоначальный ответ. Одно из возможных решений - дать явный тип для ops, чтобы Haskell не пытался сделать вывод.

Плохая новость:

Я не могу найти простую подпись типа, которая исправит проблему. Я попробовал

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

который дает разные ошибки, которые, очевидно, связаны с одной и той же причиной.