Сценарий полиморфизма в Хаскеле

Question

Я написал следующую программу на Haskell для интерпретации основных математических навыков. Я хотел бы добавить сравнения и логические операторы в дополнение к математическим операторам. Мой вопрос заключается в том, как мне следует заменить вхождения Int чем-то, что может обработать либо Int, либо Bool.

Я подумал о расширении типа 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

Answer 1

Это, безусловно, продвинутый метод, но вы можете использовать классы типов и 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

Эта идея из библиотеки UNSW ускорения .

Answer 2

Вы можете сделать фактическую функцию отдельным типом.

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

Это даст меньше дублирования кода, но для выполнения арифметики вам потребуется сопоставление с образцом в конструкторе Fcn.

Answer 3

Это оказалось намного проще, чем я думал. Оба ответа, которые я получил, помогли, но ни один из них не указал мне прямо на решение. Дело ГАДа в том, что я пытался сделать, излишне.

Все, что вам действительно нужно сделать в такой ситуации, - это обернуть операнд в тип опции и сделать простой способ поднять ваши функции для работы с этим типом. Сделав тип 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