generics-sop-0.5.1.3/0000755000000000000000000000000007346545000012445 5ustar0000000000000000generics-sop-0.5.1.3/CHANGELOG.md0000644000000000000000000002232207346545000014257 0ustar0000000000000000# 0.5.1.3 (2023-04-23) * Compatibility with GHC-9.6 / th-abstraction-0.5 (thanks to Ryan Scott). # 0.5.1.2 (2022-01-02) * Compatibility with GHC-9.2. # 0.5.1.1 (2021-02-23) * Compatibility with GHC-9.0. # 0.5.1.0 (2020-03-29) * Compatibility with GHC-8.10 (thanks to Ryan Scott). * Improve TH generation support and extend it to type families (thanks to Ryan Scott). # 0.5.0.0 (2019-05-09) * Add strictness info to the metadata. This means that code directly using the `ADT` constructor has to be modified because it now has a new fourth argument. (See #76 and #87.) * Depend on `sop-core-0.5.0.*` which changes the definition of `SameShapeAs` to improve compiler performance and adds "ejections". # 0.4.0.1 (2018-10-23) * Remove `GHC.Event` import in `Generics.SOP.Instances` to fix build on Windows. # 0.4.0.0 (2018-10-20) * Split into `sop-core` and `generics-sop` packages. * Drop support for GHC < 8.0.2, bump `base` dependency to `>= 4.9` and remove dependency on `transformers`. * Simplify `All2 c` to `All (All c)` and simplify `SListI xs` to `All Top xs`, and some implied refactoring. * Add `Semigroup` and `Monoid` instances for various datatypes. * Add specialised conversion functions for product types, enumeration, and wrapped types. * Add benchmark suite. * Fix deriving `Generic` for empty datatypes. * `Generic` is now a superclass of `HasDatatypeInfo`. * More `Generic` instances for datatypes from recent versions of `base`. # 0.3.2.0 (2018-01-08) * Make TH `deriveGenericFunctions` work properly with parameterized types (note that the more widely used `deriveGeneric` was already working correctly). * Make TH `deriveGeneric` work properly with empty types. * Add `compare_NS`, `ccompare_NS`, `compare_SOP`, and `ccompare_SOP` to better support comparison of sum structures. * Add `hctraverse_` and `hctraverse'` as well as their unconstrained variants and a number of derived functions, to support effectful traversals. # 0.3.1.0 (2017-06-11) * Add `AllZip`, `htrans`, `hcoerce`, `hfromI`, `htoI`. These functions are for converting between related structures that do not have common signatures. The most common application of these functions seems to be the scenario where a datatype has components that are all wrapped in a common type constructor application, e.g. a datatype where every component is a `Maybe`. Then we can use `hfromI` after `from` to turn the generically derived `SOP` of `I`s into an `SOP` of `Maybe`s (and back). * Add `IsProductType`, `IsEnumType`, `IsWrappedType` and `IsNewtype` constraint synonyms capturing specific classes of datypes. # 0.3.0.0 (2017-04-29) * No longer compatible with GHC 7.6, due to the lack of support for type-level literals. * Support type-level metadata. This is provided by the `Generics.SOP.Type.Metadata` module. The two modules `Generics.SOP.Metadata` and `Generics.SOP.Type.Metadata` export nearly the same names, so for backwards compatibility, we keep exporting `Generics.SOP.Metadata` directly from `Generics.SOP`, whereas `Generics.SOP.Type.Metadata` is supposed to be imported explicitly (and qualified). Term-level metadata is still available, but is now usually computed automatically from the type-level metadata which contains the same information, using the function `demoteDatatypeInfo`. Term-level metadata is unchanged from generics-sop-0.2, so in most cases, even if your code makes use of metadata, you should not need to change anything. If you use TH deriving, then both type-level metadata and term-level metadata is generated for you automatically, for all supported GHC versions. If you use GGP deriving, then type-level metadata is available if you use GHC 8.0 or newer. If you use GHC 7.x, then GHC.Generics supports only term-level metadata, so we cannot translate that into type-level metadata. In this combination, you cannot use code that relies on type-level metadata, so you should either upgrade GHC or switch to TH-based deriving. # 0.2.5.0 (2017-04-21) * GHC 8.2 compatibility. * Make `:.:` an instance of `Applicative`, `Foldable` and `Traversable`. * Add functions `apInjs'_NP` and `apInjs'_POP`. These are variants of `apInjs_NP` and `apInjs'_POP` that return their result as an n-ary product, rather than collapsing it into a list. * Add `hexpand` (and `expand_NS` and `expand_SOP`). These functions expand sums into products, given a default value to fill the other slots. * Add utility functions such as `mapII` or `mapIK` that lift functions into different combinations of identity and constant functors. * Add `NFData` (and lifted variants) instances for basic functors, products and sums. # 0.2.4.0 (2017-02-02) * Add `hindex` (and `index_NS` and `index_SOP`). * Add `hapInjs` as a generalization of `apInjs_NP` and `apInjs_POP`. * Make basic functors instances of lifted classes (such as `Eq1` etc). # 0.2.3.0 (2016-12-04) * Add various metadata getters * Add `hdicts`. * Add catamorphisms and anamorphisms for `NP` and `NS`. * TH compatibility changes for GHC 8.1 (master). # 0.2.2.0 (2016-07-10) * Introduced `unZ` to destruct a unary sum. * Add Haddock `@since` annotations for various functions. # 0.2.1.0 (2016-02-08) * Now includes a CHANGELOG. * Should now work with ghc-8.0.1-rc1 and -rc2 (thanks to Oleg Grenrus). * Introduced `hd` and `tl` to project out of a product, and `Projection` and `projections` as duals of `Injection` and `injections`. # 0.2.0.0 (2015-10-23) * Now tested with ghc-7.10 * Introduced names `hmap`, `hcmap`, `hzipWith`, `hczipWith` for `hliftA`, `hcliftA`, `hliftA2`, `hcliftA2`, respectively. Similarly for the specialized versions of these functions. * The constraint transformers `All` and `All2` are now defined as type classes, not type families. As a consequence, the partial applications `All c` and `All2 c` are now possible. * Because of the redefinition of `All` and `All2`, some special cases are no longer necessary. For example, `cpure_POP` can now be implemented as a nested application of `pure_NP`. * Because of the redefinition of `All` and `All2`, the functions `hcliftA'` and variants (with prime!) are now deprecated. One can easily use the normal versions instead. For example, the definition of `hcliftA'` is now simply hcliftA' p = hcliftA (allP p) where allP :: proxy c -> Proxy (All c) allP _ = Proxy * Because `All` and `All2` are now type classes, they now have superclass constraints implying that the type-level lists they are ranging over must have singletons. class (SListI xs, ...) => All c xs class (SListI xss, ...) => All2 c xss Some type signatures can be simplified due to this. * The `SingI` typeclass and `Sing` datatypes are now deprecated. The replacements are called `SListI` and `SList`. The `sing` method is now called `sList`. The difference is that the new versions reveal only the spine of the list, and contain no singleton representation for the elements anymore. For one-dimensional type-level lists, replace SingI xs => ... by SListI xs => ... For two-dimensional type-level lists, replace SingI xss => ... by All SListI xss => ... Because All itself implies `SListI xss` (see above), this constraint is equivalent to the old `Sing xss`. The old names are provided for (limited) backward compatibility. They map to the new constructs. This will work in some, but not all scenarios. The function `lengthSing` has also been renamed to `lengthSList` for consistency, and the old name is deprecated. * All `Proxy c` arguments have been replaced by `proxy c` flexible arguments, so that other type constructors can be used as proxies. * Class-level composition (`Compose`), pairing (`And`), and a trivial constraint (`Top`) have been added. Type-level map (`Map`) has been removed. Occurrences such as All c (Map f xs) should now be replaced with All (c `Compose` f) xs * There is a new module called `Generics.SOP.Dict` that contains functions for manipulating dictionaries explicitly. These can be used to prove theorems about non-trivial class constraints such as the ones that get built using `All` and `All2`. Some such theorems are provided. * There is a new TH function `deriveGenericFunctions` that derives the code of a datatype and conversion functions, but does not create a class instance. (Contributed by Oleg Grenrus.) * There is a new TH function `deriveMetadataValue` that derives a `DatatypeInfo` value for a datatype, but does not create an instance of `HasDatatypeInfo`. (Contributed by Oleg Grenrus.) * There is a very simple example file. (Contributed by Oleg Grenrus.) * The function `hcollapse` for `NS` now results in an `a` rather than an `I a`, matching the specialized version `collapse_NS`. (Suggested by Roman Cheplyaka.) # 0.1.1.2 (2015-03-27) * Updated version bounds for ghc-prim (for ghc-7.10). # 0.1.1.1 (2015-03-20) * Preparations for ghc-7.10. * Documentation fix. (Contributed by Roman Cheplyaka.) # 0.1.1 (2015-01-06) * Documentation fixes. * Add superclass constraint (TODO). * Now derive tuple instance for tuples up to 30 components. (Contributed by Michael Orlitzky.) generics-sop-0.5.1.3/LICENSE0000644000000000000000000000277607346545000013466 0ustar0000000000000000Copyright (c) 2014-2015, Well-Typed LLP, Edsko de Vries, Andres Löh All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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. generics-sop-0.5.1.3/bench/0000755000000000000000000000000007346545000013524 5ustar0000000000000000generics-sop-0.5.1.3/bench/SOPBench.hs0000644000000000000000000000711407346545000015464 0ustar0000000000000000{-# LANGUAGE DataKinds #-} module Main where import Criterion.Main import SOPBench.Type import SOPBench.Roundtrip main :: IO () main = defaultMainWith defaultConfig [ bgroup "Roundtrip" [ bgroup "S2" [ bench "GHCGeneric" $ nf roundtrip (s2 :: S2 'GHCGeneric) , bench "SOPGGP" $ nf roundtrip (s2 :: S2 'SOPGGP ) , bench "SOPTH" $ nf roundtrip (s2 :: S2 'SOPTH ) ] , bgroup "S20" [ bench "GHCGeneric" $ nf roundtrip (s20 :: S20 'GHCGeneric) , bench "SOPGGP" $ nf roundtrip (s20 :: S20 'SOPGGP ) , bench "SOPTH" $ nf roundtrip (s20 :: S20 'SOPTH ) ] , bgroup "PB2" [ bench "GHCGeneric" $ nf roundtrip (pb2 :: PB2 'GHCGeneric) , bench "SOPGGP" $ nf roundtrip (pb2 :: PB2 'SOPGGP ) , bench "SOPTH" $ nf roundtrip (pb2 :: PB2 'SOPTH ) ] ] , bgroup "Eq" [ bgroup "S2" [ bench "GHCDeriving" $ nf ((==) s2) (s2 :: S2 'GHCDeriving) , bench "SOPGGP" $ nf ((==) s2) (s2 :: S2 'SOPGGP ) , bench "SOPTH" $ nf ((==) s2) (s2 :: S2 'SOPTH ) ] , bgroup "S20" [ bench "GHCDeriving" $ nf ((==) s20) (s20 :: S20 'GHCDeriving) , bench "SOPGGP" $ nf ((==) s20) (s20 :: S20 'SOPGGP ) , bench "SOPTH" $ nf ((==) s20) (s20 :: S20 'SOPTH ) ] , bgroup "PB2" [ bench "GHCDeriving" $ nf ((==) pb2) (pb2 :: PB2 'GHCDeriving) , bench "SOPGGP" $ nf ((==) pb2) (pb2 :: PB2 'SOPGGP ) , bench "SOPTH" $ nf ((==) pb2) (pb2 :: PB2 'SOPTH ) ] , bgroup "Tree" [ bench "GHCDeriving" $ nf ((==) tree) (tree :: Tree 'GHCDeriving) , bench "SOPGGP" $ nf ((==) tree) (tree :: Tree 'SOPGGP ) , bench "SOPTH" $ nf ((==) tree) (tree :: Tree 'SOPTH ) ] , bgroup "Tree large" [ bench "GHCDeriving" $ nf ((==) tree_large) (tree_large :: Tree 'GHCDeriving) , bench "SOPGGP" $ nf ((==) tree_large) (tree_large :: Tree 'SOPGGP ) , bench "SOPTH" $ nf ((==) tree_large) (tree_large :: Tree 'SOPTH ) ] ] , bgroup "Show" [ bgroup "S2" [ bench "GHCDeriving" $ nf show (s2 :: S2 'GHCDeriving) , bench "SOPGGP" $ nf show (s2 :: S2 'SOPGGP ) , bench "SOPTH" $ nf show (s2 :: S2 'SOPTH ) ] , bgroup "S20" [ bench "GHCDeriving" $ nf show (s20 :: S20 'GHCDeriving) , bench "SOPGGP" $ nf show (s20 :: S20 'SOPGGP ) , bench "SOPTH" $ nf show (s20 :: S20 'SOPTH ) ] , bgroup "PB2" [ bench "GHCDeriving" $ nf show (pb2 :: PB2 'GHCDeriving) , bench "SOPGGP" $ nf show (pb2 :: PB2 'SOPGGP ) , bench "SOPTH" $ nf show (pb2 :: PB2 'SOPTH ) ] , bgroup "Tree" [ bench "GHCDeriving" $ nf show (tree :: Tree 'GHCDeriving) , bench "SOPGGP" $ nf show (tree :: Tree 'SOPGGP ) , bench "SOPTH" $ nf show (tree :: Tree 'SOPTH ) ] , bgroup "Tree large" [ bench "GHCDeriving" $ nf show (tree_large :: Tree 'GHCDeriving) , bench "SOPGGP" $ nf show (tree_large :: Tree 'SOPGGP ) , bench "SOPTH" $ nf show (tree_large :: Tree 'SOPTH ) ] ] ] generics-sop-0.5.1.3/bench/SOPBench/0000755000000000000000000000000007346545000015125 5ustar0000000000000000generics-sop-0.5.1.3/bench/SOPBench/Eq.hs0000644000000000000000000000061707346545000016032 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} module SOPBench.Eq where import Generics.SOP geq :: (Generic a, All2 Eq (Code a)) => a -> a -> Bool geq x y = eq' (from x) (from y) eq' :: All2 Eq xss => SOP I xss -> SOP I xss -> Bool eq' = ccompare_SOP peq False (\ x y -> and (hcollapse (hczipWith peq (mapIIK (==)) x y))) False peq :: Proxy Eq peq = Proxy generics-sop-0.5.1.3/bench/SOPBench/Roundtrip.hs0000644000000000000000000000045707346545000017455 0ustar0000000000000000module SOPBench.Roundtrip where import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC class Roundtrip a where roundtrip :: a -> a soproundtrip :: SOP.Generic a => a -> a soproundtrip = SOP.to . SOP.from ghcroundtrip :: GHC.Generic a => a -> a ghcroundtrip = GHC.to . GHC.from generics-sop-0.5.1.3/bench/SOPBench/Show.hs0000644000000000000000000000331307346545000016401 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module SOPBench.Show where import Data.List (intersperse) import Generics.SOP gshow :: (Generic a, HasDatatypeInfo a, All2 Show (Code a)) => a -> String gshow x = gshowsPrec 0 x "" gshowsPrec :: (Generic a, HasDatatypeInfo a, All2 Show (Code a)) => Int -> a -> ShowS gshowsPrec d x = hcollapse $ hczipWith pallshow (gshowsConstructor d) (constructorInfo (datatypeInfo (I x))) (unSOP (from x)) gshowsConstructor :: forall xs . (All Show xs) => Int -> ConstructorInfo xs -> NP I xs -> K ShowS xs gshowsConstructor d i = case i of Constructor n -> \ x -> K $ showParen (d > app_prec) $ showString n . showString " " . gshowsConstructorArgs (app_prec + 1) x Infix n _ prec -> \ (I l :* I r :* Nil) -> K $ showParen (d > prec) $ showsPrec (prec + 1) l . showString " " . showString n . showString " " . showsPrec (prec + 1) r Record n fi -> \ x -> K $ showParen (d > app_prec) -- could be even higher, but seems to match GHC behaviour $ showString n . showString " {" . gshowsRecordArgs fi x . showString "}" gshowsConstructorArgs :: (All Show xs) => Int -> NP I xs -> ShowS gshowsConstructorArgs d x = foldr (.) id $ hcollapse $ hcmap pshow (K . showsPrec d . unI) x gshowsRecordArgs :: (All Show xs) => NP FieldInfo xs -> NP I xs -> ShowS gshowsRecordArgs fi x = foldr (.) id $ intersperse (showString ", ") $ hcollapse $ hczipWith pshow (\ (FieldInfo l) (I y) -> K (showString l . showString " = " . showsPrec 0 y)) fi x pallshow :: Proxy (All Show) pallshow = Proxy pshow :: Proxy Show pshow = Proxy app_prec :: Int app_prec = 10 generics-sop-0.5.1.3/bench/SOPBench/Type.hs0000644000000000000000000001654607346545000016416 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module SOPBench.Type where import Control.DeepSeq import qualified Generics.SOP as SOP import Generics.SOP.TH import qualified GHC.Generics as GHC import Language.Haskell.TH import qualified SOPBench.Eq as SOP import qualified SOPBench.Show as SOP import SOPBench.Roundtrip data S2 (tag :: Mode) = S2_0 | S2_1 s2 :: S2 tag s2 = S2_1 data S20 (tag :: Mode) = S20_00 | S20_01 | S20_02 | S20_03 | S20_04 | S20_05 | S20_06 | S20_07 | S20_08 | S20_09 | S20_10 | S20_11 | S20_12 | S20_13 | S20_14 | S20_15 | S20_16 | S20_17 | S20_18 | S20_19 s20 :: S20 tag s20 = S20_17 data PB2 (tag :: Mode) = PB2 Bool Bool pb2 :: PB2 tag pb2 = PB2 True False data Tree (tag :: Mode) = Leaf Int | Node (Tree tag) (Tree tag) tree :: Tree tag tree = Node (Node (Leaf 1) (Leaf 2)) (Node (Leaf 3) (Leaf 4)) tree_medium :: Tree tag tree_medium = Node (Node tree (Node tree tree)) (Node (Node tree tree) tree) tree_large :: Tree tag tree_large = Node (Node tree_medium (Node tree_medium tree_medium)) (Node (Node tree_medium tree_medium) tree_medium) data Prop (tag :: Mode) = Var String | T | F | Not (Prop tag) | And (Prop tag) (Prop tag) | Or (Prop tag) (Prop tag) data Mode = Handwritten | GHCDeriving | GHCGeneric | SOPGGP | SOPTH -- NFData is used for forcing benchmark results, so we -- derive it by hand for all variants of the datatype rnfS2 :: S2 tag -> () rnfS2 S2_0 = () rnfS2 S2_1 = () instance NFData (S2 'GHCDeriving) where rnf = rnfS2 instance NFData (S2 'GHCGeneric ) where rnf = rnfS2 instance NFData (S2 'SOPGGP ) where rnf = rnfS2 instance NFData (S2 'SOPTH ) where rnf = rnfS2 rnfS20 :: S20 tag -> () rnfS20 S20_00 = () rnfS20 S20_01 = () rnfS20 S20_02 = () rnfS20 S20_03 = () rnfS20 S20_04 = () rnfS20 S20_05 = () rnfS20 S20_06 = () rnfS20 S20_07 = () rnfS20 S20_08 = () rnfS20 S20_09 = () rnfS20 S20_10 = () rnfS20 S20_11 = () rnfS20 S20_12 = () rnfS20 S20_13 = () rnfS20 S20_14 = () rnfS20 S20_15 = () rnfS20 S20_16 = () rnfS20 S20_17 = () rnfS20 S20_18 = () rnfS20 S20_19 = () instance NFData (S20 'GHCDeriving) where rnf = rnfS20 instance NFData (S20 'GHCGeneric ) where rnf = rnfS20 instance NFData (S20 'SOPGGP ) where rnf = rnfS20 instance NFData (S20 'SOPTH ) where rnf = rnfS20 rnfPB2 :: PB2 tag -> () rnfPB2 (PB2 b0 b1) = rnf b0 `seq` rnf b1 instance NFData (PB2 'GHCDeriving) where rnf = rnfPB2 instance NFData (PB2 'GHCGeneric ) where rnf = rnfPB2 instance NFData (PB2 'SOPGGP ) where rnf = rnfPB2 instance NFData (PB2 'SOPTH ) where rnf = rnfPB2 deriving instance Eq (S2 'GHCDeriving) deriving instance Show (S2 'GHCDeriving) deriving instance GHC.Generic (S2 'GHCGeneric) deriving instance GHC.Generic (S2 'SOPGGP) instance SOP.Generic (S2 'SOPGGP) instance SOP.HasDatatypeInfo (S2 'SOPGGP) deriveGenericSubst ''S2 (const (promotedT 'SOPTH)) instance Roundtrip (S2 'GHCGeneric) where roundtrip = ghcroundtrip instance Roundtrip (S2 'SOPGGP) where roundtrip = soproundtrip instance Roundtrip (S2 'SOPTH) where roundtrip = soproundtrip instance Eq (S2 'SOPGGP) where (==) = SOP.geq instance Eq (S2 'SOPTH) where (==) = SOP.geq instance Show (S2 'SOPGGP) where showsPrec = SOP.gshowsPrec instance Show (S2 'SOPTH) where showsPrec = SOP.gshowsPrec deriveGenericSubst ''S20 (const (promotedT 'SOPTH)) instance Roundtrip (S20 'GHCGeneric) where roundtrip = ghcroundtrip instance Roundtrip (S20 'SOPGGP) where roundtrip = soproundtrip instance Roundtrip (S20 'SOPTH) where roundtrip = soproundtrip deriving instance Eq (S20 'GHCDeriving) deriving instance Show (S20 'GHCDeriving) deriving instance GHC.Generic (S20 'GHCGeneric) deriving instance GHC.Generic (S20 'SOPGGP) instance SOP.Generic (S20 'SOPGGP) instance SOP.HasDatatypeInfo (S20 'SOPGGP) instance Eq (S20 'SOPGGP) where (==) = SOP.geq instance Eq (S20 'SOPTH) where (==) = SOP.geq instance Show (S20 'SOPGGP) where showsPrec = SOP.gshowsPrec instance Show (S20 'SOPTH) where showsPrec = SOP.gshowsPrec deriveGenericSubst ''PB2 (const (promotedT 'SOPTH)) instance Roundtrip (PB2 'GHCGeneric) where roundtrip = ghcroundtrip instance Roundtrip (PB2 'SOPGGP) where roundtrip = soproundtrip instance Roundtrip (PB2 'SOPTH) where roundtrip = soproundtrip deriving instance Eq (PB2 'GHCDeriving) deriving instance Show (PB2 'GHCDeriving) deriving instance GHC.Generic (PB2 'GHCGeneric) deriving instance GHC.Generic (PB2 'SOPGGP) instance SOP.Generic (PB2 'SOPGGP) instance SOP.HasDatatypeInfo (PB2 'SOPGGP) instance Eq (PB2 'SOPGGP) where (==) = SOP.geq instance Eq (PB2 'SOPTH) where (==) = SOP.geq instance Show (PB2 'SOPGGP) where showsPrec = SOP.gshowsPrec instance Show (PB2 'SOPTH) where showsPrec = SOP.gshowsPrec deriving instance Eq (Tree 'GHCDeriving) deriving instance Show (Tree 'GHCDeriving) deriving instance GHC.Generic (Tree 'GHCGeneric) deriving instance GHC.Generic (Tree 'SOPGGP) instance SOP.Generic (Tree 'SOPGGP) instance SOP.HasDatatypeInfo (Tree 'SOPGGP) deriveGenericSubst ''Tree (const (promotedT 'SOPTH)) instance Eq (Tree 'SOPGGP) where (==) = SOP.geq instance Eq (Tree 'SOPTH) where (==) = SOP.geq instance Show (Tree 'SOPGGP) where showsPrec = SOP.gshowsPrec instance Show (Tree 'SOPTH) where showsPrec = SOP.gshowsPrec deriving instance Eq (Prop 'GHCDeriving) deriving instance Show (Prop 'GHCDeriving) deriving instance GHC.Generic (Prop 'GHCGeneric) deriving instance GHC.Generic (Prop 'SOPGGP) instance SOP.Generic (Prop 'SOPGGP) instance SOP.HasDatatypeInfo (Prop 'SOPGGP) deriveGenericSubst ''Prop (const (promotedT 'SOPTH)) instance Eq (Prop 'SOPGGP) where (==) = SOP.geq instance Eq (Prop 'SOPTH) where (==) = SOP.geq instance Show (Prop 'SOPGGP) where showsPrec = SOP.gshowsPrec instance Show (Prop 'SOPTH) where showsPrec = SOP.gshowsPrec generics-sop-0.5.1.3/doctest.sh0000644000000000000000000000072707346545000014454 0ustar0000000000000000#!/bin/sh set -ex doctest --preserve-it \ -XCPP \ -XScopedTypeVariables \ -XTypeFamilies \ -XRankNTypes \ -XTypeOperators \ -XGADTs \ -XConstraintKinds \ -XMultiParamTypeClasses \ -XTypeSynonymInstances \ -XFlexibleInstances \ -XFlexibleContexts \ -XDeriveFunctor \ -XDeriveFoldable \ -XDeriveTraversable \ -XDefaultSignatures \ -XKindSignatures \ -XDataKinds \ -XFunctionalDependencies \ -i../sop/src \ $(find src -name '*.hs') generics-sop-0.5.1.3/generics-sop.cabal0000644000000000000000000001310707346545000016031 0ustar0000000000000000name: generics-sop version: 0.5.1.3 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. Datatypes are viewed in a uniform, structured way: the choice between constructors is represented using an n-ary sum, and the arguments of each constructor are represented using an n-ary product. . The module "Generics.SOP" is the main module of this library and contains more detailed documentation. . Since version 0.4.0.0, this package is now based on @@. The core package contains all the functionality of n-ary sums and products, whereas this package provides the datatype-generic programming support on top. . Examples of using this library are provided by the following packages: . * @@ basic examples, . * @@ generic pretty printing, . * @@ generically computed lenses, . * @@ generic JSON conversions. . A detailed description of the ideas behind this library is provided by the paper: . * Edsko de Vries and Andres Löh. . Workshop on Generic Programming (WGP) 2014. . license: BSD3 license-file: LICENSE author: Edsko de Vries , Andres Löh maintainer: andres@well-typed.com category: Generics build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md doctest.sh tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.7, GHC == 9.4.4, GHC == 9.6.1 source-repository head type: git location: https://github.com/well-typed/generics-sop library exposed-modules: Generics.SOP Generics.SOP.GGP Generics.SOP.TH Generics.SOP.Type.Metadata -- exposed via Generics.SOP: Generics.SOP.Instances Generics.SOP.Metadata Generics.SOP.Universe -- re-exported from Data.SOP: Generics.SOP.Dict Generics.SOP.BasicFunctors Generics.SOP.Classes Generics.SOP.Constraint Generics.SOP.NP Generics.SOP.NS Generics.SOP.Sing build-depends: base >= 4.9 && < 4.19, sop-core == 0.5.0.*, template-haskell >= 2.8 && < 2.21, th-abstraction >= 0.4 && < 0.6, ghc-prim >= 0.3 && < 0.11 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall default-extensions: CPP ScopedTypeVariables TypeFamilies RankNTypes TypeOperators GADTs ConstraintKinds MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts DeriveFunctor DeriveFoldable DeriveTraversable DefaultSignatures KindSignatures DataKinds FunctionalDependencies if impl(ghc <8.2) default-extensions: AutoDeriveTypeable -- if impl(ghc >= 8.6) -- default-extensions: NoStarIsType other-extensions: PolyKinds UndecidableInstances TemplateHaskell StandaloneDeriving EmptyCase UndecidableSuperClasses test-suite generics-sop-examples type: exitcode-stdio-1.0 main-is: Example.hs other-modules: HTransExample hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall build-depends: base >= 4.9 && < 5, generics-sop other-extensions: DeriveGeneric EmptyCase TemplateHaskell ConstraintKinds GADTs DataKinds TypeFamilies FlexibleContexts FlexibleInstances PolyKinds DefaultSignatures FunctionalDependencies MultiParamTypeClasses TypeFamilies benchmark generics-sop-bench type: exitcode-stdio-1.0 main-is: SOPBench.hs other-modules: SOPBench.Type SOPBench.Roundtrip SOPBench.Eq SOPBench.Show hs-source-dirs: bench default-language: Haskell2010 ghc-options: -Wall build-depends: base >= 4.6 && < 5, criterion, deepseq, generics-sop, template-haskell generics-sop-0.5.1.3/src/Generics/0000755000000000000000000000000007346545000014773 5ustar0000000000000000generics-sop-0.5.1.3/src/Generics/SOP.hs0000644000000000000000000003030407346545000015770 0ustar0000000000000000{-# LANGUAGE PolyKinds, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | Main module of @generics-sop@ -- -- In most cases, you will probably want to import just this module, -- and possibly "Generics.SOP.TH" if you want to use Template Haskell -- to generate 'Generic' instances for you. -- -- = Generic programming with sums of products -- -- You need this library if you want to define your own generic functions -- in the sum-of-products SOP style. Generic programming in the SOP style -- follows the following idea: -- -- 1. A large class of datatypes can be viewed in a uniform, structured -- way: the choice between constructors is represented using an n-ary -- sum (called 'NS'), and the arguments of each constructor are -- represented using an n-ary product (called 'NP'). -- -- 2. The library captures the notion of a datatype being representable -- in the following way. There is a class 'Generic', which for a given -- datatype @A@, associates the isomorphic SOP representation with -- the original type under the name @'Rep' A@. The class also provides -- functions 'from' and 'to' that convert between @A@ and @'Rep' A@ and -- witness the isomorphism. -- -- 3. Since all 'Rep' types are sums of products, you can define -- functions over them by performing induction on the structure, or -- by using predefined combinators that the library provides. Such -- functions then work for all 'Rep' types. -- -- 4. By combining the conversion functions 'from' and 'to' with the -- function that works on 'Rep' types, we obtain a function that works -- on all types that are in the 'Generic' class. -- -- 5. Most types can very easily be made an instance of 'Generic'. For -- example, if the datatype can be represented using GHC's built-in -- approach to generic programming and has an instance for the -- 'GHC.Generics.Generic' class from module "GHC.Generics", then an -- instance of the SOP 'Generic' can automatically be derived. There -- is also Template Haskell code in "Generics.SOP.TH" that allows to -- auto-generate an instance of 'Generic' for most types. -- -- = Example -- -- == Instantiating a datatype for use with SOP generics -- -- Let's assume we have the datatypes: -- -- > data A = C Bool | D A Int | E (B ()) -- > data B a = F | G a Char Bool -- -- To create 'Generic' instances for @A@ and @B@ via "GHC.Generics", we say -- -- > {-# LANGUAGE DeriveGeneric #-} -- > -- > import qualified GHC.Generics as GHC -- > import Generics.SOP -- > -- > data A = C Bool | D A Int | E (B ()) -- > deriving (Show, GHC.Generic) -- > data B a = F | G a Char Bool -- > deriving (Show, GHC.Generic) -- > -- > instance Generic A -- empty -- > instance Generic (B a) -- empty -- -- Now we can convert between @A@ and @'Rep' A@ (and between @B@ and @'Rep' B@). -- For example, -- -- >>> from (D (C True) 3) :: Rep A -- SOP (S (Z (I (C True) :* I 3 :* Nil))) -- >>> to it :: A -- D (C True) 3 -- -- Note that the transformation is shallow: In @D (C True) 3@, the -- inner value @C True@ of type @A@ is not affected by the -- transformation. -- -- For more details about @'Rep' A@, have a look at the -- "Generics.SOP.Universe" module. -- -- == Defining a generic function -- -- As an example of a generic function, let us define a generic -- version of 'Control.DeepSeq.rnf' from the @deepseq@ package. -- -- The type of 'Control.DeepSeq.rnf' is -- -- @ -- NFData a => a -> () -- @ -- -- and the idea is that for a term @x@ of type @a@ in the -- 'Control.DeepSeq.NFData' class, @rnf x@ forces complete evaluation -- of @x@ (i.e., evaluation to /normal form/), and returns @()@. -- -- We call the generic version of this function @grnf@. A direct -- definition in SOP style, making use of structural recursion on the -- sums and products, looks as follows: -- -- @ -- grnf :: ('Generic' a, 'All2' NFData ('Code' a)) => a -> () -- grnf x = grnfS ('from' x) -- -- grnfS :: ('All2' NFData xss) => 'SOP' 'I' xss -> () -- grnfS ('SOP' ('Z' xs)) = grnfP xs -- grnfS ('SOP' ('S' xss)) = grnfS ('SOP' xss) -- -- grnfP :: ('All' NFData xs) => 'NP' 'I' xs -> () -- grnfP 'Nil' = () -- grnfP ('I' x ':*' xs) = x \`deepseq\` (grnfP xs) -- @ -- -- The @grnf@ function performs the conversion between @a@ and @'Rep' a@ -- by applying 'from' and then applies @grnfS@. The type of @grnf@ -- indicates that @a@ must be in the 'Generic' class so that we can -- apply 'from', and that all the components of @a@ (i.e., all the types -- that occur as constructor arguments) must be in the 'NFData' class -- ('All2'). -- -- The function @grnfS@ traverses the outer sum structure of the -- sum of products (note that @'Rep' a = 'SOP' 'I' ('Code' a)@). It -- encodes which constructor was used to construct the original -- argument of type @a@. Once we've found the constructor in question -- ('Z'), we traverse the arguments of that constructor using @grnfP@. -- -- The function @grnfP@ traverses the product structure of the -- constructor arguments. Each argument is evaluated using the -- 'Control.DeepSeq.deepseq' function from the 'Control.DeepSeq.NFData' -- class. This requires that all components of the product must be -- in the 'NFData' class ('All') and triggers the corresponding -- constraints on the other functions. Once the end of the product -- is reached ('Nil'), we return @()@. -- -- == Defining a generic function using combinators -- -- In many cases, generic functions can be written in a much more -- concise way by avoiding the explicit structural recursion and -- resorting to the powerful combinators provided by this library -- instead. -- -- For example, the @grnf@ function can also be defined as a one-liner -- as follows: -- -- @ -- grnf :: ('Generic' a, 'All2' NFData ('Code' a)) => a -> () -- grnf = 'rnf' . 'hcollapse' . 'hcmap' ('Proxy' :: 'Proxy' NFData) ('mapIK' rnf) . 'from' -- @ -- -- 'mapIK' and friends ('mapII', 'mapKI', etc.) are small helpers for working -- with 'I' and 'K' functors, for example 'mapIK' is defined as -- @'mapIK' f = \\ ('I' x) -> 'K' (f x)@ -- -- The following interaction should provide an idea of the individual -- transformation steps: -- -- >>> let x = G 2.5 'A' False :: B Double -- >>> from x -- SOP (S (Z (I 2.5 :* I 'A' :* I False :* Nil))) -- >>> hcmap (Proxy :: Proxy NFData) (mapIK rnf) it -- SOP (S (Z (K () :* K () :* K () :* Nil))) -- >>> hcollapse it -- [(),(),()] -- >>> rnf it -- () -- -- The 'from' call converts into the structural representation. -- Via 'hcmap', we apply 'rnf' to all the components. The result -- is a sum of products of the same shape, but the components are -- no longer heterogeneous ('I'), but homogeneous (@'K' ()@). A -- homogeneous structure can be collapsed ('hcollapse') into a -- normal Haskell list. Finally, 'rnf' actually forces evaluation -- of this list (and thereby actually drives the evaluation of all -- the previous steps) and produces the final result. -- -- == Using a generic function -- -- We can directly invoke 'grnf' on any type that is an instance of -- class 'Generic'. -- -- >>> grnf (G 2.5 'A' False) -- () -- >>> grnf (G 2.5 undefined False) -- *** Exception: Prelude.undefined -- ... -- -- Note that the type of 'grnf' requires that all components of the -- type are in the 'Control.DeepSeq.NFData' class. For a recursive -- datatype such as @B@, this means that we have to make @A@ -- (and in this case, also @B@) an instance of 'Control.DeepSeq.NFData' -- in order to be able to use the 'grnf' function. But we can use 'grnf' -- to supply the instance definitions: -- -- > instance NFData A where rnf = grnf -- > instance NFData a => NFData (B a) where rnf = grnf -- -- = More examples -- -- The best way to learn about how to define generic functions in the SOP style -- is to look at a few simple examples. Examples are provided by the following -- packages: -- -- * @@ basic examples, -- * @@ generic pretty printing, -- * @@ generically computed lenses, -- * @@ generic JSON conversions. -- -- The generic functions in these packages use a wide variety of the combinators -- that are offered by the library. -- -- = Paper -- -- A detailed description of the ideas behind this library is provided by -- the paper: -- -- * Edsko de Vries and Andres Löh. -- . -- Workshop on Generic Programming (WGP) 2014. -- -- module Generics.SOP ( -- * Codes and interpretations Generic(..) , Rep , IsProductType , ProductCode , productTypeFrom , productTypeTo , IsEnumType , enumTypeFrom , enumTypeTo , IsWrappedType , WrappedCode , wrappedTypeFrom , wrappedTypeTo , IsNewtype , newtypeFrom , newtypeTo -- * n-ary datatypes , NP(..) , NS(..) , SOP(..) , unSOP , POP(..) , unPOP -- * Metadata , DatatypeInfo(..) , moduleName , datatypeName , constructorInfo , ConstructorInfo(..) , constructorName , FieldInfo(..) , fieldName , HasDatatypeInfo(..) , DatatypeName , ModuleName , ConstructorName , FieldName , Associativity(..) , Fixity -- * Combinators -- ** Constructing products , HPure(..) -- ** Destructing products , hd , tl , Projection , projections , shiftProjection -- ** Application , type (-.->)(..) , fn , fn_2 , fn_3 , fn_4 , Prod , HAp(..) -- ** Lifting / mapping , hliftA , hliftA2 , hliftA3 , hcliftA , hcliftA2 , hcliftA3 , hmap , hzipWith , hzipWith3 , hcmap , hczipWith , hczipWith3 -- ** Constructing sums , Injection , injections , shift , shiftInjection , UnProd , HApInjs(..) , apInjs_NP -- deprecated export , apInjs_POP -- deprecated export -- ** Destructing sums , unZ , HIndex(..) , Ejection , ejections , shiftEjection -- ** Dealing with @'All' c@ , hcliftA' , hcliftA2' , hcliftA3' -- ** Comparison , compare_NS , ccompare_NS , compare_SOP , ccompare_SOP -- ** Collapsing , CollapseTo , HCollapse(..) -- ** Folding and sequencing , HTraverse_(..) , hcfoldMap , hcfor_ , HSequence(..) , hsequence , hsequenceK , hctraverse , hcfor -- ** Expanding sums to products , HExpand(..) -- ** Transformation of index lists and coercions , HTrans(..) , hfromI , htoI -- ** Partial operations , fromList -- * Utilities -- ** Basic functors , K(..) , unK , I(..) , unI , (:.:)(..) , unComp -- *** Mapping functions , mapII , mapIK , mapKI , mapKK , mapIII , mapIIK , mapIKI , mapIKK , mapKII , mapKIK , mapKKI , mapKKK -- ** Mapping constraints , All , All2 , cpara_SList , ccase_SList , AllZip , AllZip2 , AllN , AllZipN -- ** Other constraints , Compose , And , Top , LiftedCoercible , SameShapeAs -- ** Singletons , SList(..) , SListI , SListI2 , sList , para_SList , case_SList -- *** Shape of type-level lists , Shape(..) , shape , lengthSList -- ** Re-exports -- Workaround for lack of MIN_TOOL_VERSION macro in Cabal 1.18, see: -- https://github.com/well-typed/generics-sop/issues/3 #ifndef MIN_TOOL_VERSION_haddock #define MIN_TOOL_VERSION_haddock(x,y,z) 0 #endif #if !(defined(__HADDOCK_VERSION__)) || MIN_TOOL_VERSION_haddock(2,14,0) , Proxy(..) -- hidden from old Haddock versions, because it triggers an internal error #endif ) where import Data.Proxy (Proxy(..)) import Generics.SOP.BasicFunctors import Generics.SOP.Classes import Generics.SOP.Constraint import Generics.SOP.Instances () import Generics.SOP.Metadata import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe import Generics.SOP.Sing -- $setup -- -- >>> :set -XDeriveGeneric -- >>> import qualified GHC.Generics as GHC -- >>> import Generics.SOP -- >>> import Control.DeepSeq -- >>> data B a = F | G a Char Bool deriving (Show, GHC.Generic) -- >>> data A = C Bool | D A Int | E (B ()) deriving (Show, GHC.Generic) -- >>> instance Generic A -- empty -- >>> instance Generic (B a) -- empty -- -- >>> let grnf = rnf . hcollapse . hcmap (Proxy :: Proxy NFData) (\ (I x) -> K (rnf x)) . from generics-sop-0.5.1.3/src/Generics/SOP/0000755000000000000000000000000007346545000015434 5ustar0000000000000000generics-sop-0.5.1.3/src/Generics/SOP/BasicFunctors.hs0000644000000000000000000000016007346545000020532 0ustar0000000000000000module Generics.SOP.BasicFunctors ( module Data.SOP.BasicFunctors ) where import Data.SOP.BasicFunctorsgenerics-sop-0.5.1.3/src/Generics/SOP/Classes.hs0000644000000000000000000000013607346545000017365 0ustar0000000000000000module Generics.SOP.Classes ( module Data.SOP.Classes ) where import Data.SOP.Classesgenerics-sop-0.5.1.3/src/Generics/SOP/Constraint.hs0000644000000000000000000000014707346545000020116 0ustar0000000000000000module Generics.SOP.Constraint ( module Data.SOP.Constraint ) where import Data.SOP.Constraintgenerics-sop-0.5.1.3/src/Generics/SOP/Dict.hs0000644000000000000000000000012507346545000016651 0ustar0000000000000000module Generics.SOP.Dict ( module Data.SOP.Dict ) where import Data.SOP.Dictgenerics-sop-0.5.1.3/src/Generics/SOP/GGP.hs0000644000000000000000000002163007346545000016407 0ustar0000000000000000{-# LANGUAGE EmptyCase, PolyKinds, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'. -- -- The technique being used here is described in the following paper: -- -- * José Pedro Magalhães and Andres Löh. -- . -- Practical Aspects of Declarative Languages (PADL) 2014. -- module Generics.SOP.GGP ( GCode , GFrom , GTo , GDatatypeInfo , GDatatypeInfoOf , gfrom , gto , gdatatypeInfo ) where import Data.Proxy (Proxy (..)) import Data.Kind (Type) import GHC.Generics as GHC import Generics.SOP.NP as SOP import Generics.SOP.NS as SOP import Generics.SOP.BasicFunctors as SOP import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.Metadata as SOP type family ToSingleCode (a :: Type -> Type) :: Type type instance ToSingleCode (K1 _i a) = a type family ToProductCode (a :: Type -> Type) (xs :: [Type]) :: [Type] type instance ToProductCode (a :*: b) xs = ToProductCode a (ToProductCode b xs) type instance ToProductCode U1 xs = xs type instance ToProductCode (M1 S _c a) xs = ToSingleCode a ': xs type family ToSumCode (a :: Type -> Type) (xs :: [[Type]]) :: [[Type]] type instance ToSumCode (a :+: b) xs = ToSumCode a (ToSumCode b xs) type instance ToSumCode V1 xs = xs type instance ToSumCode (M1 D _c a) xs = ToSumCode a xs type instance ToSumCode (M1 C _c a) xs = ToProductCode a '[] ': xs data InfoProxy (c :: Meta) (f :: Type -> Type) (x :: Type) = InfoProxy type family ToInfo (a :: Type -> Type) :: SOP.T.DatatypeInfo type instance ToInfo (M1 D (MetaData n m p False) a) = SOP.T.ADT m n (ToSumInfo a '[]) (ToStrictnessInfoss a '[]) type instance ToInfo (M1 D (MetaData n m p True) a) = SOP.T.Newtype m n (ToSingleConstructorInfo a) type family ToStrictnessInfoss (a :: Type -> Type) (xss :: [[SOP.T.StrictnessInfo]]) :: [[SOP.T.StrictnessInfo]] type instance ToStrictnessInfoss (a :+: b) xss = ToStrictnessInfoss a (ToStrictnessInfoss b xss) type instance ToStrictnessInfoss V1 xss = xss type instance ToStrictnessInfoss (M1 C _ a) xss = ToStrictnessInfos a '[] ': xss type family ToStrictnessInfos (a :: Type -> Type) (xs :: [SOP.T.StrictnessInfo]) :: [SOP.T.StrictnessInfo] type instance ToStrictnessInfos (a :*: b) xs = ToStrictnessInfos a (ToStrictnessInfos b xs) type instance ToStrictnessInfos U1 xs = xs type instance ToStrictnessInfos (M1 S s a) xs = ToStrictnessInfo s ': xs type family ToStrictnessInfo (s :: Meta) :: SOP.T.StrictnessInfo type instance ToStrictnessInfo (MetaSel _ su ss ds) = 'SOP.T.StrictnessInfo su ss ds type family ToSumInfo (a :: Type -> Type) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo] type instance ToSumInfo (a :+: b) xs = ToSumInfo a (ToSumInfo b xs) type instance ToSumInfo V1 xs = xs type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs type family ToSingleConstructorInfo (a :: Type -> Type) :: SOP.T.ConstructorInfo type instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) = SOP.T.Constructor n type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) = SOP.T.Infix n assoc fix type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) = SOP.T.Record n (ToProductInfo a '[]) type family ToProductInfo (a :: Type -> Type) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo] type instance ToProductInfo (a :*: b) xs = ToProductInfo a (ToProductInfo b xs) type instance ToProductInfo U1 xs = xs type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs type family ToSingleInfo (a :: Type -> Type) :: SOP.T.FieldInfo type instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n class GFieldInfos (a :: Type -> Type) where gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs) instance (GFieldInfos a, GFieldInfos b) => GFieldInfos (a :*: b) where gFieldInfos _ xs = gFieldInfos (Proxy :: Proxy a) (gFieldInfos (Proxy :: Proxy b) xs) instance GFieldInfos U1 where gFieldInfos _ xs = xs instance (Selector c) => GFieldInfos (M1 S c a) where gFieldInfos _ xs = FieldInfo (selName p) :* xs where p :: InfoProxy c a x p = InfoProxy class GSingleFrom (a :: Type -> Type) where gSingleFrom :: a x -> ToSingleCode a instance GSingleFrom (K1 i a) where gSingleFrom (K1 a) = a class GProductFrom (a :: Type -> Type) where gProductFrom :: a x -> NP I xs -> NP I (ToProductCode a xs) instance (GProductFrom a, GProductFrom b) => GProductFrom (a :*: b) where gProductFrom (a :*: b) xs = gProductFrom a (gProductFrom b xs) instance GProductFrom U1 where gProductFrom U1 xs = xs instance GSingleFrom a => GProductFrom (M1 S c a) where gProductFrom (M1 a) xs = I (gSingleFrom a) :* xs class GSingleTo (a :: Type -> Type) where gSingleTo :: ToSingleCode a -> a x instance GSingleTo (K1 i a) where gSingleTo a = K1 a class GProductTo (a :: Type -> Type) where gProductTo :: NP I (ToProductCode a xs) -> (a x -> NP I xs -> r) -> r instance (GProductTo a, GProductTo b) => GProductTo (a :*: b) where gProductTo xs k = gProductTo xs (\ a ys -> gProductTo ys (\ b zs -> k (a :*: b) zs)) instance GSingleTo a => GProductTo (M1 S c a) where gProductTo (SOP.I a :* xs) k = k (M1 (gSingleTo a)) xs instance GProductTo U1 where gProductTo xs k = k U1 xs -- This can most certainly be simplified class GSumFrom (a :: Type -> Type) where gSumFrom :: a x -> proxy xss -> SOP I (ToSumCode a xss) gSumSkip :: proxy a -> SOP I xss -> SOP I (ToSumCode a xss) instance GSumFrom V1 where gSumFrom x = case x of {} gSumSkip _ xss = xss instance (GSumFrom a, GSumFrom b) => GSumFrom (a :+: b) where gSumFrom (L1 a) xss = gSumFrom a (toSumCodeProxy xss) where toSumCodeProxy :: proxy xss -> Proxy (ToSumCode b xss) toSumCodeProxy _ = Proxy gSumFrom (R1 b) xss = gSumSkip (Proxy :: Proxy a) (gSumFrom b xss) gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) (gSumSkip (Proxy :: Proxy b) xss) instance (GSumFrom a) => GSumFrom (M1 D c a) where gSumFrom (M1 a) xss = gSumFrom a xss gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) xss instance (GProductFrom a) => GSumFrom (M1 C c a) where gSumFrom (M1 a) _ = SOP (Z (gProductFrom a Nil)) gSumSkip _ (SOP xss) = SOP (S xss) class GSumTo (a :: Type -> Type) where gSumTo :: SOP I (ToSumCode a xss) -> (a x -> r) -> (SOP I xss -> r) -> r instance GSumTo V1 where gSumTo x _ k = k x instance (GSumTo a, GSumTo b) => GSumTo (a :+: b) where gSumTo xss s k = gSumTo xss (s . L1) (\ r -> gSumTo r (s . R1) k) instance (GProductTo a) => GSumTo (M1 C c a) where gSumTo (SOP (Z xs)) s _ = s (M1 (gProductTo xs ((\ x Nil -> x) :: a x -> NP I '[] -> a x))) gSumTo (SOP (S xs)) _ k = k (SOP xs) instance (GSumTo a) => GSumTo (M1 D c a) where gSumTo xss s k = gSumTo xss (s . M1) k -- | Compute the SOP code of a datatype. -- -- This requires that 'GHC.Rep' is defined, which in turn requires that -- the type has a 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.Code'. -- For more info, see 'Generics.SOP.Generic'. -- type GCode (a :: Type) = ToSumCode (GHC.Rep a) '[] -- | Constraint for the class that computes 'gfrom'. type GFrom a = GSumFrom (GHC.Rep a) -- | Constraint for the class that computes 'gto'. type GTo a = GSumTo (GHC.Rep a) -- | Constraint for the class that computes 'gdatatypeInfo'. type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a) -- | Compute the datatype info of a datatype. -- -- @since 0.3.0.0 -- type GDatatypeInfoOf (a :: Type) = ToInfo (GHC.Rep a) -- | An automatically computed version of 'Generics.SOP.from'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.from'. -- For more info, see 'Generics.SOP.Generic'. -- gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a) gfrom x = gSumFrom (GHC.from x) (Proxy :: Proxy '[]) -- | An automatically computed version of 'Generics.SOP.to'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.to'. -- For more info, see 'Generics.SOP.Generic'. -- gto :: forall a. (GTo a, GHC.Generic a) => SOP I (GCode a) -> a gto x = GHC.to (gSumTo x id ((\y -> case y of {}) :: SOP I '[] -> (GHC.Rep a) x)) -- | An automatically computed version of 'Generics.SOP.datatypeInfo'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.datatypeInfo'. -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a) gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a)) generics-sop-0.5.1.3/src/Generics/SOP/Instances.hs0000644000000000000000000002434407346545000017726 0ustar0000000000000000{-# LANGUAGE EmptyCase #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | Instances for 'Generic' and 'HasMetadata'. -- -- We define instances for datatypes from @generics-sop@ and -- @base@ that are supported. -- -- (There are only instances defined in this module, so the -- documentation is empty.) -- module Generics.SOP.Instances () where -- GHC versions and base versions: -- -- 7.6.3: 4.6.0.1 -- 7.8.3: 4.7.0.1 -- 7.8.4: 4.7.0.2 -- 7.10.3: 4.8.2.0 -- 8.0.2: 4.9.1.0 -- 8.2.2: 4.10.1.0 -- 8.4.3: 4.11.1.0 -- 8.6.1: 4.12.0.0 import Control.Exception import Data.Char import Data.Complex import Data.Data import Data.Fixed import Data.Functor.Compose -- new import qualified Data.Functor.Const -- new import Data.Functor.Identity -- new import Data.Functor.Product -- new import Data.Functor.Sum -- new import Data.List.NonEmpty -- new import qualified Data.Monoid import Data.Ord import qualified Data.Semigroup -- new import Data.Version import Data.Void -- new import Foreign.C.Error import Foreign.C.Types #if MIN_VERSION_base(4,11,0) import GHC.ByteOrder -- new #endif import GHC.Conc -- new import GHC.ExecutionStack -- new import GHC.Exts -- new -- import GHC.Events -- platform-specific, omitted import GHC.Fingerprint -- new import GHC.Float -- new import qualified GHC.Generics -- new import GHC.IO.Buffer -- new import GHC.IO.Device -- new import GHC.IO.Encoding -- new import GHC.IO.Encoding.Failure -- new import GHC.IO.Exception -- new import GHC.IO.Handle -- new import GHC.RTS.Flags -- new import qualified GHC.Stack -- new import GHC.StaticPtr -- new import GHC.Stats -- new import System.Console.GetOpt import System.IO import Text.Printf import Text.Read.Lex import Generics.SOP.BasicFunctors import Generics.SOP.Classes import Generics.SOP.TH -- Types from Generics.SOP: deriveGeneric ''I deriveGeneric ''K deriveGeneric ''(:.:) deriveGeneric ''(-.->) -- new -- Cannot derive instances for Sing -- Cannot derive instances for Shape -- Cannot derive instances for NP, NS, POP, SOP -- Cannot derive instances for metadata types -- Types from the Prelude: deriveGeneric ''Bool deriveGeneric ''Ordering deriveGeneric ''Maybe deriveGeneric ''Either deriveGeneric ''() deriveGeneric ''(,) -- 2 deriveGeneric ''(,,) deriveGeneric ''(,,,) deriveGeneric ''(,,,,) -- 5 deriveGeneric ''(,,,,,) deriveGeneric ''(,,,,,,) deriveGeneric ''(,,,,,,,) deriveGeneric ''(,,,,,,,,) deriveGeneric ''(,,,,,,,,,) -- 10 deriveGeneric ''(,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,) -- 15 deriveGeneric ''(,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30 deriveGeneric ''[] -- Other types from base: -- From Control.Exception: deriveGeneric ''IOException deriveGeneric ''ArithException deriveGeneric ''ArrayException deriveGeneric ''AssertionFailed deriveGeneric ''AsyncException deriveGeneric ''NonTermination deriveGeneric ''NestedAtomically deriveGeneric ''BlockedIndefinitelyOnMVar deriveGeneric ''BlockedIndefinitelyOnSTM deriveGeneric ''AllocationLimitExceeded -- new deriveGeneric ''Deadlock deriveGeneric ''NoMethodError deriveGeneric ''PatternMatchFail deriveGeneric ''RecConError deriveGeneric ''RecSelError deriveGeneric ''RecUpdError deriveGeneric ''ErrorCall deriveGeneric ''TypeError -- new deriveGeneric ''MaskingState -- From Data.Char: deriveGeneric ''GeneralCategory -- From Data.Complex: deriveGeneric ''Complex -- From Data.Data: deriveGeneric ''DataRep deriveGeneric ''Fixity deriveGeneric ''ConstrRep -- From Data.Fixed: deriveGeneric ''Fixed deriveGeneric ''E0 deriveGeneric ''E1 deriveGeneric ''E2 deriveGeneric ''E3 deriveGeneric ''E6 deriveGeneric ''E9 deriveGeneric ''E12 -- From Data.Functor.Compose deriveGeneric ''Compose -- new -- From Data.Functor.Const deriveGeneric ''Data.Functor.Const.Const -- new -- From Data.Functor.Identity deriveGeneric ''Identity -- new -- From Data.Functor.Product deriveGeneric ''Product -- new -- From Data.Functor.Sum deriveGeneric ''Sum -- new -- From Data.List.NonEmpty deriveGeneric ''NonEmpty -- new -- From Data.Monoid: deriveGeneric ''Data.Monoid.Dual deriveGeneric ''Data.Monoid.Endo deriveGeneric ''Data.Monoid.All deriveGeneric ''Data.Monoid.Any deriveGeneric ''Data.Monoid.Sum deriveGeneric ''Data.Monoid.Product deriveGeneric ''Data.Monoid.First deriveGeneric ''Data.Monoid.Last deriveGeneric ''Data.Monoid.Alt -- new -- From Data.Ord: deriveGeneric ''Down -- From Data.Proxy: deriveGeneric ''Proxy -- From Data.Semigroup: deriveGeneric ''Data.Semigroup.Min -- new deriveGeneric ''Data.Semigroup.Max -- new deriveGeneric ''Data.Semigroup.First -- new deriveGeneric ''Data.Semigroup.Last -- new deriveGeneric ''Data.Semigroup.WrappedMonoid -- new #if !MIN_VERSION_base(4,16,0) deriveGeneric ''Data.Semigroup.Option -- new #endif deriveGeneric ''Data.Semigroup.Arg -- new -- From Data.Version: deriveGeneric ''Version -- From Data.Void: deriveGeneric ''Void -- new -- From Foreign.C.Error: deriveGeneric ''Errno -- From Foreign.C.Types: deriveGeneric ''CChar deriveGeneric ''CSChar deriveGeneric ''CUChar deriveGeneric ''CShort deriveGeneric ''CUShort deriveGeneric ''CInt deriveGeneric ''CUInt deriveGeneric ''CLong deriveGeneric ''CULong deriveGeneric ''CPtrdiff deriveGeneric ''CSize deriveGeneric ''CWchar deriveGeneric ''CSigAtomic deriveGeneric ''CLLong deriveGeneric ''CULLong deriveGeneric ''CIntPtr deriveGeneric ''CUIntPtr deriveGeneric ''CIntMax deriveGeneric ''CUIntMax deriveGeneric ''CClock deriveGeneric ''CTime deriveGeneric ''CUSeconds deriveGeneric ''CSUSeconds deriveGeneric ''CFloat deriveGeneric ''CDouble #if MIN_VERSION_base(4,11,0) -- From GHC.ByteOrder: deriveGeneric ''ByteOrder -- new #endif -- From GHC.Conc: deriveGeneric ''ThreadStatus -- new deriveGeneric ''BlockReason -- new -- From GHC.ExecutionStack: deriveGeneric ''Location -- new deriveGeneric ''SrcLoc -- new -- From GHC.Exts: deriveGeneric ''RuntimeRep -- new deriveGeneric ''VecCount -- new deriveGeneric ''VecElem -- new #if !MIN_VERSION_base(4,15,0) deriveGeneric ''SpecConstrAnnotation -- new #endif -- From GHC.Generics: deriveGeneric ''GHC.Generics.K1 -- new deriveGeneric ''GHC.Generics.U1 -- new deriveGeneric ''GHC.Generics.V1 -- new deriveGeneric ''GHC.Generics.Par1 -- new deriveGeneric ''GHC.Generics.M1 -- new deriveGeneric ''GHC.Generics.R -- new deriveGeneric ''GHC.Generics.S -- new deriveGeneric ''GHC.Generics.D -- new deriveGeneric ''GHC.Generics.C -- new deriveGeneric ''(GHC.Generics.:*:) -- new deriveGeneric ''(GHC.Generics.:+:) -- new deriveGeneric ''(GHC.Generics.:.:) -- new deriveGeneric ''GHC.Generics.Associativity -- new deriveGeneric ''GHC.Generics.DecidedStrictness -- new deriveGeneric ''GHC.Generics.SourceStrictness -- new deriveGeneric ''GHC.Generics.SourceUnpackedness -- new deriveGeneric ''GHC.Generics.Fixity -- new -- From GHC.IO.Buffer: deriveGeneric ''Buffer -- new deriveGeneric ''BufferState -- new -- From GHC.IO.Device: deriveGeneric ''IODeviceType -- new -- From GHC.IO.Encoding: deriveGeneric ''BufferCodec -- new deriveGeneric ''CodingProgress -- new -- From GHC.IO.Encoding.Failure: deriveGeneric ''CodingFailureMode -- new -- From GHC.Fingerprint deriveGeneric ''Fingerprint -- new -- From GHC.Float deriveGeneric ''FFFormat -- new -- From GHC.IO.Exception: #if MIN_VERSION_base(4,11,0) deriveGeneric ''FixIOException -- new deriveGeneric ''IOErrorType -- new #endif -- From GHC.IO.Handle: deriveGeneric ''HandlePosn -- new #if MIN_VERSION_base(4,10,0) deriveGeneric ''LockMode -- new #endif -- From GHC.RTS.Flags: deriveGeneric ''RTSFlags -- new deriveGeneric ''GiveGCStats -- new deriveGeneric ''GCFlags -- new deriveGeneric ''ConcFlags -- new deriveGeneric ''MiscFlags -- new deriveGeneric ''DebugFlags -- new deriveGeneric ''DoCostCentres -- new deriveGeneric ''CCFlags -- new deriveGeneric ''DoHeapProfile -- new deriveGeneric ''ProfFlags -- new deriveGeneric ''DoTrace -- new deriveGeneric ''TraceFlags -- new deriveGeneric ''TickyFlags -- new #if MIN_VERSION_base(4,10,0) deriveGeneric ''ParFlags -- new #endif -- From GHC.Stack: deriveGeneric ''GHC.Stack.SrcLoc -- new deriveGeneric ''GHC.Stack.CallStack -- new -- From GHC.StaticPtr: deriveGeneric ''StaticPtrInfo -- new -- From GHC.Stats: #if MIN_VERSION_base(4,10,0) deriveGeneric ''RTSStats -- new deriveGeneric ''GCDetails -- new #endif #if !MIN_VERSION_base(4,11,0) deriveGeneric ''GCStats -- new #endif -- From System.Console.GetOpt: deriveGeneric ''ArgOrder deriveGeneric ''OptDescr deriveGeneric ''ArgDescr -- From System.Exit: deriveGeneric ''ExitCode -- From System.IO: deriveGeneric ''IOMode deriveGeneric ''BufferMode deriveGeneric ''SeekMode deriveGeneric ''Newline deriveGeneric ''NewlineMode -- From Text.Printf: deriveGeneric ''FieldFormat deriveGeneric ''FormatAdjustment deriveGeneric ''FormatSign deriveGeneric ''FormatParse -- From Text.Read.Lex: deriveGeneric ''Lexeme deriveGeneric ''Number -- Abstract / primitive datatypes (we don't derive Generic for these): -- -- Ratio -- Integer -- ThreadId -- Chan -- MVar -- QSem -- QSemN -- DataType -- Dynamic -- IORef -- TypeRep -- TyCon -- TypeRepKey -- KProxy -- not abstract, but intended for kind-level use -- STRef -- Unique -- ForeignPtr -- CFile -- CFpos -- CJmpBuf -- Pool -- Ptr -- FunPtr -- IntPtr -- WordPtr -- StablePtr -- Char -- Double -- Float -- Int -- Int8 -- Int16 -- Int32 -- Int64 -- Word -- Word8 -- Word16 -- Word32 -- Word64 -- IO -- ST -- (->) -- RealWorld -- Handle -- HandlePosn -- TextEncoding -- StableName -- Weak -- ReadP -- ReadPrec -- STM -- TVar -- Natural -- Event -- EventManager -- CostCentre -- CostCentreStack -- -- Datatypes we cannot currently handle: -- -- SomeException -- SomeAsyncException -- Handler -- Coercion -- (:~:) generics-sop-0.5.1.3/src/Generics/SOP/Metadata.hs0000644000000000000000000001132107346545000017506 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-} -- | Metadata about what a datatype looks like -- -- In @generics-sop@, the metadata is completely independent of the main -- universe. Many generic functions will use this metadata, but other don't, -- and yet others might need completely different metadata. -- -- This module defines a datatype to represent standard metadata, i.e., names -- of the datatype, its constructors, and possibly its record selectors. -- Metadata descriptions are in general GADTs indexed by the code of the -- datatype they're associated with, so matching on the metadata will reveal -- information about the shape of the datatype. -- module Generics.SOP.Metadata ( module Generics.SOP.Metadata -- * re-exports , Associativity(..) , DecidedStrictness(..) , SourceStrictness(..) , SourceUnpackedness(..) ) where import Data.Kind (Type) import GHC.Generics ( Associativity(..) , DecidedStrictness(..) , SourceStrictness(..) , SourceUnpackedness(..) ) import Generics.SOP.Constraint import Generics.SOP.NP -- | Metadata for a datatype. -- -- A value of type @'DatatypeInfo' c@ contains the information about a datatype -- that is not contained in @'Code' c@. This information consists -- primarily of the names of the datatype, its constructors, and possibly its -- record selectors. -- -- The constructor indicates whether the datatype has been declared using @newtype@ -- or not. -- data DatatypeInfo :: [[Type]] -> Type where -- Standard algebraic datatype ADT :: ModuleName -> DatatypeName -> NP ConstructorInfo xss -> POP StrictnessInfo xss -> DatatypeInfo xss -- Newtype Newtype :: ModuleName -> DatatypeName -> ConstructorInfo '[x] -> DatatypeInfo '[ '[x] ] -- | The module name where a datatype is defined. -- -- @since 0.2.3.0 -- moduleName :: DatatypeInfo xss -> ModuleName moduleName (ADT name _ _ _) = name moduleName (Newtype name _ _) = name -- | The name of a datatype (or newtype). -- -- @since 0.2.3.0 -- datatypeName :: DatatypeInfo xss -> DatatypeName datatypeName (ADT _ name _ _) = name datatypeName (Newtype _ name _) = name -- | The constructor info for a datatype (or newtype). -- -- @since 0.2.3.0 -- constructorInfo :: DatatypeInfo xss -> NP ConstructorInfo xss constructorInfo (ADT _ _ cs _) = cs constructorInfo (Newtype _ _ c) = c :* Nil deriving instance ( All (Show `Compose` ConstructorInfo) xs , All (Show `Compose` NP StrictnessInfo) xs ) => Show (DatatypeInfo xs) deriving instance ( All (Eq `Compose` ConstructorInfo) xs , All (Eq `Compose` NP StrictnessInfo) xs ) => Eq (DatatypeInfo xs) deriving instance ( All (Eq `Compose` ConstructorInfo) xs , All (Ord `Compose` ConstructorInfo) xs , All (Eq `Compose` NP StrictnessInfo) xs , All (Ord `Compose` NP StrictnessInfo) xs ) => Ord (DatatypeInfo xs) -- | Metadata for a single constructor. -- -- This is indexed by the product structure of the constructor components. -- data ConstructorInfo :: [Type] -> Type where -- Normal constructor Constructor :: SListI xs => ConstructorName -> ConstructorInfo xs -- Infix constructor Infix :: ConstructorName -> Associativity -> Fixity -> ConstructorInfo '[ x, y ] -- Record constructor Record :: SListI xs => ConstructorName -> NP FieldInfo xs -> ConstructorInfo xs -- | The name of a constructor. -- -- @since 0.2.3.0 -- constructorName :: ConstructorInfo xs -> ConstructorName constructorName (Constructor name) = name constructorName (Infix name _ _) = name constructorName (Record name _) = name deriving instance All (Show `Compose` FieldInfo) xs => Show (ConstructorInfo xs) deriving instance All (Eq `Compose` FieldInfo) xs => Eq (ConstructorInfo xs) deriving instance (All (Eq `Compose` FieldInfo) xs, All (Ord `Compose` FieldInfo) xs) => Ord (ConstructorInfo xs) -- | Metadata for strictness information of a field. -- -- Indexed by the type of the field. -- -- @since 0.4.0.0 -- data StrictnessInfo :: Type -> Type where StrictnessInfo :: SourceUnpackedness -> SourceStrictness -> DecidedStrictness -> StrictnessInfo a deriving (Show, Eq, Ord, Functor) -- | For records, this functor maps the component to its selector name. data FieldInfo :: Type -> Type where FieldInfo :: FieldName -> FieldInfo a deriving (Show, Eq, Ord, Functor) -- | The name of a field. -- -- @since 0.2.3.0 -- fieldName :: FieldInfo a -> FieldName fieldName (FieldInfo n) = n -- | The name of a datatype. type DatatypeName = String -- | The name of a module. type ModuleName = String -- | The name of a data constructor. type ConstructorName = String -- | The name of a field / record selector. type FieldName = String -- | The fixity of an infix constructor. type Fixity = Int generics-sop-0.5.1.3/src/Generics/SOP/NP.hs0000644000000000000000000000011707346545000016304 0ustar0000000000000000module Generics.SOP.NP ( module Data.SOP.NP ) where import Data.SOP.NPgenerics-sop-0.5.1.3/src/Generics/SOP/NS.hs0000644000000000000000000000011707346545000016307 0ustar0000000000000000module Generics.SOP.NS ( module Data.SOP.NS ) where import Data.SOP.NSgenerics-sop-0.5.1.3/src/Generics/SOP/Sing.hs0000644000000000000000000000012507346545000016666 0ustar0000000000000000module Generics.SOP.Sing ( module Data.SOP.Sing ) where import Data.SOP.Singgenerics-sop-0.5.1.3/src/Generics/SOP/TH.hs0000644000000000000000000005576707346545000016327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -- | Generate @generics-sop@ boilerplate instances using Template Haskell. module Generics.SOP.TH ( deriveGeneric , deriveGenericOnly , deriveGenericSubst , deriveGenericOnlySubst , deriveGenericFunctions , deriveMetadataValue , deriveMetadataType ) where import Control.Monad (join, replicateM, unless) import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Proxy -- importing in this order to avoid unused import warning import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH import Language.Haskell.TH.Datatype as TH import Generics.SOP.BasicFunctors import qualified Generics.SOP.Metadata as SOP import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe -- | Generate @generics-sop@ boilerplate for the given datatype. -- -- This function takes the name of a datatype and generates: -- -- * a 'Code' instance -- * a 'Generic' instance -- * a 'HasDatatypeInfo' instance -- -- Note that the generated code will require the @TypeFamilies@ and -- @DataKinds@ extensions to be enabled for the module. -- -- /Example:/ If you have the datatype -- -- > data Tree = Leaf Int | Node Tree Tree -- -- and say -- -- > deriveGeneric ''Tree -- -- then you get code that is equivalent to: -- -- > instance Generic Tree where -- > -- > type Code Tree = '[ '[Int], '[Tree, Tree] ] -- > -- > from (Leaf x) = SOP ( Z (I x :* Nil)) -- > from (Node l r) = SOP (S (Z (I l :* I r :* Nil))) -- > -- > to (SOP (Z (I x :* Nil))) = Leaf x -- > to (SOP (S (Z (I l :* I r :* Nil)))) = Node l r -- > to (SOP (S (S x))) = x `seq` error "inaccessible" -- > -- > instance HasDatatypeInfo Tree where -- > type DatatypeInfoOf Tree = -- > T.ADT "Main" "Tree" -- > '[ T.Constructor "Leaf", T.Constructor "Node" ] -- > -- > datatypeInfo _ = -- > T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree)) -- -- /Limitations:/ Generation does not work for GADTs, for -- datatypes that involve existential quantification, for -- datatypes with unboxed fields. -- deriveGeneric :: Name -> Q [Dec] deriveGeneric n = deriveGenericSubst n varT -- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance. deriveGenericOnly :: Name -> Q [Dec] deriveGenericOnly n = deriveGenericOnlySubst n varT -- | Variant of 'deriveGeneric' that allows to restrict the type parameters. -- -- Experimental function, exposed primarily for benchmarking. -- deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec] deriveGenericSubst n f = do dec <- reifyDatatype n ds1 <- withDataDec dec (deriveGenericForDataDec f) ds2 <- withDataDec dec (deriveMetadataForDataDec f) return (ds1 ++ ds2) -- | Variant of 'deriveGenericOnly' that allows to restrict the type parameters. -- -- Experimental function, exposed primarily for benchmarking. -- deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec] deriveGenericOnlySubst n f = do dec <- reifyDatatype n withDataDec dec (deriveGenericForDataDec f) -- | Like 'deriveGenericOnly', but don't derive class instance, only functions. -- -- /Example:/ If you say -- -- > deriveGenericFunctions ''Tree "TreeCode" "fromTree" "toTree" -- -- then you get code that is equivalent to: -- -- > type TreeCode = '[ '[Int], '[Tree, Tree] ] -- > -- > fromTree :: Tree -> SOP I TreeCode -- > fromTree (Leaf x) = SOP ( Z (I x :* Nil)) -- > fromTree (Node l r) = SOP (S (Z (I l :* I r :* Nil))) -- > -- > toTree :: SOP I TreeCode -> Tree -- > toTree (SOP (Z (I x :* Nil))) = Leaf x -- > toTree (SOP (S (Z (I l :* I r :* Nil)))) = Node l r -- > toTree (SOP (S (S x))) = x `seq` error "inaccessible" -- -- @since 0.2 -- deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec] deriveGenericFunctions n codeName fromName toName = do let codeName' = mkName codeName let fromName' = mkName fromName let toName' = mkName toName dec <- reifyDatatype n withDataDec dec $ \_variant _cxt name bndrs instTys cons -> do let codeType = codeFor varT cons -- '[ '[Int], '[Tree, Tree] ] let origType = appTysSubst varT name instTys -- Tree let repType = [t| SOP I $(appTyVars varT codeName' bndrs) |] -- SOP I TreeCode sequence [ tySynD codeName' bndrs codeType -- type TreeCode = '[ '[Int], '[Tree, Tree] ] , sigD fromName' [t| $origType -> $repType |] -- fromTree :: Tree -> SOP I TreeCode , embedding fromName' cons -- fromTree ... = , sigD toName' [t| $repType -> $origType |] -- toTree :: SOP I TreeCode -> Tree , projection toName' cons -- toTree ... = ] -- | Derive @DatatypeInfo@ value for the type. -- -- /Example:/ If you say -- -- > deriveMetadataValue ''Tree "TreeCode" "treeDatatypeInfo" -- -- then you get code that is equivalent to: -- -- > treeDatatypeInfo :: DatatypeInfo TreeCode -- > treeDatatypeInfo = ADT "Main" "Tree" -- > (Constructor "Leaf" :* Constructor "Node" :* Nil) -- -- /Note:/ CodeType needs to be derived with 'deriveGenericFunctions'. -- -- @since 0.2 -- deriveMetadataValue :: Name -> String -> String -> Q [Dec] deriveMetadataValue n codeName datatypeInfoName = do let codeName' = mkName codeName let datatypeInfoName' = mkName datatypeInfoName dec <- reifyDatatype n withDataDec dec $ \variant _cxt name bndrs _instTys cons -> do sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(appTyVars varT codeName' bndrs) |] -- treeDatatypeInfo :: DatatypeInfo TreeCode , funD datatypeInfoName' [clause [] (normalB $ metadata' variant name cons) []] -- treeDatatypeInfo = ... ] {-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-} -- | Derive @DatatypeInfo@ type for the type. -- -- /Example:/ If you say -- -- > deriveMetadataType ''Tree "TreeDatatypeInfo" -- -- then you get code that is equivalent to: -- -- > type TreeDatatypeInfo = -- > T.ADT "Main" "Tree" -- > [ T.Constructor "Leaf", T.Constructor "Node" ] -- -- @since 0.3.0.0 -- deriveMetadataType :: Name -> String -> Q [Dec] deriveMetadataType n datatypeInfoName = do let datatypeInfoName' = mkName datatypeInfoName dec <- reifyDatatype n withDataDec dec $ \ variant _ctx name _bndrs _instTys cons -> sequence [ tySynD datatypeInfoName' [] (metadataType' variant name cons) ] deriveGenericForDataDec :: (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec] deriveGenericForDataDec f _variant _cxt name _bndrs instTys cons = do let typ = appTysSubst f name instTys deriveGenericForDataType f typ cons deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [TH.ConstructorInfo] -> Q [Dec] deriveGenericForDataType f typ cons = do let codeSyn = tySynInstDCompat ''Generics.SOP.Universe.Code Nothing [typ] (codeFor f cons) inst <- instanceD (cxt []) [t| Generic $typ |] [codeSyn, embedding 'from cons, projection 'to cons] return [inst] deriveMetadataForDataDec :: (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec] deriveMetadataForDataDec f variant _cxt name _bndrs instTys cons = do let typ = appTysSubst f name instTys deriveMetadataForDataType variant name typ cons deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [TH.ConstructorInfo] -> Q [Dec] deriveMetadataForDataType variant name typ cons = do md <- instanceD (cxt []) [t| HasDatatypeInfo $typ |] [ metadataType typ variant name cons , funD 'datatypeInfo [ clause [wildP] (normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |]) [] ] ] -- [metadata variant name cons] return [md] {------------------------------------------------------------------------------- Computing the code for a data type -------------------------------------------------------------------------------} codeFor :: (Name -> Q Type) -> [TH.ConstructorInfo] -> Q Type codeFor f = promotedTypeList . map go where go :: TH.ConstructorInfo -> Q Type go c = do (_, ts) <- conInfo c promotedTypeListSubst f ts {------------------------------------------------------------------------------- Computing the embedding/projection pair -------------------------------------------------------------------------------} embedding :: Name -> [TH.ConstructorInfo] -> Q Dec embedding fromName = funD fromName . go' (\e -> [| Z $e |]) where go' :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause] go' _ [] = (:[]) $ do x <- newName "x" clause [varP x] (normalB (caseE (varE x) [])) [] go' br cs = go br cs go :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause] go _ [] = [] go br (c:cs) = mkClause br c : go (\e -> [| S $(br e) |]) cs mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x") clause [conP n (map varP vars)] (normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |]) [] projection :: Name -> [TH.ConstructorInfo] -> Q Dec projection toName = funD toName . go' where go' :: [TH.ConstructorInfo] -> [Q Clause] go' [] = (:[]) $ do x <- newName "x" clause [varP x] (normalB (caseE (varE x) [])) [] go' cs = go id cs go :: (Q Pat -> Q Pat) -> [TH.ConstructorInfo] -> [Q Clause] go br [] = [mkUnreachableClause br] go br (c:cs) = mkClause br c : go (\p -> conP 'S [br p]) cs -- Generates a final clause of the form: -- -- to (S (... (S x))) = x `seq` error "inaccessible" -- -- An equivalent way of achieving this would be: -- -- to (S (... (S x))) = case x of {} -- -- This, however, would require clients to enable the EmptyCase extension -- in their own code, which is something which we have not previously -- required. Therefore, we do not generate this code at the moment. mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause mkUnreachableClause br = do var <- newName "x" clause [conP 'SOP [br (varP var)]] (normalB [| $(varE var) `seq` error "inaccessible" |]) [] mkClause :: (Q Pat -> Q Pat) -> TH.ConstructorInfo -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x") clause [conP 'SOP [br . conP 'Z . (:[]) . npP . map (\v -> conP 'I [varP v]) $ vars]] (normalB . appsE $ conE n : map varE vars) [] {------------------------------------------------------------------------------- Compute metadata -------------------------------------------------------------------------------} metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec metadataType typ variant typeName cs = tySynInstDCompat ''DatatypeInfoOf Nothing [typ] (metadataType' variant typeName cs) -- | Derive term-level metadata. metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp metadata' dataVariant typeName cs = md where md :: Q Exp md | isNewtypeVariant dataVariant = [| SOP.Newtype $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(mdCon (head cs)) |] | otherwise = [| SOP.ADT $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(npE $ map mdCon cs) $(popE $ map mdStrictness cs) |] mdStrictness :: TH.ConstructorInfo -> Q [Q Exp] mdStrictness ci@(ConstructorInfo { constructorName = n , constructorStrictness = bs }) = checkForGADTs ci $ mdConStrictness n bs mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp] mdConStrictness n bs = do dss <- reifyConStrictness n return (zipWith (\ (FieldStrictness su ss) ds -> [| SOP.StrictnessInfo $(mdTHUnpackedness su) $(mdTHStrictness ss) $(mdDecidedStrictness ds) |]) bs dss) mdCon :: TH.ConstructorInfo -> Q Exp mdCon ci@(ConstructorInfo { constructorName = n , constructorVariant = conVariant }) = checkForGADTs ci $ case conVariant of NormalConstructor -> [| SOP.Constructor $(stringE (nameBase n)) |] RecordConstructor ts -> [| SOP.Record $(stringE (nameBase n)) $(npE (map mdField ts)) |] InfixConstructor -> do fixity <- reifyFixity n case fromMaybe defaultFixity fixity of Fixity f a -> [| SOP.Infix $(stringE (nameBase n)) $(mdAssociativity a) f |] mdField :: Name -> Q Exp mdField n = [| SOP.FieldInfo $(stringE (nameBase n)) |] mdTHUnpackedness :: TH.Unpackedness -> Q Exp mdTHUnpackedness UnspecifiedUnpackedness = [| SOP.NoSourceUnpackedness |] mdTHUnpackedness NoUnpack = [| SOP.SourceNoUnpack |] mdTHUnpackedness Unpack = [| SOP.SourceUnpack |] mdTHStrictness :: TH.Strictness -> Q Exp mdTHStrictness UnspecifiedStrictness = [| SOP.NoSourceStrictness |] mdTHStrictness Lazy = [| SOP.SourceLazy |] mdTHStrictness TH.Strict = [| SOP.SourceStrict |] mdDecidedStrictness :: DecidedStrictness -> Q Exp mdDecidedStrictness DecidedLazy = [| SOP.DecidedLazy |] mdDecidedStrictness DecidedStrict = [| SOP.DecidedStrict |] mdDecidedStrictness DecidedUnpack = [| SOP.DecidedUnpack |] mdAssociativity :: FixityDirection -> Q Exp mdAssociativity InfixL = [| SOP.LeftAssociative |] mdAssociativity InfixR = [| SOP.RightAssociative |] mdAssociativity InfixN = [| SOP.NotAssociative |] -- | Derive type-level metadata. metadataType' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Type metadataType' dataVariant typeName cs = md where md :: Q Type md | isNewtypeVariant dataVariant = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName)) $(stringT (nameBase typeName)) $(mdCon (head cs)) |] | otherwise = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) $(stringT (nameBase typeName)) $(promotedTypeList $ map mdCon cs) $(promotedTypeListOfList $ map mdStrictness cs) |] mdStrictness :: TH.ConstructorInfo -> Q [Q Type] mdStrictness ci@(ConstructorInfo { constructorName = n , constructorStrictness = bs }) = checkForGADTs ci $ mdConStrictness n bs mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type] mdConStrictness n bs = do dss <- reifyConStrictness n return (zipWith (\ (FieldStrictness su ss) ds -> [t| 'SOP.T.StrictnessInfo $(mdTHUnpackedness su) $(mdTHStrictness ss) $(mdDecidedStrictness ds) |]) bs dss) mdCon :: TH.ConstructorInfo -> Q Type mdCon ci@(ConstructorInfo { constructorName = n , constructorVariant = conVariant }) = checkForGADTs ci $ case conVariant of NormalConstructor -> [t| 'SOP.T.Constructor $(stringT (nameBase n)) |] RecordConstructor ts -> [t| 'SOP.T.Record $(stringT (nameBase n)) $(promotedTypeList (map mdField ts)) |] InfixConstructor -> do fixity <- reifyFixity n case fromMaybe defaultFixity fixity of Fixity f a -> [t| 'SOP.T.Infix $(stringT (nameBase n)) $(mdAssociativity a) $(natT f) |] mdField :: Name -> Q Type mdField n = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |] mdTHUnpackedness :: TH.Unpackedness -> Q Type mdTHUnpackedness UnspecifiedUnpackedness = [t| 'SOP.NoSourceUnpackedness |] mdTHUnpackedness NoUnpack = [t| 'SOP.SourceNoUnpack |] mdTHUnpackedness Unpack = [t| 'SOP.SourceUnpack |] mdTHStrictness :: TH.Strictness -> Q Type mdTHStrictness UnspecifiedStrictness = [t| 'SOP.NoSourceStrictness |] mdTHStrictness Lazy = [t| 'SOP.SourceLazy |] mdTHStrictness TH.Strict = [t| 'SOP.SourceStrict |] mdDecidedStrictness :: DecidedStrictness -> Q Type mdDecidedStrictness DecidedLazy = [t| 'SOP.DecidedLazy |] mdDecidedStrictness DecidedStrict = [t| 'SOP.DecidedStrict |] mdDecidedStrictness DecidedUnpack = [t| 'SOP.DecidedUnpack |] mdAssociativity :: FixityDirection -> Q Type mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |] mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |] mdAssociativity InfixN = [t| 'SOP.T.NotAssociative |] nameModule' :: Name -> String nameModule' = fromMaybe "" . nameModule {------------------------------------------------------------------------------- Constructing n-ary pairs -------------------------------------------------------------------------------} -- Given -- -- > [a, b, c] -- -- Construct -- -- > a :* b :* c :* Nil npE :: [Q Exp] -> Q Exp npE [] = [| Nil |] npE (e:es) = [| $e :* $(npE es) |] -- Construct a POP. popE :: [Q [Q Exp]] -> Q Exp popE ess = [| POP $(npE (map (join . fmap npE) ess)) |] -- Like npE, but construct a pattern instead npP :: [Q Pat] -> Q Pat npP [] = conP 'Nil [] npP (p:ps) = conP '(:*) [p, npP ps] {------------------------------------------------------------------------------- Some auxiliary definitions for working with TH -------------------------------------------------------------------------------} conInfo :: TH.ConstructorInfo -> Q (Name, [Q Type]) conInfo ci@(ConstructorInfo { constructorName = n , constructorFields = ts }) = checkForGADTs ci $ return (n, map return ts) stringT :: String -> Q Type stringT = litT . strTyLit natT :: Int -> Q Type natT = litT . numTyLit . fromIntegral promotedTypeList :: [Q Type] -> Q Type promotedTypeList [] = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] promotedTypeListOfList :: [Q [Q Type]] -> Q Type promotedTypeListOfList = promotedTypeList . map (join . fmap promotedTypeList) promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type promotedTypeListSubst _ [] = promotedNilT promotedTypeListSubst f (t:ts) = [t| $promotedConsT $(t >>= substType f) $(promotedTypeListSubst f ts) |] appsT :: Name -> [Q Type] -> Q Type appsT n = foldl' appT (conT n) appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type appTyVars f n bndrs = appsT n (map (f . tvName) bndrs) appTysSubst :: (Name -> Q Type) -> Name -> [Type] -> Q Type appTysSubst f n args = appsT n (map (substType f . unSigType) args) unSigType :: Type -> Type unSigType (SigT t _) = t unSigType t = t substType :: (Name -> Q Type) -> Type -> Q Type substType f = go where go (VarT n) = f n go (AppT t1 t2) = AppT <$> go t1 <*> go t2 go ListT = return ListT go (ConT n) = return (ConT n) go ArrowT = return ArrowT go (TupleT i) = return (TupleT i) go t = return t -- error (show t) -- TODO: This is incorrect, but we only need substitution to work -- in simple cases for now. The reason is that substitution is normally -- the identity, except if we use TH derivation for the tagged datatypes -- in the benchmarking suite. So we can fall back on identity in all -- but the cases we need for the benchmarking suite. -- Process a DatatypeInfo using continuation-passing style. withDataDec :: TH.DatatypeInfo -> (DatatypeVariant -- The variety of data type -- (@data@, @newtype@, @data instance@, or @newtype instance@) -> Cxt -- The datatype context -> Name -- The data type's name -> [TyVarBndrUnit] -- The datatype's type variable binders, both implicit and explicit. -- Examples: -- -- - For `data Maybe a = Nothing | Just a`, the binders are -- [PlainTV a] -- - For `data Proxy (a :: k) = Proxy`, the binders are -- [PlainTV k, KindedTV a (VarT k)] -- - For `data instance DF Int (Maybe b) = DF b`, the binders are -- [PlainTV b] -> [Type] -- For vanilla data types, these are the explicitly bound -- type variable binders, but in Type form. -- For data family instances, these are the type arguments. -- Examples: -- -- - For `data Maybe a = Nothing | Just a`, the types are -- [VarT a] -- - For `data Proxy (a :: k) = Proxy`, the types are -- [SigT (VarT a) (VarT k)] -- - For `data instance DF Int (Maybe b) = DF b`, the binders are -- [ConT ''Int, ConT ''Maybe `AppT` VarT b] -> [TH.ConstructorInfo] -- The data type's constructors -> Q a) -> Q a withDataDec (TH.DatatypeInfo { datatypeContext = ctxt , datatypeName = name , datatypeVars = bndrs , datatypeInstTypes = instTypes , datatypeVariant = variant , datatypeCons = cons }) f = checkForTypeData variant $ f variant ctxt name bndrs instTypes cons checkForTypeData :: DatatypeVariant -> Q a -> Q a checkForTypeData variant q = do case variant of #if MIN_VERSION_th_abstraction(0,5,0) TH.TypeData -> fail $ "`type data` declarations not supported" #endif _ -> return () q checkForGADTs :: TH.ConstructorInfo -> Q a -> Q a checkForGADTs (ConstructorInfo { constructorVars = exVars , constructorContext = exCxt }) q = do unless (null exVars) $ fail "Existentials not supported" unless (null exCxt) $ fail "GADTs not supported" q isNewtypeVariant :: DatatypeVariant -> Bool isNewtypeVariant Datatype = False isNewtypeVariant DataInstance = False isNewtypeVariant Newtype = True isNewtypeVariant NewtypeInstance = True #if MIN_VERSION_th_abstraction(0,5,0) isNewtypeVariant TH.TypeData = False #endif generics-sop-0.5.1.3/src/Generics/SOP/Type/0000755000000000000000000000000007346545000016355 5ustar0000000000000000generics-sop-0.5.1.3/src/Generics/SOP/Type/Metadata.hs0000644000000000000000000002740307346545000020437 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | Type-level metadata -- -- This module provides datatypes (to be used promoted) that can represent the -- metadata of Haskell datatypes on the type level. -- -- We do not reuse the term-level metadata types, because these are GADTs that -- incorporate additional invariants. We could (at least in GHC 8) impose the -- same invariants on the type level as well, but some tests have revealed that -- the resulting type are rather inconvenient to work with. -- -- So we use simple datatypes to represent the type-level metadata, even if -- this means that some invariants are not explicitly captured. -- -- We establish a relation between the term- and type-level versions of the -- metadata by automatically computing the term-level version from the type-level -- version. -- -- As we now have two versions of metadata (term-level and type-level) -- with very similar, yet slightly different datatype definitions, the names -- between the modules clash, and this module is recommended to be imported -- qualified when needed. -- -- The interface exported by this module is still somewhat experimental. -- -- @since 0.3.0.0 -- module Generics.SOP.Type.Metadata ( module Generics.SOP.Type.Metadata -- * re-exports , Associativity(..) ) where #if __GLASGOW_HASKELL__ <802 import Data.Kind (Type) #endif import Data.Proxy (Proxy (..)) import GHC.Generics ( Associativity(..) , DecidedStrictness(..) , SourceStrictness(..) , SourceUnpackedness(..) ) import GHC.Types import GHC.TypeLits import qualified Generics.SOP.Metadata as M import Generics.SOP.NP import Generics.SOP.Sing -- Regarding the CPP in the datatype definitions below: -- -- We cannot promote type synonyms in GHC 7, so we -- use equivalent yet less descriptive definitions -- for the older GHCs. -- | Metadata for a datatype (to be used promoted). -- -- A type of kind @'DatatypeInfo'@ contains meta-information about a datatype -- that is not contained in its code. This information consists -- primarily of the names of the datatype, its constructors, and possibly its -- record selectors. -- -- The constructor indicates whether the datatype has been declared using @newtype@ -- or not. -- -- @since 0.3.0.0 -- data DatatypeInfo = ADT ModuleName DatatypeName [ConstructorInfo] [[StrictnessInfo]] -- ^ Standard algebraic datatype | Newtype ModuleName DatatypeName ConstructorInfo -- ^ Newtype -- | Metadata for a single constructors (to be used promoted). -- -- @since 0.3.0.0 -- data ConstructorInfo = Constructor ConstructorName -- ^ Normal constructor | Infix ConstructorName Associativity Fixity -- ^ Infix constructor | Record ConstructorName [FieldInfo] -- ^ Record constructor -- | Strictness information for a single field (to be used promoted). -- -- @since 0.4.0.0 -- data StrictnessInfo = StrictnessInfo SourceUnpackedness SourceStrictness DecidedStrictness -- | Metadata for a single record field (to be used promoted). -- -- @since 0.3.0.0 -- data FieldInfo = FieldInfo FieldName -- | The name of a datatype. type DatatypeName = Symbol -- | The name of a module. type ModuleName = Symbol -- | The name of a data constructor. type ConstructorName = Symbol -- | The name of a field / record selector. type FieldName = Symbol -- | The fixity of an infix constructor. type Fixity = Nat -- Demotion -- -- The following classes are concerned with computing the -- term-level metadata from the type-level metadata. -- | Class for computing term-level datatype information from -- type-level datatype information. -- -- @since 0.3.0.0 -- class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[Type]]) where -- | Given a proxy of some type-level datatype information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteDatatypeInfo :: proxy x -> M.DatatypeInfo xss instance ( KnownSymbol m , KnownSymbol d , DemoteConstructorInfos cs xss , DemoteStrictnessInfoss sss xss ) => DemoteDatatypeInfo ('ADT m d cs sss) xss where demoteDatatypeInfo _ = M.ADT (symbolVal (Proxy :: Proxy m)) (symbolVal (Proxy :: Proxy d)) (demoteConstructorInfos (Proxy :: Proxy cs)) (POP (demoteStrictnessInfoss (Proxy :: Proxy sss))) instance (KnownSymbol m, KnownSymbol d, DemoteConstructorInfo c '[ x ]) => DemoteDatatypeInfo ('Newtype m d c) '[ '[ x ] ] where demoteDatatypeInfo _ = M.Newtype (symbolVal (Proxy :: Proxy m)) (symbolVal (Proxy :: Proxy d)) (demoteConstructorInfo (Proxy :: Proxy c)) -- | Class for computing term-level constructor information from -- type-level constructor information. -- -- @since 0.3.0.0 -- class DemoteConstructorInfos (cs :: [ConstructorInfo]) (xss :: [[Type]]) where -- | Given a proxy of some type-level constructor information, -- return the corresponding term-level information as a product. -- -- @since 0.3.0.0 -- demoteConstructorInfos :: proxy cs -> NP M.ConstructorInfo xss instance DemoteConstructorInfos '[] '[] where demoteConstructorInfos _ = Nil instance (DemoteConstructorInfo c xs, DemoteConstructorInfos cs xss) => DemoteConstructorInfos (c ': cs) (xs ': xss) where demoteConstructorInfos _ = demoteConstructorInfo (Proxy :: Proxy c) :* demoteConstructorInfos (Proxy :: Proxy cs) -- | Class for computing term-level constructor information from -- type-level constructor information. -- -- @since 0.3.0.0 -- class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [Type]) where -- | Given a proxy of some type-level constructor information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteConstructorInfo :: proxy x -> M.ConstructorInfo xs instance (KnownSymbol s, SListI xs) => DemoteConstructorInfo ('Constructor s) xs where demoteConstructorInfo _ = M.Constructor (symbolVal (Proxy :: Proxy s)) instance (KnownSymbol s, DemoteAssociativity a, KnownNat f) => DemoteConstructorInfo ('Infix s a f) [y, z] where demoteConstructorInfo _ = M.Infix (symbolVal (Proxy :: Proxy s)) (demoteAssociativity (Proxy :: Proxy a)) (fromInteger (natVal (Proxy :: Proxy f))) instance (KnownSymbol s, DemoteFieldInfos fs xs) => DemoteConstructorInfo ('Record s fs) xs where demoteConstructorInfo _ = M.Record (symbolVal (Proxy :: Proxy s)) (demoteFieldInfos (Proxy :: Proxy fs)) class DemoteStrictnessInfoss (sss :: [[StrictnessInfo]]) (xss :: [[Type]]) where demoteStrictnessInfoss :: proxy sss -> NP (NP M.StrictnessInfo) xss instance DemoteStrictnessInfoss '[] '[] where demoteStrictnessInfoss _ = Nil instance (DemoteStrictnessInfos ss xs, DemoteStrictnessInfoss sss xss) => DemoteStrictnessInfoss (ss ': sss) (xs ': xss) where demoteStrictnessInfoss _ = demoteStrictnessInfos (Proxy :: Proxy ss ) :* demoteStrictnessInfoss (Proxy :: Proxy sss) class DemoteStrictnessInfos (ss :: [StrictnessInfo]) (xs :: [Type]) where demoteStrictnessInfos :: proxy ss -> NP M.StrictnessInfo xs instance DemoteStrictnessInfos '[] '[] where demoteStrictnessInfos _ = Nil instance (DemoteStrictnessInfo s x, DemoteStrictnessInfos ss xs) => DemoteStrictnessInfos (s ': ss) (x ': xs) where demoteStrictnessInfos _ = demoteStrictnessInfo (Proxy :: Proxy s ) :* demoteStrictnessInfos (Proxy :: Proxy ss) class DemoteStrictnessInfo (s :: StrictnessInfo) (x :: Type) where demoteStrictnessInfo :: proxy s -> M.StrictnessInfo x instance ( DemoteSourceUnpackedness su , DemoteSourceStrictness ss , DemoteDecidedStrictness ds ) => DemoteStrictnessInfo ('StrictnessInfo su ss ds) x where demoteStrictnessInfo _ = M.StrictnessInfo (demoteSourceUnpackedness (Proxy :: Proxy su)) (demoteSourceStrictness (Proxy :: Proxy ss)) (demoteDecidedStrictness (Proxy :: Proxy ds)) -- | Class for computing term-level field information from -- type-level field information. -- -- @since 0.3.0.0 -- class SListI xs => DemoteFieldInfos (fs :: [FieldInfo]) (xs :: [Type]) where -- | Given a proxy of some type-level field information, -- return the corresponding term-level information as a product. -- -- @since 0.3.0.0 -- demoteFieldInfos :: proxy fs -> NP M.FieldInfo xs instance DemoteFieldInfos '[] '[] where demoteFieldInfos _ = Nil instance (DemoteFieldInfo f x, DemoteFieldInfos fs xs) => DemoteFieldInfos (f ': fs) (x ': xs) where demoteFieldInfos _ = demoteFieldInfo (Proxy :: Proxy f) :* demoteFieldInfos (Proxy :: Proxy fs) -- | Class for computing term-level field information from -- type-level field information. -- -- @since 0.3.0.0 -- class DemoteFieldInfo (x :: FieldInfo) (a :: Type) where -- | Given a proxy of some type-level field information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteFieldInfo :: proxy x -> M.FieldInfo a instance KnownSymbol s => DemoteFieldInfo ('FieldInfo s) a where demoteFieldInfo _ = M.FieldInfo (symbolVal (Proxy :: Proxy s)) -- | Class for computing term-level associativity information -- from type-level associativity information. -- -- @since 0.3.0.0 -- class DemoteAssociativity (a :: Associativity) where -- | Given a proxy of some type-level associativity information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteAssociativity :: proxy a -> M.Associativity instance DemoteAssociativity 'LeftAssociative where demoteAssociativity _ = M.LeftAssociative instance DemoteAssociativity 'RightAssociative where demoteAssociativity _ = M.RightAssociative instance DemoteAssociativity 'NotAssociative where demoteAssociativity _ = M.NotAssociative -- | Class for computing term-level source unpackedness information -- from type-level source unpackedness information. -- -- @since 0.4.0.0 -- class DemoteSourceUnpackedness (a :: SourceUnpackedness) where -- | Given a proxy of some type-level source unpackedness information, -- return the corresponding term-level information. -- -- @since 0.4.0.0 -- demoteSourceUnpackedness :: proxy a -> M.SourceUnpackedness instance DemoteSourceUnpackedness 'NoSourceUnpackedness where demoteSourceUnpackedness _ = M.NoSourceUnpackedness instance DemoteSourceUnpackedness 'SourceNoUnpack where demoteSourceUnpackedness _ = M.SourceNoUnpack instance DemoteSourceUnpackedness 'SourceUnpack where demoteSourceUnpackedness _ = M.SourceUnpack -- | Class for computing term-level source strictness information -- from type-level source strictness information. -- -- @since 0.4.0.0 -- class DemoteSourceStrictness (a :: SourceStrictness) where -- | Given a proxy of some type-level source strictness information, -- return the corresponding term-level information. -- -- @since 0.4.0.0 -- demoteSourceStrictness :: proxy a -> M.SourceStrictness instance DemoteSourceStrictness 'NoSourceStrictness where demoteSourceStrictness _ = M.NoSourceStrictness instance DemoteSourceStrictness 'SourceLazy where demoteSourceStrictness _ = M.SourceLazy instance DemoteSourceStrictness 'SourceStrict where demoteSourceStrictness _ = M.SourceStrict -- | Class for computing term-level decided strictness information -- from type-level decided strictness information. -- -- @since 0.4.0.0 -- class DemoteDecidedStrictness (a :: DecidedStrictness) where -- | Given a proxy of some type-level source strictness information, -- return the corresponding term-level information. -- -- @since 0.4.0.0 -- demoteDecidedStrictness :: proxy a -> M.DecidedStrictness instance DemoteDecidedStrictness 'DecidedLazy where demoteDecidedStrictness _ = M.DecidedLazy instance DemoteDecidedStrictness 'DecidedStrict where demoteDecidedStrictness _ = M.DecidedStrict instance DemoteDecidedStrictness 'DecidedUnpack where demoteDecidedStrictness _ = M.DecidedUnpack generics-sop-0.5.1.3/src/Generics/SOP/Universe.hs0000644000000000000000000001727607346545000017605 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | Codes and interpretations module Generics.SOP.Universe where import Data.Kind (Type) import Data.Coerce (Coercible, coerce) import Data.Proxy import qualified GHC.Generics as GHC import Generics.SOP.BasicFunctors import Generics.SOP.Constraint import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.GGP import Generics.SOP.Metadata import qualified Generics.SOP.Type.Metadata as T -- | The (generic) representation of a datatype. -- -- A datatype is isomorphic to the sum-of-products of its code. -- The isomorphism is witnessed by 'from' and 'to' from the -- 'Generic' class. -- type Rep a = SOP I (Code a) -- | The class of representable datatypes. -- -- The SOP approach to generic programming is based on viewing -- datatypes as a representation ('Rep') built from the sum of -- products of its components. The components of a datatype -- are specified using the 'Code' type family. -- -- The isomorphism between the original Haskell datatype and its -- representation is witnessed by the methods of this class, -- 'from' and 'to'. So for instances of this class, the following -- laws should (in general) hold: -- -- @ -- 'to' '.' 'from' === 'id' :: a -> a -- 'from' '.' 'to' === 'id' :: 'Rep' a -> 'Rep' a -- @ -- -- You typically don't define instances of this class by hand, but -- rather derive the class instance automatically. -- -- /Option 1:/ Derive via the built-in GHC-generics. For this, you -- need to use the @DeriveGeneric@ extension to first derive an -- instance of the 'GHC.Generics.Generic' class from module "GHC.Generics". -- With this, you can then give an empty instance for 'Generic', and -- the default definitions will just work. The pattern looks as -- follows: -- -- @ -- import qualified "GHC.Generics" as GHC -- import "Generics.SOP" -- -- ... -- -- data T = ... deriving (GHC.'GHC.Generics.Generic', ...) -- -- instance 'Generic' T -- empty -- instance 'HasDatatypeInfo' T -- empty, if you want/need metadata -- @ -- -- /Option 2:/ Derive via Template Haskell. For this, you need to -- enable the @TemplateHaskell@ extension. You can then use -- 'Generics.SOP.TH.deriveGeneric' from module "Generics.SOP.TH" -- to have the instance generated for you. The pattern looks as -- follows: -- -- @ -- import "Generics.SOP" -- import "Generics.SOP.TH" -- -- ... -- -- data T = ... -- -- 'Generics.SOP.TH.deriveGeneric' \'\'T -- derives 'HasDatatypeInfo' as well -- @ -- -- /Tradeoffs:/ Whether to use Option 1 or 2 is mainly a matter -- of personal taste. The version based on Template Haskell probably -- has less run-time overhead. -- -- /Non-standard instances:/ -- It is possible to give 'Generic' instances manually that deviate -- from the standard scheme, as long as at least -- -- @ -- 'to' '.' 'from' === 'id' :: a -> a -- @ -- -- still holds. -- class (All SListI (Code a)) => Generic (a :: Type) where -- | The code of a datatype. -- -- This is a list of lists of its components. The outer list contains -- one element per constructor. The inner list contains one element -- per constructor argument (field). -- -- /Example:/ The datatype -- -- > data Tree = Leaf Int | Node Tree Tree -- -- is supposed to have the following code: -- -- > type instance Code (Tree a) = -- > '[ '[ Int ] -- > , '[ Tree, Tree ] -- > ] -- type Code a :: [[Type]] type Code a = GCode a -- | Converts from a value to its structural representation. from :: a -> Rep a default from :: (GFrom a, GHC.Generic a, Rep a ~ SOP I (GCode a)) => a -> Rep a from = gfrom -- | Converts from a structural representation back to the -- original value. to :: Rep a -> a default to :: (GTo a, GHC.Generic a, Rep a ~ SOP I (GCode a)) => Rep a -> a to = gto -- | A class of datatypes that have associated metadata. -- -- It is possible to use the sum-of-products approach to generic programming -- without metadata. If you need metadata in a function, an additional -- constraint on this class is in order. -- -- You typically don't define instances of this class by hand, but -- rather derive the class instance automatically. See the documentation -- of 'Generic' for the options. -- class Generic a => HasDatatypeInfo a where -- | Type-level datatype info type DatatypeInfoOf a :: T.DatatypeInfo type DatatypeInfoOf a = GDatatypeInfoOf a -- | Term-level datatype info; by default, the term-level datatype info is produced -- from the type-level info. -- datatypeInfo :: proxy a -> DatatypeInfo (Code a) default datatypeInfo :: (GDatatypeInfo a, GCode a ~ Code a) => proxy a -> DatatypeInfo (Code a) datatypeInfo = gdatatypeInfo -- | Constraint that captures that a datatype is a product type, -- i.e., a type with a single constructor. -- -- It also gives access to the code for the arguments of that -- constructor. -- -- @since 0.3.1.0 -- type IsProductType (a :: Type) (xs :: [Type]) = (Generic a, Code a ~ '[ xs ]) -- | Direct access to the part of the code that is relevant -- for a product type. -- -- @since 0.4.0.0 -- type ProductCode (a :: Type) = Head (Code a) -- | Convert from a product type to its product representation. -- -- @since 0.4.0.0 -- productTypeFrom :: IsProductType a xs => a -> NP I xs productTypeFrom = unZ . unSOP . from {-# INLINE productTypeFrom #-} -- | Convert a product representation to the original type. -- -- @since 0.4.0.0 -- productTypeTo :: IsProductType a xs => NP I xs -> a productTypeTo = to . SOP . Z {-# INLINE productTypeTo #-} -- | Constraint that captures that a datatype is an enumeration type, -- i.e., none of the constructors have any arguments. -- -- @since 0.3.1.0 -- type IsEnumType (a :: Type) = (Generic a, All ((~) '[]) (Code a)) -- | Convert from an enum type to its sum representation. -- -- @since 0.4.0.0 -- enumTypeFrom :: IsEnumType a => a -> NS (K ()) (Code a) enumTypeFrom = map_NS (const (K ())) . unSOP . from {-# INLINE enumTypeFrom #-} -- | Convert a sum representation to ihe original type. -- enumTypeTo :: IsEnumType a => NS (K ()) (Code a) -> a enumTypeTo = to . SOP . cmap_NS (Proxy :: Proxy ((~) '[])) (const Nil) {-# INLINE enumTypeTo #-} -- | Constraint that captures that a datatype is a single-constructor, -- single-field datatype. This always holds for newtype-defined types, -- but it can also be true for data-defined types. -- -- The constraint also gives access to the type that is wrapped. -- -- @since 0.3.1.0 -- type IsWrappedType (a :: Type) (x :: Type) = (Generic a, Code a ~ '[ '[ x ] ]) -- | Direct access to the part of the code that is relevant -- for wrapped types and newtypes. -- -- @since 0.4.0.0 -- type WrappedCode (a :: Type) = Head (Head (Code a)) -- | Convert from a wrapped type to its inner type. -- -- @since 0.4.0.0 -- wrappedTypeFrom :: IsWrappedType a x => a -> x wrappedTypeFrom = unI . hd . unZ . unSOP . from {-# INLINE wrappedTypeFrom #-} -- | Convert a type to a wrapped type. -- -- @since 0.4.0.0 -- wrappedTypeTo :: IsWrappedType a x => x -> a wrappedTypeTo = to . SOP . Z . (:* Nil) . I {-# INLINE wrappedTypeTo #-} -- | Constraint that captures that a datatype is a newtype. -- This makes use of the fact that newtypes are always coercible -- to the type they wrap, whereas datatypes are not. -- -- @since 0.3.1.0 -- type IsNewtype (a :: Type) (x :: Type) = (IsWrappedType a x, Coercible a x) -- | Convert a newtype to its inner type. -- -- This is a specialised synonym for 'coerce'. -- -- @since 0.4.0.0 -- newtypeFrom :: IsNewtype a x => a -> x newtypeFrom = coerce {-# INLINE newtypeFrom #-} -- | Convert a type to a newtype. -- -- This is a specialised synonym for 'coerce'. -- -- @since 0.4.0.0 -- newtypeTo :: IsNewtype a x => x -> a newtypeTo = coerce {-# INLINE newtypeTo #-} generics-sop-0.5.1.3/test/0000755000000000000000000000000007346545000013424 5ustar0000000000000000generics-sop-0.5.1.3/test/Example.hs0000644000000000000000000001317607346545000015363 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Main (main, toTreeC, toDataFamC) where import qualified GHC.Generics as GHC import Generics.SOP import Generics.SOP.TH import qualified Generics.SOP.Type.Metadata as T import HTransExample -- Generic show, kind of gshow :: (Generic a, All2 Show (Code a)) => a -> String gshow x = gshowS (from x) gshowS :: (All2 Show xss) => SOP I xss -> String gshowS (SOP (Z xs)) = gshowP xs gshowS (SOP (S xss)) = gshowS (SOP xss) gshowP :: (All Show xs) => NP I xs -> String gshowP Nil = "" gshowP (I x :* xs) = show x ++ (gshowP xs) -- Generic enum, kind of class Enumerable a where enum :: [a] genum :: (Generic a, All2 Enumerable (Code a)) => [a] genum = fmap to genumS genumS :: (All SListI xss, All2 Enumerable xss) => [SOP I xss] genumS = concat (fmap apInjs_POP (hsequence (hcpure (Proxy :: Proxy Enumerable) enum))) -- GHC.Generics data Tree = Leaf Int | Node Tree Tree deriving (GHC.Generic) tree :: Tree tree = Node (Leaf 1) (Leaf 2) abc :: ABC abc = B instance Generic Tree instance HasDatatypeInfo Tree data ABC = A | B | C deriving (GHC.Generic) instance Generic ABC instance HasDatatypeInfo ABC data Void deriving (GHC.Generic) instance Generic Void instance HasDatatypeInfo Void data family DataFam a b c data instance DataFam Int (Maybe b) c = DF b c deriving (GHC.Generic) dataFam :: DataFam Int (Maybe Int) Int dataFam = DF 1 2 instance Generic (DataFam Int (Maybe b) c) instance HasDatatypeInfo (DataFam Int (Maybe b) c) instance Show Tree where show = gshow instance Show ABC where show = gshow instance Show Void where show = gshow instance (Show b, Show c) => Show (DataFam Int (Maybe b) c) where show = gshow instance Enumerable ABC where enum = genum instance Enumerable Void where enum = genum -- Template Haskell data TreeB = LeafB Int | NodeB TreeB TreeB treeB :: TreeB treeB = NodeB (LeafB 1) (LeafB 2) deriveGeneric ''TreeB data ABCB = AB | BB | CB abcB :: ABCB abcB = BB deriveGeneric ''ABCB data VoidB deriveGeneric ''VoidB data family DataFamB a b c data instance DataFamB Int (Maybe b) c = DFB b c dataFamB :: DataFamB Int (Maybe Int) Int dataFamB = DFB 1 2 deriveGeneric 'DFB instance Show TreeB where show = gshow instance Show ABCB where show = gshow instance Show VoidB where show = gshow instance (Show b, Show c) => Show (DataFamB Int (Maybe b) c) where show = gshow instance Enumerable ABCB where enum = genum instance Enumerable VoidB where enum = genum -- Orphan approach data TreeC = LeafC Int | NodeC TreeC TreeC treeC :: TreeC treeC = NodeC (LeafC 1) (LeafC 2) data ABCC = AC | BC | CC abcC :: ABCC abcC = BC data VoidC data family DataFamC a b c data instance DataFamC Int (Maybe b) c = DFC b c dataFamC :: DataFamC Int (Maybe Int) Int dataFamC = DFC 1 2 deriveGenericFunctions ''TreeC "TreeCCode" "fromTreeC" "toTreeC" deriveMetadataValue ''TreeC "TreeCCode" "treeDatatypeInfo" deriveMetadataType ''TreeC "TreeDatatypeInfo" deriveGenericFunctions ''ABCC "ABCCCode" "fromABCC" "toABCC" deriveMetadataValue ''ABCC "ABCCCode" "abcDatatypeInfo" deriveMetadataType ''ABCC "ABCDatatypeInfo" deriveGenericFunctions ''VoidC "VoidCCode" "fromVoidC" "toVoidC" deriveMetadataValue ''VoidC "VoidCCode" "voidDatatypeInfo" deriveMetadataType ''VoidC "VoidDatatypeInfo" deriveGenericFunctions 'DFC "DataFamCCode" "fromDataFamC" "toDataFamC" deriveMetadataValue 'DFC "DataFamCCode" "dataFamDatatypeInfo" deriveMetadataType 'DFC "DataFamDatatypeInfo" demotedTreeDatatypeInfo :: DatatypeInfo TreeCCode demotedTreeDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy TreeDatatypeInfo) demotedABCDatatypeInfo :: DatatypeInfo ABCCCode demotedABCDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy ABCDatatypeInfo) demotedVoidDatatypeInfo :: DatatypeInfo VoidCCode demotedVoidDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy VoidDatatypeInfo) demotedDataFamDatatypeInfo :: DatatypeInfo (DataFamCCode b c) demotedDataFamDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy DataFamDatatypeInfo) instance Show TreeC where show x = gshowS (fromTreeC x) instance Show ABCC where show x = gshowS (fromABCC x) instance Show VoidC where show x = gshowS (fromVoidC x) instance (Show b, Show c) => Show (DataFamC Int (Maybe b) c) where show x = gshowS (fromDataFamC x) instance Enumerable ABCC where enum = fmap toABCC genumS instance Enumerable VoidC where enum = fmap toVoidC genumS -- Tests main :: IO () main = do print tree print abc print dataFam print $ (enum :: [ABC]) print $ (enum :: [Void]) print $ datatypeInfo (Proxy :: Proxy Tree) print $ datatypeInfo (Proxy :: Proxy Void) print $ datatypeInfo (Proxy :: Proxy (DataFam Int (Maybe Int) Int)) print treeB print abcB print dataFamB print $ (enum :: [ABCB]) print $ (enum :: [VoidB]) print $ datatypeInfo (Proxy :: Proxy TreeB) print $ datatypeInfo (Proxy :: Proxy VoidB) print $ datatypeInfo (Proxy :: Proxy (DataFamB Int (Maybe Int) Int)) print treeC print abcC print dataFamC print $ (enum :: [ABCC]) print $ (enum :: [VoidC]) print treeDatatypeInfo print demotedTreeDatatypeInfo print demotedDataFamDatatypeInfo print (treeDatatypeInfo == demotedTreeDatatypeInfo) print (abcDatatypeInfo == demotedABCDatatypeInfo) print (voidDatatypeInfo == demotedVoidDatatypeInfo) print (dataFamDatatypeInfo == demotedDataFamDatatypeInfo) print $ convertFull tree generics-sop-0.5.1.3/test/HTransExample.hs0000644000000000000000000000164507346545000016501 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module HTransExample where import Generics.SOP class IsTupleTypeOf xs y | xs -> y where toTuple :: NP I xs -> y default toTuple :: (Generic y, Code y ~ '[ xs ]) => NP I xs -> y toTuple = to . SOP . Z instance IsTupleTypeOf '[] () instance IsTupleTypeOf '[x1] x1 where toTuple = unI . hd instance IsTupleTypeOf '[x1, x2] (x1, x2) instance IsTupleTypeOf '[x1, x2, x3] (x1, x2, x3) instance IsTupleTypeOf '[x1, x2, x3, x4] (x1, x2, x3, x4) convert :: (AllZip IsTupleTypeOf xss ys) => NS (NP I) xss -> NS I ys convert = htrans (Proxy :: Proxy IsTupleTypeOf) (I . toTuple) convertFull :: (Generic a, AllZip IsTupleTypeOf (Code a) ys) => a -> NS I ys convertFull = convert . unSOP . from