{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} module Polysemy.Internal.CustomErrors ( WhenStuck , FirstOrder , type (<>) , type (%) ) where import Data.Kind import Fcf import GHC.TypeLits (Symbol) import Polysemy.Internal.Kind import Polysemy.Internal.CustomErrors.Redefined import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck) -- These are taken from type-errors-pretty because it's not in stackage for 9.0.1 -- See https://github.com/polysemy-research/polysemy/issues/401 type family ToErrorMessage (t :: k) :: ErrorMessage where ToErrorMessage (t :: Symbol) = 'Text t ToErrorMessage (t :: ErrorMessage) = t ToErrorMessage t = 'ShowType t infixl 5 <> type family (<>) (l :: k1) (r :: k2) :: ErrorMessage where l <> r = ToErrorMessage l ':<>: ToErrorMessage r infixr 4 % type family (%) (t :: k1) (b :: k2) :: ErrorMessage where t % b = ToErrorMessage t ':$$: ToErrorMessage b -- TODO(sandy): Put in type-errors type ShowTypeBracketed t = "(" <> t <> ")" ------------------------------------------------------------------------------ -- | The constructor of the effect row --- it's either completely polymorphic, -- a nil, or a cons. data EffectRowCtor = TyVarR | NilR | ConsR ------------------------------------------------------------------------------ -- | Given that @r@ isn't stuck, determine which constructor it has. type family UnstuckRState (r :: EffectRow) :: EffectRowCtor where UnstuckRState '[] = 'NilR UnstuckRState (_ ': _) = 'ConsR ------------------------------------------------------------------------------ -- | Put brackets around @r@ if it's a cons. type family ShowRQuoted (rstate :: EffectRowCtor) (r :: EffectRow) :: ErrorMessage where ShowRQuoted 'TyVarR r = 'ShowType r ShowRQuoted 'NilR r = 'ShowType r ShowRQuoted 'ConsR r = ShowTypeBracketed r data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint type instance Eval (FirstOrderErrorFcf e fn) = $(te[t| UnlessPhantom (e PHANTOM) ( "'" <> e <> "' is higher-order, but '" <> fn <> "' can help only" % "with first-order effects." % "Fix:" % " use '" <> fn <> "H' instead." ) |]) ------------------------------------------------------------------------------ -- | This constraint gives helpful error messages if you attempt to use a -- first-order combinator with a higher-order type. type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn) data DoError :: ErrorMessage -> Exp k type instance Eval (DoError a) = TypeError a