diff --git a/singletons-base/CHANGES.md b/singletons-base/CHANGES.md index 01cb575d..20ee4864 100644 --- a/singletons-base/CHANGES.md +++ b/singletons-base/CHANGES.md @@ -1,8 +1,18 @@ Changelog for the `singletons-base` project =========================================== -3.1.2 [????.??.??] ------------------- +3.2 [????.??.??] +---------------- +* The kinds of the promoted `Error` and `ErrorWithoutStackTrace` functions have + been monomorphized to `Symbol`. A previous release generalized the kinds of + these arguments to allow passing arguments besides `Symbol`s, but this change + introduces ambiguity in derived code when `OverloadedString`s is enabled. + See [#89](https://github.com/goldfirere/singletons/issues/89) for the full + story. + + If you were relying on the previous, kind-polymorphic behavior of `Error`, you + can instead use the new `Data.Singletons.Base.PolyError` module that provides + `PolyError`, a version of `Error` with a kind-polymorphic argument. * Provide `TestEquality` and `TestCoercion` instances for `SNat, `SSymbol`, and `SChar`. diff --git a/singletons-base/singletons-base.cabal b/singletons-base/singletons-base.cabal index 68121d54..1e50272c 100644 --- a/singletons-base/singletons-base.cabal +++ b/singletons-base/singletons-base.cabal @@ -1,5 +1,5 @@ name: singletons-base -version: 3.1.2 +version: 3.2 cabal-version: 1.24 synopsis: A promoted and singled version of the base library homepage: http://www.github.com/goldfirere/singletons @@ -84,6 +84,7 @@ library exposed-modules: Data.Singletons.Base.CustomStar Data.Singletons.Base.Enum Data.Singletons.Base.TH + Data.Singletons.Base.PolyError Data.Singletons.Base.SomeSing Data.Singletons.Base.TypeError Data.Singletons.Base.TypeRepTYPE diff --git a/singletons-base/src/Data/Singletons/Base/PolyError.hs b/singletons-base/src/Data/Singletons/Base/PolyError.hs new file mode 100644 index 00000000..00c80410 --- /dev/null +++ b/singletons-base/src/Data/Singletons/Base/PolyError.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Base.TypeError +-- Copyright : (C) 2023 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines a replacement for the promoted @Error@ function whose argument is +-- kind-polymorphic. +-- +---------------------------------------------------------------------------- +module Data.Singletons.Base.PolyError (PolyError) where + +import Data.Singletons.TH + +-- | Like @Error@ from "GHC.TypeLits.Singletons", but with an argument that is +-- generalized to be kind-polymorphic. This allows passing additional +-- information to the error besides raw @Symbol@s. +type PolyError :: a -> b +type family PolyError (arg :: a) :: b where {} +$(genDefunSymbols [''PolyError]) diff --git a/singletons-base/src/GHC/TypeLits/Singletons/Internal.hs b/singletons-base/src/GHC/TypeLits/Singletons/Internal.hs index 86172745..95edaf6e 100644 --- a/singletons-base/src/GHC/TypeLits/Singletons/Internal.hs +++ b/singletons-base/src/GHC/TypeLits/Singletons/Internal.hs @@ -244,22 +244,31 @@ withKnownSymbol SSym f = f withKnownChar :: Sing n -> (KnownChar n => r) -> r withKnownChar SChar f = f --- | The promotion of 'error'. This version is more poly-kinded for --- easier use. -type Error :: k0 -> a -type family Error (str :: k0) :: a where {} +-- | A promoted version of 'error'. This implements 'Error' as a stuck type +-- family with a 'Symbol' argument. Depending on your needs, you might also +-- consider the following alternatives: +-- +-- * "Data.Singletons.Base.PolyError" provides @PolyError@, which generalizes +-- the argument to be kind-polymorphic. This allows passing additional +-- information to the error besides raw 'Symbol's. +-- +-- * "Data.Singletons.Base.TypeError" provides @TypeError@, a slightly modified +-- version of the custom type error machinery found in "GHC.TypeLits". This +-- allows emitting error messages as compiler errors rather than as stuck type +-- families. +type Error :: Symbol -> a +type family Error (str :: Symbol) :: a where {} $(genDefunSymbols [''Error]) instance SingI (ErrorSym0 :: Symbol ~> a) where sing = singFun1 sError --- | The singleton for 'error' +-- | The singleton for 'error'. sError :: HasCallStack => Sing (str :: Symbol) -> a sError sstr = error (T.unpack (fromSing sstr)) --- | The promotion of 'errorWithoutStackTrace'. This version is more --- poly-kinded for easier use. -type ErrorWithoutStackTrace :: k0 -> a -type family ErrorWithoutStackTrace (str :: k0) :: a where {} +-- | The promotion of 'errorWithoutStackTrace'. +type ErrorWithoutStackTrace :: Symbol -> a +type family ErrorWithoutStackTrace (str :: Symbol) :: a where {} $(genDefunSymbols [''ErrorWithoutStackTrace]) instance SingI (ErrorWithoutStackTraceSym0 :: Symbol ~> a) where sing = singFun1 sErrorWithoutStackTrace diff --git a/singletons-base/tests/SingletonsBaseTestSuite.hs b/singletons-base/tests/SingletonsBaseTestSuite.hs index a6ff19e4..22630867 100644 --- a/singletons-base/tests/SingletonsBaseTestSuite.hs +++ b/singletons-base/tests/SingletonsBaseTestSuite.hs @@ -58,6 +58,7 @@ tests = compileAndDumpStdTest "Classes2" , compileAndDumpStdTest "FunDeps" , compileAndDumpStdTest "T78" + , compileAndDumpStdTest "T89" , compileAndDumpStdTest "OrdDeriving" , compileAndDumpStdTest "BoundedDeriving" , compileAndDumpStdTest "BadBoundedDeriving" diff --git a/singletons-base/tests/compile-and-dump/Singletons/T89.golden b/singletons-base/tests/compile-and-dump/Singletons/T89.golden new file mode 100644 index 00000000..c5aa0f91 --- /dev/null +++ b/singletons-base/tests/compile-and-dump/Singletons/T89.golden @@ -0,0 +1,78 @@ +Singletons/T89.hs:0:0:: Splicing declarations + singletons + [d| data Foo + = Foo + deriving (Enum) |] + ======> + data Foo + = Foo + deriving Enum + type FooSym0 :: Foo + type family FooSym0 :: Foo where + FooSym0 = Foo + type family Case_0123456789876543210 n t where + Case_0123456789876543210 n 'True = FooSym0 + Case_0123456789876543210 n 'False = Apply ErrorSym0 (FromString "toEnum: bad argument") + type ToEnum_0123456789876543210 :: GHC.Num.Natural.Natural -> Foo + type family ToEnum_0123456789876543210 (a :: GHC.Num.Natural.Natural) :: Foo where + ToEnum_0123456789876543210 n = Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 0)) + type ToEnum_0123456789876543210Sym0 :: (~>) GHC.Num.Natural.Natural Foo + data ToEnum_0123456789876543210Sym0 :: (~>) GHC.Num.Natural.Natural Foo + where + ToEnum_0123456789876543210Sym0KindInference :: SameKind (Apply ToEnum_0123456789876543210Sym0 arg) (ToEnum_0123456789876543210Sym1 arg) => + ToEnum_0123456789876543210Sym0 a0123456789876543210 + type instance Apply ToEnum_0123456789876543210Sym0 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings ToEnum_0123456789876543210Sym0 where + suppressUnusedWarnings + = snd (((,) ToEnum_0123456789876543210Sym0KindInference) ()) + type ToEnum_0123456789876543210Sym1 :: GHC.Num.Natural.Natural + -> Foo + type family ToEnum_0123456789876543210Sym1 (a0123456789876543210 :: GHC.Num.Natural.Natural) :: Foo where + ToEnum_0123456789876543210Sym1 a0123456789876543210 = ToEnum_0123456789876543210 a0123456789876543210 + type FromEnum_0123456789876543210 :: Foo -> GHC.Num.Natural.Natural + type family FromEnum_0123456789876543210 (a :: Foo) :: GHC.Num.Natural.Natural where + FromEnum_0123456789876543210 Foo = FromInteger 0 + type FromEnum_0123456789876543210Sym0 :: (~>) Foo GHC.Num.Natural.Natural + data FromEnum_0123456789876543210Sym0 :: (~>) Foo GHC.Num.Natural.Natural + where + FromEnum_0123456789876543210Sym0KindInference :: SameKind (Apply FromEnum_0123456789876543210Sym0 arg) (FromEnum_0123456789876543210Sym1 arg) => + FromEnum_0123456789876543210Sym0 a0123456789876543210 + type instance Apply FromEnum_0123456789876543210Sym0 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 + instance SuppressUnusedWarnings FromEnum_0123456789876543210Sym0 where + suppressUnusedWarnings + = snd (((,) FromEnum_0123456789876543210Sym0KindInference) ()) + type FromEnum_0123456789876543210Sym1 :: Foo + -> GHC.Num.Natural.Natural + type family FromEnum_0123456789876543210Sym1 (a0123456789876543210 :: Foo) :: GHC.Num.Natural.Natural where + FromEnum_0123456789876543210Sym1 a0123456789876543210 = FromEnum_0123456789876543210 a0123456789876543210 + instance PEnum Foo where + type ToEnum a = Apply ToEnum_0123456789876543210Sym0 a + type FromEnum a = Apply FromEnum_0123456789876543210Sym0 a + data SFoo :: Foo -> Type where SFoo :: SFoo (Foo :: Foo) + type instance Sing @Foo = SFoo + instance SingKind Foo where + type Demote Foo = Foo + fromSing SFoo = Foo + toSing Foo = SomeSing SFoo + instance SEnum Foo where + sToEnum :: + forall (t :: GHC.Num.Natural.Natural). Sing t + -> Sing (Apply (Data.Singletons.Base.Enum.ToEnumSym0 :: TyFun GHC.Num.Natural.Natural Foo + -> Type) t) + sFromEnum :: + forall (t :: Foo). Sing t + -> Sing (Apply (Data.Singletons.Base.Enum.FromEnumSym0 :: TyFun Foo GHC.Num.Natural.Natural + -> Type) t) + sToEnum (sN :: Sing n) + = (id + @(Sing (Case_0123456789876543210 n (Apply (Apply (==@#@$) n) (FromInteger 0))))) + (case + (applySing ((applySing ((singFun2 @(==@#@$)) (%==))) sN)) + (sFromInteger (sing :: Sing 0)) + of + STrue -> SFoo + SFalse + -> sError (sFromString (sing :: Sing "toEnum: bad argument"))) + sFromEnum SFoo = sFromInteger (sing :: Sing 0) + instance SingI Foo where + sing = SFoo diff --git a/singletons-base/tests/compile-and-dump/Singletons/T89.hs b/singletons-base/tests/compile-and-dump/Singletons/T89.hs new file mode 100644 index 00000000..7fdc08e0 --- /dev/null +++ b/singletons-base/tests/compile-and-dump/Singletons/T89.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +module T89 where + +import Data.Singletons.Base.TH + +$(singletons [d|data Foo = Foo deriving (Enum)|])