diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,23 @@ +# Change Log + +Notable changes to the project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/) and the +project adheres to the [Haskell Package Versioning +Policy (PVP)](https://pvp.haskell.org) + +## [unreleased] + +## [1.0.0.0] - 2022-06-08 + +This is the initial release of the library. + +### Added + +- The POSable class, which captures non-recursive Haskell 98 data types as a product-of-sums +- A generic implementation of the POSable class, based on the generics-sop library +- A usage example (in examples/Examples.hs) +- Instances of POSable for data types in the Prelude (Bool, Maybe, Either, Ord, tuples up to length 16) + +[unreleased]: https://github.com/Riscky/posable/compare/v1.0.0.0...HEAD +[1.0.0.0]: https://github.com/Riscky/posable/compare/c81f50a2b...v1.0.0.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Rick van Hoef + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Rick van Hoef nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# POSable + +A library to convert non-recursive Haskell-98 datatypes to a Product-of-Sums +representation - and back. This makes it possible to compactly store arrays of +(nested) sum types in a struct-of-arrays representation, which is used in +array-based languages like [Accelerate]. + +[Accelerate]: https://www.acceleratehs.org/ + +## Dependencies + +- The [Stack] package manager (Tested with stack 2.7.3) +- `stylish-haskell` and `hlint` (for linting only) + +[Stack]: https://docs.haskellstack.org/en/stable/README/ + +## Tests and lints + +``` bash +stylish-haskell -r src examples test +hlint src examples test +stack test +``` + +## Building + +``` bash +stack build +# To build the docs +stack haddock posable +``` + +## Examples + +In the [examples](examples) folder you will find examples that describe how to use this +library. diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -0,0 +1,41 @@ +-- Needed to derive POSable +{-# LANGUAGE DeriveAnyClass #-} +-- Needed to derive GHC.Generic +{-# LANGUAGE DeriveGeneric #-} +-- To generate instances for ground types +{-# LANGUAGE TemplateHaskell #-} +-- Needed to determine the tag size at compile time +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +-- Larger types need more iterations +{-# OPTIONS_GHC -fconstraint-solver-iterations=11 #-} +{-# OPTIONS_GHC -ddump-splices #-} + +-- | Contains an example for deriving POSable for some datatype +module Examples () where + +-- POSable re-exports SOP.Generic +import GHC.Generics as GHC +import Generics.POSable.POSable as POSable +import Generics.POSable.Representation +import Generics.POSable.TH + +data Test a b c = C1 a + | C2 b + | C3 c + | C4 a a a a a a a + | C5 a b c + deriving (GHC.Generic, POSable.Generic, POSable) + +-- Define a set of types that can be the ground types of the POSable +-- representation. Only types in this set can occur in Fields. +instance Ground Float where + mkGround = 0.0 + +instance Ground Double where + mkGround = 0 + + +-- Define a POSable instance for these ground types +mkPOSableGround ''Float + +mkPOSableGround ''Double diff --git a/posable.cabal b/posable.cabal new file mode 100644 --- /dev/null +++ b/posable.cabal @@ -0,0 +1,96 @@ +cabal-version: 2.2 + +name: posable + +synopsis: A product-of-sums generics library + +description: A generics library that represents a non-recursive Haskell 98 + datatype as a product-of-sums. Each type is represented + with a single tag, and a product of sums of fields. The tag + represents all constructor choices in the type, the fields + contain all the values in the type. This representation + maps easily to a struct of unions, which is a + memory-efficient way to store sum datatypes. + +category: Generics + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://wiki.haskell.org/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.0.0.0 +tested-with: GHC >= 8.10 + +license: BSD-3-Clause + +license-file: LICENSE + +author: Rick van Hoef + +maintainer: Rick van Hoef +homepage: https://github.com/Riscky/posable +bug-reports: https://github.com/Riscky/posable/issues + +build-type: Simple + +extra-source-files: CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +library + -- Modules included in this executable, other than Main. + exposed-modules: Generics.POSable.POSable + , Generics.POSable.Instances + , Generics.POSable.Representation + , Generics.POSable.TH + + other-modules: Examples + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.15.0 && < 4.16 + , finite-typelits >= 0.1.4 && < 0.2 + , generics-sop >= 0.5.1 && < 0.6 + , template-haskell >= 2.17.0 && < 2.18 + , ghc-typelits-knownnat >= 0.7.6 && < 0.8, + + -- Directories containing source files. + hs-source-dirs: src + , examples + + default-extensions: NoStarIsType + , DataKinds + , TypeApplications + , TypeOperators + , ScopedTypeVariables + , TypeFamilies + , GADTs + , DeriveAnyClass + + -- Base language which the package is written in. + default-language: Haskell2010 + ghc-options: -Wall + +test-suite unit-test + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -Wall + hs-source-dirs: + test + build-depends: + posable + , base + , ghc-typelits-knownnat + , template-haskell + , tasty >= 1.4 && < 1.5 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.10.2 && < 0.11 + default-language: + Haskell2010 diff --git a/src/Generics/POSable/Instances.hs b/src/Generics/POSable/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Generics/POSable/Instances.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +-- This is needed to derive POSable for tuples of size more then 4 +{-# OPTIONS_GHC -fconstraint-solver-iterations=16 #-} + +-- | This module contains instances of `POSable` for all Haskell prelude data types +-- as well as fixed size integers from Data.Int (`Int8`, `Int16`, `Int32` and `Int64`) +module Generics.POSable.Instances (POSable) where + +import Generics.POSable.POSable +import Generics.POSable.Representation +import Language.Haskell.TH + +----------------------------------------------------------------------- +-- Instances for common nonrecursive Haskell datatypes +deriving instance POSable Bool +deriving instance POSable x => POSable (Maybe x) +deriving instance (POSable l, POSable r) => POSable (Either l r) +deriving instance POSable Ordering + +deriving instance POSable () + +deriving instance POSable Undef + +-- Instances for tuples of length 2 - 16 +runQ $ do + let + mkTuple :: Int -> Q Dec + mkTuple n = + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + res = foldl (\ts' t -> [t| $ts' $t |]) (tupleT (length ts)) ts + ctx = mapM (appT [t| POSable |]) ts + in + instanceD ctx [t| POSable $res |] [] + mapM mkTuple [2..16] + diff --git a/src/Generics/POSable/POSable.hs b/src/Generics/POSable/POSable.hs new file mode 100644 --- /dev/null +++ b/src/Generics/POSable/POSable.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +-- | Exports the `POSable` class, which has a generic implementation `GPOSable`. +-- Also re-exports Generic.SOP, which is needed to derive POSable. +module Generics.POSable.POSable (POSable(..), Generic, Finite) where + +import Data.Finite (combineProduct, combineSum, + separateProduct, separateSum) +import Generics.POSable.Representation +import Generics.SOP hiding (Nil, shift) +import Generics.SOP.NP hiding (Nil) + +import Data.Kind (Type) + +import qualified Generics.SOP as SOP + +import GHC.Base (Nat) +import GHC.TypeLits (KnownNat, natVal, type (*), + type (+)) + +import Data.Finite.Internal + +-- | POSable, the base of this library. Provide a compact memory representation +-- for a type and a function to get back to the original type. +-- This memory representation consist of `choices`, that represent all +-- constructor choices in the type in a single Finite integer, and `fields` +-- which represents all values in the type as a Product of Sums, which can +-- be mapped to a struct-of-arrays representation for use in array-based +-- languages like Accelerate. +class (KnownNat (Choices x)) => POSable x where + type Choices x :: Nat + type Choices x = GChoices (SOP I (Code x)) + + choices :: x -> Finite (Choices x) + default choices :: + ( Generic x + , GPOSable (SOP I (Code x)) + , GChoices (SOP I (Code x)) ~ Choices x + ) => x -> Finite (Choices x) + choices x = gchoices $ from x + + -- | The `tags` function returns the range of each constructor. + -- A few examples: + -- >>> tags @Bool + -- [1,1] + -- >>> tags @(Either Float Float) + -- [1,1] + -- >>> tags @(Bool, Bool) + -- [4] + -- >>> tags @(Either Bool Bool) + -- [2,2] + tags :: [Integer] + default tags :: + ( GPOSable (SOP I (Code x)) + ) => [Integer] + tags = gtags @(SOP I (Code x)) + + fromPOSable :: Finite (Choices x) -> Product (Fields x) -> x + + default fromPOSable :: + ( Generic x + , GPOSable (SOP I (Code x)) + , Fields x ~ GFields (SOP I (Code x)) + , Choices x ~ GChoices (SOP I (Code x)) + ) => Finite (Choices x) -> Product (Fields x) -> x + fromPOSable cs fs = to $ gfromPOSable cs fs + + type Fields x :: [[Type]] + type Fields x = GFields (SOP I (Code x)) + + fields :: x -> Product (Fields x) + + default fields :: + ( Generic x + , Fields x ~ GFields (SOP I (Code x)) + , GPOSable (SOP I (Code x)) + ) => x -> Product (Fields x) + fields x = gfields $ from x + + emptyFields :: ProductType (Fields x) + + default emptyFields :: + ( GPOSable (SOP I (Code x)) + , Fields x ~ GFields (SOP I (Code x)) + ) => ProductType (Fields x) + emptyFields = gemptyFields @(SOP I (Code x)) + + +----------------------------------------------------------------------- +-- | Generic implementation of POSable, +class (KnownNat (GChoices x)) => GPOSable x where + type GChoices x :: Nat + gchoices :: x -> Finite (GChoices x) + + gtags :: [Integer] + + type GFields x :: [[Type]] + gfields :: x -> Product (GFields x) + + gfromPOSable :: Finite (GChoices x) -> Product (GFields x) -> x + + gemptyFields :: ProductType (GFields x) + +----------------------------------------------------------------------- +-- Generic instance for POSable +instance + ( All2 POSable xss + , KnownNat (Sums (MapProducts (Map2Choices xss))) + , All2 KnownNat (Map2Choices xss) + , All KnownNat (MapProducts (Map2Choices xss)) + , KnownNat (Length xss) + ) => GPOSable (SOP I xss) where + + type GChoices (SOP I xss) = Sums (MapProducts (Map2Choices xss)) + gchoices x = sums $ mapProducts $ map2choices $ unSOP x + + gtags = getTags (pureChoices2 @xss) + + type GFields (SOP I xss) = FoldMerge (MapConcat (Map2Fields xss)) + gfields (SOP x) = foldMerge + (mapConcatT (pureMap2Fields @xss)) + (mapConcat (map2Fields x)) + + gemptyFields = foldMergeT $ mapConcatT (pureMap2Fields @xss) + + gfromPOSable cs fs = SOP (mapFromPOSable cs' fs (pureConcatFields @xss)) + where + cs' = unSums cs (pureChoices2 @xss) + + +getTags :: All KnownNat (MapProducts (Map2Choices xss)) => NP ProductsMapChoices xss -> [Integer] +getTags SOP.Nil = [] +getTags (ProductsMapChoices x :* xs) = natVal x : getTags xs + +-------------------------------------------------------------------------------- +-- Supporting types and classes +-------------------------------------------------------------------------------- + +type family Length (xs :: [x]) :: Nat where + Length '[] = 0 + Length (x ': xs) = Length xs + 1 + +type family MapLength (xss :: [[x]]) :: [Nat] where + MapLength '[] = '[] + MapLength (x ': xs) = Length x ': MapLength xs + +type family MapChoices (xs :: [Type]) :: [Nat] where + MapChoices '[] = '[] + MapChoices (x ': xs) = Choices x ': MapChoices xs + + +type family Map2Choices (xss :: [[Type]]) :: [[Nat]] where + Map2Choices '[] = '[] + Map2Choices (xs ': xss) = MapChoices xs ': Map2Choices xss + + +type family MapFields (xs :: [Type]) :: [[[Type]]] where + MapFields '[] = '[] + MapFields (x ': xs) = Fields x ': MapFields xs + + +type family Map2Fields (xss :: [[Type]]) :: [[[[Type]]]] where + Map2Fields '[] = '[] + Map2Fields (xs ': xss) = MapFields xs ': Map2Fields xss + + +type family Products (xs :: [Nat]) :: Nat where + Products '[] = 1 + Products (x ': xs) = x * Products xs + +type family MapProducts (xss :: [[Nat]]) :: [Nat] where + MapProducts '[] = '[] + MapProducts (xs ': xss) = Products xs ': MapProducts xss + +type family Sums (xs :: [Nat]) :: Nat where + Sums '[] = 0 + Sums (x ': xs) = x + Sums xs + +-------------------------------------------------------------------------------- +-- Functions that deal with Choices +-------------------------------------------------------------------------------- + +mapChoices :: forall xs . (All POSable xs) => NP I xs -> NP Finite (MapChoices xs) +mapChoices SOP.Nil = SOP.Nil +mapChoices (x :* xs) = choices (unI x) :* mapChoices xs + +map2choices :: (All2 POSable xss) => NS (NP I) xss -> NS (NP Finite) (Map2Choices xss) +map2choices (Z x) = Z (mapChoices x) +map2choices (S xs) = S (map2choices xs) + +sums :: All KnownNat xs => NS Finite xs -> Finite (Sums xs) +sums (Z y) = combineSum (Left y) +sums (S ys) = combineSum (Right (sums ys)) + +mapProducts :: (All2 KnownNat xss) => NS (NP Finite) xss -> NS Finite (MapProducts xss) +mapProducts (Z x) = Z (combineProducts x) +mapProducts (S xs) = S (mapProducts xs) + +combineProducts :: (All KnownNat xs) => NP Finite xs -> Finite (Products xs) +combineProducts SOP.Nil = 0 +combineProducts (y :* ys) = combineProduct (y, combineProducts ys) + +-------------------------------------------------------------------------------- +-- Functions that deal with Fields +-------------------------------------------------------------------------------- + +mapFields :: forall xs . (All POSable xs) => NP I xs -> NP Product (MapFields xs) +mapFields SOP.Nil = SOP.Nil +mapFields (x :* xs) = fields (unI x) :* mapFields xs + +map2Fields :: (All2 POSable xss) => NS (NP I) xss -> NS (NP Product) (Map2Fields xss) +map2Fields (Z x) = Z (mapFields x) +map2Fields (S xs) = S (map2Fields xs) + +mapConcat :: NS (NP Product) xss -> NS Product (MapConcat xss) +mapConcat (Z x) = Z (appends x) +mapConcat (S xs) = S (mapConcat xs) + +appends :: NP Product xs -> Product (Concat xs) +appends SOP.Nil = Nil +appends (x :* xs) = concatP x (appends xs) + +foldMerge :: NP ProductType xss -> NS Product xss -> Product (FoldMerge xss) +foldMerge (_ :* SOP.Nil) (Z y) = y +foldMerge (_ :* SOP.Nil) (S _) = error "Reached an inaccessible pattern" +foldMerge SOP.Nil _ = Nil +foldMerge (_ :* x' :* xs) (Z y) = merge $ Left (y, foldMergeT (x' :* xs)) +foldMerge (x :* x' :* xs) (S ys) = merge $ Right (x, foldMerge (x' :* xs) ys) + +appendsT :: NP ProductType xs -> ProductType (Concat xs) +appendsT SOP.Nil = PTNil +appendsT (x :* xs) = concatPT x (appendsT xs) + +mapConcatT :: NP (NP ProductType) xss -> NP ProductType (MapConcat xss) +mapConcatT SOP.Nil = SOP.Nil +mapConcatT (x :* xs) = appendsT x :* mapConcatT xs + +foldMergeT :: NP ProductType xss -> ProductType (FoldMerge xss) +foldMergeT (x :* SOP.Nil) = x +foldMergeT SOP.Nil = PTNil +foldMergeT (x :* x' :* xs) = mergeT x (foldMergeT (x' :* xs)) + +-------------------------------------------------------------------------------- +-- Functions that deal with creating Products from types + +newtype ProductFields a = ProductFields (Product (Fields a)) + +newtype ProductFieldsT a = ProductFieldsT (ProductType (Fields a)) + +newtype ProductConcatFieldsT a = ProductConcatFieldsT (ProductType (Concat (MapFields a))) + +newtype ProductMapFieldsT a = ProductMapFieldsT (NP ProductType (MapFields a)) + +pureMapFields :: forall xs . (All POSable xs) => NP ProductType (MapFields xs) +pureMapFields = convert $ pureFields @xs + where + convert :: NP ProductFieldsT ys -> NP ProductType (MapFields ys) + convert SOP.Nil = SOP.Nil + convert (ProductFieldsT x :* xs) = x :* convert xs + +pureFields :: (All POSable xs) => NP ProductFieldsT xs +pureFields = cpure_NP (Proxy :: Proxy POSable) pureProductFields + where + pureProductFields :: forall x . (POSable x) => ProductFieldsT x + pureProductFields = ProductFieldsT $ emptyFields @x + +pureMap2Fields :: forall xss . (All2 POSable xss) => NP (NP ProductType) (Map2Fields xss) +pureMap2Fields = convert $ pure2Fields @xss + where + convert :: NP ProductMapFieldsT yss -> NP (NP ProductType) (Map2Fields yss) + convert SOP.Nil = SOP.Nil + convert (ProductMapFieldsT x :* xs) = x :* convert xs + +pure2Fields :: (All2 POSable zss) => NP ProductMapFieldsT zss +pure2Fields = cpure_NP (Proxy :: Proxy (All POSable)) pureProductMapFieldsT + where + pureProductMapFieldsT :: forall xs . (All POSable xs) => ProductMapFieldsT xs + pureProductMapFieldsT = ProductMapFieldsT $ pureMapFields @xs + +pureConcatFields :: forall xss . (All2 POSable xss) => NP ProductConcatFieldsT xss +pureConcatFields = convert $ pure2Fields @xss + where + convert :: NP ProductMapFieldsT yss -> NP ProductConcatFieldsT yss + convert SOP.Nil = SOP.Nil + convert (ProductMapFieldsT x :* xs) = ProductConcatFieldsT (appendsT x) :* convert xs + +-------------------------------------------------------------------------------- +-- Functions that deal with creating Choices from types + +newtype FChoices a = FChoices (Finite (Choices a)) + +newtype ProductsMapChoices a = ProductsMapChoices (Finite (Products (MapChoices a))) + +newtype FMapChoices a = FMapChoices (NP Finite (MapChoices a)) + +pureChoices2 :: forall xss . (All2 KnownNat (Map2Choices xss)) => (All2 POSable xss) => NP ProductsMapChoices xss +pureChoices2 = convert $ pure2Choices @xss + where + convert :: (All2 KnownNat (Map2Choices yss)) => NP FMapChoices yss -> NP ProductsMapChoices yss + convert SOP.Nil = SOP.Nil + convert (FMapChoices x :* xs) = ProductsMapChoices (combineProducts x) :* convert xs + +pureMapChoices :: forall xs . (All POSable xs) => NP Finite (MapChoices xs) +pureMapChoices = convert $ pureChoices @xs + where + convert :: NP FChoices ys -> NP Finite (MapChoices ys) + convert SOP.Nil = SOP.Nil + convert (FChoices x :* xs) = x :* convert xs + +pureChoices :: (All POSable xs) => NP FChoices xs +pureChoices = cpure_NP (Proxy :: Proxy POSable) (FChoices 0) + +pure2Choices :: (All2 POSable xss) => NP FMapChoices xss +pure2Choices = cpure_NP (Proxy :: Proxy (All POSable)) pureFMapChoices + where + pureFMapChoices :: forall xs . (All POSable xs) => FMapChoices xs + pureFMapChoices = FMapChoices $ pureMapChoices @xs + +------------------------------------------------------- +-- Functions to get back to the SOP representation + +separateProducts :: (All KnownNat (MapChoices xs)) => ProductsMapChoices xs -> NP FChoices xs -> NP FChoices xs +separateProducts _ SOP.Nil = SOP.Nil +separateProducts (ProductsMapChoices x) (_ :* ys) = FChoices x' :* separateProducts (ProductsMapChoices xs) ys + where + (x', xs) = separateProduct x + +zipFromPOSable :: All POSable xs => NP FChoices xs -> NP ProductFields xs -> NP I xs +zipFromPOSable SOP.Nil SOP.Nil = SOP.Nil +zipFromPOSable (FChoices c :* cs) (ProductFields f :* fs) = I (fromPOSable c f) :* zipFromPOSable cs fs + +foldMergeT2 :: NP ProductConcatFieldsT xss -> ProductType (FoldMerge (MapConcat (Map2Fields xss))) +foldMergeT2 (ProductConcatFieldsT x :* SOP.Nil) = x +foldMergeT2 SOP.Nil = PTNil +foldMergeT2 (ProductConcatFieldsT x :* x' :* xs) = mergeT x (foldMergeT2 (x' :* xs)) + +unSums :: (All KnownNat (MapProducts (Map2Choices xs))) => Finite (Sums (MapProducts (Map2Choices xs))) -> NP ProductsMapChoices xs -> NS ProductsMapChoices xs +unSums _ SOP.Nil = error "Cannot construct empty sum" +unSums x (_ :* ys) = case separateSum x of + Left x' -> Z (ProductsMapChoices x') + Right x' -> S (unSums x' ys) + +mapFromPOSable + :: forall xss . + ( All2 KnownNat (Map2Choices xss) + , All2 POSable xss + ) => NS ProductsMapChoices xss + -> Product (FoldMerge (MapConcat (Map2Fields xss))) + -> NP ProductConcatFieldsT xss + -> NS (NP I) xss +mapFromPOSable (Z cs) fs fts@(_ :* _ :* _) = Z (zipFromPOSable cs' ( unConcat (unMergeLeft fs fts) pureFields)) + where + cs' = separateProducts cs pureChoices +mapFromPOSable (S cs) fs fts@(_ :* _ :* _) = S (mapFromPOSable cs (unMergeRight fs fts) (tl fts)) +mapFromPOSable (Z cs) fs (_ :* SOP.Nil) = Z (zipFromPOSable cs' (unConcat fs pureFields)) + where + cs' = separateProducts cs pureChoices +mapFromPOSable (S cs) _ fts@(_ :* SOP.Nil) = S (mapFromPOSable cs Nil (tl fts)) + +unConcat :: Product (Concat (MapFields xs)) -> NP ProductFieldsT xs -> NP ProductFields xs +unConcat Nil SOP.Nil = SOP.Nil +unConcat xs (ProductFieldsT ys :* yss) = ProductFields x' :* unConcat xs' yss + where + (x', xs') = unConcatP xs ys + +unMergeLeft :: forall xs xss . Product (Merge (Concat (MapFields xs)) (FoldMerge (MapConcat (Map2Fields xss)))) -> NP ProductConcatFieldsT (xs ': xss) -> Product (Concat (MapFields xs)) +unMergeLeft xs (ProductConcatFieldsT y :* ys) = splitLeft xs y (foldMergeT2 @xss ys) + +unMergeRight :: forall xs xss . Product (Merge (Concat (MapFields xs)) (FoldMerge (MapConcat (Map2Fields xss)))) -> NP ProductConcatFieldsT (xs ': xss) -> Product (FoldMerge (MapConcat (Map2Fields xss))) +unMergeRight xs (ProductConcatFieldsT y :* ys) = splitRight xs y (foldMergeT2 @xss ys) diff --git a/src/Generics/POSable/Representation.hs b/src/Generics/POSable/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Generics/POSable/Representation.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module exports the `Product` and `Sum` type, and type- and valuelevel +-- functions on these types. +module Generics.POSable.Representation + ( type (++) + , ProductType(..) + , concatPT + , Product(..) + , concatP + , SumType(..) + , Sum(..) + , Merge + , FoldMerge + , MapConcat + , Concat + , Ground(..) + , mergeT + , merge + , splitLeft + , splitRight + , unConcatP + , Undef(..) +) where +import Data.Kind +import Data.Typeable (Typeable) +import GHC.Generics as GHC +import Generics.SOP as SOP (All, All2, Generic) + +-- | Concatenation of typelevel lists +type family (++) (xs :: [k]) (ys :: [k]) :: [k] where + '[] ++ ys = ys + (x ': xs) ++ ys = x ': xs ++ ys + +infixr 5 ++ + + +-- | The set of types that can exist in the sums. +-- This set can be extended by the user by providing an instance of Ground +-- for their types. The mkGround function gives a default value for the type. +-- Ground depends on Typeable, as this makes it possible for library users +-- to inspect the types of the contents of the sums. +class (Typeable a) => Ground a where + mkGround :: a + +----------------------------------------------------------------------- +-- Heterogeneous lists with explicit types + +-- | Type witness for `Product` +data ProductType :: [[Type]] -> Type where + PTNil :: ProductType '[] + PTCons :: SumType x -> ProductType xs -> ProductType (x ': xs) + +instance (All2 Show (Map2TypeRep xs)) => Show (ProductType xs) where + show PTNil = "PTNil" + show (PTCons a as) = "PTCons" ++ show a ++ " (" ++ show as ++ ")" + +-- | Concatenates `ProductType` values +concatPT :: ProductType x -> ProductType y -> ProductType (x ++ y) +concatPT PTNil ys = ys +concatPT (PTCons x xs) ys = PTCons x (concatPT xs ys) + +-- | Typelevel product of `Sum`s with values +data Product :: [[Type]] -> Type where + Nil :: Product '[] + Cons :: Sum x -> Product xs -> Product (x ': xs) + +deriving instance (All2 Eq xs) => Eq (Product xs) + +instance (All2 Show xs) => Show (Product xs) where + show Nil = "Nil" + show (Cons a as) = "Cons " ++ show a ++ " (" ++ show as ++ ")" + +-- | Concatenates `Product` values +concatP :: Product x -> Product y -> Product (x ++ y) +concatP Nil ys = ys +concatP (Cons x xs) ys = Cons x (concatP xs ys) + +-- | Type witness for `Sum` +data SumType :: [Type] -> Type where + STSucc :: (Ground x) => x -> SumType xs -> SumType (x ': xs) + STZero :: SumType '[] + +-- | Typelevel sum, contains one value from the typelevel list of types, or +-- undefined. +data Sum :: [Type] -> Type where + Pick :: (Ground x) => x -> Sum (x ': xs) + Skip :: (Ground x) => Sum xs -> Sum (x ': xs) + +data Undef = Undef + deriving (Eq, Show, GHC.Generic, SOP.Generic) + +-- Undef is the only default Ground, because we need to mark when no value +-- is when 2 non-equal-lenght types are zipped +instance Ground Undef where + mkGround = Undef + +deriving instance (All Eq xs) => Eq (Sum xs) + +type family MapTypeRep (xs :: [Type]) :: [Type] where + MapTypeRep '[] = '[] + MapTypeRep (x ': xs) = x ': MapTypeRep xs + +type family Map2TypeRep (xss :: [[Type]]) :: [[Type]] where + Map2TypeRep '[] = '[] + Map2TypeRep (x ': xs) = MapTypeRep x ': Map2TypeRep xs + +instance (All Show (MapTypeRep xs)) => Show (SumType xs) where + show (STSucc x xs) = "STSucc" ++ show x ++ "(" ++ show xs ++ ")" + show STZero = "STZero" + +instance (All Show x) => Show (Sum x) where + show (Pick x) = "Pick " ++ show x + show (Skip x) = "Skip " ++ show x + +-- only used in examples +data A +data B +data C +data D +data E +data F +data G +data H + +---------------------------------------- +-- Type functions on lists + +-- | Concatenate a list of lists, typelevel equivalent of +-- +-- > concat :: [[a]] -> [a]` +-- +-- Example: +-- +-- >>> :kind! Concat '[ '[A, B], '[C, D]] +-- Concat '[ '[A, B], '[C, D]] :: [Type] +-- = '[A, B, C, D] +-- +type family Concat (xss :: [[x]]) :: [x] where + Concat '[] = '[] + Concat (xs ': xss) = xs ++ Concat xss + +-- | Map `Concat` over a list (of lists, of lists), typelevel equivalent of +-- +-- > map . concat :: [[[a]]] -> [[a]] +-- +-- Example: +-- +-- >>> :kind! MapConcat '[ '[ '[A, B], '[C, D]], '[[E, F], '[G, H]]] +-- MapConcat '[ '[ '[A, B], '[C, D]], '[[E, F], '[G, H]]] :: [[Type]] +-- = '[ '[A, B, C, D], '[E, F, G, H]] +-- +type family MapConcat (xsss :: [[[x]]]) :: [[x]] where + MapConcat '[] = '[] + MapConcat (xss ': xsss) = Concat xss ': MapConcat xsss + +-- | Zip two lists of lists with ++` as operator, while keeping the length of +-- the longest outer list +-- +-- Example: +-- +-- >>> :kind! Merge '[ '[A, B, C], '[D, E]] '[ '[F, G]] +-- Merge '[ '[A, B, C], '[D, E]] '[ '[F, G]] :: [[Type]] +-- = '[ '[A, B, C, F, G], '[D, E]] +-- +type family Merge (xs :: [[Type]]) (ys :: [[Type]]) :: [[Type]] where + Merge '[] '[] = '[] + Merge '[] (b ': bs) = (Undef ': b) ': Merge '[] bs + Merge (a ': as) '[] = (a ++ '[Undef]) ': Merge as '[] + Merge (a ': as) (b ': bs) = (a ++ b) ': Merge as bs + +-- | Fold `Merge` over a list (of lists, of lists) +-- +-- Example: +-- +-- >>> :kind! FoldMerge '[ '[ '[A, B, C], '[D, E]], '[ '[F, G]], '[ '[H]]] +-- FoldMerge '[ '[ '[A, B, C], '[D, E]], '[ '[F, G]], '[ '[H]]] :: [[Type]] +-- = '[ '[A, B, C, F, G, H], '[D, E]] +-- +type family FoldMerge (xss :: [[[Type]]]) :: [[Type]] where + FoldMerge '[a] = a + FoldMerge (a ': as) = Merge a (FoldMerge as) + FoldMerge '[] = '[] + +---------------------------------------- +-- Functions on Products and Sums + +-- | Merge a `ProductType` and a `Product`, putting the values of the `Product` in +-- the right argument of `Merge` +zipSumRight :: ProductType l -> Product r -> Product (Merge l r) +zipSumRight PTNil Nil = Nil +zipSumRight PTNil (Cons y ys) = Cons (takeRightUndef y) (zipSumRight PTNil ys) +zipSumRight (PTCons x xs) Nil = Cons (makeUndefRight x) (zipSumRight xs Nil) +zipSumRight (PTCons x xs) (Cons y ys) = Cons (takeRight x y) (zipSumRight xs ys) + +makeUndefRight :: SumType x -> Sum (x ++ '[Undef]) +makeUndefRight (STSucc _ xs) = Skip (makeUndefRight xs) +makeUndefRight STZero = Pick Undef + +makeUndefLeft :: SumType x -> Sum (Undef ': x) +makeUndefLeft _ = Pick Undef + +takeRightUndef :: Sum r -> Sum (Undef ': r) +takeRightUndef = Skip + +takeLeftUndef :: Sum x -> Sum (x ++ '[Undef]) +takeLeftUndef (Pick x) = Pick x +takeLeftUndef (Skip xs) = Skip (takeLeftUndef xs) + +-- | Merge a `ProductType` and a `Product` +merge :: Either (Product l, ProductType r) (ProductType l, Product r) -> Product (Merge l r) +merge (Left (l, r)) = zipSumLeft l r +merge (Right (l, r)) = zipSumRight l r + +-- | Merge a `ProductType` and a `Product`, putting the values of the `Product` +-- in the left argument of `Merge` +zipSumLeft :: Product l -> ProductType r -> Product (Merge l r) +zipSumLeft Nil PTNil = Nil +zipSumLeft Nil (PTCons y ys) = Cons (makeUndefLeft y) (zipSumLeft Nil ys) +zipSumLeft (Cons x xs) PTNil = Cons (takeLeftUndef x) (zipSumLeft xs PTNil) +zipSumLeft (Cons x xs) (PTCons y ys) = Cons (takeLeft x y) (zipSumLeft xs ys) + +-- | Merge two `ProductType`s +mergeT :: ProductType l -> ProductType r -> ProductType (Merge l r) +mergeT PTNil PTNil = PTNil +mergeT PTNil (PTCons y ys) = PTCons (makeUndefLeftT y) (mergeT PTNil ys) +mergeT (PTCons x xs) PTNil = PTCons (makeUndefRightT x) (mergeT xs PTNil) +mergeT (PTCons x xs) (PTCons y ys) = PTCons (takeST x y) (mergeT xs ys) + +makeUndefRightT :: SumType x -> SumType (x ++ '[Undef]) +makeUndefRightT (STSucc x xs) = STSucc x (makeUndefRightT xs) +makeUndefRightT STZero = STSucc Undef STZero + +makeUndefLeftT :: SumType x -> SumType (Undef ': x) +makeUndefLeftT = STSucc Undef + +takeST :: SumType l -> SumType r -> SumType (l ++ r) +takeST (STSucc l ls) rs = STSucc l (takeST ls rs) +takeST STZero rs = rs + +takeLeft :: Sum l -> SumType r -> Sum (l ++ r) +takeLeft (Pick l) _ = Pick l +takeLeft (Skip ls) rs = Skip (takeLeft ls rs) + +takeRight :: SumType l -> Sum r -> Sum (l ++ r) +takeRight (STSucc _ ls) rs = Skip (takeRight ls rs) +takeRight STZero rs = rs + +-- | UnMerge a `Product`, using two `ProductType`s as witnesses for the left and +-- right argument of `Merge`. Produces a value of type Product right +splitRight :: Product (Merge l r) -> ProductType l -> ProductType r -> Product r +splitRight (Cons x xs) PTNil (PTCons _ rs) = Cons (removeUndefLeft x) (splitRight xs PTNil rs) +splitRight _ _ PTNil = Nil +splitRight (Cons x xs) (PTCons l ls) (PTCons r rs) = Cons (splitSumRight x l r) (splitRight xs ls rs) + +removeUndefLeft :: Sum (Undef ': x) -> Sum x +removeUndefLeft (Pick Undef) = error "Undefined value where I expected an actual value" +removeUndefLeft (Skip xs) = xs + +removeUndefRight :: SumType x -> Sum (x ++ '[Undef]) -> Sum x +removeUndefRight STZero _ = error "Undefined value where I expected an actual value" +removeUndefRight (STSucc _ _) (Pick y) = Pick y +removeUndefRight (STSucc _ xs) (Skip ys) = Skip (removeUndefRight xs ys) + +-- | UnMerge a `Product`, using two `ProductType`s as witnesses for the left and +-- right argument of `Merge`. Produces a value of type Product left +splitLeft :: Product (Merge l r) -> ProductType l -> ProductType r -> Product l +splitLeft _ PTNil _ = Nil +splitLeft (Cons x xs) (PTCons l ls) PTNil = Cons (removeUndefRight l x) (splitLeft xs ls PTNil) +splitLeft (Cons x xs) (PTCons l ls) (PTCons r rs) = Cons (splitSumLeft x l r) (splitLeft xs ls rs) + +splitSumRight :: Sum (l ++ r) -> SumType l -> SumType r -> Sum r +splitSumRight xs STZero _ = xs +splitSumRight (Pick _) (STSucc _ _) _ = error "No value found in right side of Sum" +splitSumRight (Skip xs) (STSucc _ ls) rs = splitSumRight xs ls rs + +splitSumLeft :: Sum (l ++ r) -> SumType l -> SumType r -> Sum l +splitSumLeft (Pick x) (STSucc _ _) _ = Pick x +splitSumLeft _ STZero _ = error "No value value found in left side of Sum" +splitSumLeft (Skip xs) (STSucc _ ls) rs = Skip $ splitSumLeft xs ls rs + +-- | UnConcat a `Product`, using a `ProductType` as the witness for the first +-- argument of `++`. Produces a tuple with the first and second argument of `++` +unConcatP :: Product (x ++ y) -> ProductType x -> (Product x, Product y) +unConcatP xs PTNil = (Nil, xs) +unConcatP (Cons x xs) (PTCons _ ts) = (Cons x xs', ys') + where + (xs', ys') = unConcatP xs ts diff --git a/src/Generics/POSable/TH.hs b/src/Generics/POSable/TH.hs new file mode 100644 --- /dev/null +++ b/src/Generics/POSable/TH.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + + +{-# OPTIONS_GHC -ddump-splices #-} + +module Generics.POSable.TH (mkPOSableGround) where + +import Generics.POSable.POSable +import Generics.POSable.Representation +import Language.Haskell.TH + +mkPOSableGround :: Name -> DecsQ +mkPOSableGround name = mkDec (pure (ConT name)) + +mkDec :: Q Type -> DecsQ +mkDec name = + [d| instance POSable $name where + type Choices $name = 1 + choices _ = 0 + + type Fields $name = '[ '[$name]] + fields x = Cons (Pick x) Nil + + -- A singleton type has only a single tag, which is 0 + -- The upper bound of this first range is 1 + tags = [1] + + fromPOSable 0 (Cons (Pick x) Nil) = x + fromPOSable _ _ = error "index out of range" + + emptyFields = PTCons (STSucc (mkGround @($name)) STZero) PTNil + |] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fconstraint-solver-iterations=26 #-} + +module Main where + +import GHC.Generics as GHC (Generic) +import Generics.POSable.Instances () +import Generics.POSable.POSable as POSable +import Generics.POSable.Representation +import Generics.POSable.TH +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Test.Tasty (TestTree, defaultMain, + testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck + +propInjectivity :: (POSable a, Arbitrary a, Eq a) => a -> Bool +propInjectivity x = fromPOSable (choices x) (fields x) == x + +instance Ground Float where + mkGround = 0 + +instance Ground Double where + mkGround = 0 + +instance Ground Char where + mkGround = '0' + +instance Ground Int where + mkGround = 0 + +instance Ground Word where + mkGround = 0 + +mkPOSableGround ''Float + +mkPOSableGround ''Double + +mkPOSableGround ''Char + +mkPOSableGround ''Int + +mkPOSableGround ''Word + +$(runQ $ do + -- generate :: Int -> (Int -> a) -> [a] + let generate n f = case n of + 0 -> [] + _ -> f n : generate (n - 1) f + + let baseTypes = [''Int, ''Float, ''Char, ''Bool] + + let buildValue n = ( Bang NoSourceUnpackedness NoSourceStrictness + , ConT (baseTypes !! (n-1))) + + let buildCons name n = NormalC (mkName name) (generate n buildValue) + + let arbitraryCon name n = case n of + 0 -> AppE (VarE 'pure) (ConE name) + 1 -> AppE (AppE (VarE '(<$>)) (ConE name)) (VarE 'arbitrary) + _ -> AppE (AppE (VarE '(<*>)) (arbitraryCon name (n-1))) (VarE 'arbitrary) + + let buildData name ncons nvals = DataD + [] + (mkName name) + [] + Nothing + (generate ncons (\x -> buildCons (name ++ show x) nvals)) + [ + DerivClause + Nothing + [ ConT ''Show, ConT ''Eq, ConT ''GHC.Generic + , ConT ''POSable.Generic, ConT ''POSable + ] + ] + + let buildInstance name ncons nvals = InstanceD + Nothing + [] + (AppT (ConT ''Arbitrary) (ConT (mkName name))) + [ + FunD + 'arbitrary + [ + Clause + [] + (NormalB ( AppE (VarE 'oneof) (ListE (generate ncons (\x -> + arbitraryCon (mkName (name ++ show x)) nvals + ))))) + [] + ] + ] + + let buildDataAndInstance ncons m | nvals <- m-1, name <- "TEST" ++ show ncons ++ show nvals = + [ + buildData name ncons nvals, + buildInstance name ncons nvals + ] + + let buildTest ncons m | nvals <- m-1, name <- "TEST" ++ show ncons ++ show nvals = + AppE + (AppE (VarE 'testProperty) (LitE (StringL name))) + (AppTypeE (VarE 'propInjectivity) (ConT (mkName name))) + + let tests ncons nvals = FunD (mkName "thtests") [Clause [] (NormalB ( + AppE + (AppE + (VarE 'testGroup) + (LitE (StringL "QuickCheck Template Haskell"))) + (ListE (concat (generate 4 (generate 5 . buildTest))) + ) + )) []] + + return (tests 4 5 : concat (concat (generate 4 (generate 5 . buildDataAndInstance)))) + ) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Test Choices and Fields of basic data types" + [ testGroup "Maybe" + [ testCase "Nothing" $ + choices (Nothing :: Maybe Int) @?= 0 + , testCase "Just" $ + choices (Just 14 :: Maybe Int) @?= 1 + , testCase "Nested" $ + choices nestedMaybe @?= 2 + , testCase "Fields" $ + fields nestedMaybe @?= Cons (Skip (Skip (Pick 1.4))) Nil + ] + , testGroup "Either" + [ testCase "Left" $ + choices (Left 1 :: Either Int Float) @?= 0 + , testCase "Right" $ + choices (Right 14 :: Either Float Int) @?= 1 + , testCase "Nested" $ + choices nestedEither @?= 2 + , testCase "Fields" $ + fields nestedEither @?= Cons (Skip $ Skip $ Pick 1.4) Nil + ] + , testGroup "Tuple" + [ testCase "choices" $ + choices (1 :: Int, 2.3 :: Float) @?= 0 + , testCase "fields" $ + fields (1 :: Int, 2.3 :: Float) @?= Cons (Pick 1) (Cons (Pick 2.3) Nil) + ] + , testGroup "Mixed" + [ testCase "fields (Either, Either)" $ + choices tupleOfEithers @?= 2 + , testCase "choices (Either, Either)" $ + fields tupleOfEithers @?= Cons (Pick 1) (Cons (Skip $ Pick 2.3) Nil) + , testCase "fields Either (,) (,)" $ + choices eitherOfTuples @?= 0 + , testCase "choices Either (,) (,)" $ + fields eitherOfTuples @?= Cons (Pick 1) (Cons (Pick 3.4) Nil) + ] + , testGroup "QuickCheck" + [ testProperty "Either Int Float" $ + propInjectivity @(Either Int Float) + , testProperty "Either Either Tuple" $ + propInjectivity @(Either (Either Int Float) (Float, Int)) + , testProperty "Long tuple" $ + propInjectivity @(Int, Float, Word, Float, Char) + , testProperty "Unit" $ + propInjectivity @() + , testProperty "Ordering" $ + propInjectivity @Ordering + , testProperty "Large sum" $ + propInjectivity @LONGSUM + , testProperty "Large product" $ + propInjectivity @LONGPRODUCT + ] + , testGroup "tags" + [ testCase "Bool" $ + tags @Bool @?= [1,1] + , testCase "Either Int Float" $ + tags @(Either Int Float) @?= [1,1] + , testCase "Either Bool Bool" $ + tags @(Either Bool Bool) @?= [2,2] + , testCase "Either (Maybe Int) Float" $ + tags @(Either (Maybe Int) Float) @?= [2,1] + , testCase "Unit" $ + tags @() @?= [1] + , testCase "Float" $ + tags @() @?= [1] + , testCase "(Float, Bool, Bool)" $ + tags @(Float, Bool, Bool) @?= [4] + ] + , thtests + ] + +data LONGSUM = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + deriving (Show, Eq, GHC.Generic, POSable.Generic, POSable) + +instance Arbitrary LONGSUM where + arbitrary = elements [A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z] + +data LONGPRODUCT = LONGPRODUCT Int Float Double Char Word Int Float Double Char Word Int Float Double Char Word Int Float Double Char Word + deriving (Show, Eq, GHC.Generic, POSable.Generic, POSable) + +instance Arbitrary LONGPRODUCT where + arbitrary = LONGPRODUCT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +nestedMaybe :: Maybe (Maybe Float) +nestedMaybe = Just (Just 1.4) + +nestedEither :: Either (Either Int Float) (Either Float Int) +nestedEither = Right (Left 1.4) + +tupleOfEithers :: (Either Int Float, Either Int Float) +tupleOfEithers = (Left 1, Right 2.3) + +eitherOfTuples :: Either (Int, Float) (Float, Int) +eitherOfTuples = Left (1,3.4)