diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +## 0.3.0 (2024-04-10) +Rename package from `generic-data-asserts` to `generic-type-asserts`. This +package only does type-level work, so it's more appropriate. + + * don't expose util type families + +## 0.2.0 (2024-04-05) +* split errors out into own module + +## 0.1.1 (2024-04-04) +Initial release. + + * extracted from generic-data-functions diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Ben Orchard (@raehik) + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +[gdf-hackage]: https://hackage.haskell.org/package/generic-data-functions + +# generic-data-asserts +Structural assertions on the generic data representations (`GHC.Generic.Rep a`). + +Sometimes, we want to write generics that only work on certain data types with a +certain shape e.g. non-sum types (single constructor). Achieving this is fairly +straightforward if we add a `TypeError` constraint on the relevant generic +representation unwrapping instance (here, the `(:+:)` constructor sum type). + +This library effectively pulls those checks out of generic code and runs them by +separately. This way, we can simplify our generics, and make them more flexible +(e.g. a user may choose whether to permit void types at compile time or not). + +This began as a minor feature in my [generic-data-functions][gdf-hackage] +library. + +## License +Provided under the MIT license. See `LICENSE` for license text. diff --git a/generic-type-asserts.cabal b/generic-type-asserts.cabal new file mode 100644 --- /dev/null +++ b/generic-type-asserts.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: generic-type-asserts +version: 0.3.0 +synopsis: Structural assertions on generic type representations. +description: Please see README.md. +category: Data, Generics, Type +homepage: https://github.com/raehik/generic-type-asserts#readme +bug-reports: https://github.com/raehik/generic-type-asserts/issues +author: Ben Orchard +maintainer: Ben Orchard +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/raehik/generic-type-asserts + +library + exposed-modules: + Generic.Type.Assert + Generic.Type.Assert.Error + other-modules: + Paths_generic_type_asserts + hs-source-dirs: + src + default-extensions: + LambdaCase + NoStarIsType + DerivingVia + DeriveAnyClass + GADTs + RoleAnnotations + DefaultSignatures + TypeFamilies + DataKinds + MagicHash + ghc-options: -Wall + build-depends: + base >=4.14 && <5 + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_generic_type_asserts + hs-source-dirs: + test + default-extensions: + LambdaCase + NoStarIsType + DerivingVia + DeriveAnyClass + GADTs + RoleAnnotations + DefaultSignatures + TypeFamilies + DataKinds + MagicHash + ghc-options: -Wall + build-depends: + base >=4.14 && <5 + , generic-type-asserts + , type-spec >=0.4.0.0 && <0.5 + default-language: GHC2021 diff --git a/src/Generic/Type/Assert.hs b/src/Generic/Type/Assert.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Type/Assert.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE UndecidableInstances #-} -- for IsEnum + +-- | Structural assertions on generic type representation. + +module Generic.Type.Assert + ( type GAssertNotVoid + , type GAssertNotSum, type GAssertSum + , type GAssertEnum + ) where + +import GHC.Generics +import Generic.Type.Assert.Error +import GHC.TypeError ( Assert ) + +-- | Type is not void i.e. has at least one constructor. +type GAssertNotVoid a = + Assert (IsNotVoid (StripD1 (Rep a))) (GAssertErrorVoid a) +type family IsNotVoid a where + IsNotVoid V1 = False + IsNotVoid _ = True + +-- | Type is not a sum type i.e. has at most one constructor. +-- +-- Permits void types. +type GAssertNotSum a = + Assert (IsNotSum (StripD1 (Rep a))) (GAssertErrorSum a) +type family IsNotSum a where + IsNotSum (_ :+: _) = False + IsNotSum _ = True + +-- | Type is a sum type i.e. has >=2 constructors. +-- +-- Permits void types. +type GAssertSum a = + Assert (IsSum (StripD1 (Rep a))) (GAssertErrorNotSum a) +type family IsSum a where + IsSum (C1 _ _) = False + IsSum _ = True + +-- | Type has only empty constructors. +-- +-- Permits void types. +type GAssertEnum a = + Assert (IsEnum (StripD1 (Rep a))) (GAssertErrorNotEnum a) +type family IsEnum a where + IsEnum V1 = True + IsEnum (C1 _ a) = ConsIsEmpty a + IsEnum (l :+: r) = IsEnum l `And` IsEnum r + +-------------------------------------------------------------------------------- + +type family StripD1 a where StripD1 (D1 _ a) = a + +type family ConsIsEmpty a where + ConsIsEmpty U1 = True + ConsIsEmpty _ = False + +-- | Type level boolean AND. +type family And l r where + And True True = True + And _ _ = False diff --git a/src/Generic/Type/Assert/Error.hs b/src/Generic/Type/Assert/Error.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Type/Assert/Error.hs @@ -0,0 +1,30 @@ +-- | Descriptive type errors for generic representation assertion failures. +-- +-- These are potentially useful separately from the asserts, in places where +-- we're unable to perform asserts which evaluate to 'Constraint's e.g. type +-- families, so we expose them neatly here. + +module Generic.Type.Assert.Error where + +import GHC.TypeError +import GHC.TypeLits ( type Symbol ) + +-- polymorphic kind keeps us extra useful -- we only use as 'Constraint', but +-- library users may want to use this in type families +type GAssertError :: ka -> Symbol -> k +type GAssertError a msg = TypeError + ('Text "Assertion on generic representation failed for type: " + :<>: 'ShowType a + :$$: 'Text "Message: " :<>: 'Text msg) + +type GAssertErrorVoid a = + GAssertError a "not non-void type (>=1 constructor)" + +type GAssertErrorSum a = + GAssertError a "not non-sum type (1 constructor)" + +type GAssertErrorNotSum a = + GAssertError a "not sum type (>=2 constructors)" + +type GAssertErrorNotEnum a = + GAssertError a "not enum type (all empty constructors)" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,27 @@ +module Main where + +import Test.TypeSpec +import GHC.Generics +import Generic.Type.Assert +import Data.Kind + +data DSum = DSum1 () | DSum2 deriving stock Generic +data DEnum = DEnum1 | DEnum2 | DEnum3 deriving stock Generic +data DNonSum = DNonSum () () deriving stock Generic +data DVoid deriving stock Generic + +main :: IO () +main = print spec + +spec + :: Expect '[ AssertPasses (GAssertNotVoid DSum) + , AssertPasses (GAssertSum DSum) + , AssertPasses (GAssertNotSum DNonSum) + , AssertPasses (GAssertEnum DEnum) + ] +spec = Valid + +type AssertPasses a = Is a (() :: Constraint) + +-- can't write this because GHC finds the TypeError before type-spec +--type AssertFails a = Isn't a (() :: Constraint)