TypeLits.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Re-exports 'GHC.TypeLits', modifying it considering our practices.
module Util.TypeLits
  ( Symbol
  , KnownSymbol
  , AppendSymbol
  , symbolVal
  , symbolValT
  , symbolValT'

  , TypeError
  , ErrorMessage (..)

  , TypeErrorUnless
  , inTypeErrorUnless
  ) where

import Data.Constraint (Dict(..))
import GHC.TypeLits
import Unsafe.Coerce (unsafeCoerce)

symbolValT :: forall s. KnownSymbol s => Proxy s -> Text
symbolValT = toText . symbolVal

symbolValT' :: forall s. KnownSymbol s => Text
symbolValT' = symbolValT (Proxy @s)

-- | Conditional type error.
--
-- Note that @TypeErrorUnless cond err@ is the same as
-- @If cond () (TypeError err)@, but does not produce type-level error when
-- one of its arguments cannot be deduced.
type family TypeErrorUnless (cond :: Bool) (err :: ErrorMessage) :: Constraint where
  TypeErrorUnless 'True _ = ()
  TypeErrorUnless 'False err = TypeError err

-- | Reify the fact that condition under 'TypeErrorUnless' constraint can be
-- assumed to always hold.
inTypeErrorUnless
  :: forall cond err a.
      TypeErrorUnless cond err
  => (cond ~ 'True => a)
  -> a
inTypeErrorUnless a =
  case unsafeCoerce @(Dict ('True ~ 'True)) @(Dict (cond ~ 'True)) Dict of
    Dict -> a