我如何多态地解释类似 Arrow 的 GADT DSL？

Question

TL;DR: 如何为我的 Lang GADT 编写解释器 (run :: Lang a b -> whatever)？

我有一个 DSL：

data Lang a b where
  F :: Lang x y
  G :: Lang x y

我想构建如下程序：

prog :: Lang a b
prog = G . F

并任意解释它们，其中 F 和 G 的替换可以是任何函数，只要它们的类型正确组合即可。

-- run ~= (+1) . fst
run :: Lang a b -> ((Int, b) -> Int)
run F = fst
run G = (+1) -- error: couldn't match type (Int, b) with Int

解释是我的大问题。我如何编写如下函数：

run :: Lang a b -> whatever
-- eg reusing the variables
run :: Lang a b -> (a -> IO b)

我在我的语言中添加了组合的概念：

data Lang a b where
  ...

  Lift :: (a -> b) -> Lang a b
  Comp :: Lang b c -> Lang a b -> Lang a c

instance C.Category Lang where
  id = Lift id
  (.) = Comp

这让我可以构建程序，但不能解释它们。我理解编译器对我的错误，当我尝试将一个特定术语实例化为某种不是整体 run fn 类型的类型时。

这看起来有点像 Free 方法，也许是 Indexed Free？相关地，这是我的实际问题的简化版本，主要使用箭头，但是，我认为这个简化的公式概括了我的问题。

这是一个可运行的测试环境：

{-# LANGUAGE GADTs #-}

module T15_GADT_Lang where

import qualified Control.Category as C

------------------------------
-- * My Lang

data Lang a b where
  -- | DSL
  F :: Lang x y
  G :: Lang x y

  -- | Composition
  Lift :: (a -> b) -> Lang a b
  Comp :: Lang b c -> Lang a b -> Lang a c

instance C.Category Lang where
  id = Lift id
  (.) = Comp

------------------------------
-- * Program A can be interpreted in 2 different ways

progA :: Lang a b
progA = F

runA1 :: Lang a b -> (Int -> String)
runA1 F x = show x <> "!"

runA2 :: Lang a b -> ([Double] -> String)
runA2 F x = show x <> "!"

progAWorksNicely = do
  putStrLn $ runA1 progA 123
  putStrLn $ runA2 progA [1..3]


------------------------------
-- * Program B, I can't interpret the interim functions indepenedently

progB :: Lang a b
progB = G C.. F

-- | get the fst and increment it
runB1 :: Lang a b -> ((Int, b) -> Int)
runB1 F = fst
runB1 G = (+1) -- error: couldn't match type (Int, b) with Int

-- | Get the head and duplicate it
runB2 :: Lang a b -> ([a] -> (a, a))
runB2 F xs = head xs -- you're giving an `a`, but it should be `(a,a)`
runB2 G x = (x, x)

Answer 1

您可以仅使用 Lift 和 Comp 来编写这些不同的解释，但是如何将 F 解释为 fst 和 head 就不太明显了] 以一种有意义的方式

-- > run (Lift (\x -> show x <> "!")) 1
-- "1!"
-- > run (Lift (\x -> show x <> "!")) [pi,pi]
-- "[3.141592653589793,3.141592653589793]!"
-- > run (Lift (1 +) `Comp` Lift fst) (100, "ok")
-- 101
-- dup a = (a, a)
-- >> run (Lift dup `Comp` Lift head) [1,2,3]
-- (1, 1)
run :: Lang a b -> (a -> b)
run (Comp f g) = run f . run g
run (Lift f)   = f

F 和 G 的问题在于它们的索引是完全通用量化的，这意味着与它们组合也可能是无类型的，因为任何输入和输出都是有效的！

如果你想要 G . F 的类型安全组合，它们的解释必须以某种方式连接到那些类型，所以你必须为 Lang 提供统一这两种用途的索引

