Question

我正在尝试构建一个静态类型的授权系统，并具有以下工作代码片段：

{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeFamilies #-}

module Try where

import Data.Singletons.TH

data FeatureFlag = Feature1 | Feature2 deriving (Eq, Show)
$(genSingletons [''FeatureFlag])

type family Feature (f :: FeatureFlag) (fs :: [FeatureFlag]) where
  Feature f '[] = 'False
  Feature f (f:fs) = 'True
  Feature f (q:fs) = Feature f fs  


lockedFeatureAction :: (MonadIO (m fs), Feature 'Feature1 fs ~ 'True) => m fs ()
lockedFeatureaction = undefined

checkFeatureFlagsAndRun :: forall (fs :: [FeatureFlag]) . (SingI fs) => Proxy fs -> AppM fs () -> IO ()
checkFeatureFlagsAndRun = undefined

这就是它的使用方式：

ghci> checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature1]) lockedFeatureAction

当类型和星形对齐时，一切都很好。但是，如果类型不对齐，则错误消息是经典的Sherlock Holmes“ whodunnit”：

ghci> checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction

<interactive>:462:32: error:
    • Couldn't match type ‘'False’ with ‘'True’
        arising from a use of ‘lockedFeatureAction’
    • In the second argument of ‘checkFeatureFlagsAndRun’, namely ‘lockedFeatureAction’
      In the expression: checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction
      In an equation for ‘it’: it = checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction

我尝试搜索并偶然发现https://kcsongor.github.io/report-stuck-families/，其中提到了TypeError，我试图像这样使用它，但是没有用：

type family Feature (f :: FeatureFlag) (fs :: [FeatureFlag]) where
  Feature f '[] = TypeError "Could not satisfy FeatureFlag conditions"
  Feature f (f:fs) = 'True
  Feature f (q:fs) = Feature f fs

--     • Expected kind ‘ghc-prim-0.5.2.0:GHC.Types.Symbol -> Bool’,
--         but ‘TypeError’ has kind ‘*’
--     • In the type ‘TypeError "Could not satisfy FeatureFlag conditions"’
--       In the type family declaration for ‘Feature’
--    |
-- 19 |   Feature f '[] = TypeError "Could not satisfy FeatureFlag conditions"
--    |                   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

使用TypeError的正确方法是什么？另外，还有其他方法可以获取更好的错误消息吗？

Answer 1

确保可以使用自定义类型错误提供更好的编译时错误消息。我已经在我的博客文章中介绍了如何使用它们：

A story told by Type Errors

但是，由于您的方法不是基于类型类的，因此您需要使用一些其他实用程序。具体来说，您需要使用type-errors软件包。

自定义错误消息的外观如下：

ghci> checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature1]) lockedFeatureAction
<works as expected>

ghci> :t checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction

    • Type-level list of features should contain feature: 'Feature1
      But it doesn't:

          '[ 'Feature2]

    • In the second argument of ‘checkFeatureFlagsAndRun’, namely
        ‘lockedFeatureAction’
      In the expression:
        checkFeatureFlagsAndRun
          (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction

下面我提供完整的代码：

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Feature where

import Control.Monad.IO.Class (MonadIO)
import Data.Kind (Constraint)
import Data.Proxy (Proxy)
import Data.Singletons.TH (SingI, genSingletons)
import Data.Type.Bool (If)
import Fcf (Stuck)
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Type.Errors (DelayError, WhenStuck)


data FeatureFlag = Feature1 | Feature2 deriving (Eq, Show)
$(genSingletons [''FeatureFlag])

data AppM (fs :: [FeatureFlag]) a

type family HasFeature (f :: FeatureFlag) (fs :: [FeatureFlag]) :: Constraint where
    HasFeature f fs = WhenStuck (Elem f fs) (DelayError (NoFeature f fs))

type family Elem (x :: k) (xs :: [k]) :: Bool where
    Elem _ '[]       = Stuck
    Elem x (x ': xs) = 'True
    Elem x (y ': xs) = Elem x xs

type NoFeature (f :: FeatureFlag) (fs :: [FeatureFlag]) =
        'Text "Type-level list of features should contain feature: " ':<>: 'ShowType f
  ':$$: 'Text "But it doesn't:"
  ':$$: 'Text ""
  ':$$: 'Text "    " ':<>: 'ShowType fs
  ':$$: 'Text ""

lockedFeatureAction :: (MonadIO (m fs), HasFeature 'Feature1 fs) => m fs ()
lockedFeatureAction = undefined

checkFeatureFlagsAndRun :: forall (fs :: [FeatureFlag]) . (SingI fs) => Proxy fs -> AppM fs () -> IO ()
checkFeatureFlagsAndRun = undefined

Answer 2

好的，我找到了一个“妥协”的解决方案，但是我对此并不完全满意。有有可以更好/内置的方式来处理此问题。

data FeatureFlag = Feature1 | Feature2 | FeatureNotFound

type family Feature (f :: FeatureFlag) (fs :: [FeatureFlag]) where
  Feature f '[] = 'FeatureNotFound
  Feature f (f:fs) = f
  Feature f (q:fs) = Feature f fs

type NeedFeature (f :: FeatureFlag) (fs :: [FeatureFlag]) = (Feature f fs ~ f)

lockedFeatureAction :: (MonadIO (m fs), NeedFeature 'Feature1 fs) => m fs ()
lockedFeatureaction = undefined

现在，如果类型不对齐，我会收到类似以下内容的错误消息：

ghci> checkFeatureFlagsAndRun (Proxy :: Proxy '[ 'Feature2]) lockedFeatureAction

    • Couldn't match type ‘'FeatureNotFound’
                     with ‘'FeatureBookingEngine’
        arising from a use of ‘lockedFeatureAction’

如何获得类型家族更好的错误消息？

2 个答案: