Использование ViewPatterns и PatternSynonyms для простого сопоставления с образцом

Question

Допустим, у меня есть GADT для такого языка (мой настоящий язык гораздо более сложный, около 50 конструкторов, но это упрощенный пример):

data Expr t where
  Add :: Expr t -> Expr t -> Expr t
  Sub :: Expr t -> Expr t -> Expr t
  Mult :: Expr t -> Expr t -> Expr t
  Negate :: Expr t -> Expr t
  Abs :: Expr t -> Expr t
  Scalar :: t -> Expr t

Теперь давайте определим другой тип данных следующим образом:

data BinOpT = AddOp | SubOp | MultOp

Также, допустим, у меня есть следующая функция:

stringBinOp :: BinOpT -> String
stringBinOp AddOp = "+"
stringBinOp SubOp = "-"
stringBinOp MultOp = "*"

Также давайте определим следующий тип:

data BinOp t = BinOp BinOpT (Expr t) (Expr t)

Теперь я хочу определить красивую функцию печати следующим образом:

prettyPrint :: Show t => Expr t -> String
prettyPrint (BinOp op x y) = prettyPrint x ++ showOp op ++ prettyPrint y
prettyPrint (Negate x) = "-" ++ prettyPrint x
prettyPrint (Abs x) = "abs(" ++ prettyPrint x ++ ")"
prettyPrint (Scalar x) = show x

Обратите внимание, что это недействительно, так как BinOp не является конструктором Expr t,

Конечно, я мог бы переопределить Expr t вот так:

data Expr t where
  BinOp :: BinOp -> Expr t -> Expr t -> Expr t
  Negate :: Expr t -> Expr t
  Abs :: Expr t -> Expr t
  Scalar :: t -> Expr t

И это будет работать нормально, но я бы предпочел не делать этого. Это делает другой код, который использует это, немного уродливее, а также я думаю, что он будет немного более неэффективным с точки зрения пространства и времени, и вам придется сопоставлять два конструктора вместо одного, что означает два оператора case (следовательно, jump таблицы) вместо одного.

Я подозреваю, что могу использовать комбинацию следующих двух расширений GHC, чтобы добиться того, что я пытаюсь сделать чисто, а именно:

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}

Но я не совсем уверен, как лучше всего это сделать. Был бы полезен простой пример для этого кода (затем я могу применить его к более сложному языку, с которым я имею дело).

Многие мнимые бонусные баллы будут начислены, если решение будет скомпилировано без предупреждений о пропущенных совпадениях. Я понимаю, что GHC 8.2 может быть полезен в этом отношении, поэтому пример GHC 8.2 с его расширениями для проверки исчерпываемости будет хорошим, хотя решение до GHC 8.2 с прохождением проверки исчерпанности будет еще лучше.

Разъяснение:

На самом деле я спрашиваю, как я могу сделать что-то вроде этого:

prettyPrint :: Show t => Expr t -> String
prettyPrint (BinOp op x y) = prettyPrint x ++ showOp op ++ prettyPrint y
prettyPrint (Negate x) = "-" ++ prettyPrint x
prettyPrint (Abs x) = "abs(" ++ prettyPrint x ++ ")"
prettyPrint (Scalar x) = show x

Сохраняя определение Expr t вот так:

data Expr t where
  Add :: Expr t -> Expr t -> Expr t
  Sub :: Expr t -> Expr t -> Expr t
  Mult :: Expr t -> Expr t -> Expr t
  Negate :: Expr t -> Expr t
  Abs :: Expr t -> Expr t
  Scalar :: t -> Expr t

Важная строка:

prettyPrint (BinOp op x y) = prettyPrint x ++ showOp op ++ prettyPrint y

Который не будет компилироваться как BinOp не является конструктором Expr t, Я хочу, чтобы эта строка компилировалась, поскольку я не хочу делать это везде:

prettyPrint (Add x y) = ...
prettyPrint (Sub x y) = ...
prettyPrint (Mult x y) = ...

Потому что это означает много дублирования кода, так как многие функции будут использовать Expr t,

Answer 1

Посмотреть шаблон

asBinOp (Add a b) = Just (AddOp, a, b)
asBinOp (Sub a b) = Just (SubOp, a, b)
asBinOp (Mul a b) = Just (MulOp, a, b)
asBinOp _ = Nothing

prettyPrint (asBinOp -> Just (op, x, y)) = prettyPrint x ++ showOp op ++ prettyPrint y

... + Паттерн синоним

pattern BinOp :: BinOpT -> Expr t -> Expr t -> Expr t
pattern BinOp op a b <- (asBinOp -> Just (op, a, b)) where
  BinOp AddOp a b = Add a b
  BinOp SubOp a b = Sub a b
  BinOp MulOp a b = Mul a b

prettyPrint (BinOp op x y) = prettyPrint x ++ showOp op ++ prettyPrint y

В GHC 8.2 вы можете удовлетворить проверку исчерпанности с помощью этой прагмы:

{-# COMPLETE BinOp, Negate, Abs, Scalar #-}