run F = fst   :: (a, b) -> a
run G = (+) 1 ::           Int -> Int

run F = head :: [a] -> a
run G = dup  ::        a -> (a, a)

在 Lift 的情况下，输入和输出类型清楚地反映在索引中。它们中的每一个都可以制成单独的构造函数，这些构造函数具有不同的索引。

Lift (\x -> show x <> "!") :: Lang Int      String
Lift (\x -> show x <> "!") :: Lang [Double] String
Lift fst                   :: Lang (a, b)   a
Lift (1 +)                 :: Lang Int      Int
Lift head                  :: Lang [a]      a
Lift dup                   :: Lang a        (a, a)

如果你想将 F 解释为 fst 并将 G 解释为 (+ 1) 你的类型匹配

type Lang :: Cat Type
data Lang a b where
  One   :: Lang (a, b) a
  Plus1 :: Lang Int    Int
  ..

-- > run (Plus1 . One) (100, 200)
-- 101
run :: Lang a b -> (a -> b)
run One   = fst
run Plus1 = (+) 1
..

您可以类似地解释为 IO-kleisli 箭头

-- > runIO  (Plus1 . One) (100, 200)
-- One
-- (+) 1
-- 101
runIO :: Lang a b -> (a -> IO b)
runIO One ~(a, _) = do
  putStrLn "One"
  pure a
runIO Plus1 n = do
  putStrLn "(+) 1"
  pure (1 + n)
runIO (Comp f g) a = 
  (runIO f <=< runIO g) a

切线

您还可以通过将构造函数抽象为类型 class 的方法并解释它受该 class

的约束来解释它

type Lang :: Cat Type
data Lang a b where
  One   :: Lang (a, b) a
  Plus1 :: Lang Int Int
  Lift  :: (a -> b) -> Lang a b
  Comp  :: Lang b c -> Lang a b -> Lang a c

type  Langc :: Cat Type -> Constraint
class Langc lang where
 one   :: lang (a, b) a
 plus1 :: lang Int    Int
 lift  :: (a -> b) -> lang a b
 comp  :: lang b c -> lang a b -> lang a c

run :: Lang a b -> (forall lang. Langc lang => lang a b)
run = \case
 One      -> one
 Plus1    -> plus1
 Lift f   -> lift f
 Comp f g -> comp (run f) (run g)

我想目标是将 Lift id 视为 Comp 的标识，就像类别操作一样。语言可以表示为“free Category”

type  Langc :: Cat Type -> Constraint
class Category cat => Langc cat where
 one   :: cat (a, b) a
 plus1 :: cat Int    Int
 lift  :: (a -> b) -> cat a b

run :: Lang a b -> (forall lang. Langc lang => lang a b)
run = \case
 One      -> one
 Plus1    -> plus1
 Lift f   -> lift f
 Comp f g -> run f . run g

或免费的 Arrow 其中有 arr :: Arrow arr => (a -> b) -> arr a b

type  Langc :: Cat Type -> Constraint
class Arrow arr => Langc arr where
 one   :: cat (a, b) a
 plus1 :: cat Int    Int

run :: Lang a b -> (forall lang. Langc lang => lang a b)
run = \case
 One      -> one
 Plus1    -> plus1
 Lift f   -> arr f
 Comp f g -> run f . run g

可以解释为 Langc (->) 和 Langc (Kleisli IO)。

事实上，您可以跳过“初始”Lang 编码并将其定义为“最终”

type Lang :: Cat Type
type Lang a b = (forall lang. Langc lang => lang a b)

f :: Lang (Int, a) Int
f = one >>> plus1

-- > run f (100, "ok")
-- 101
run :: Lang a b -> (a -> b)     -- requires: instance Langc (->)
run lang = lang

我如何多态地解释类似 Arrow 的 GADT DSL？

How can I polymorphically interpret an Arrow-like GADT DSL?

haskell

dsl

dependent-type

gadt

free-monad