Haskell 计算类型索引自由单子的详细信息

我一直在使用一个免费的monad来构建DSL。作为语言的一部分，有一个

input

命令，其目的是反映输入原语在类型级别上期望的类型，以实现额外的安全性

例如，我希望能够编写以下程序

concat :: Action '[String, String] ()
concat = do
  (x :: String) <- input
  (y :: String) <- input 
  output $ x ++ " " ++ y

其工作原理如下

> eval concat ("a" `HCons` "b" `HCons` HNil)
["a b"]

这是我到目前为止所拥有的

data HList i where
  HNil :: HList '[]
  HCons :: h -> HList t -> HList (h ': t)

type family Append (a :: [k]) (b :: [k]) :: [k] where
  Append ('[]) l = l
  Append (e ': l) l' = e ': (Append l l')

data ActionF next where
   Input :: (a -> next) ->  ActionF next
   Output :: String -> next -> ActionF next

instance Functor ActionF where
  fmap f (Input c) = Input (fmap f c)
  fmap f (Output s n) = Output s (f n)

data FreeIx f i a where
  Return :: a -> FreeIx f '[] a
  Free :: f (FreeIx f i a) -> FreeIx f i a

type Action i a = FreeIx ActionF i a

liftF :: Functor f => f a -> FreeIx f i a
liftF = Free . fmap Return

input :: forall a . Action '[a] a
input = liftF (Input id)

output :: String -> Action '[] ()
output s = liftF (Output s ())

bind :: Functor f => FreeIx f t a -> (a -> FreeIx f v b) -> FreeIx f (Append t v) b
bind (Return a) f = f a
bind (Free x) f   = Free (fmap (flip bind f) x)

问题在于

liftF

不进行类型检查

liftF :: Functor f => Proxy i -> f a -> FreeIx f i a
liftF p = Free . fmap Return

这是正确的方法吗

我想这个包裹可能会给我一些灵感。这就是

返回

和

免费

的定义

---

关于更多的背景故事：我在几个地方看到，用户将以这种方式定义DSL，然后定义一个求值函数

eval:：Action a->[String]->a

或类似的东西。这种方法的明显问题是，所有参数必须具有相同的类型，并且不能静态保证提供正确数量的参数。这是解决这个问题的一种尝试。

简要介绍索引单子：它们是由幺半群索引的单子。比较默认单子：

class Monad m where
  return :: a -> m a
  bind :: m a -> (a -> m b) -> m b
  -- or `bind` alternatives:
  fmap :: (a -> b) -> m a -> m b
  join :: m (m a) -> m a

幺半群是一种配备了

mempty

-标识元素和

（）：A->A->A

二进制关联操作的类型。提升到类型级别，我们可以使用

单元

类型和

加上

关联二进制类型操作。注意，列表是值级别上的自由幺半群，

HList

是类型级别上的自由幺半群

现在我们可以定义索引幺半群类：

class IxMonad m where
  type Unit
  type Plus i j

  return :: a -> m Unit a
  bind :: m i a -> (a -> m j b) -> m (Plus i j) b
  --
  fmap :: (a -> b) -> m i a -> m i b
  join :: m i (m j a) -> m (Plus i j) a

您可以为索引版本声明monad法则。您会注意到，要使索引对齐，它们必须遵守幺半群法则

---

有了免费的monad，你需要为

函子

配备

return

和

join

操作。稍微改变一下你的定义：

data FreeIx f i a where
  Return :: a -> FreeIx f '[] a -- monoid laws imply we should have `[] as index here!
  Free :: f (FreeIx f k a) -> FreeIx f k a

bind :: Functor f => FreeIx f i a -> (a -> FreeIx f j b) -> FreeIx f (Append i j) b
bind (Return a) f = f a
bind (Free x) f   = Free (fmap (flip bind f) x)

---

我必须承认，我不能100%确定

Free

构造函数索引的合理性，但它们似乎是有效的。如果我们考虑函数<代码>包装：：f（m a）-> m < a /代码> <代码> MonadFree < /代码>类，用一个定律：

wrap (fmap f x) ≡ wrap (fmap return x) >>= f

以及

Free

软件包中关于

Free

的注释

实际上，您可以只查看一个

自由f

一个围绕

a

类型值的多个

f

层，其中

（>=）

对每个自由变量执行替换并移植新的

f

层

这样一来，包装值就不会影响索引

---

然而，您希望将任何

f

值提升为任意索引的一元值。这是一个非常合理的要求。但唯一有效的定义强制提升值具有

'[]

-

单位

或

mempty

索引：

liftF :: Functor f => f a -> FreeIx f '[] a
liftF = Free . fmap Return

如果尝试将

返回
定义更改为
：：a->FreeIx f k a
（
k
，而不是
[]
——纯值可以有任意索引），则
绑定
定义不会进行类型检查


我不确定你是否能让自由索引的单子只做一些小的修改。一个想法是将任意单子提升为索引单子：

data FreeIx m i a where
  FreeIx :: m a -> FreeIx m k a

liftF :: Proxy i -> f a -> FreeIx f i a
liftF _ = FreeIx

returnIx :: Monad m => a -> FreeIx m i a
returnIx = FreeIx . return

bind :: Monad m => FreeIx m i a -> (a -> FreeIx m j b) -> FreeIx m (Append i j) b
bind (FreeIx x) f = FreeIx $ x >>= (\x' -> case f x' of
                                             FreeIx y -> y)

这种方法感觉有点像作弊，因为我们总是可以重新索引值


另一种方法是提醒
函子
它是一个索引函子，或者从中的索引函子开始。
如果您愿意牺牲隐式排序而使用显式访问器，则可以使用
ReaderT（HList'[Int，Int]）
实现
操作'[Int，Int]
。如果您使用提供镜头的现有库，如
乙烯基
，您可以编写如下内容：

-- Implemented with pseudo-vinyl
-- X and Y are Int fields, with accessors xField and yField
addTwo :: ReaderT (PlainRec '[X, Y]) Output ()
addTwo = do
  x <- view (rGet xField)
  y <- view (rGet yField)
  lift . output $ show (x + y) -- output :: String -> Output ()

我们失去了排序属性，这是一个重大损失，特别是如果排序是有意义的，例如表示用户交互的顺序

此外，我们现在必须使用
runReaderT
（~
eval
）。比如说，我们不能将用户输入与输出交错

编辑：我已经发布了一个更一般的。我离开
这个答案现在在这里，因为它可能是一个有用的例子
手工构造目标单子

我的解决方案符合OP的要求（尽管它涉及到手动编写monad实例，所以当然还有改进的余地）

软件包（OP提到的）已经包含一个处理从
HList
读取的效果。它叫。然而，我们还需要一个
Writer
效果来实现
输出
，在我看来，库不允许我们将这两者结合起来

我们仍然可以采用
ReadOnceReader
的思想，手动为所需的语言编写AST。当然，AST应该是一个索引单子。如果我们也能通过一个索引的自由单子或操作单子来实现这一点，那就太好了。到目前为止，我还没有获得过免费单子的成功。我可能会在查看操作单子后更新我的答案

预备工作：

{-# LANGUAGE
    RebindableSyntax, DataKinds, ScopedTypeVariables,
    GADTs, TypeFamilies, TypeOperators,
    PolyKinds, StandaloneDeriving, DeriveFunctor #-}

import Prelude hiding (Monad(..))

data HList (xs :: [*]) where
  Nil  :: HList '[]
  (:>) :: x -> HList xs -> HList (x ': xs)
infixr 5 :>                     

type family (++) (xs :: [*]) (ys :: [*]) where
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

索引单子必须提供将（
Plus
）索引与标识（
Unit
）相结合的方法。简而言之，索引应该是幺半群

class IxMonad (m :: k -> * -> *) where
  type Unit m :: k
  type Plus m (i :: k) (j :: k) :: k
  return :: a -> m (Unit m) a
  (>>=)  :: m i a -> (a -> m j b) -> m (Plus m i j) b
  fail   :: m i a

此处关注的是
输入类型
：我们将输入类型预先添加到下一次计算的结果索引中：

data Action i a where
  Return :: a -> Action '[] a
  Input  :: (x -> Action xs a) -> Action (x ': xs) a
  Output :: String -> Action i a -> Action i a
deriving instance Functor (Action i)

IxMonad
实例和智能构造函数是完全标准的，
eval
函数也直接实现

instance IxMonad Action where
  type Unit Action = '[]
  type Plus Action i j = i ++ j
  return = Return
  Return a     >>= f = f a
  Input k      >>= f = Input ((>>= f) . k)
  Output s nxt >>= f = Output s (nxt >>= f)
  fail = undefined

input :: Action '[a] a
input = Input Return

output :: String -> Action '[] ()
output s = Output s (Return ())

eval :: Action xs a -> HList xs -> [String]
eval (Return a)     xs        = []
eval (Input k)      (x :> xs) = eval (k x) xs
eval (Output s nxt) xs        = s : eval nxt xs

现在一切正常：

concat' :: Action '[String, String] ()
concat' = do
  (x :: String) <- input
  (y :: String) <- input 
  output $ x ++ " " ++ y

main = print $ eval concat' ("a" :> "b" :> Nil)
-- prints ["a b"]

concat'：：Action'[String，String]（）
concat'=do
（x：：String）我找到了这个问题的令人满意的解决方案。以下是对最终结果的初步了解：

addTwo = do
  (x :: Int) <- input
  (y :: Int) <- input 
  output $ show (x + y)

eval (1 ::: 2 ::: HNil) addTwo = ["3"]

我们将使用来操纵类型相等

import Data.Type.Equality
import Data.Proxy

因为我们将重新绑定
Monad
语法，所以我们将从
Prelude
导入中隐藏所有
Monad
。
rebindable语法
扩展用于
do
表示任何函数
>=
、
>
和
failaddTwo = do
  (x :: Int) <- input
  (y :: Int) <- input 
  output $ show (x + y)

eval (1 ::: 2 ::: HNil) addTwo = ["3"]

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RebindableSyntax #-}

import Data.Type.Equality
import Data.Proxy

import Prelude hiding (Monad, (>>=), (>>), fail, return)

data HList i where
  HNil :: HList '[]
  (:::) :: h -> HList t -> HList (h ': t)

infixr 5 :::

type family (++) (a :: [k]) (b :: [k]) :: [k] where
  '[]      ++ l  = l
  (e ': l) ++ l' = e ': l ++ l'

class Functor1 (f :: k -> * -> *) where
    fmap1 :: (a -> b) -> f i a -> f i b

data ActionF i next where
   Input :: (a -> next) ->  ActionF '[a] next
   Output :: String -> next -> ActionF '[] next 

instance Functor (ActionF i) where
  fmap f (Input c) = Input (fmap f c)
  fmap f (Output s n) = Output s (f n)

instance Functor1 ActionF where
  fmap1 f = fmap f

data FreeIx f (i :: [k]) a where
  Return :: a -> FreeIx f '[] a
  Free :: (WitnessList i) => f i (FreeIx f j a) -> FreeIx f (i ++ j) a

instance (Functor1 f) => Functor (FreeIx f i) where
  fmap f (Return a) = Return (f a)
  fmap f (Free x) = Free (fmap1 (fmap f) x)

instance (Functor1 f) => Functor1 (FreeIx f) where
  fmap1 f = fmap f

data IxIdentityT f i a = IxIdentityT {runIxIdentityT :: f a}

instance Functor f => Functor (IxIdentityT f i) where
    fmap f = IxIdentityT . fmap f . runIxIdentityT

instance Functor f => Functor1 (IxIdentityT f) where
    fmap1 f = fmap f

data SList (i :: [k]) where
  SNil :: SList '[]
  SSucc :: SList t -> SList (h ': t)

appAssoc ::
  SList xs -> Proxy ys -> Proxy zs ->
  (xs ++ (ys ++ zs)) :~: ((xs ++ ys) ++ zs)
appAssoc SNil ys zs = Refl
appAssoc (SSucc xs) ys zs =
  case appAssoc xs ys zs of Refl -> Refl

appRightId :: SList xs -> xs :~: (xs ++ '[])
appRightId SNil = Refl
appRightId (SSucc xs) = case appRightId xs of Refl -> Refl

class WitnessList (xs :: [k]) where
  witness :: SList xs

instance WitnessList '[] where
  witness = SNil

instance WitnessList xs => WitnessList (x ': xs) where
  witness = SSucc witness

liftF :: forall f i a . (WitnessList i, Functor1 f) => f i a -> FreeIx f i a
liftF = case appRightId (witness :: SList i) of Refl -> Free . fmap1 Return

type Action i a = FreeIx ActionF i a

input :: Action '[a] a
input = liftF (Input id)

output :: String -> Action '[] ()
output s = liftF (Output s ())

class Functor1 m => IxMonad (m :: k -> * -> *) where
    type Unit :: k
    type Plus (i :: k) (j :: k) :: k

    return :: a -> m Unit a
    (>>=) :: m i a -> (a -> m j b) -> m (Plus i j) b

    (>>) :: m i a -> m j b -> m (Plus i j) b
    a >> b = a >>= const b

    fail :: String -> m i a
    fail s = error s

bind :: forall f i j a b. (Functor1 f) => FreeIx f i a -> (a -> FreeIx f j b) -> FreeIx f (i ++ j) b
bind (Return a) f = f a
bind (Free (x :: f i1 (FreeIx f j1 a))) f =
    case appAssoc (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j)
    of Refl -> Free (fmap1 (`bind` f) x)

instance (Functor1 f) => IxMonad (FreeIx f) where
    type Unit = '[]
    type Plus i j = i ++ j

    return = Return
    (>>=) = bind

eval :: HList i -> Action i () -> [String]
eval inputs action = 
    case action of 
        Return () -> []
        Free (Input f) -> 
            case inputs of
                (x ::: xs) -> eval xs (f x)
        Free (Output s next) -> s : eval inputs next

addTwo = do
  (x :: Int) <- input
  (y :: Int) <- input 
  output $ show (x + y)

> :t addTwo
addTwo :: FreeIx ActionF '[Int, Int] ()

    return :: a -> m i i a
    (>>=) :: m i j a -> (a -> m j k b) -> m i k b

data IxFree f i j a where
  Pure :: a -> IxFree f i i a
  Free :: f i j (IxFree f j k a) -> IxFree f i k a

-- compute transitions top-down
test = do
  (x :: Int) <- input       -- prepend Int to typestate
  (y :: String) <- input    -- prepend String to typestate
  return ()                 -- do nothing         

{-# LANGUAGE
    RebindableSyntax, DataKinds,
    GADTs, TypeFamilies, TypeOperators,
    PolyKinds, StandaloneDeriving, DeriveFunctor #-}

import Prelude hiding (Monad(..))

class IxFunctor (f :: ix -> ix -> * -> *) where
    imap :: (a -> b) -> f i j a -> f i j b

class IxFunctor m => IxMonad (m :: ix -> ix -> * -> *) where
    return :: a -> m i i a
    (>>=) :: m j k a -> (a -> m i j b) -> m i k b -- note the change of index orders

    (>>) :: m j k a -> m i j b -> m i k b -- here too
    a >> b = a >>= const b

    fail :: String -> m i j a
    fail = error

data IxFree f i j a where
  Pure :: a -> IxFree f i i a
  Free :: f j k (IxFree f i j a) -> IxFree f i k a -- compute bottom-up

instance IxFunctor f => Functor (IxFree f i j) where
  fmap f (Pure a)  = Pure (f a)
  fmap f (Free fa) = Free (imap (fmap f) fa)

instance IxFunctor f => IxFunctor (IxFree f) where
  imap = fmap

instance IxFunctor f => IxMonad (IxFree f) where
  return = Pure
  Pure a  >>= f = f a
  Free fa >>= f = Free (imap (>>= f) fa)

liftf :: IxFunctor f => f i j a -> IxFree f i j a
liftf = Free . imap Pure

data ActionF i j next where
  Input  :: (a -> next) -> ActionF i (a ': i) next
  Output :: String -> next -> ActionF i i next

deriving instance Functor (ActionF i j)                                      
instance IxFunctor ActionF where
  imap = fmap

type family (++) xs ys where -- I use (++) here only for the type synonyms
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

type Action' xs rest = IxFree ActionF rest (xs ++ rest)
type Action xs a = forall rest. IxFree ActionF rest (xs ++ rest) a  

input :: Action '[a] a
input = liftf (Input id)

output :: String -> Action '[] ()
output s = liftf (Output s ())

data HList i where
  HNil :: HList '[]
  (:::) :: h -> HList t -> HList (h ': t)
infixr 5 :::

eval :: Action' xs r a -> HList xs -> [String]
eval (Pure a)              xs         = []
eval (Free (Input k))      (x ::: xs) = eval (k x) xs
eval (Free (Output s nxt)) xs         = s : eval nxt xs

addTwice :: Action [Int, Int] ()
addTwice = do
  x <- input
  y <- input
  output (show $ x + y)

data IxStateF i j next where
  Put :: j -> next -> IxStateF j i next
  Get :: (i -> next) -> IxStateF i i next

deriving instance Functor (IxStateF i j)
instance IxFunctor IxStateF where imap = fmap

put s = liftf (Put s ())
get   = liftf (Get id)

type IxState i j = IxFree IxStateF j i

evalState :: IxState i o a -> i -> (a, o)
evalState (Pure a)         i = (a, i)
evalState (Free (Get k))   i = evalState (k i) i
evalState (Free (Put s k)) i = evalState k s

test :: IxState Int String ()
test = do
  n <- get
  put (show $ n * 100)