diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -56,9 +56,6 @@ import Control.Applicative (Alternative (empty)) import Control.Lens ((.~), (^.), (&), Const (..), Identity, anyOf) -import Data.Barbie (ProductB (buniq)) -import Data.Functor.Const (Const (..)) -import Data.Functor.Identity (Identity (..)) import Data.Generic.HKD import Data.Maybe (isJust, isNothing) import Data.Monoid (Last (..)) @@ -212,7 +209,7 @@ ```haskell eg10 :: HKD Triple [] -eg10 = buniq empty +eg10 = bpure empty -- Triple [] [] [] ``` @@ -330,10 +327,11 @@ ### Documentation All the docs in this library are tested on `cabal new-test`. Furthermore, this -README is tested by `markdown-unlit`. To keep _that_ happy, we do need a `main` -in this file, so just ignore the following :) +README is tested by `markdown-unlit`. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -56,9 +56,6 @@ import Control.Applicative (Alternative (empty)) import Control.Lens ((.~), (^.), (&), Const (..), Identity, anyOf) -import Data.Barbie (ProductB (buniq)) -import Data.Functor.Const (Const (..)) -import Data.Functor.Identity (Identity (..)) import Data.Generic.HKD import Data.Maybe (isJust, isNothing) import Data.Monoid (Last (..)) @@ -212,7 +209,7 @@ ```haskell eg10 :: HKD Triple [] -eg10 = buniq empty +eg10 = bpure empty -- Triple [] [] [] ``` @@ -330,10 +327,11 @@ ### Documentation All the docs in this library are tested on `cabal new-test`. Furthermore, this -README is tested by `markdown-unlit`. To keep _that_ happy, we do need a `main` -in this file, so just ignore the following :) +README is tested by `markdown-unlit`. + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ -import Distribution.Simple -main = defaultMain +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/higgledy.cabal b/higgledy.cabal --- a/higgledy.cabal +++ b/higgledy.cabal @@ -1,45 +1,61 @@ -cabal-version: 2.4 +cabal-version: 2.4 +build-type: Custom +name: higgledy +version: 0.4.0.0 +synopsis: Partial types as a type constructor. +description: Use the generic representation of an ADT to get a higher-kinded data-style interface automatically. +homepage: https://github.com/i-am-tom/higgledy +license: MIT +license-file: LICENSE +author: Tom Harding +maintainer: tom.harding@habito.com +category: Data +extra-source-files: CHANGELOG.md + , README.md -name: higgledy -version: 0.3.1.0 -synopsis: Partial types as a type constructor. -description: Use the generic representation of an ADT to get a higher-kinded data-style interface automatically. -homepage: https://github.com/i-am-tom/higgledy --- bug-reports: -license: MIT -license-file: LICENSE -author: Tom Harding -maintainer: tom.harding@habito.com --- copyright: -category: Data -extra-source-files: CHANGELOG.md - , README.md +custom-setup + setup-depends: + base, + Cabal, + cabal-doctest ^>= 1.0 library - exposed-modules: Data.Generic.HKD - Data.Generic.HKD.Build - Data.Generic.HKD.Construction - Data.Generic.HKD.Labels - Data.Generic.HKD.Named - Data.Generic.HKD.Types - -- other-modules: - -- other-extensions: - build-depends: base ^>= 4.12 - , barbies ^>= 1.1.0 - , generic-lens ^>= 1.1.0 - , QuickCheck >= 2.12.6 && < 2.14 - , named ^>= 0.3.0.0 + exposed-modules: Data.Generic.HKD + Data.Generic.HKD.Build + Data.Generic.HKD.Construction + Data.Generic.HKD.Labels + Data.Generic.HKD.Named + Data.Generic.HKD.Types + build-depends: base >= 4.12 && < 5 + , barbies ^>= 2.0 + , generic-lens ^>= 2.0 + , generic-lens-core ^>= 2.0 + , QuickCheck >= 2.12.6 && < 2.14 + , named ^>= 0.3.0.0 hs-source-dirs: src default-language: Haskell2010 +test-suite doctests + build-depends: base + , base-compat ^>= 0.11 + , doctest ^>= 0.17 + , higgledy + , lens + , QuickCheck + , template-haskell + main-is: Doctest.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + ghc-options: -Wall -Wextra -threaded + default-language: Haskell2010 + test-suite test build-depends: base - , barbies ^>= 1.1.0 - , doctest ^>= 0.16.0 + , barbies , higgledy , hspec >= 2.6.1 && < 2.8 - , lens ^>= 4.17 - , QuickCheck >= 2.12.6 && < 2.14 + , lens >= 4.17 && < 5 + , QuickCheck main-is: Main.hs type: exitcode-stdio-1.0 hs-source-dirs: test @@ -47,8 +63,8 @@ test-suite readme build-depends: base - , barbies ^>= 1.1.0 - , lens ^>= 4.17 + , barbies + , lens >= 4.17 && < 5 , higgledy , named ^>= 0.3.0.0 main-is: README.lhs diff --git a/src/Data/Generic/HKD.hs b/src/Data/Generic/HKD.hs --- a/src/Data/Generic/HKD.hs +++ b/src/Data/Generic/HKD.hs @@ -15,10 +15,10 @@ module Data.Generic.HKD ( module Exports - , Barbie.ConstraintsB (..) - , Barbie.FunctorB (..) - , Barbie.ProductBC (..) - , Barbie.TraversableB (..) + , Barbies.ApplicativeB (..) + , Barbies.ConstraintsB (..) + , Barbies.FunctorB (..) + , Barbies.TraversableB (..) , position , field @@ -30,7 +30,7 @@ import Data.Generic.HKD.Named as Exports import Data.Generic.HKD.Types as Exports -import qualified Data.Barbie as Barbie +import qualified Barbies import qualified Data.Generics.Internal.VL.Lens as G import qualified Data.Generics.Product as G diff --git a/src/Data/Generic/HKD/Build.hs b/src/Data/Generic/HKD/Build.hs --- a/src/Data/Generic/HKD/Build.hs +++ b/src/Data/Generic/HKD/Build.hs @@ -25,7 +25,7 @@ ) where import Data.Kind (Type) -import Data.GenericLens.Internal (HList (..)) +import Data.Generics.Product.Internal.HList (HList (..)) import Data.Generic.HKD.Types (HKD (..), GHKD_) import GHC.Generics import Prelude hiding (uncurry) @@ -86,7 +86,7 @@ -- ... -- -- Once we call the 'build' function, and indicate the type we want to build, --- we are free to pick whichever 'f' we like and get to work! +-- we are free to pick whichever @f@ we like and get to work! class Build (structure :: Type) (f :: Type -> Type) (k :: Type) | f structure -> k where build :: k diff --git a/src/Data/Generic/HKD/Labels.hs b/src/Data/Generic/HKD/Labels.hs --- a/src/Data/Generic/HKD/Labels.hs +++ b/src/Data/Generic/HKD/Labels.hs @@ -15,7 +15,7 @@ , labelsWhere ) where -import Data.Barbie (ProductB (..), TraversableB (..)) +import Barbies (ApplicativeB (..), TraversableB (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Product (Product (..)) import Data.Generic.HKD.Types (HKD (..), GHKD_) @@ -83,7 +83,7 @@ labelsWhere :: forall structure f . ( Label structure - , ProductB (HKD structure) + , ApplicativeB (HKD structure) , TraversableB (HKD structure) ) => (forall a. f a -> Bool) diff --git a/src/Data/Generic/HKD/Named.hs b/src/Data/Generic/HKD/Named.hs --- a/src/Data/Generic/HKD/Named.hs +++ b/src/Data/Generic/HKD/Named.hs @@ -28,7 +28,7 @@ import Data.Functor.Contravariant (Contravariant (..)) import Data.Generic.HKD.Types (HKD, HKD_) -import Data.GenericLens.Internal (GUpcast (..)) +import Data.Generics.Product.Internal.Subtype (GUpcast (..)) import Data.Kind (Type) import GHC.Generics import Named ((:!), NamedF (..)) diff --git a/src/Data/Generic/HKD/Types.hs b/src/Data/Generic/HKD/Types.hs --- a/src/Data/Generic/HKD/Types.hs +++ b/src/Data/Generic/HKD/Types.hs @@ -31,8 +31,8 @@ , Tuple (..) ) where -import Data.Barbie (ConstraintsB (..), FunctorB (..), ProductB (..), ProductBC (..), TraversableB (..)) -import Data.Barbie.Constraints (Dict (..)) +import Barbies (ConstraintsB (..), FunctorB (..), ApplicativeB (..), TraversableB (..)) +import Barbies.Constraints (Dict (..)) import Data.Function (on) import Data.Functor.Contravariant (Contravariant (..), phantom) import Data.Functor.Product (Product (..)) @@ -176,6 +176,10 @@ ------------------------------------------------------------------------------- +-- | Often, we can get instances by using an 'HKD' type's isomorphism with a +-- certain size of tuple. This class witnesses the isomorphism with a certain +-- tuple (specifically a nested tree of pairs) to allow us to derive "via" +-- these shapes. class Tuple (f :: Type -> Type) (structure :: Type) (tuple :: Type) | f structure -> tuple where toTuple :: HKD structure f -> tuple @@ -249,30 +253,30 @@ ------------------------------------------------------------------------------- -class GProductB (rep :: Type -> Type) where +class GApplicativeB (rep :: Type -> Type) where gbprod :: GHKD_ f rep p -> GHKD_ g rep p -> GHKD_ (f `Product` g) rep p - gbuniq :: (forall a. f a) -> GHKD_ f rep p + gbpure :: (forall a. f a) -> GHKD_ f rep p -instance GProductB inner => GProductB (M1 index meta inner) where +instance GApplicativeB inner => GApplicativeB (M1 index meta inner) where gbprod (M1 x) (M1 y) = M1 (gbprod @inner x y) - gbuniq zero = M1 (gbuniq @inner zero) + gbpure zero = M1 (gbpure @inner zero) -instance (GProductB left, GProductB right) - => GProductB (left :*: right) where +instance (GApplicativeB left, GApplicativeB right) + => GApplicativeB (left :*: right) where gbprod (leftX :*: rightX) (leftY :*: rightY) = gbprod @left leftX leftY :*: gbprod @right rightX rightY - gbuniq zero - = gbuniq @left zero :*: gbuniq @right zero + gbpure zero + = gbpure @left zero :*: gbpure @right zero -instance GProductB (K1 index inner) where +instance GApplicativeB (K1 index inner) where gbprod (K1 x) (K1 y) = K1 (Pair x y) - gbuniq zero = K1 zero + gbpure zero = K1 zero -instance (FunctorB (HKD structure), GProductB (Rep structure)) - => ProductB (HKD structure) where +instance (FunctorB (HKD structure), GApplicativeB (Rep structure)) + => ApplicativeB (HKD structure) where bprod (HKD x) (HKD y) = HKD (gbprod @(Rep structure) x y) - buniq zero = HKD (gbuniq @(Rep structure) zero) + bpure zero = HKD (gbpure @(Rep structure) zero) ------------------------------------------------------------------------------- @@ -317,25 +321,3 @@ -> HKD structure (Dict c `Product` f) baddDicts (HKD x) = HKD (gbaddDicts @(Rep structure) x) - -------------------------------------------------------------------------------- - -class GProductBC (rep :: Type -> Type) where - gbdicts :: GAllB c rep => GHKD_ (Dict c) rep p - -instance GProductBC inner => GProductBC (M1 index meta inner) where - gbdicts = M1 gbdicts - -instance (GProductBC left, GProductBC right) - => GProductBC (left :*: right) where - gbdicts = gbdicts :*: gbdicts - -instance GProductBC (K1 index inner) where - gbdicts = K1 Dict - -instance - ( ProductB (HKD structure) - , ConstraintsB (HKD structure) - , GProductBC (Rep structure) - ) => ProductBC (HKD structure) where - bdicts = HKD gbdicts diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,7 @@ +import Build_doctests (flags, pkgs, module_sources) +import System.Environment.Compat (unsetEnv) +import Test.DocTest (doctest) + +main :: IO () +main = unsetEnv "GHC_ENVIRONMENT" >> doctest args + where args = flags ++ pkgs ++ module_sources diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,14 +11,13 @@ module Main where import Control.Lens (Lens', (.~), (^.)) -import Data.Barbie.Constraints (Dict) +import Barbies.Constraints (Dict) import Data.Function ((&), on) import Data.Functor.Identity (Identity (..)) import Data.Functor.Product (Product (..)) import Data.Generic.HKD import Data.Monoid (Last (..)) import GHC.Generics -import Test.DocTest import Test.Hspec import Test.QuickCheck @@ -26,53 +25,50 @@ type WTF a = HKD a [] main :: IO () -main = do - doctest ["src", "test"] - - hspec do - describe "Unnamed" do - eq @(Partial Triple) - ord @(Partial Triple) - semigroup @(Partial Triple) - idempotent @(Partial Triple) - monoid @(Partial Triple) +main = hspec do + describe "Unnamed" do + eq @(Partial Triple) + ord @(Partial Triple) + semigroup @(Partial Triple) + idempotent @(Partial Triple) + monoid @(Partial Triple) - eq @(WTF Triple) - ord @(WTF Triple) - semigroup @(WTF Triple) - monoid @(WTF Triple) + eq @(WTF Triple) + ord @(WTF Triple) + semigroup @(WTF Triple) + monoid @(WTF Triple) - lens @(Partial Triple) (position @1) - lens @(Partial Triple) (position @2) - lens @(Partial Triple) (position @3) + lens @(Partial Triple) (position @1) + lens @(Partial Triple) (position @2) + lens @(Partial Triple) (position @3) - lens @(WTF Triple) (position @1) - lens @(WTF Triple) (position @2) - lens @(WTF Triple) (position @3) + lens @(WTF Triple) (position @1) + lens @(WTF Triple) (position @2) + lens @(WTF Triple) (position @3) - describe "Named" do - eq @(Partial Person) - ord @(Partial Person) - semigroup @(Partial Person) - idempotent @(Partial Person) - monoid @(Partial Person) + describe "Named" do + eq @(Partial Person) + ord @(Partial Person) + semigroup @(Partial Person) + idempotent @(Partial Person) + monoid @(Partial Person) - eq @(WTF Person) - ord @(WTF Person) - semigroup @(WTF Person) - monoid @(WTF Person) + eq @(WTF Person) + ord @(WTF Person) + semigroup @(WTF Person) + monoid @(WTF Person) - lens @(WTF Person) (position @1) - lens @(WTF Person) (position @2) - lens @(WTF Person) (position @3) + lens @(WTF Person) (position @1) + lens @(WTF Person) (position @2) + lens @(WTF Person) (position @3) - lens @(Partial Person) (field @"name") - lens @(Partial Person) (field @"age") - lens @(Partial Person) (field @"likesDogs") + lens @(Partial Person) (field @"name") + lens @(Partial Person) (field @"age") + lens @(Partial Person) (field @"likesDogs") - lens @(WTF Person) (field @"name") - lens @(WTF Person) (field @"age") - lens @(WTF Person) (field @"likesDogs") + lens @(WTF Person) (field @"name") + lens @(WTF Person) (field @"age") + lens @(WTF Person) (field @"likesDogs") -------------------------------------------------------------------------------