2

我编写了以下 Haskell 程序来解释基本数学。除了数学运算符之外，我还想添加比较和布尔运算符。我的问题是我应该如何用可以处理or的Int东西替换出现的.IntBool

我考虑将Token类型扩展为具有三种类型的运算符，它们仅在函数的类型（(Int -> Int -> Int)、、(Int -> Int -> Bool)和）上有所不同(Bool -> Bool -> Bool)，但这似乎会导致在类型声明和模式匹配。有没有办法用类型类来做到这一点？

type Precedence = Int
data Associativity = AssocL | AssocR
data Token = Operand Int | Operator String (Int -> Int -> Int) Associativity Precedence | ParenL | ParenR

instance Eq Token where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

evalMath :: String -> Int
evalMath = rpn . shuntingYard . tokenize

tokenize :: String -> [Token]
tokenize = map token . words
  where token s@"+" = Operator s (+) AssocL 2
        token s@"-" = Operator s (-) AssocL 2
        token s@"*" = Operator s (*) AssocL 3
        token s@"/" = Operator s div AssocL 3
        token s@"^" = Operator s (^) AssocR 4
        token "("   = ParenL
        token ")"   = ParenR
        token x     = Operand $ read x

shuntingYard :: [Token] -> [Token]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token] -> Int
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs
4

3 回答 3

3

这绝对是一种先进的技术，但是您可以使用类型类和 GADT 将特定多态性提升到您的 DSL，并获得类型化标记作为结果（即，您不能构造类型不正确的标记）。

{-# LANGUAGE GADTs #-}

(.<) :: IsScalar a => Token ((a, a) -> Bool)
(.<) = Operator (Lt scalarType)

(.+) :: IsNum a => Token ((a, a) -> a)
(.+) = Operator (Add numType)

(.==) :: IsScalar a => Token ((a, a) -> Bool)
(.==) = Operator (Eq scalarType)


lit7  :: Token Int
lit7  =  Operand 7

data Token a where
    Operand  :: (IsScalar a, Show a) => a -> Token a
    Operator :: Fun (a -> r) -> Token (a -> r)
    ParenL   :: Token ()
    ParenR   :: Token ()

-- The types of primitive functions
data Fun s where
    Lt   :: ScalarType a -> Fun ((a, a) -> Bool)
    Gt   :: ScalarType a -> Fun ((a, a) -> Bool)

    Eq   :: ScalarType a -> Fun ((a, a) -> Bool)
    NEq  :: ScalarType a -> Fun ((a, a) -> Bool)

    Add  :: NumType a -> Fun ((a, a) -> a)
    Mul  :: NumType a -> Fun ((a, a) -> a)

现在是类型类的所有起重工具：

-- Polymorphism. Use dictionaries in Haskell, in the DSL.

class IsScalar a where
  scalarType    :: ScalarType a

class (Num a, IsScalar a) => IsNum a where
  numType       :: NumType a

class (IsScalar a, IsNum a) => IsIntegral a where
  integralType  :: IntegralType a

instance IsIntegral Int where
  integralType = TypeInt IntegralDict

instance IsNum Int where
  numType = IntegralNumType integralType

instance IsScalar Int where
  scalarType = NumScalarType numType

data ScalarType a where
  NumScalarType    :: NumType a    -> ScalarType a
  NonNumScalarType :: NonNumType a -> ScalarType a

data NumType a where
  IntegralNumType :: IntegralType a -> NumType a

data IntegralType a where
  TypeInt     :: IntegralDict Int     -> IntegralType Int

data NonNumType a where
  TypeBool    :: NonNumDict Bool      -> NonNumType Bool

-- Reified dictionaries: lift our dictionaries to the DSL
data IntegralDict a where
  IntegralDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a
                  , Integral a, Num a, Real a)
               => IntegralDict a

data NonNumDict a where
  NonNumDict :: (Eq a, Ord a, Show a)
             => NonNumDict a

这个想法来自新南威尔士大学加速图书馆。

于 2011-04-27T03:19:47.150 回答
2

您可以将实际函数设为单独的类型。

data Fcn = III (Int -> Int -> Int) | IIB (Int -> Int -> Bool) | BBB (Bool -> Bool -> Bool)
data Token = ... | Operator String Fcn Associativity Precedence | ...

这将减少代码重复，但您必须在 Fcn 构造函数上进行模式匹配才能执行算术。

于 2011-04-27T02:55:54.253 回答
1

这最终比我想象的要简单得多。我收到的两个答案都有帮助，但都没有直接指向我的解决方案。GADT 的事情对于我试图做的事情来说太过分了。

在这种情况下，您真正​​需要做的就是将操作数包装在一个选项类型中，并采用一种简单的方法来提升您的函数以对该类型进行操作。通过使Token类型由操作数类型参数化（Result如下），我能够非常愉快地概括该算法。

import ShuntingYard

data Result = I Int | B Bool deriving (Eq)

instance Show Result where
  show (I x) = show x
  show (B x) = show x

evalMath :: String -> Result
evalMath = rpn . shuntingYard . tokenize

liftIII f (I x) (I y) = I $ f x y
liftIIB f (I x) (I y) = B $ f x y
liftBBB f (B x) (B y) = B $ f x y

tokenize :: String -> [Token Result]
tokenize = map token . words
  where token s@"&&" = Operator s (liftBBB (&&)) AssocL 0
        token s@"||" = Operator s (liftBBB (||)) AssocL 0
        token s@"="  = Operator s (liftIIB (==)) AssocL 1
        token s@"!=" = Operator s (liftIIB (/=)) AssocL 1
        token s@">"  = Operator s (liftIIB (<))  AssocL 1
        token s@"<"  = Operator s (liftIIB (>))  AssocL 1
        token s@"<=" = Operator s (liftIIB (>=)) AssocL 1
        token s@">=" = Operator s (liftIIB (<=)) AssocL 1
        token s@"+"  = Operator s (liftIII (+))  AssocL 2
        token s@"-"  = Operator s (liftIII (-))  AssocL 2
        token s@"*"  = Operator s (liftIII (*))  AssocL 3
        token s@"/"  = Operator s (liftIII div)  AssocL 3
        token s@"^"  = Operator s (liftIII (^))  AssocR 4
        token "("    = ParenL
        token ")"    = ParenR
        token "f"    = Operand $ B False
        token "t"    = Operand $ B True
        token x      = Operand $ I $ read x

ShuntingYard 模块定义为：

module ShuntingYard ( Associativity(AssocL, AssocR)
                    , Token(Operand, Operator, ParenL, ParenR)
                    , shuntingYard
                    , rpn) where 

type Precedence = Int
data Associativity = AssocL | AssocR
data Token a = Operand a | Operator String (a -> a -> a) Associativity Precedence | ParenL | ParenR

instance (Show a) => Show (Token a) where
  show (Operator s _ _ _) = s
  show (Operand x)        = show x
  show ParenL             = "("
  show ParenR             = ")"

instance (Eq a) => Eq (Token a) where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

shuntingYard :: (Eq a) => [Token a] -> [Token a]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token a] -> a
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs
于 2013-04-08T19:51:10.577 回答