packages feed

posable (empty) → 1.0.0.0

raw patch · 10 files changed

+1205/−0 lines, 10 filesdep +basedep +finite-typelitsdep +generics-sop

Dependencies added: base, finite-typelits, generics-sop, ghc-typelits-knownnat, posable, tasty, tasty-hunit, tasty-quickcheck, template-haskell

Files

+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ examples/Examples.hs view
@@ -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
+ posable.cabal view
@@ -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 <hackage@rickvanhoef.nl>+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
+ src/Generics/POSable/Instances.hs view
@@ -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]+
+ src/Generics/POSable/POSable.hs view
@@ -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)
+ src/Generics/POSable/Representation.hs view
@@ -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
+ src/Generics/POSable/TH.hs view
@@ -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+  |]
+ test/Main.hs view
@@ -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)