diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# 0.9.1.0 + +- Fix `conIdToString` (it was completely broken) +- Add `conIdMin` and `conIdMax` representing the leftmost and rightmost + constructors of a data type. +- Add `NonEmptyType` and `IsEmptyType` to express the constraint that + a generic type must or must not be empty. +- Reexport `Generic` and `Generic1` for convenience. + # 0.9.0.0 - Improved definition of `gfoldMap`, `gtraverse`, and `sequenceA`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Generic data types in Haskell [![Hackage](https://img.shields.io/hackage/v/generic-data.svg)](https://hackage.haskell.org/package/generic-data) [![Build Status](https://travis-ci.org/Lysxia/generic-data.svg)](https://travis-ci.org/Lysxia/generic-data) +# Generic data types in Haskell [![Hackage](https://img.shields.io/hackage/v/generic-data.svg)](https://hackage.haskell.org/package/generic-data) [![GitHub CI](https://github.com/Lysxia/generic-data/workflows/CI/badge.svg)](https://github.com/Lysxia/generic-data/actions) Utilities for `GHC.Generics`. @@ -36,7 +36,6 @@ -- base import Data.Semigroup (Semigroup(..)) -import GHC.Generics -- generic-data import Generic.Data (gmappend) @@ -97,8 +96,7 @@ ```haskell {-# LANGUAGE DeriveGeneric #-} -import GHC.Generic (Generic) -import Generic.Data (gshowsPrec) +import Generic.Data (Generic, gshowsPrec) import Generic.Data.Microsurgery (toData, derecordify) -- An example record type @@ -123,7 +121,7 @@ ```haskell {-# LANGUAGE DeriveGeneric, DerivingVia #-} -import GHC.Generic (Generic) +import Generic.Data (Generic) -- Reexported from GHC.Generics -- Constructors must be visible to use DerivingVia import Generic.Data.Microsurgery (Surgery, Surgery'(..), Generically(..), Derecordify) @@ -162,6 +160,8 @@ [first-class-families](https://hackage.haskell.org/package/first-class-families) (second one written by me) libraries for dependently-typed programming in Haskell. +- [coercible-utils](https://hackage.haskell.org/package/coercible-utils): + utilities for coercible types. --- diff --git a/generic-data.cabal b/generic-data.cabal --- a/generic-data.cabal +++ b/generic-data.cabal @@ -1,5 +1,5 @@ name: generic-data -version: 0.9.0.0 +version: 0.9.1.0 synopsis: Deriving instances with GHC.Generics and related utilities description: Generic implementations of standard type classes. diff --git a/src/Generic/Data.hs b/src/Generic/Data.hs --- a/src/Generic/Data.hs +++ b/src/Generic/Data.hs @@ -221,6 +221,11 @@ , conIdNamed , ConIdNamed + , conIdMin + , conIdMax + , NonEmptyType + , IsEmptyType + -- ** Using type families , MetaOf , MetaDataName @@ -235,6 +240,12 @@ , MetaSelUnpack , MetaSelSourceStrictness , MetaSelStrictness + + -- * The @Generic@ class + + -- | Reexported from "GHC.Generics". + , Generic() + , Generic1() ) where import Generic.Data.Internal.Prelude hiding (gfoldMap, gtraverse, gsequenceA) @@ -247,3 +258,5 @@ import Generic.Data.Internal.Newtype import Generic.Data.Internal.Resolvers import Generic.Data.Internal.Utils + +import GHC.Generics (Generic, Generic1) diff --git a/src/Generic/Data/Internal/Meta.hs b/src/Generic/Data/Internal/Meta.hs --- a/src/Generic/Data/Internal/Meta.hs +++ b/src/Generic/Data/Internal/Meta.hs @@ -1,7 +1,9 @@ {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -141,22 +143,22 @@ conIdToString :: forall a. Constructors a => ConId a -> String conIdToString = gConIdToString . fromConId --- | All constructor identifiers. This must not be called on an empty type. +-- | All constructor identifiers. -- -- @ -- 'gconNum' \@a = length ('conIdEnum' \@a) -- @ conIdEnum :: forall a. Constructors a => [ConId a] -conIdEnum = fmap ConId [0 .. n] +conIdEnum = fmap ConId [0 .. n-1] where - ConId n = conIdMax @a + n = gConNum @(Rep a) --- | This must not be called on an empty type. -conIdMin :: forall a. Constructors a => ConId a +-- | The first constructor. This must not be called on an empty type. +conIdMin :: forall a. (Constructors a, NonEmptyType "conIdMin" a) => ConId a conIdMin = ConId 0 --- | This must not be called on an empty type. -conIdMax :: forall a. Constructors a => ConId a +-- | The last constructor. This must not be called on an empty type. +conIdMax :: forall a. (Constructors a, NonEmptyType "conIdMax" a) => ConId a conIdMax = toConId gConIdMax -- | Get a 'ConId' by name. @@ -219,9 +221,9 @@ if i < nf then gConIdToString @f (GConId i) else - gConIdToString @g (GConId (i - nf - 1)) + gConIdToString @g (GConId (i - nf)) where - GConId nf = gConIdMax @f + nf = gConNum @f gConId (L1 x) = reGConId (gConId x) gConId (R1 y) = let GConId i = gConId y in GConId (nf + 1 + i) where @@ -239,6 +241,13 @@ gConFixity = conFixity gConIsRecord = conIsRecord +instance GConstructors V1 where + gConIdToString x = x `seq` error "gConIdToString: empty type" -- Input should be empty. + gConId v = case v of {} + gConNum = 0 + gConFixity v = case v of {} + gConIsRecord v = case v of {} + -- *** Find a constructor tag by name type ConIdNamed' n t = GConIdNamedIf n t (GConIdNamed n (Rep t)) @@ -257,6 +266,60 @@ GConIdNamedIf n t 'Nothing = TypeError ('Text "No constructor named " ':<>: 'ShowType n ':<>: 'Text " in generic type " ':<>: 'ShowType t) + +-- *** Check that a type is not empty + +-- | Constraint that a generic type @a@ is not empty. +-- Producing an error message otherwise. +-- +-- The 'Symbol' parameter 'fname' is used only for error messages. +-- +-- It is implied by the simpler constraint @'IsEmptyType' a ~ 'False@ +class NonEmptyType_ fname a => NonEmptyType fname a +instance NonEmptyType_ fname a => NonEmptyType fname a + +-- | Internal definition of 'NonEmptyType'. +-- It is implied by the simpler constraint @'IsEmptyType' a ~ 'False@. +-- +-- >>> :set -XTypeFamilies +-- >>> :{ +-- conIdMin' :: (Constructors a, IsEmptyType a ~ 'False) => ConId a +-- conIdMin' = conIdMin +-- :} +-- +-- >>> :{ +-- conIdMax' :: (Constructors a, IsEmptyType a ~ 'False) => ConId a +-- conIdMax' = conIdMax +-- :} +type NonEmptyType_ fname a = (ErrorIfEmpty fname a (IsEmptyType a) ~ '()) + +-- 'True' if the generic representation is @M1 D _ V1@. +type family GIsEmptyType (r :: k -> *) :: Bool where + GIsEmptyType (M1 D _d V1) = 'True + GIsEmptyType (M1 D _d (M1 C _c _f)) = 'False + GIsEmptyType (M1 D _d (_f :+: _g)) = 'False + +-- | 'True' if the generic type @a@ is empty. +type IsEmptyType a = IsEmptyType_ a + +-- | Internal definition of 'IsEmptyType'. +type IsEmptyType_ a = GIsEmptyType (Rep a) + +-- | Throw an error if the boolean @b@ is true, meaning that the type @a@ is empty. +-- +-- Example: +-- +-- > ghci> data E deriving Generic +-- > ghci> conIdMin :: ConId E +-- +-- Error message: +-- +-- > The function 'conIdMin' cannot be used with the empty type E +type family ErrorIfEmpty (fname :: Symbol) (a :: *) (b :: Bool) :: () where + ErrorIfEmpty fname a 'True = TypeError + ('Text "The function '" ':<>: 'Text fname + ':<>: 'Text "' cannot be used with the empty type " ':<>: 'ShowType a) + ErrorIfEmpty fname a 'False = '() -- * Type families diff --git a/test/bench.hs b/test/bench.hs --- a/test/bench.hs +++ b/test/bench.hs @@ -10,7 +10,6 @@ #-} import Data.Semigroup (Sum(..)) -import GHC.Generics (Generic) import Text.Show (showParen, showString) import Control.DeepSeq diff --git a/test/example.hs b/test/example.hs --- a/test/example.hs +++ b/test/example.hs @@ -8,8 +8,7 @@ #endif import Data.Semigroup (Semigroup(..)) -import GHC.Generics -import Generic.Data (gmappend, Generically(..)) +import Generic.Data (Generic, gmappend, Generically(..)) import Generic.Data.Orphans () data Foo a = Bar [a] [a] deriving Generic diff --git a/test/inspection.hs b/test/inspection.hs --- a/test/inspection.hs +++ b/test/inspection.hs @@ -15,8 +15,8 @@ {-# LANGUAGE TypeOperators, TypeFamilies #-} import Control.Applicative (liftA2) -import Data.Coerce (coerce) import GHC.Generics +import Data.Coerce (coerce) import Data.Semigroup (Sum(..), All(..)) import Test.Inspection diff --git a/test/lens-surgery.hs b/test/lens-surgery.hs --- a/test/lens-surgery.hs +++ b/test/lens-surgery.hs @@ -8,13 +8,12 @@ import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) -import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit import Data.Generics.Product (field_) -import Generic.Data (gshowsPrec, Opaque(Opaque)) +import Generic.Data (Generic, gshowsPrec, Opaque(Opaque)) import Generic.Data.Microsurgery (onData, toData) data T = R { f :: Int -> Int } deriving Generic diff --git a/test/microsurgery.hs b/test/microsurgery.hs --- a/test/microsurgery.hs +++ b/test/microsurgery.hs @@ -10,11 +10,10 @@ -- @DataKinds@ and @TypeApplications@ for @renameFields@ and @renameConstrs@ -import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit -import Generic.Data (gshowsPrec) +import Generic.Data (Generic, gshowsPrec) import Generic.Data.Microsurgery ( toData , derecordify, typeage, renameFields, renameConstrs diff --git a/test/record.hs b/test/record.hs --- a/test/record.hs +++ b/test/record.hs @@ -11,7 +11,6 @@ import Data.Functor.Classes import Data.Semigroup import Data.Monoid (Alt(..)) -import GHC.Generics (Generic) import Text.Read import Generic.Data diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -13,7 +13,7 @@ import Test.Tasty.HUnit import Text.Read -import GHC.Generics +import GHC.Generics (Fixity(Prefix)) import Generic.Data import Generic.Data.Orphans () @@ -259,12 +259,23 @@ , testCase "conIsRecord" $ False @=? gconIsRecord (Just ()) , testCase "conNum" $ 2 @=? gconNum @(Maybe Int) ] + , testGroup "ConId" + [ testCase "conIdEnum" $ [conId Nothing, conId (Just ())] @?= conIdEnum @(Maybe ()) + , testCase "conIdMin" $ conId (Nothing :: Maybe ()) @?= conIdMin + , testCase "conIdMax" $ conId (Just ()) @?= conIdMax + ] + , let i = conId (Nothing :: Maybe ()) in + testGroup "ConId (Nothing)" + [ testCase "conId" $ "ConId 0" @?= show i + , testCase "conIdToInt" $ 0 @?= conIdToInt i + , testCase "conIdToString" $ "Nothing" @?= conIdToString i + , testCase "conIdNamed" $ i @?= conIdNamed @"Nothing" + ] , let i = conId (Just ()) in - testGroup "ConId" + testGroup "ConId (Just)" [ testCase "conId" $ "ConId 1" @?= show i , testCase "conIdToInt" $ 1 @?= conIdToInt i , testCase "conIdToString" $ "Just" @?= conIdToString i - , testCase "conIdEnum" $ [conId Nothing, conId (Just ())] @?= conIdEnum @(Maybe ()) , testCase "conIdNamed" $ i @?= conIdNamed @"Just" ] ]