generics-sop 0.2.5.0 → 0.5.1.4
raw patch · 25 files changed
Files
- CHANGELOG.md +138/−3
- Setup.hs +0/−2
- bench/SOPBench.hs +82/−0
- bench/SOPBench/Eq.hs +20/−0
- bench/SOPBench/Roundtrip.hs +14/−0
- bench/SOPBench/Show.hs +60/−0
- bench/SOPBench/Type.hs +296/−0
- doctest.sh +25/−0
- generics-sop.cabal +61/−26
- src/Generics/SOP.hs +66/−10
- src/Generics/SOP/BasicFunctors.hs +3/−473
- src/Generics/SOP/Classes.hs +3/−520
- src/Generics/SOP/Constraint.hs +3/−145
- src/Generics/SOP/Dict.hs +5/−159
- src/Generics/SOP/GGP.hs +72/−81
- src/Generics/SOP/Instances.hs +208/−24
- src/Generics/SOP/Metadata.hs +56/−14
- src/Generics/SOP/NP.hs +3/−601
- src/Generics/SOP/NS.hs +3/−590
- src/Generics/SOP/Sing.hs +3/−114
- src/Generics/SOP/TH.hs +406/−133
- src/Generics/SOP/Type/Metadata.hs +376/−0
- src/Generics/SOP/Universe.hs +138/−9
- test/Example.hs +172/−2
- test/HTransExample.hs +27/−0
CHANGELOG.md view
@@ -1,3 +1,138 @@+# 0.5.1.4 (2023-10-18)++* Compatibility with GHC-9.8 / th-abstraction-0.6+ (thanks to Ganesh Sittampalam).++# 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.@@ -79,8 +214,8 @@ hcliftA' p = hcliftA (allP p) where- allP :: proxy c -> Proxy (All c)- allP _ = Proxy+ 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@@ -99,7 +234,7 @@ For one-dimensional type-level lists, replace - SingI xs => ... + SingI xs => ... by
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ bench/SOPBench.hs view
@@ -0,0 +1,82 @@+{-# 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 )+ ]+ ]+ ]
+ bench/SOPBench/Eq.hs view
@@ -0,0 +1,20 @@+{-# 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
+ bench/SOPBench/Roundtrip.hs view
@@ -0,0 +1,14 @@+module 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+
+ bench/SOPBench/Show.hs view
@@ -0,0 +1,60 @@+{-# 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
+ bench/SOPBench/Type.hs view
@@ -0,0 +1,296 @@+{-# 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++
+ doctest.sh view
@@ -0,0 +1,25 @@+#!/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.cabal view
@@ -1,5 +1,5 @@ name: generics-sop-version: 0.2.5.0+version: 0.5.1.4 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions.@@ -11,6 +11,11 @@ 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+ @<https://hackage.haskell.org/package/sop-core sop-core>@. 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: .@@ -36,8 +41,8 @@ category: Generics build-type: Simple cabal-version: >=1.10-extra-source-files: CHANGELOG.md-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.*+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, GHC == 9.8.1 source-repository head type: git@@ -47,27 +52,24 @@ exposed-modules: Generics.SOP Generics.SOP.GGP Generics.SOP.TH- Generics.SOP.Dict+ 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.Instances- Generics.SOP.Metadata Generics.SOP.NP Generics.SOP.NS- Generics.SOP.Universe Generics.SOP.Sing- build-depends: base >= 4.6 && < 5,- template-haskell >= 2.8 && < 2.13,- ghc-prim >= 0.3 && < 0.6,- deepseq >= 1.3 && < 1.5- if !impl (ghc >= 7.8)- build-depends: tagged >= 0.7 && < 0.9- if !impl (ghc >= 8.0)- build-depends: transformers-compat >= 0.3 && < 0.6,- transformers >= 0.3 && < 0.6-+ build-depends: base >= 4.9 && < 4.20,+ sop-core == 0.5.0.*,+ template-haskell >= 2.8 && < 2.22,+ th-abstraction >= 0.6 && < 0.7,+ ghc-prim >= 0.3 && < 0.12 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -89,22 +91,55 @@ KindSignatures DataKinds FunctionalDependencies- if impl (ghc >= 7.8)- default-extensions: AutoDeriveTypeable- other-extensions: OverloadedStrings- PolyKinds++ if impl(ghc <8.2)+ default-extensions: AutoDeriveTypeable++ -- if impl(ghc >= 8.6)+ -- default-extensions: NoStarIsType+ other-extensions: PolyKinds UndecidableInstances TemplateHaskell- DeriveGeneric StandaloneDeriving- if impl (ghc < 7.10)- other-extensions: OverlappingInstances+ EmptyCase+ UndecidableSuperClasses -test-suite generic-sop-examples+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.6 && < 5,+ 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
src/Generics/SOP.hs view
@@ -25,7 +25,7 @@ -- witness the isomorphism. -- -- 3. Since all 'Rep' types are sums of products, you can define--- functions over them by performing induction on the structure, of+-- 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. --@@ -145,16 +145,20 @@ -- -- @ -- grnf :: ('Generic' a, 'All2' NFData ('Code' a)) => a -> ()--- grnf = 'rnf' . 'hcollapse' . 'hcliftA' ('Proxy' :: 'Proxy' NFData) (\\ ('I' x) -> 'K' (rnf x)) . 'from'+-- 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)))--- >>> hcliftA (Proxy :: Proxy NFData) (\ (I x) -> K (rnf x)) it+-- >>> hcmap (Proxy :: Proxy NFData) (mapIK rnf) it -- SOP (S (Z (K () :* K () :* K () :* Nil))) -- >>> hcollapse it -- [(),(),()]@@ -162,7 +166,7 @@ -- () -- -- The 'from' call converts into the structural representation.--- Via 'hcliftA', we apply 'rnf' to all the components. The result+-- 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@@ -179,6 +183,7 @@ -- () -- >>> 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@@ -218,6 +223,20 @@ -- * Codes and interpretations Generic(..) , Rep+ , IsProductType+ , ProductCode+ , productTypeFrom+ , productTypeTo+ , IsEnumType+ , enumTypeFrom+ , enumTypeTo+ , IsWrappedType+ , WrappedCode+ , wrappedTypeFrom+ , wrappedTypeTo+ , IsNewtype+ , newtypeFrom+ , newtypeTo -- * n-ary datatypes , NP(..) , NS(..)@@ -283,19 +302,36 @@ -- ** 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(..)- -- ** Sequencing+ -- ** 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@@ -322,21 +358,29 @@ -- ** Mapping constraints , All , All2+ , cpara_SList+ , ccase_SList+ , AllZip+ , AllZip2+ , AllN+ , AllZipN+ -- ** Other constraints , Compose , And , Top- , AllN+ , LiftedCoercible+ , SameShapeAs -- ** Singletons , SList(..)- , SListI(..)+ , SListI , SListI2- , Sing- , SingI(..)+ , sList+ , para_SList+ , case_SList -- *** Shape of type-level lists , Shape(..) , shape , lengthSList- , lengthSing -- ** Re-exports -- Workaround for lack of MIN_TOOL_VERSION macro in Cabal 1.18, see:@@ -362,3 +406,15 @@ 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
src/Generics/SOP/BasicFunctors.hs view
@@ -1,476 +1,6 @@-{-# LANGUAGE PolyKinds, DeriveGeneric #-}--- | Basic functors.------ Definitions of the type-level equivalents of--- 'const', 'id', and ('.'), and a definition of--- the lifted function space.------ These datatypes are generally useful, but in this--- library, they're primarily used as parameters for--- the 'NP', 'NS', 'POP', and 'SOP' types.------ We define own variants of 'Control.Applicative.Const',--- 'Data.Functor.Identity.Identity' and 'Data.Functor.Compose.Compose' for--- various reasons.------ * 'Control.Applicative.Const' and 'Data.Functor.Compose.Compose' become--- kind polymorphic only in @base-4.9.0.0@ (@transformers-0.5.0.0@).------ * Shorter names are convenient, and pattern synonyms aren't--- (yet) powerful enough, particularly exhaustiveness check doesn't work--- properly. See <https://ghc.haskell.org/trac/ghc/ticket/8779>.--- module Generics.SOP.BasicFunctors- ( -- * Basic functors- K(..)- , unK- , I(..)- , unI- , (:.:)(..)- , unComp- -- * Mapping functions- , mapII- , mapIK- , mapKI- , mapKK- , mapIII- , mapIIK- , mapIKI- , mapIKK- , mapKII- , mapKIK- , mapKKI- , mapKKK+ (+ module Data.SOP.BasicFunctors ) where -#if MIN_VERSION_base(4,8,0)-import Data.Monoid ((<>))-#else-import Control.Applicative-import Data.Foldable (Foldable(..))-import Data.Monoid (Monoid, mempty, (<>))-import Data.Traversable (Traversable(..))-#endif-import qualified GHC.Generics as GHC--import Data.Functor.Classes--#if MIN_VERSION_base(4,9,0)-#define LIFTED_CLASSES 1-#else-#if MIN_VERSION_transformers(0,5,0)-#define LIFTED_CLASSES 1-#else-#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)-#define LIFTED_CLASSES 1-#endif-#endif-#endif--import Control.DeepSeq (NFData(..))-#if MIN_VERSION_deepseq(1,4,3)-import Control.DeepSeq (NFData1(..), NFData2(..))-#endif---- * Basic functors---- | The constant type functor.------ Like 'Data.Functor.Constant.Constant', but kind-polymorphic--- in its second argument and with a shorter name.----newtype K (a :: *) (b :: k) = K a-#if MIN_VERSION_base(4,7,0)- deriving (Functor, Foldable, Traversable, GHC.Generic)-#else- deriving (GHC.Generic)--instance Functor (K a) where- fmap _ (K x) = K x--instance Foldable (K a) where- foldr _ z (K _) = z- foldMap _ (K _) = mempty--instance Traversable (K a) where- traverse _ (K x) = pure (K x)-#endif--#ifdef LIFTED_CLASSES--- | @since 0.2.4.0-instance Eq2 K where- liftEq2 eq _ (K x) (K y) = eq x y--- | @since 0.2.4.0-instance Ord2 K where- liftCompare2 comp _ (K x) (K y) = comp x y--- | @since 0.2.4.0-instance Read2 K where- liftReadsPrec2 rp _ _ _ = readsData $- readsUnaryWith rp "K" K--- | @since 0.2.4.0-instance Show2 K where- liftShowsPrec2 sp _ _ _ d (K x) = showsUnaryWith sp "K" d x---- | @since 0.2.4.0-instance (Eq a) => Eq1 (K a) where- liftEq = liftEq2 (==)--- | @since 0.2.4.0-instance (Ord a) => Ord1 (K a) where- liftCompare = liftCompare2 compare--- | @since 0.2.4.0-instance (Read a) => Read1 (K a) where- liftReadsPrec = liftReadsPrec2 readsPrec readList--- | @since 0.2.4.0-instance (Show a) => Show1 (K a) where- liftShowsPrec = liftShowsPrec2 showsPrec showList-#else--- | @since 0.2.4.0-instance (Eq a) => Eq1 (K a) where- eq1 (K x) (K y) = x == y--- | @since 0.2.4.0-instance (Ord a) => Ord1 (K a) where- compare1 (K x) (K y) = compare x y--- | @since 0.2.4.0-instance (Read a) => Read1 (K a) where- readsPrec1 = readsData $ readsUnary "K" K--- | @since 0.2.4.0-instance (Show a) => Show1 (K a) where- showsPrec1 d (K x) = showsUnary "K" d x-#endif---- This have to be implemented manually, K is polykinded.-instance (Eq a) => Eq (K a b) where- K x == K y = x == y-instance (Ord a) => Ord (K a b) where- compare (K x) (K y) = compare x y-#ifdef LIFTED_CLASSES-instance (Read a) => Read (K a b) where- readsPrec = readsData $ readsUnaryWith readsPrec "K" K-instance (Show a) => Show (K a b) where- showsPrec d (K x) = showsUnaryWith showsPrec "K" d x-#else-instance (Read a) => Read (K a b) where- readsPrec = readsData $ readsUnary "K" K-instance (Show a) => Show (K a b) where- showsPrec d (K x) = showsUnary "K" d x-#endif--instance Monoid a => Applicative (K a) where- pure _ = K mempty- K x <*> K y = K (x <> y)---- | Extract the contents of a 'K' value.-unK :: K a b -> a-unK (K x) = x---- | The identity type functor.------ Like 'Data.Functor.Identity.Identity', but with a shorter name.----newtype I (a :: *) = I a-#if MIN_VERSION_base(4,7,0)- deriving (Functor, Foldable, Traversable, GHC.Generic)-#else- deriving (GHC.Generic)--instance Functor I where- fmap f (I x) = I (f x)--instance Foldable I where- foldr f z (I x) = f x z- foldMap f (I x) = f x--instance Traversable I where- traverse f (I x) = fmap I (f x)-#endif--instance Applicative I where- pure = I- I f <*> I x = I (f x)--instance Monad I where- return = I- I x >>= f = f x---#ifdef LIFTED_CLASSES--- | @since 0.2.4.0-instance Eq1 I where- liftEq eq (I x) (I y) = eq x y--- | @since 0.2.4.0-instance Ord1 I where- liftCompare comp (I x) (I y) = comp x y--- | @since 0.2.4.0-instance Read1 I where- liftReadsPrec rp _ = readsData $- readsUnaryWith rp "I" I--- | @since 0.2.4.0-instance Show1 I where- liftShowsPrec sp _ d (I x) = showsUnaryWith sp "I" d x-#else--- | @since 0.2.4.0-instance Eq1 I where- eq1 (I x) (I y) = x == y--- | @since 0.2.4.0-instance Ord1 I where- compare1 (I x) (I y) = compare x y--- | @since 0.2.4.0-instance Read1 I where- readsPrec1 = readsData $ readsUnary "I" I--- | @since 0.2.4.0-instance Show1 I where- showsPrec1 d (I x) = showsUnary "I" d x-#endif--instance (Eq a) => Eq (I a) where (==) = eq1-instance (Ord a) => Ord (I a) where compare = compare1-instance (Read a) => Read (I a) where readsPrec = readsPrec1-instance (Show a) => Show (I a) where showsPrec = showsPrec1---- | Extract the contents of an 'I' value.-unI :: I a -> a-unI (I x) = x---- | Composition of functors.------ Like 'Data.Functor.Compose.Compose', but kind-polymorphic--- and with a shorter name.----newtype (:.:) (f :: l -> *) (g :: k -> l) (p :: k) = Comp (f (g p))- deriving (GHC.Generic)--infixr 7 :.:--instance (Functor f, Functor g) => Functor (f :.: g) where- fmap f (Comp x) = Comp (fmap (fmap f) x)---- | @since 0.2.5.0-instance (Applicative f, Applicative g) => Applicative (f :.: g) where- pure x = Comp (pure (pure x))- Comp f <*> Comp x = Comp ((<*>) <$> f <*> x)---- | @since 0.2.5.0-instance (Foldable f, Foldable g) => Foldable (f :.: g) where- foldMap f (Comp t) = foldMap (foldMap f) t---- | @since 0.2.5.0-instance (Traversable f, Traversable g) => Traversable (f :.: g) where- traverse f (Comp t) = Comp <$> traverse (traverse f) t----- Instances of lifted Prelude classes--#ifdef LIFTED_CLASSES--- | @since 0.2.4.0-instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where- liftEq eq (Comp x) (Comp y) = liftEq (liftEq eq) x y---- | @since 0.2.4.0-instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where- liftCompare comp (Comp x) (Comp y) =- liftCompare (liftCompare comp) x y---- | @since 0.2.4.0-instance (Read1 f, Read1 g) => Read1 (f :.: g) where- liftReadsPrec rp rl = readsData $- readsUnaryWith (liftReadsPrec rp' rl') "Comp" Comp- where- rp' = liftReadsPrec rp rl- rl' = liftReadList rp rl---- | @since 0.2.4.0-instance (Show1 f, Show1 g) => Show1 (f :.: g) where- liftShowsPrec sp sl d (Comp x) =- showsUnaryWith (liftShowsPrec sp' sl') "Comp" d x- where- sp' = liftShowsPrec sp sl- sl' = liftShowList sp sl--instance (Eq1 f, Eq1 g, Eq a) => Eq ((f :.: g) a) where (==) = eq1-instance (Ord1 f, Ord1 g, Ord a) => Ord ((f :.: g) a) where compare = compare1-instance (Read1 f, Read1 g, Read a) => Read ((f :.: g) a) where readsPrec = readsPrec1-instance (Show1 f, Show1 g, Show a) => Show ((f :.: g) a) where showsPrec = showsPrec1-#else--- kludge to get type with the same instances as g a-newtype Apply g a = Apply (g a)--getApply :: Apply g a -> g a-getApply (Apply x) = x--instance (Eq1 g, Eq a) => Eq (Apply g a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 g, Read a) => Read (Apply g a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 g, Show a) => Show (Apply g a) where- showsPrec d (Apply x) = showsPrec1 d x--instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq ((f :.: g) a) where- Comp x == Comp y = eq1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord ((f :.: g) a) where- compare (Comp x) (Comp y) = compare1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Read1 f, Read1 g, Read a) => Read ((f :.: g) a) where- readsPrec = readsData $ readsUnary1 "Comp" (Comp . fmap getApply)--instance (Functor f, Show1 f, Show1 g, Show a) => Show ((f :.: g) a) where- showsPrec d (Comp x) = showsUnary1 "Comp" d (fmap Apply x)---- | @since 0.2.4.0-instance (Functor f, Eq1 f, Eq1 g) => Eq1 (f :.: g) where eq1 = (==)--- | @since 0.2.4.0-instance (Functor f, Ord1 f, Ord1 g) => Ord1 (f :.: g) where- compare1 = compare--- | @since 0.2.4.0-instance (Functor f, Read1 f, Read1 g) => Read1 (f :.: g) where- readsPrec1 = readsPrec--- | @since 0.2.4.0-instance (Functor f, Show1 f, Show1 g) => Show1 (f :.: g) where- showsPrec1 = showsPrec-#endif---- NFData Instances---- | @since 0.2.5.0-instance NFData a => NFData (I a) where- rnf (I x) = rnf x---- | @since 0.2.5.0-instance NFData a => NFData (K a b) where- rnf (K x) = rnf x---- | @since 0.2.5.0-instance NFData (f (g a)) => NFData ((f :.: g) a) where- rnf (Comp x) = rnf x--#if MIN_VERSION_deepseq(1,4,3)--- | @since 0.2.5.0-instance NFData1 I where- liftRnf r (I x) = r x---- | @since 0.2.5.0-instance NFData a => NFData1 (K a) where- liftRnf _ (K x) = rnf x---- | @since 0.2.5.0-instance NFData2 K where- liftRnf2 r _ (K x) = r x---- | @since 0.2.5.0-instance (NFData1 f, NFData1 g) => NFData1 (f :.: g) where- liftRnf r (Comp x) = liftRnf (liftRnf r) x-#endif---- | Extract the contents of a 'Comp' value.-unComp :: (f :.: g) p -> f (g p)-unComp (Comp x) = x---- * Mapping functions---- Implementation note:------ All of these functions are just type specializations of--- 'coerce'. However, we currently still support GHC 7.6--- which does not support 'coerce', so we write them--- explicitly.---- | Lift the given function.------ @since 0.2.5.0----mapII :: (a -> b) -> I a -> I b-mapII = \ f (I a) -> I (f a)-{-# INLINE mapII #-}---- | Lift the given function.------ @since 0.2.5.0----mapIK :: (a -> b) -> I a -> K b c-mapIK = \ f (I a) -> K (f a)-{-# INLINE mapIK #-}---- | Lift the given function.------ @since 0.2.5.0----mapKI :: (a -> b) -> K a c -> I b-mapKI = \ f (K a) -> I (f a)-{-# INLINE mapKI #-}---- | Lift the given function.------ @since 0.2.5.0----mapKK :: (a -> b) -> K a c -> K b d-mapKK = \ f (K a) -> K (f a)-{-# INLINE mapKK #-}---- | Lift the given function.------ @since 0.2.5.0----mapIII :: (a -> b -> c) -> I a -> I b -> I c-mapIII = \ f (I a) (I b) -> I (f a b)-{-# INLINE mapIII #-}---- | Lift the given function.------ @since 0.2.5.0----mapIIK :: (a -> b -> c) -> I a -> I b -> K c d-mapIIK = \ f (I a) (I b) -> K (f a b)-{-# INLINE mapIIK #-}---- | Lift the given function.------ @since 0.2.5.0----mapIKI :: (a -> b -> c) -> I a -> K b d -> I c-mapIKI = \ f (I a) (K b) -> I (f a b)-{-# INLINE mapIKI #-}---- | Lift the given function.------ @since 0.2.5.0----mapIKK :: (a -> b -> c) -> I a -> K b d -> K c e-mapIKK = \ f (I a) (K b) -> K (f a b)-{-# INLINE mapIKK #-}---- | Lift the given function.------ @since 0.2.5.0----mapKII :: (a -> b -> c) -> K a d -> I b -> I c-mapKII = \ f (K a) (I b) -> I (f a b)-{-# INLINE mapKII #-}---- | Lift the given function.------ @since 0.2.5.0----mapKIK :: (a -> b -> c) -> K a d -> I b -> K c e-mapKIK = \ f (K a) (I b) -> K (f a b)-{-# INLINE mapKIK #-}---- | Lift the given function.------ @since 0.2.5.0----mapKKI :: (a -> b -> c) -> K a d -> K b e -> I c-mapKKI = \ f (K a) (K b) -> I (f a b)-{-# INLINE mapKKI #-}---- | Lift the given function.------ @since 0.2.5.0----mapKKK :: (a -> b -> c) -> K a d -> K b e -> K c f-mapKKK = \ f (K a) (K b) -> K (f a b)-{-# INLINE mapKKK #-}+import Data.SOP.BasicFunctors
src/Generics/SOP/Classes.hs view
@@ -1,523 +1,6 @@-{-# LANGUAGE PolyKinds #-}--- | Classes for generalized combinators on SOP types.------ In the SOP approach to generic programming, we're predominantly--- concerned with four structured datatypes:------ @--- 'Generics.SOP.NP.NP' :: (k -> *) -> ( [k] -> *) -- n-ary product--- 'Generics.SOP.NS.NS' :: (k -> *) -> ( [k] -> *) -- n-ary sum--- 'Generics.SOP.NP.POP' :: (k -> *) -> ([[k]] -> *) -- product of products--- 'Generics.SOP.NS.SOP' :: (k -> *) -> ([[k]] -> *) -- sum of products--- @------ All of these have a kind that fits the following pattern:------ @--- (k -> *) -> (l -> *)--- @------ These four types support similar interfaces. In order to allow--- reusing the same combinator names for all of these types, we define--- various classes in this module that allow the necessary--- generalization.------ The classes typically lift concepts that exist for kinds @*@ or--- @* -> *@ to datatypes of kind @(k -> *) -> (l -> *)@. This module--- also derives a number of derived combinators.------ The actual instances are defined in "Generics.SOP.NP" and--- "Generics.SOP.NS".--- module Generics.SOP.Classes- ( -- * Generalized applicative functor structure- -- ** Generalized 'Control.Applicative.pure'- HPure(..)- -- ** Generalized 'Control.Applicative.<*>'- , type (-.->)(..)- , fn- , fn_2- , fn_3- , fn_4- , Prod- , HAp(..)- -- ** Derived functions- , hliftA- , hliftA2- , hliftA3- , hmap- , hzipWith- , hzipWith3- , hcliftA- , hcliftA2- , hcliftA3- , hcmap- , hczipWith- , hczipWith3- -- * Collapsing homogeneous structures- , CollapseTo- , HCollapse(..)- -- * Sequencing effects- , HSequence(..)- -- ** Derived functions- , hsequence- , hsequenceK- -- * Indexing into sums- , HIndex(..)- -- * Applying all injections- , UnProd- , HApInjs(..)- -- * Expanding sums to products- , HExpand(..)+ (+ module Data.SOP.Classes ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative (Applicative)-#endif--import Generics.SOP.BasicFunctors-import Generics.SOP.Constraint---- * Generalized applicative functor structure---- ** Generalized 'Control.Applicative.pure'---- | A generalization of 'Control.Applicative.pure' or--- 'Control.Monad.return' to higher kinds.-class HPure (h :: (k -> *) -> (l -> *)) where- -- | Corresponds to 'Control.Applicative.pure' directly.- --- -- /Instances:/- --- -- @- -- 'hpure', 'Generics.SOP.NP.pure_NP' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a) -> 'Generics.SOP.NP.NP' f xs- -- 'hpure', 'Generics.SOP.NP.pure_POP' :: 'SListI2' xss => (forall a. f a) -> 'Generics.SOP.NP.POP' f xss- -- @- --- hpure :: SListIN h xs => (forall a. f a) -> h f xs-- -- | A variant of 'hpure' that allows passing in a constrained- -- argument.- --- -- Calling @'hcpure' f s@ where @s :: h f xs@ causes @f@ to be- -- applied at all the types that are contained in @xs@. Therefore,- -- the constraint @c@ has to be satisfied for all elements of @xs@,- -- which is what @'AllMap' h c xs@ states.- --- -- Morally, 'hpure' is a special case of 'hcpure' where the- -- constraint is empty. However, it is in the nature of how 'AllMap'- -- is defined as well as current GHC limitations that it is tricky- -- to prove to GHC in general that @'AllMap' h c NoConstraint xs@ is- -- always satisfied. Therefore, we typically define 'hpure'- -- separately and directly, and make it a member of the class.- --- -- /Instances:/- --- -- @- -- 'hcpure', 'Generics.SOP.NP.cpure_NP' :: ('All' c xs ) => proxy c -> (forall a. c a => f a) -> 'Generics.SOP.NP.NP' f xs- -- 'hcpure', 'Generics.SOP.NP.cpure_POP' :: ('All2' c xss) => proxy c -> (forall a. c a => f a) -> 'Generics.SOP.NP.POP' f xss- -- @- --- hcpure :: (AllN h c xs) => proxy c -> (forall a. c a => f a) -> h f xs---- ** Generalized 'Control.Applicative.<*>'---- | Lifted functions.-newtype (f -.-> g) a = Fn { apFn :: f a -> g a }-infixr 1 -.->---- | Construct a lifted function.------ Same as 'Fn'. Only available for uniformity with the--- higher-arity versions.----fn :: (f a -> f' a) -> (f -.-> f') a---- | Construct a binary lifted function.-fn_2 :: (f a -> f' a -> f'' a) -> (f -.-> f' -.-> f'') a---- | Construct a ternary lifted function.-fn_3 :: (f a -> f' a -> f'' a -> f''' a) -> (f -.-> f' -.-> f'' -.-> f''') a---- | Construct a quarternary lifted function.-fn_4 :: (f a -> f' a -> f'' a -> f''' a -> f'''' a) -> (f -.-> f' -.-> f'' -.-> f''' -.-> f'''') a--fn f = Fn $ \x -> f x-fn_2 f = Fn $ \x -> Fn $ \x' -> f x x'-fn_3 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> f x x' x''-fn_4 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> Fn $ \x''' -> f x x' x'' x'''---- | Maps a structure containing sums to the corresponding--- product structure.-type family Prod (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *)---- | A generalization of 'Control.Applicative.<*>'.-class (Prod (Prod h) ~ Prod h, HPure (Prod h)) => HAp (h :: (k -> *) -> (l -> *)) where-- -- | Corresponds to 'Control.Applicative.<*>'.- --- -- For products ('Generics.SOP.NP.NP') as well as products of products- -- ('Generics.SOP.NP.POP'), the correspondence is rather direct. We combine- -- a structure containing (lifted) functions and a compatible structure- -- containing corresponding arguments into a compatible structure- -- containing results.- --- -- The same combinator can also be used to combine a product- -- structure of functions with a sum structure of arguments, which then- -- results in another sum structure of results. The sum structure- -- determines which part of the product structure will be used.- --- -- /Instances:/- --- -- @- -- 'hap', 'Generics.SOP.NP.ap_NP' :: 'Generics.SOP.NP.NP' (f -.-> g) xs -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' g xs- -- 'hap', 'Generics.SOP.NS.ap_NS' :: 'Generics.SOP.NS.NP' (f -.-> g) xs -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NS.NS' g xs- -- 'hap', 'Generics.SOP.NP.ap_POP' :: 'Generics.SOP.NP.POP' (f -.-> g) xss -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' g xss- -- 'hap', 'Generics.SOP.NS.ap_SOP' :: 'Generics.SOP.NS.POP' (f -.-> g) xss -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NS.SOP' g xss- -- @- --- hap :: Prod h (f -.-> g) xs -> h f xs -> h g xs---- ** Derived functions---- | A generalized form of 'Control.Applicative.liftA',--- which in turn is a generalized 'map'.------ Takes a lifted function and applies it to every element of--- a structure while preserving its shape.------ /Specification:/------ @--- 'hliftA' f xs = 'hpure' ('fn' f) \` 'hap' \` xs--- @------ /Instances:/------ @--- 'hliftA', 'Generics.SOP.NP.liftA_NP' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a) -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' f' xs--- 'hliftA', 'Generics.SOP.NS.liftA_NS' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a) -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NS.NS' f' xs--- 'hliftA', 'Generics.SOP.NP.liftA_POP' :: 'SListI2' xss => (forall a. f a -> f' a) -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' f' xss--- 'hliftA', 'Generics.SOP.NS.liftA_SOP' :: 'SListI2' xss => (forall a. f a -> f' a) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NS.SOP' f' xss--- @----hliftA :: (SListIN (Prod h) xs, HAp h) => (forall a. f a -> f' a) -> h f xs -> h f' xs---- | A generalized form of 'Control.Applicative.liftA2',--- which in turn is a generalized 'zipWith'.------ Takes a lifted binary function and uses it to combine two--- structures of equal shape into a single structure.------ It either takes two product structures to a product structure,--- or one product and one sum structure to a sum structure.------ /Specification:/------ @--- 'hliftA2' f xs ys = 'hpure' ('fn_2' f) \` 'hap' \` xs \` 'hap' \` ys--- @------ /Instances:/------ @--- 'hliftA2', 'Generics.SOP.NP.liftA2_NP' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a -> f'' a) -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' f' xs -> 'Generics.SOP.NP.NP' f'' xs--- 'hliftA2', 'Generics.SOP.NS.liftA2_NS' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a -> f'' a) -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NS.NS' f' xs -> 'Generics.SOP.NS.NS' f'' xs--- 'hliftA2', 'Generics.SOP.NP.liftA2_POP' :: 'SListI2' xss => (forall a. f a -> f' a -> f'' a) -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' f' xss -> 'Generics.SOP.NP.POP' f'' xss--- 'hliftA2', 'Generics.SOP.NS.liftA2_SOP' :: 'SListI2' xss => (forall a. f a -> f' a -> f'' a) -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NS.SOP' f' xss -> 'Generics.SOP.NS.SOP' f'' xss--- @----hliftA2 :: (SListIN (Prod h) xs, HAp h, HAp (Prod h)) => (forall a. f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs---- | A generalized form of 'Control.Applicative.liftA3',--- which in turn is a generalized 'zipWith3'.------ Takes a lifted ternary function and uses it to combine three--- structures of equal shape into a single structure.------ It either takes three product structures to a product structure,--- or two product structures and one sum structure to a sum structure.------ /Specification:/------ @--- 'hliftA3' f xs ys zs = 'hpure' ('fn_3' f) \` 'hap' \` xs \` 'hap' \` ys \` 'hap' \` zs--- @------ /Instances:/------ @--- 'hliftA3', 'Generics.SOP.NP.liftA3_NP' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a -> f'' a -> f''' a) -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' f' xs -> 'Generics.SOP.NP.NP' f'' xs -> 'Generics.SOP.NP.NP' f''' xs--- 'hliftA3', 'Generics.SOP.NS.liftA3_NS' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a -> f' a -> f'' a -> f''' a) -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' f' xs -> 'Generics.SOP.NS.NS' f'' xs -> 'Generics.SOP.NS.NS' f''' xs--- 'hliftA3', 'Generics.SOP.NP.liftA3_POP' :: 'SListI2' xss => (forall a. f a -> f' a -> f'' a -> f''' a) -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' f' xss -> 'Generics.SOP.NP.POP' f'' xss -> 'Generics.SOP.NP.POP' f''' xs--- 'hliftA3', 'Generics.SOP.NS.liftA3_SOP' :: 'SListI2' xss => (forall a. f a -> f' a -> f'' a -> f''' a) -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' f' xss -> 'Generics.SOP.NS.SOP' f'' xss -> 'Generics.SOP.NP.SOP' f''' xs--- @----hliftA3 :: (SListIN (Prod h) xs, HAp h, HAp (Prod h)) => (forall a. f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs--hliftA f xs = hpure (fn f) `hap` xs-hliftA2 f xs ys = hpure (fn_2 f) `hap` xs `hap` ys-hliftA3 f xs ys zs = hpure (fn_3 f) `hap` xs `hap` ys `hap` zs---- | Another name for 'hliftA'.------ @since 0.2----hmap :: (SListIN (Prod h) xs, HAp h) => (forall a. f a -> f' a) -> h f xs -> h f' xs---- | Another name for 'hliftA2'.------ @since 0.2----hzipWith :: (SListIN (Prod h) xs, HAp h, HAp (Prod h)) => (forall a. f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs---- | Another name for 'hliftA3'.------ @since 0.2----hzipWith3 :: (SListIN (Prod h) xs, HAp h, HAp (Prod h)) => (forall a. f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs--hmap = hliftA-hzipWith = hliftA2-hzipWith3 = hliftA3---- | Variant of 'hliftA' that takes a constrained function.------ /Specification:/------ @--- 'hcliftA' p f xs = 'hcpure' p ('fn' f) \` 'hap' \` xs--- @----hcliftA :: (AllN (Prod h) c xs, HAp h) => proxy c -> (forall a. c a => f a -> f' a) -> h f xs -> h f' xs---- | Variant of 'hcliftA2' that takes a constrained function.------ /Specification:/------ @--- 'hcliftA2' p f xs ys = 'hcpure' p ('fn_2' f) \` 'hap' \` xs \` 'hap' \` ys--- @----hcliftA2 :: (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall a. c a => f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs---- | Variant of 'hcliftA3' that takes a constrained function.------ /Specification:/------ @--- 'hcliftA3' p f xs ys zs = 'hcpure' p ('fn_3' f) \` 'hap' \` xs \` 'hap' \` ys \` 'hap' \` zs--- @----hcliftA3 :: (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall a. c a => f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs--hcliftA p f xs = hcpure p (fn f) `hap` xs-hcliftA2 p f xs ys = hcpure p (fn_2 f) `hap` xs `hap` ys-hcliftA3 p f xs ys zs = hcpure p (fn_3 f) `hap` xs `hap` ys `hap` zs---- | Another name for 'hcliftA'.------ @since 0.2----hcmap :: (AllN (Prod h) c xs, HAp h) => proxy c -> (forall a. c a => f a -> f' a) -> h f xs -> h f' xs---- | Another name for 'hcliftA2'.------ @since 0.2----hczipWith :: (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall a. c a => f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs---- | Another name for 'hcliftA3'.------ @since 0.2----hczipWith3 :: (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall a. c a => f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs--hcmap = hcliftA-hczipWith = hcliftA2-hczipWith3 = hcliftA3---- * Collapsing homogeneous structures---- | Maps products to lists, and sums to identities.-type family CollapseTo (h :: (k -> *) -> (l -> *)) (x :: *) :: *---- | A class for collapsing a heterogeneous structure into--- a homogeneous one.-class HCollapse (h :: (k -> *) -> (l -> *)) where-- -- | Collapse a heterogeneous structure with homogeneous elements- -- into a homogeneous structure.- --- -- If a heterogeneous structure is instantiated to the constant- -- functor 'K', then it is in fact homogeneous. This function- -- maps such a value to a simpler Haskell datatype reflecting that.- -- An @'NS' ('K' a)@ contains a single @a@, and an @'NP' ('K' a)@ contains- -- a list of @a@s.- --- -- /Instances:/- --- -- @- -- 'hcollapse', 'Generics.SOP.NP.collapse_NP' :: 'Generics.SOP.NP.NP' ('K' a) xs -> [a]- -- 'hcollapse', 'Generics.SOP.NS.collapse_NS' :: 'Generics.SOP.NS.NS' ('K' a) xs -> a- -- 'hcollapse', 'Generics.SOP.NP.collapse_POP' :: 'Generics.SOP.NP.POP' ('K' a) xss -> [[a]]- -- 'hcollapse', 'Generics.SOP.NS.collapse_SOP' :: 'Generics.SOP.NP.SOP' ('K' a) xss -> [a]- -- @- --- hcollapse :: SListIN h xs => h (K a) xs -> CollapseTo h a---- * Sequencing effects---- | A generalization of 'Data.Traversable.sequenceA'.-class HAp h => HSequence (h :: (k -> *) -> (l -> *)) where-- -- | Corresponds to 'Data.Traversable.sequenceA'.- --- -- Lifts an applicative functor out of a structure.- --- -- /Instances:/- --- -- @- -- 'hsequence'', 'Generics.SOP.NP.sequence'_NP' :: ('Generics.SOP.Sing.SListI' xs , 'Applicative' f) => 'Generics.SOP.NP.NP' (f ':.:' g) xs -> f ('Generics.SOP.NP.NP' g xs )- -- 'hsequence'', 'Generics.SOP.NS.sequence'_NS' :: ('Generics.SOP.Sing.SListI' xs , 'Applicative' f) => 'Generics.SOP.NS.NS' (f ':.:' g) xs -> f ('Generics.SOP.NS.NS' g xs )- -- 'hsequence'', 'Generics.SOP.NP.sequence'_POP' :: ('SListI2' xss, 'Applicative' f) => 'Generics.SOP.NP.POP' (f ':.:' g) xss -> f ('Generics.SOP.NP.POP' g xss)- -- 'hsequence'', 'Generics.SOP.NS.sequence'_SOP' :: ('SListI2' xss, 'Applicative' f) => 'Generics.SOP.NS.SOP' (f ':.:' g) xss -> f ('Generics.SOP.NS.SOP' g xss)- -- @- --- hsequence' :: (SListIN h xs, Applicative f) => h (f :.: g) xs -> f (h g xs)---- ** Derived functions---- | Special case of 'hsequence'' where @g = 'I'@.-hsequence :: (SListIN h xs, SListIN (Prod h) xs, HSequence h) => Applicative f => h f xs -> f (h I xs)-hsequence = hsequence' . hliftA (Comp . fmap I)---- | Special case of 'hsequence'' where @g = 'K' a@.-hsequenceK :: (SListIN h xs, SListIN (Prod h) xs, Applicative f, HSequence h) => h (K (f a)) xs -> f (h (K a) xs)-hsequenceK = hsequence' . hliftA (Comp . fmap K . unK)---- * Indexing into sums---- | A class for determining which choice in a sum-like structure--- a value represents.----class HIndex (h :: (k -> *) -> (l -> *)) where-- -- | If 'h' is a sum-like structure representing a choice- -- between @n@ different options, and @x@ is a value of- -- type @h f xs@, then @'hindex' x@ returns a number between- -- @0@ and @n - 1@ representing the index of the choice- -- made by @x@.- --- -- /Instances:/- --- -- @- -- 'hindex', 'Generics.SOP.NS.index_NS' :: 'Generics.SOP.NS.NS' f xs -> Int- -- 'hindex', 'Generics.SOP.NS.index_SOP' :: 'Generics.SOP.NS.SOP' f xs -> Int- -- @- --- -- /Examples:/- --- -- >>> hindex (S (S (Z (I False))))- -- 2- -- >>> hindex (Z (K ()))- -- 0- -- >>> hindex (SOP (S (Z (I True :* I 'x' :* Nil))))- -- 1- --- -- @since 0.2.4.0- --- hindex :: h f xs -> Int---- * Applying all injections---- | Maps a structure containing products to the corresponding--- sum structure.------ @since 0.2.4.0----type family UnProd (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *)---- | A class for applying all injections corresponding to a sum-like--- structure to a table containing suitable arguments.----class (UnProd (Prod h) ~ h) => HApInjs (h :: (k -> *) -> (l -> *)) where-- -- | For a given table (product-like structure), produce a list where- -- each element corresponds to the application of an injection function- -- into the corresponding sum-like structure.- --- -- /Instances:/- --- -- @- -- 'hapInjs', 'Generics.SOP.NS.apInjs_NP' :: 'Generics.SOP.Sing.SListI' xs => 'Generics.SOP.NP.NP' f xs -> ['Generics.SOP.NS.NS' f xs ]- -- 'hapInjs', 'Generics.SOP.NS.apInjs_SOP' :: 'SListI2' xss => 'Generics.SOP.NP.POP' f xs -> ['Generics.SOP.NS.SOP' f xss]- -- @- --- -- /Examples:/- --- -- >>> hapInjs (I 'x' :* I True :* I 2 :* Nil)- -- [Z (I 'x'), S (Z (I True)), S (S (Z (I 2)))]- --- -- >>> hapInjs (POP ((I 'x' :* Nil) :* (I True :* I 2 :* Nil) :* Nil)- -- [SOP (Z (I 'x' :* Nil)), SOP (S (Z (I True :* (I 2 :* Nil))))]- --- -- @since 0.2.4.0- --- hapInjs :: (SListIN h xs) => Prod h f xs -> [h f xs]---- * Expanding sums to products---- | A class for expanding sum structures into corresponding product--- structures, filling in the slots not targeted by the sum with--- default values.------ @since 0.2.5.0----class HExpand (h :: (k -> *) -> (l -> *)) where-- -- | Expand a given sum structure into a corresponding product- -- structure by placing the value contained in the sum into the- -- corresponding position in the product, and using the given- -- default value for all other positions.- --- -- /Instances:/- --- -- @- -- 'hexpand', 'Generics.SOP.NS.expand_NS' :: 'Generics.SOP.Sing.SListI' xs => (forall x . f x) -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NS.NP' f xs- -- 'hexpand', 'Generics.SOP.NS.expand_SOP' :: 'SListI2' xss => (forall x . f x) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NP.POP' f xss- -- @- --- -- /Examples:/- --- -- >>> hexpand Nothing (S (Z (Just 3))) :: NP Maybe '[Char, Int, Bool]- -- Nothing :* Just 3 :* Nothing :* Nil- -- >>> hexpand [] (SOP (S (Z ([1,2] :* "xyz" :* Nil)))) :: POP [] '[ '[Bool], '[Int, Char] ]- -- POP (([] :* Nil) :* ([1,2] :* "xyz" :* Nil) :* Nil)- --- -- @since 0.2.5.0- --- hexpand :: (SListIN (Prod h) xs) => (forall x . f x) -> h f xs -> Prod h f xs-- -- | Variant of 'hexpand' that allows passing a constrained default.- --- -- /Instances:/- --- -- @- -- 'hcexpand', 'Generics.SOP.NS.cexpand_NS' :: 'All' c xs => proxy c -> (forall x . c x => f x) -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NP.NP' f xs- -- 'hcexpand', 'Generics.SOP.NS.cexpand_SOP' :: 'All2' c xss => proxy c -> (forall x . c x => f x) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NP.POP' f xss- -- @- --- -- /Examples:/- --- -- >>> hcexpand (Proxy :: Proxy Bounded) (I minBound) (S (Z (I 20))) :: NP I '[Bool, Int, Ordering]- -- I False :* I 20 :* I LT :* Nil- -- >>> hcexpand (Proxy :: Proxy Num) (I 0) (SOP (S (Z (I 1 :* I 2 :* Nil)))) :: POP I '[ '[Double], '[Int, Int] ]- -- POP ((I 0.0 :* Nil) :* (I 1 :* I 2 :* Nil) :* Nil)- --- -- @since 0.2.5.0- --- hcexpand :: (AllN (Prod h) c xs) => proxy c -> (forall x . c x => f x) -> h f xs -> Prod h f xs---- $setup--- >>> import Generics.SOP+import Data.SOP.Classes
src/Generics/SOP/Constraint.hs view
@@ -1,148 +1,6 @@-{-# LANGUAGE PolyKinds, UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}-#endif-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}--- | Constraints for indexed datatypes.------ This module contains code that helps to specify that all--- elements of an indexed structure must satisfy a particular--- constraint.--- module Generics.SOP.Constraint- ( module Generics.SOP.Constraint- , Constraint+ (+ module Data.SOP.Constraint ) where -import GHC.Exts (Constraint)-import Generics.SOP.Sing---- | Require a constraint for every element of a list.------ If you have a datatype that is indexed over a type-level--- list, then you can use 'All' to indicate that all elements--- of that type-level list must satisfy a given constraint.------ /Example:/ The constraint------ > All Eq '[ Int, Bool, Char ]------ is equivalent to the constraint------ > (Eq Int, Eq Bool, Eq Char)------ /Example:/ A type signature such as------ > f :: All Eq xs => NP I xs -> ...------ means that 'f' can assume that all elements of the n-ary--- product satisfy 'Eq'.----class (AllF f xs, SListI xs) => All (f :: k -> Constraint) (xs :: [k])-instance (AllF f xs, SListI xs) => All f xs---- | Type family used to implement 'All'.----type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint-type instance AllF _c '[] = ()-type instance AllF c (x ': xs) = (c x, All c xs)---- | Require a singleton for every inner list in a list of lists.-type SListI2 = All SListI---- | Require a constraint for every element of a list of lists.------ If you have a datatype that is indexed over a type-level--- list of lists, then you can use 'All2' to indicate that all--- elements of the innert lists must satisfy a given constraint.------ /Example:/ The constraint------ > All2 Eq '[ '[ Int ], '[ Bool, Char ] ]------ is equivalent to the constraint------ > (Eq Int, Eq Bool, Eq Char)------ /Example:/ A type signature such as------ > f :: All2 Eq xss => SOP I xs -> ...------ means that 'f' can assume that all elements of the sum--- of product satisfy 'Eq'.----class (AllF (All f) xss, SListI xss) => All2 f xss-instance (AllF (All f) xss, SListI xss) => All2 f xss------ NOTE:------ The definition------ type All2 f = All (All f)------ is more direct, but has the unfortunate disadvantage the--- it triggers GHC's superclass cycle check when used in a--- class context.---- | Composition of constraints.------ Note that the result of the composition must be a constraint,--- and therefore, in @f ':.' g@, the kind of @f@ is @k -> 'Constraint'@.--- The kind of @g@, however, is @l -> k@ and can thus be an normal--- type constructor.------ A typical use case is in connection with 'All' on an 'NP' or an--- 'NS'. For example, in order to denote that all elements on an--- @'NP' f xs@ satisfy 'Show', we can say @'All' ('Show' :. f) xs@.------ @since 0.2----class (f (g x)) => (f `Compose` g) x-instance (f (g x)) => (f `Compose` g) x-infixr 9 `Compose`---- | Pairing of constraints.------ @since 0.2----class (f x, g x) => (f `And` g) x-instance (f x, g x) => (f `And` g) x-infixl 7 `And`---- | A constraint that can always be satisfied.------ @since 0.2----class Top x-instance Top x---- | A generalization of 'All' and 'All2'.------ The family 'AllN' expands to 'All' or 'All2' depending on whether--- the argument is indexed by a list or a list of lists.----type family AllN (h :: (k -> *) -> (l -> *)) (c :: k -> Constraint) :: l -> Constraint---- | A generalization of 'SListI'.------ The family 'SListIN' expands to 'SListI' or 'SListI2' depending--- on whether the argument is indexed by a list or a list of lists.----type family SListIN (h :: (k -> *) -> (l -> *)) :: l -> Constraint--instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPABLE #-}-#endif- SListI xs => SingI (xs :: [k]) where- sing = sList--instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPING #-}-#endif- (All SListI xss, SListI xss) => SingI (xss :: [[k]]) where- sing = sList+import Data.SOP.Constraint
src/Generics/SOP/Dict.hs view
@@ -1,160 +1,6 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE StandaloneDeriving #-}--- | Explicit dictionaries.------ When working with compound constraints such as constructed--- using 'All' or 'All2', GHC cannot always prove automatically--- what one would expect to hold.------ This module provides a way of explicitly proving--- conversions between such constraints to GHC. Such conversions--- still have to be manually applied.------ This module is new and experimental in generics-sop 0.2.--- It is therefore not yet exported via the main module and--- has to be imported explicitly. Its interface is to be--- considered even less stable than that of the rest of the--- library. Feedback is very welcome though.----module Generics.SOP.Dict where--import Data.Proxy-import Generics.SOP.Classes-import Generics.SOP.Constraint-import Generics.SOP.NP-import Generics.SOP.Sing---- | An explicit dictionary carrying evidence of a--- class constraint.------ The constraint parameter is separated into a--- second argument so that @'Dict' c@ is of the correct--- kind to be used directly as a parameter to e.g. 'NP'.------ @since 0.2----data Dict (c :: k -> Constraint) (a :: k) where- Dict :: c a => Dict c a--deriving instance Show (Dict c a)---- | A proof that the trivial constraint holds--- over all type-level lists.------ @since 0.2----pureAll :: SListI xs => Dict (All Top) xs-pureAll = all_NP (hpure Dict)---- | A proof that the trivial constraint holds--- over all type-level lists of lists.------ @since 0.2----pureAll2 :: All SListI xss => Dict (All2 Top) xss-pureAll2 = all_POP (hpure Dict)---- | Lifts a dictionary conversion over a type-level list.------ @since 0.2----mapAll :: forall c d xs .- (forall a . Dict c a -> Dict d a)- -> Dict (All c) xs -> Dict (All d) xs-mapAll f Dict = (all_NP . hmap f . unAll_NP) Dict---- | Lifts a dictionary conversion over a type-level list--- of lists.------ @since 0.2----mapAll2 :: forall c d xss .- (forall a . Dict c a -> Dict d a)- -> Dict (All2 c) xss -> Dict (All2 d) xss-mapAll2 f d @ Dict = (all2 . mapAll (mapAll f) . unAll2) d---- | If two constraints 'c' and 'd' hold over a type-level--- list 'xs', then the combination of both constraints holds--- over that list.------ @since 0.2----zipAll :: Dict (All c) xs -> Dict (All d) xs -> Dict (All (c `And` d)) xs-zipAll dc @ Dict dd = all_NP (hzipWith (\ Dict Dict -> Dict) (unAll_NP dc) (unAll_NP dd))---- | If two constraints 'c' and 'd' hold over a type-level--- list of lists 'xss', then the combination of both constraints--- holds over that list of lists.------ @since 0.2----zipAll2 :: All SListI xss => Dict (All2 c) xss -> Dict (All2 d) xss -> Dict (All2 (c `And` d)) xss-zipAll2 dc dd = all_POP (hzipWith (\ Dict Dict -> Dict) (unAll_POP dc) (unAll_POP dd))--- TODO: I currently don't understand why the All constraint in the beginning--- cannot be inferred.---- | If we have a constraint 'c' that holds over a type-level--- list 'xs', we can create a product containing proofs that--- each individual list element satisfies 'c'.------ @since 0.2----unAll_NP :: forall c xs . Dict (All c) xs -> NP (Dict c) xs-unAll_NP d = withDict d hdicts---- | If we have a constraint 'c' that holds over a type-level--- list of lists 'xss', we can create a product of products--- containing proofs that all the inner elements satisfy 'c'.------ @since 0.2----unAll_POP :: forall c xss . Dict (All2 c) xss -> POP (Dict c) xss-unAll_POP d = withDict d hdicts---- | If we have a product containing proofs that each element--- of 'xs' satisfies 'c', then 'All c' holds for 'xs'.------ @since 0.2----all_NP :: NP (Dict c) xs -> Dict (All c) xs-all_NP Nil = Dict-all_NP (Dict :* ds) = withDict (all_NP ds) Dict---- | If we have a product of products containing proofs that--- each inner element of 'xss' satisfies 'c', then 'All2 c'--- holds for 'xss'.------ @since 0.2----all_POP :: SListI xss => POP (Dict c) xss -> Dict (All2 c) xss-all_POP = all2 . all_NP . hmap all_NP . unPOP--- TODO: Is the constraint necessary?---- | The constraint 'All2 c' is convertible to 'All (All c)'.------ @since 0.2----unAll2 :: Dict (All2 c) xss -> Dict (All (All c)) xss-unAll2 Dict = Dict---- | The constraint 'All (All c)' is convertible to 'All2 c'.------ @since 0.2----all2 :: Dict (All (All c)) xss -> Dict (All2 c) xss-all2 Dict = Dict---- | If we have an explicit dictionary, we can unwrap it and--- pass a function that makes use of it.------ @since 0.2----withDict :: Dict c a -> (c a => r) -> r-withDict Dict x = x+module Generics.SOP.Dict+ (+ module Data.SOP.Dict+ ) where --- | A structure of dictionaries.------ @since 0.2.3.0----hdicts :: forall h c xs . (AllN h c xs, HPure h) => h (Dict c) xs-hdicts = hcpure (Proxy :: Proxy c) Dict+import Data.SOP.Dict
src/Generics/SOP/GGP.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE UndecidableInstances #-}+{-# 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:@@ -12,101 +13,78 @@ , GFrom , GTo , GDatatypeInfo+ , GDatatypeInfoOf , gfrom , gto , gdatatypeInfo ) where -import Data.Proxy+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 Generics.SOP.Constraint as SOP+import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.Metadata as SOP-import Generics.SOP.Sing -type family ToSingleCode (a :: * -> *) :: *+type family ToSingleCode (a :: Type -> Type) :: Type type instance ToSingleCode (K1 _i a) = a -type family ToProductCode (a :: * -> *) (xs :: [*]) :: [*]+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 :: * -> *) (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 -#if MIN_VERSION_base(4,9,0)-data InfoProxy (c :: Meta) (f :: * -> *) (x :: *) = InfoProxy-#else-data InfoProxy (c :: *) (f :: * -> *) (x :: *) = InfoProxy-#endif--class GDatatypeInfo' (a :: * -> *) where- gDatatypeInfo' :: proxy a -> DatatypeInfo (ToSumCode a '[])--#if !(MIN_VERSION_base(4,7,0))---- | 'isNewtype' does not exist in "GHC.Generics" before GHC-7.8.------ The only safe assumption to make is that it always returns 'False'.----isNewtype :: Datatype d => t d (f :: * -> *) a -> Bool-isNewtype _ = False+data InfoProxy (c :: Meta) (f :: Type -> Type) (x :: Type) = InfoProxy -#endif+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) -instance (All SListI (ToSumCode a '[]), Datatype c, GConstructorInfos a) => GDatatypeInfo' (M1 D c a) where- gDatatypeInfo' _ =- let adt = ADT (GHC.moduleName p) (GHC.datatypeName p)- ci = gConstructorInfos (Proxy :: Proxy a) Nil- in if isNewtype p- then case isNewtypeShape ci of- NewYes c -> Newtype (GHC.moduleName p) (GHC.datatypeName p) c- NewNo -> adt ci -- should not happen- else adt ci- where- p :: InfoProxy c a x- p = InfoProxy+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 -data IsNewtypeShape (xss :: [[*]]) where- NewYes :: ConstructorInfo '[x] -> IsNewtypeShape '[ '[x] ]- NewNo :: IsNewtypeShape 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 -isNewtypeShape :: All SListI xss => NP ConstructorInfo xss -> IsNewtypeShape xss-isNewtypeShape (x :* Nil) = go shape x- where- go :: Shape xs -> ConstructorInfo xs -> IsNewtypeShape '[ xs ]- go (ShapeCons ShapeNil) c = NewYes c- go _ _ = NewNo-isNewtypeShape _ = NewNo+type family ToStrictnessInfo (s :: Meta) :: SOP.T.StrictnessInfo+type instance ToStrictnessInfo (MetaSel _ su ss ds) = 'SOP.T.StrictnessInfo su ss ds -class GConstructorInfos (a :: * -> *) where- gConstructorInfos :: proxy a -> NP ConstructorInfo xss -> NP ConstructorInfo (ToSumCode a xss)+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 -instance (GConstructorInfos a, GConstructorInfos b) => GConstructorInfos (a :+: b) where- gConstructorInfos _ xss = gConstructorInfos (Proxy :: Proxy a) (gConstructorInfos (Proxy :: Proxy b) xss)+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 '[]) -instance GConstructorInfos GHC.V1 where- gConstructorInfos _ xss = xss+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 -instance (Constructor c, GFieldInfos a, SListI (ToProductCode a '[])) => GConstructorInfos (M1 C c a) where- gConstructorInfos _ xss- | conIsRecord p = Record (conName p) (gFieldInfos (Proxy :: Proxy a) Nil) :* xss- | otherwise = case conFixity p of- Prefix -> Constructor (conName p) :* xss- GHC.Infix a f -> case (shape :: Shape (ToProductCode a '[])) of- ShapeCons (ShapeCons ShapeNil) -> SOP.Infix (conName p) a f :* xss- _ -> Constructor (conName p) :* xss -- should not happen- where- p :: InfoProxy c a x- p = InfoProxy+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 :: * -> *) where+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@@ -121,13 +99,13 @@ p :: InfoProxy c a x p = InfoProxy -class GSingleFrom (a :: * -> *) where+class GSingleFrom (a :: Type -> Type) where gSingleFrom :: a x -> ToSingleCode a instance GSingleFrom (K1 i a) where gSingleFrom (K1 a) = a -class GProductFrom (a :: * -> *) where+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@@ -139,13 +117,13 @@ instance GSingleFrom a => GProductFrom (M1 S c a) where gProductFrom (M1 a) xs = I (gSingleFrom a) :* xs -class GSingleTo (a :: * -> *) where+class GSingleTo (a :: Type -> Type) where gSingleTo :: ToSingleCode a -> a x instance GSingleTo (K1 i a) where gSingleTo a = K1 a -class GProductTo (a :: * -> *) where+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@@ -153,20 +131,24 @@ instance GSingleTo a => GProductTo (M1 S c a) where gProductTo (SOP.I a :* xs) k = k (M1 (gSingleTo a)) xs-#if __GLASGOW_HASKELL__ < 800- gProductTo _ _ = error "inaccessible"-#endif instance GProductTo U1 where gProductTo xs k = k U1 xs -- This can most certainly be simplified-class GSumFrom (a :: * -> *) where- gSumFrom :: a x -> SOP I xss -> SOP I (ToSumCode a xss)+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 (gSumSkip (Proxy :: Proxy b) xss)+ 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)@@ -179,9 +161,12 @@ gSumFrom (M1 a) _ = SOP (Z (gProductFrom a Nil)) gSumSkip _ (SOP xss) = SOP (S xss) -class GSumTo (a :: * -> *) where+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) @@ -200,7 +185,7 @@ -- This is the default definition for 'Generics.SOP.Code'. -- For more info, see 'Generics.SOP.Generic'. ---type GCode (a :: *) = ToSumCode (GHC.Rep a) '[]+type GCode (a :: Type) = ToSumCode (GHC.Rep a) '[] -- | Constraint for the class that computes 'gfrom'. type GFrom a = GSumFrom (GHC.Rep a)@@ -209,8 +194,14 @@ type GTo a = GSumTo (GHC.Rep a) -- | Constraint for the class that computes 'gdatatypeInfo'.-type GDatatypeInfo a = GDatatypeInfo' (GHC.Rep a)+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@@ -220,7 +211,7 @@ -- For more info, see 'Generics.SOP.Generic'. -- gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a)-gfrom x = gSumFrom (GHC.from x) (error "gfrom: internal error" :: SOP.SOP SOP.I '[])+gfrom x = gSumFrom (GHC.from x) (Proxy :: Proxy '[]) -- | An automatically computed version of 'Generics.SOP.to'. --@@ -231,7 +222,7 @@ -- 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 ((\ _ -> error "inaccessible") :: SOP I '[] -> (GHC.Rep a) x))+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'. --@@ -242,5 +233,5 @@ -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a)-gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a))+gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a))
src/Generics/SOP/Instances.hs view
@@ -1,11 +1,9 @@+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -freduction-depth=100 #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#else-{-# OPTIONS_GHC -fcontext-stack=50 #-}-#endif+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- | Instances for 'Generic' and 'HasMetadata'. -- -- We define instances for datatypes from @generics-sop@ and@@ -16,28 +14,62 @@ -- 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.Monoid+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-#if !(MIN_VERSION_base(4,7,0))-import Data.Proxy-#endif+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.Exit import System.IO-#if MIN_VERSION_base(4,7,0) import Text.Printf-#endif import Text.Read.Lex import Generics.SOP.BasicFunctors+import Generics.SOP.Classes import Generics.SOP.TH -- Types from Generics.SOP:@@ -45,6 +77,7 @@ deriveGeneric ''I deriveGeneric ''K deriveGeneric ''(:.:)+deriveGeneric ''(-.->) -- new -- Cannot derive instances for Sing -- Cannot derive instances for Shape@@ -101,6 +134,7 @@ deriveGeneric ''NestedAtomically deriveGeneric ''BlockedIndefinitelyOnMVar deriveGeneric ''BlockedIndefinitelyOnSTM+deriveGeneric ''AllocationLimitExceeded -- new deriveGeneric ''Deadlock deriveGeneric ''NoMethodError deriveGeneric ''PatternMatchFail@@ -108,6 +142,7 @@ deriveGeneric ''RecSelError deriveGeneric ''RecUpdError deriveGeneric ''ErrorCall+deriveGeneric ''TypeError -- new deriveGeneric ''MaskingState -- From Data.Char:@@ -123,16 +158,42 @@ -- 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 ''Dual-deriveGeneric ''Endo-deriveGeneric ''All-deriveGeneric ''Any-deriveGeneric ''Sum-deriveGeneric ''Product-deriveGeneric ''First-deriveGeneric ''Last+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@@ -140,9 +201,23 @@ -- 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 @@ -173,6 +248,112 @@ 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@@ -193,19 +374,15 @@ -- From Text.Printf: -#if MIN_VERSION_base(4,7,0) deriveGeneric ''FieldFormat deriveGeneric ''FormatAdjustment deriveGeneric ''FormatSign deriveGeneric ''FormatParse-#endif -- From Text.Read.Lex: deriveGeneric ''Lexeme-#if MIN_VERSION_base(4,7,0) deriveGeneric ''Number-#endif -- Abstract / primitive datatypes (we don't derive Generic for these): --@@ -259,6 +436,13 @@ -- Weak -- ReadP -- ReadPrec+-- STM+-- TVar+-- Natural+-- Event+-- EventManager+-- CostCentre+-- CostCentreStack -- -- Datatypes we cannot currently handle: --
src/Generics/SOP/Metadata.hs view
@@ -15,13 +15,21 @@ ( module Generics.SOP.Metadata -- * re-exports , Associativity(..)+ , DecidedStrictness(..)+ , SourceStrictness(..)+ , SourceUnpackedness(..) ) where -import GHC.Generics (Associativity(..))+import Data.Kind (Type)+import GHC.Generics+ ( Associativity(..)+ , DecidedStrictness(..)+ , SourceStrictness(..)+ , SourceUnpackedness(..)+ ) import Generics.SOP.Constraint import Generics.SOP.NP-import Generics.SOP.Sing -- | Metadata for a datatype. --@@ -33,18 +41,27 @@ -- The constructor indicates whether the datatype has been declared using @newtype@ -- or not. ---data DatatypeInfo :: [[*]] -> * where+data DatatypeInfo :: [[Type]] -> Type where -- Standard algebraic datatype- ADT :: ModuleName -> DatatypeName -> NP ConstructorInfo xss -> DatatypeInfo xss+ ADT ::+ ModuleName+ -> DatatypeName+ -> NP ConstructorInfo xss+ -> POP StrictnessInfo xss+ -> DatatypeInfo xss -- Newtype- Newtype :: ModuleName -> DatatypeName -> ConstructorInfo '[x] -> DatatypeInfo '[ '[x] ]+ 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 (ADT name _ _ _) = name moduleName (Newtype name _ _) = name -- | The name of a datatype (or newtype).@@ -52,7 +69,7 @@ -- @since 0.2.3.0 -- datatypeName :: DatatypeInfo xss -> DatatypeName-datatypeName (ADT _ name _ ) = name+datatypeName (ADT _ name _ _) = name datatypeName (Newtype _ name _) = name -- | The constructor info for a datatype (or newtype).@@ -60,18 +77,29 @@ -- @since 0.2.3.0 -- constructorInfo :: DatatypeInfo xss -> NP ConstructorInfo xss-constructorInfo (ADT _ _ cs) = cs+constructorInfo (ADT _ _ cs _) = cs constructorInfo (Newtype _ _ c) = c :* Nil -deriving instance All (Show `Compose` ConstructorInfo) xs => Show (DatatypeInfo xs)-deriving instance All (Eq `Compose` ConstructorInfo) xs => Eq (DatatypeInfo xs)-deriving instance (All (Eq `Compose` ConstructorInfo) xs, All (Ord `Compose` ConstructorInfo) xs) => Ord (DatatypeInfo xs)+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 constructors.+-- | Metadata for a single constructor. -- -- This is indexed by the product structure of the constructor components. ---data ConstructorInfo :: [*] -> * where+data ConstructorInfo :: [Type] -> Type where -- Normal constructor Constructor :: SListI xs => ConstructorName -> ConstructorInfo xs -- Infix constructor@@ -92,8 +120,22 @@ 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 :: * -> * where+data FieldInfo :: Type -> Type where FieldInfo :: FieldName -> FieldInfo a deriving (Show, Eq, Ord, Functor)
src/Generics/SOP/NP.hs view
@@ -1,604 +1,6 @@-{-# LANGUAGE PolyKinds, StandaloneDeriving, UndecidableInstances #-}--- | n-ary products (and products of products) module Generics.SOP.NP- ( -- * Datatypes- NP(..)- , POP(..)- , unPOP- -- * Constructing products- , pure_NP- , pure_POP- , cpure_NP- , cpure_POP- -- ** Construction from a list- , fromList- -- * Application- , ap_NP- , ap_POP- -- * Destructing products- , hd- , tl- , Projection- , projections- , shiftProjection- -- * Lifting / mapping- , liftA_NP- , liftA_POP- , liftA2_NP- , liftA2_POP- , liftA3_NP- , liftA3_POP- , map_NP- , map_POP- , zipWith_NP- , zipWith_POP- , zipWith3_NP- , zipWith3_POP- , cliftA_NP- , cliftA_POP- , cliftA2_NP- , cliftA2_POP- , cliftA3_NP- , cliftA3_POP- , cmap_NP- , cmap_POP- , czipWith_NP- , czipWith_POP- , czipWith3_NP- , czipWith3_POP- -- * Dealing with @'All' c@- , hcliftA'- , hcliftA2'- , hcliftA3'- , cliftA2'_NP- -- * Collapsing- , collapse_NP- , collapse_POP- -- * Sequencing- , sequence'_NP- , sequence'_POP- , sequence_NP- , sequence_POP- -- * Catamorphism and anamorphism- , cata_NP- , ccata_NP- , ana_NP- , cana_NP+ (+ module Data.SOP.NP ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif-import Data.Proxy (Proxy(..))--import Control.DeepSeq (NFData(..))--import Generics.SOP.BasicFunctors-import Generics.SOP.Classes-import Generics.SOP.Constraint-import Generics.SOP.Sing---- | An n-ary product.------ The product is parameterized by a type constructor @f@ and--- indexed by a type-level list @xs@. The length of the list--- determines the number of elements in the product, and if the--- @i@-th element of the list is of type @x@, then the @i@-th--- element of the product is of type @f x@.------ The constructor names are chosen to resemble the names of the--- list constructors.------ Two common instantiations of @f@ are the identity functor 'I'--- and the constant functor 'K'. For 'I', the product becomes a--- heterogeneous list, where the type-level list describes the--- types of its components. For @'K' a@, the product becomes a--- homogeneous list, where the contents of the type-level list are--- ignored, but its length still specifies the number of elements.------ In the context of the SOP approach to generic programming, an--- n-ary product describes the structure of the arguments of a--- single data constructor.------ /Examples:/------ > I 'x' :* I True :* Nil :: NP I '[ Char, Bool ]--- > K 0 :* K 1 :* Nil :: NP (K Int) '[ Char, Bool ]--- > Just 'x' :* Nothing :* Nil :: NP Maybe '[ Char, Bool ]----data NP :: (k -> *) -> [k] -> * where- Nil :: NP f '[]- (:*) :: f x -> NP f xs -> NP f (x ': xs)--infixr 5 :*--deriving instance All (Show `Compose` f) xs => Show (NP f xs)-deriving instance All (Eq `Compose` f) xs => Eq (NP f xs)-deriving instance (All (Eq `Compose` f) xs, All (Ord `Compose` f) xs) => Ord (NP f xs)---- | @since 0.2.5.0-instance All (NFData `Compose` f) xs => NFData (NP f xs) where- rnf Nil = ()- rnf (x :* xs) = rnf x `seq` rnf xs---- | A product of products.------ This is a 'newtype' for an 'NP' of an 'NP'. The elements of the--- inner products are applications of the parameter @f@. The type--- 'POP' is indexed by the list of lists that determines the lengths--- of both the outer and all the inner products, as well as the types--- of all the elements of the inner products.------ A 'POP' is reminiscent of a two-dimensional table (but the inner--- lists can all be of different length). In the context of the SOP--- approach to generic programming, a 'POP' is useful to represent--- information that is available for all arguments of all constructors--- of a datatype.----newtype POP (f :: (k -> *)) (xss :: [[k]]) = POP (NP (NP f) xss)--deriving instance (Show (NP (NP f) xss)) => Show (POP f xss)-deriving instance (Eq (NP (NP f) xss)) => Eq (POP f xss)-deriving instance (Ord (NP (NP f) xss)) => Ord (POP f xss)---- | @since 0.2.5.0-instance (NFData (NP (NP f) xss)) => NFData (POP f xss) where- rnf (POP xss) = rnf xss---- | Unwrap a product of products.-unPOP :: POP f xss -> NP (NP f) xss-unPOP (POP xss) = xss--type instance AllN NP c = All c-type instance AllN POP c = All2 c--type instance SListIN NP = SListI-type instance SListIN POP = SListI2---- * Constructing products---- | Specialization of 'hpure'.------ The call @'pure_NP' x@ generates a product that contains 'x' in every--- element position.------ /Example:/------ >>> pure_NP [] :: NP [] '[Char, Bool]--- "" :* [] :* Nil--- >>> pure_NP (K 0) :: NP (K Int) '[Double, Int, String]--- K 0 :* K 0 :* K 0 :* Nil----pure_NP :: forall f xs. SListI xs => (forall a. f a) -> NP f xs-pure_NP f = case sList :: SList xs of- SNil -> Nil- SCons -> f :* pure_NP f---- | Specialization of 'hpure'.------ The call @'pure_POP' x@ generates a product of products that contains 'x'--- in every element position.----pure_POP :: All SListI xss => (forall a. f a) -> POP f xss-pure_POP f = POP (cpure_NP sListP (pure_NP f))--sListP :: Proxy SListI-sListP = Proxy---- | Specialization of 'hcpure'.------ The call @'cpure_NP' p x@ generates a product that contains 'x' in every--- element position.----cpure_NP :: forall c xs proxy f. All c xs- => proxy c -> (forall a. c a => f a) -> NP f xs-cpure_NP p f = case sList :: SList xs of- SNil -> Nil- SCons -> f :* cpure_NP p f---- | Specialization of 'hcpure'.------ The call @'cpure_NP' p x@ generates a product of products that contains 'x'--- in every element position.----cpure_POP :: forall c xss proxy f. All2 c xss- => proxy c -> (forall a. c a => f a) -> POP f xss-cpure_POP p f = POP (cpure_NP (allP p) (cpure_NP p f))--allP :: proxy c -> Proxy (All c)-allP _ = Proxy--instance HPure NP where- hpure = pure_NP- hcpure = cpure_NP--instance HPure POP where- hpure = pure_POP- hcpure = cpure_POP---- ** Construction from a list---- | Construct a homogeneous n-ary product from a normal Haskell list.------ Returns 'Nothing' if the length of the list does not exactly match the--- expected size of the product.----fromList :: SListI xs => [a] -> Maybe (NP (K a) xs)-fromList = go sList- where- go :: SList xs -> [a] -> Maybe (NP (K a) xs)- go SNil [] = return Nil- go SCons (x:xs) = do ys <- go sList xs ; return (K x :* ys)- go _ _ = Nothing---- * Application---- | Specialization of 'hap'.------ Applies a product of (lifted) functions pointwise to a product of--- suitable arguments.----ap_NP :: NP (f -.-> g) xs -> NP f xs -> NP g xs-ap_NP Nil Nil = Nil-ap_NP (Fn f :* fs) (x :* xs) = f x :* ap_NP fs xs-#if __GLASGOW_HASKELL__ < 800-ap_NP _ _ = error "inaccessible"-#endif---- | Specialization of 'hap'.------ Applies a product of (lifted) functions pointwise to a product of--- suitable arguments.----ap_POP :: POP (f -.-> g) xss -> POP f xss -> POP g xss-ap_POP (POP fss') (POP xss') = POP (go fss' xss')- where- go :: NP (NP (f -.-> g)) xss -> NP (NP f) xss -> NP (NP g) xss- go Nil Nil = Nil- go (fs :* fss) (xs :* xss) = ap_NP fs xs :* go fss xss-#if __GLASGOW_HASKELL__ < 800- go _ _ = error "inaccessible"-#endif---- The definition of 'ap_POP' is a more direct variant of--- '_ap_POP_spec'. The direct definition has the advantage--- that it avoids the 'SListI' constraint.-_ap_POP_spec :: SListI xss => POP (f -.-> g) xss -> POP f xss -> POP g xss-_ap_POP_spec (POP fs) (POP xs) = POP (liftA2_NP ap_NP fs xs)--type instance Prod NP = NP-type instance Prod POP = POP--instance HAp NP where hap = ap_NP-instance HAp POP where hap = ap_POP---- * Destructing products---- | Obtain the head of an n-ary product.------ @since 0.2.1.0----hd :: NP f (x ': xs) -> f x-hd (x :* _xs) = x---- | Obtain the tail of an n-ary product.------ @since 0.2.1.0----tl :: NP f (x ': xs) -> NP f xs-tl (_x :* xs) = xs---- | The type of projections from an n-ary product.----type Projection (f :: k -> *) (xs :: [k]) = K (NP f xs) -.-> f---- | Compute all projections from an n-ary product.------ Each element of the resulting product contains one of the projections.----projections :: forall xs f . SListI xs => NP (Projection f xs) xs-projections = case sList :: SList xs of- SNil -> Nil- SCons -> fn (hd . unK) :* liftA_NP shiftProjection projections--shiftProjection :: Projection f xs a -> Projection f (x ': xs) a-shiftProjection (Fn f) = Fn $ f . K . tl . unK---- * Lifting / mapping---- | Specialization of 'hliftA'.-liftA_NP :: SListI xs => (forall a. f a -> g a) -> NP f xs -> NP g xs--- | Specialization of 'hliftA'.-liftA_POP :: All SListI xss => (forall a. f a -> g a) -> POP f xss -> POP g xss--liftA_NP = hliftA-liftA_POP = hliftA---- | Specialization of 'hliftA2'.-liftA2_NP :: SListI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NP g xs -> NP h xs--- | Specialization of 'hliftA2'.-liftA2_POP :: All SListI xss => (forall a. f a -> g a -> h a) -> POP f xss -> POP g xss -> POP h xss--liftA2_NP = hliftA2-liftA2_POP = hliftA2---- | Specialization of 'hliftA3'.-liftA3_NP :: SListI xs => (forall a. f a -> g a -> h a -> i a) -> NP f xs -> NP g xs -> NP h xs -> NP i xs--- | Specialization of 'hliftA3'.-liftA3_POP :: All SListI xss => (forall a. f a -> g a -> h a -> i a) -> POP f xss -> POP g xss -> POP h xss -> POP i xss--liftA3_NP = hliftA3-liftA3_POP = hliftA3---- | Specialization of 'hmap', which is equivalent to 'hliftA'.-map_NP :: SListI xs => (forall a. f a -> g a) -> NP f xs -> NP g xs--- | Specialization of 'hmap', which is equivalent to 'hliftA'.-map_POP :: All SListI xss => (forall a. f a -> g a) -> POP f xss -> POP g xss--map_NP = hmap-map_POP = hmap---- | Specialization of 'hzipWith', which is equivalent to 'hliftA2'.-zipWith_NP :: SListI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NP g xs -> NP h xs--- | Specialization of 'hzipWith', which is equivalent to 'hliftA2'.-zipWith_POP :: All SListI xss => (forall a. f a -> g a -> h a) -> POP f xss -> POP g xss -> POP h xss--zipWith_NP = hzipWith-zipWith_POP = hzipWith---- | Specialization of 'hzipWith3', which is equivalent to 'hliftA3'.-zipWith3_NP :: SListI xs => (forall a. f a -> g a -> h a -> i a) -> NP f xs -> NP g xs -> NP h xs -> NP i xs--- | Specialization of 'hzipWith3', which is equivalent to 'hliftA3'.-zipWith3_POP :: All SListI xss => (forall a. f a -> g a -> h a -> i a) -> POP f xss -> POP g xss -> POP h xss -> POP i xss--zipWith3_NP = hzipWith3-zipWith3_POP = hzipWith3---- | Specialization of 'hcliftA'.-cliftA_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NP f xs -> NP g xs--- | Specialization of 'hcliftA'.-cliftA_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> POP f xss -> POP g xss--cliftA_NP = hcliftA-cliftA_POP = hcliftA---- | Specialization of 'hcliftA2'.-cliftA2_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a) -> NP f xs -> NP g xs -> NP h xs--- | Specialization of 'hcliftA2'.-cliftA2_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a) -> POP f xss -> POP g xss -> POP h xss--cliftA2_NP = hcliftA2-cliftA2_POP = hcliftA2---- | Specialization of 'hcliftA3'.-cliftA3_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a -> i a) -> NP f xs -> NP g xs -> NP h xs -> NP i xs--- | Specialization of 'hcliftA3'.-cliftA3_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a -> i a) -> POP f xss -> POP g xss -> POP h xss -> POP i xss--cliftA3_NP = hcliftA3-cliftA3_POP = hcliftA3---- | Specialization of 'hcmap', which is equivalent to 'hcliftA'.-cmap_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NP f xs -> NP g xs--- | Specialization of 'hcmap', which is equivalent to 'hcliftA'.-cmap_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> POP f xss -> POP g xss--cmap_NP = hcmap-cmap_POP = hcmap---- | Specialization of 'hczipWith', which is equivalent to 'hcliftA2'.-czipWith_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a) -> NP f xs -> NP g xs -> NP h xs--- | Specialization of 'hczipWith', which is equivalent to 'hcliftA2'.-czipWith_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a) -> POP f xss -> POP g xss -> POP h xss--czipWith_NP = hczipWith-czipWith_POP = hczipWith---- | Specialization of 'hczipWith3', which is equivalent to 'hcliftA3'.-czipWith3_NP :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a -> i a) -> NP f xs -> NP g xs -> NP h xs -> NP i xs--- | Specialization of 'hczipWith3', which is equivalent to 'hcliftA3'.-czipWith3_POP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a -> i a) -> POP f xss -> POP g xss -> POP h xss -> POP i xss--czipWith3_NP = hczipWith3-czipWith3_POP = hczipWith3---- * Dealing with @'All' c@---- | Lift a constrained function operating on a list-indexed structure--- to a function on a list-of-list-indexed structure.------ This is a variant of 'hcliftA'.------ /Specification:/------ @--- 'hcliftA'' p f xs = 'hpure' ('fn_2' $ \\ 'AllDictC' -> f) \` 'hap' \` 'allDict_NP' p \` 'hap' \` xs--- @------ /Instances:/------ @--- 'hcliftA'' :: 'All2' c xss => proxy c -> (forall xs. 'All' c xs => f xs -> f' xs) -> 'NP' f xss -> 'NP' f' xss--- 'hcliftA'' :: 'All2' c xss => proxy c -> (forall xs. 'All' c xs => f xs -> f' xs) -> 'Generics.SOP.NS.NS' f xss -> 'Generics.SOP.NS.NS' f' xss--- @----{-# DEPRECATED hcliftA' "Use 'hcliftA' or 'hcmap' instead." #-}-hcliftA' :: (All2 c xss, Prod h ~ NP, HAp h) => proxy c -> (forall xs. All c xs => f xs -> f' xs) -> h f xss -> h f' xss---- | Like 'hcliftA'', but for binary functions.-{-# DEPRECATED hcliftA2' "Use 'hcliftA2' or 'hczipWith' instead." #-}-hcliftA2' :: (All2 c xss, Prod h ~ NP, HAp h) => proxy c -> (forall xs. All c xs => f xs -> f' xs -> f'' xs) -> Prod h f xss -> h f' xss -> h f'' xss---- | Like 'hcliftA'', but for ternay functions.-{-# DEPRECATED hcliftA3' "Use 'hcliftA3' or 'hczipWith3' instead." #-}-hcliftA3' :: (All2 c xss, Prod h ~ NP, HAp h) => proxy c -> (forall xs. All c xs => f xs -> f' xs -> f'' xs -> f''' xs) -> Prod h f xss -> Prod h f' xss -> h f'' xss -> h f''' xss--hcliftA' p = hcliftA (allP p)-hcliftA2' p = hcliftA2 (allP p)-hcliftA3' p = hcliftA3 (allP p)---- | Specialization of 'hcliftA2''.-{-# DEPRECATED cliftA2'_NP "Use 'cliftA2_NP' instead." #-}-cliftA2'_NP :: All2 c xss => proxy c -> (forall xs. All c xs => f xs -> g xs -> h xs) -> NP f xss -> NP g xss -> NP h xss--cliftA2'_NP = hcliftA2'---- * Collapsing---- | Specialization of 'hcollapse'.------ /Example:/------ >>> collapse_NP (K 1 :* K 2 :* K 3 :* Nil)--- [1,2,3]----collapse_NP :: NP (K a) xs -> [a]---- | Specialization of 'hcollapse'.------ /Example:/------ >>> collapse_POP (POP ((K 'a' :* Nil) :* (K 'b' :* K 'c' :* Nil) :* Nil) :: POP (K Char) '[ '[(a :: *)], '[b, c] ])--- ["a", "bc"]------ (The type signature is only necessary in this case to fix the kind of the type variables.)----collapse_POP :: SListI xss => POP (K a) xss -> [[a]]--collapse_NP Nil = []-collapse_NP (K x :* xs) = x : collapse_NP xs--collapse_POP = collapse_NP . hliftA (K . collapse_NP) . unPOP--type instance CollapseTo NP a = [a]-type instance CollapseTo POP a = [[a]]--instance HCollapse NP where hcollapse = collapse_NP-instance HCollapse POP where hcollapse = collapse_POP---- * Sequencing---- | Specialization of 'hsequence''.-sequence'_NP :: Applicative f => NP (f :.: g) xs -> f (NP g xs)---- | Specialization of 'hsequence''.-sequence'_POP :: (SListI xss, Applicative f) => POP (f :.: g) xss -> f (POP g xss)--sequence'_NP Nil = pure Nil-sequence'_NP (mx :* mxs) = (:*) <$> unComp mx <*> sequence'_NP mxs--sequence'_POP = fmap POP . sequence'_NP . hliftA (Comp . sequence'_NP) . unPOP--instance HSequence NP where hsequence' = sequence'_NP-instance HSequence POP where hsequence' = sequence'_POP---- | Specialization of 'hsequence'.------ /Example:/------ >>> sequence_NP (Just 1 :* Just 2 :* Nil)--- Just (I 1 :* I 2 :* Nil)----sequence_NP :: (SListI xs, Applicative f) => NP f xs -> f (NP I xs)---- | Specialization of 'hsequence'.------ /Example:/------ >>> sequence_POP (POP ((Just 1 :* Nil) :* (Just 2 :* Just 3 :* Nil) :* Nil))--- Just (POP ((I 1 :* Nil) :* ((I 2 :* (I 3 :* Nil)) :* Nil)))----sequence_POP :: (All SListI xss, Applicative f) => POP f xss -> f (POP I xss)--sequence_NP = hsequence-sequence_POP = hsequence---- * Catamorphism and anamorphism---- | Catamorphism for 'NP'.------ This is a suitable generalization of 'foldr'. It takes--- parameters on what to do for 'Nil' and ':*'. Since the--- input list is heterogeneous, the result is also indexed--- by a type-level list.------ @since 0.2.3.0----cata_NP ::- forall r f xs .- r '[]- -> (forall y ys . f y -> r ys -> r (y ': ys))- -> NP f xs- -> r xs-cata_NP nil cons = go- where- go :: forall ys . NP f ys -> r ys- go Nil = nil- go (x :* xs) = cons x (go xs)---- | Constrained catamorphism for 'NP'.------ The difference compared to 'cata_NP' is that the function--- for the cons-case can make use of the fact that the specified--- constraint holds for all the types in the signature of the--- product.------ @since 0.2.3.0----ccata_NP ::- forall c proxy r f xs . (All c xs)- => proxy c- -> r '[]- -> (forall y ys . c y => f y -> r ys -> r (y ': ys))- -> NP f xs- -> r xs-ccata_NP _ nil cons = go- where- go :: forall ys . (All c ys) => NP f ys -> r ys- go Nil = nil- go (x :* xs) = cons x (go xs)---- | Anamorphism for 'NP'.------ In contrast to the anamorphism for normal lists, the--- generating function does not return an 'Either', but--- simply an element and a new seed value.------ This is because the decision on whether to generate a--- 'Nil' or a ':*' is determined by the types.------ @since 0.2.3.0----ana_NP ::- forall s f xs .- SListI xs- => (forall y ys . s (y ': ys) -> (f y, s ys))- -> s xs- -> NP f xs-ana_NP uncons = go sList- where- go :: forall ys . SList ys -> s ys -> NP f ys- go SNil _ = Nil- go SCons s = case uncons s of- (x, s') -> x :* go sList s'---- | Constrained anamorphism for 'NP'.------ Compared to 'ana_NP', the generating function can--- make use of the specified constraint here for the--- elements that it generates.------ @since 0.2.3.0----cana_NP ::- forall c proxy s f xs . (All c xs)- => proxy c- -> (forall y ys . c y => s (y ': ys) -> (f y, s ys))- -> s xs- -> NP f xs-cana_NP _ uncons = go sList- where- go :: forall ys . (All c ys) => SList ys -> s ys -> NP f ys- go SNil _ = Nil- go SCons s = case uncons s of- (x, s') -> x :* go sList s'+import Data.SOP.NP
src/Generics/SOP/NS.hs view
@@ -1,593 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}--- | n-ary sums (and sums of products) module Generics.SOP.NS- ( -- * Datatypes- NS(..)- , SOP(..)- , unSOP- -- * Constructing sums- , Injection- , injections- , shift- , shiftInjection- , apInjs_NP- , apInjs'_NP- , apInjs_POP- , apInjs'_POP- -- * Destructing sums- , unZ- , index_NS- , index_SOP- -- * Application- , ap_NS- , ap_SOP- -- * Lifting / mapping- , liftA_NS- , liftA_SOP- , liftA2_NS- , liftA2_SOP- , cliftA_NS- , cliftA_SOP- , cliftA2_NS- , cliftA2_SOP- , map_NS- , map_SOP- , cmap_NS- , cmap_SOP- -- * Dealing with @'All' c@- , cliftA2'_NS- -- * Collapsing- , collapse_NS- , collapse_SOP- -- * Sequencing- , sequence'_NS- , sequence'_SOP- , sequence_NS- , sequence_SOP- -- * Catamorphism and anamorphism- , cata_NS- , ccata_NS- , ana_NS- , cana_NS- -- * Expanding sums to products- , expand_NS- , cexpand_NS- , expand_SOP- , cexpand_SOP+ (+ module Data.SOP.NS ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-#endif-import Data.Proxy--import Control.DeepSeq (NFData(..))--import Generics.SOP.BasicFunctors-import Generics.SOP.Classes-import Generics.SOP.Constraint-import Generics.SOP.NP-import Generics.SOP.Sing---- * Datatypes---- | An n-ary sum.------ The sum is parameterized by a type constructor @f@ and--- indexed by a type-level list @xs@. The length of the list--- determines the number of choices in the sum and if the--- @i@-th element of the list is of type @x@, then the @i@-th--- choice of the sum is of type @f x@.------ The constructor names are chosen to resemble Peano-style--- natural numbers, i.e., 'Z' is for "zero", and 'S' is for--- "successor". Chaining 'S' and 'Z' chooses the corresponding--- component of the sum.------ /Examples:/------ > Z :: f x -> NS f (x ': xs)--- > S . Z :: f y -> NS f (x ': y ': xs)--- > S . S . Z :: f z -> NS f (x ': y ': z ': xs)--- > ...------ Note that empty sums (indexed by an empty list) have no--- non-bottom elements.------ Two common instantiations of @f@ are the identity functor 'I'--- and the constant functor 'K'. For 'I', the sum becomes a--- direct generalization of the 'Either' type to arbitrarily many--- choices. For @'K' a@, the result is a homogeneous choice type,--- where the contents of the type-level list are ignored, but its--- length specifies the number of options.------ In the context of the SOP approach to generic programming, an--- n-ary sum describes the top-level structure of a datatype,--- which is a choice between all of its constructors.------ /Examples:/------ > Z (I 'x') :: NS I '[ Char, Bool ]--- > S (Z (I True)) :: NS I '[ Char, Bool ]--- > S (Z (K 1)) :: NS (K Int) '[ Char, Bool ]----data NS :: (k -> *) -> [k] -> * where- Z :: f x -> NS f (x ': xs)- S :: NS f xs -> NS f (x ': xs)--deriving instance All (Show `Compose` f) xs => Show (NS f xs)-deriving instance All (Eq `Compose` f) xs => Eq (NS f xs)-deriving instance (All (Eq `Compose` f) xs, All (Ord `Compose` f) xs) => Ord (NS f xs)---- | @since 0.2.5.0-instance All (NFData `Compose` f) xs => NFData (NS f xs) where- rnf (Z x) = rnf x- rnf (S xs) = rnf xs---- | Extract the payload from a unary sum.------ For larger sums, this function would be partial, so it is only--- provided with a rather restrictive type.------ /Example:/------ >>> unZ (Z (I 'x'))--- I 'x'------ @since 0.2.2.0----unZ :: NS f '[x] -> f x-unZ (Z x) = x-unZ _ = error "inaccessible" -- needed even in GHC 8.0.1---- | Obtain the index from an n-ary sum.------ An n-nary sum represents a choice between n different options.--- This function returns an integer between 0 and n - 1 indicating--- the option chosen by the given value.------ /Examples:/------ >>> index_NS (S (S (Z (I False))))--- 2--- >>> index_NS (Z (K ()))--- 0------ @since 0.2.4.0----index_NS :: forall f xs . NS f xs -> Int-index_NS = go 0- where- go :: forall ys . Int -> NS f ys -> Int- go !acc (Z _) = acc- go !acc (S x) = go (acc + 1) x--instance HIndex NS where- hindex = index_NS---- | A sum of products.------ This is a 'newtype' for an 'NS' of an 'NP'. The elements of the--- (inner) products are applications of the parameter @f@. The type--- 'SOP' is indexed by the list of lists that determines the sizes--- of both the (outer) sum and all the (inner) products, as well as--- the types of all the elements of the inner products.------ An @'SOP' 'I'@ reflects the structure of a normal Haskell datatype.--- The sum structure represents the choice between the different--- constructors, the product structure represents the arguments of--- each constructor.----newtype SOP (f :: (k -> *)) (xss :: [[k]]) = SOP (NS (NP f) xss)--deriving instance (Show (NS (NP f) xss)) => Show (SOP f xss)-deriving instance (Eq (NS (NP f) xss)) => Eq (SOP f xss)-deriving instance (Ord (NS (NP f) xss)) => Ord (SOP f xss)---- | @since 0.2.5.0-instance (NFData (NS (NP f) xss)) => NFData (SOP f xss) where- rnf (SOP xss) = rnf xss---- | Unwrap a sum of products.-unSOP :: SOP f xss -> NS (NP f) xss-unSOP (SOP xss) = xss---- | Obtain the index from an n-ary sum of products.------ An n-nary sum represents a choice between n different options.--- This function returns an integer between 0 and n - 1 indicating--- the option chosen by the given value.------ /Specification:/------ @--- 'index_SOP' = 'index_NS' '.' 'unSOP'--- @------ /Example:/------ >>> index_SOP (SOP (S (Z (I True :* I 'x' :* Nil))))--- 1------ @since 0.2.4.0----index_SOP :: SOP f xs -> Int-index_SOP = index_NS . unSOP--instance HIndex SOP where- hindex = index_SOP---- * Constructing sums---- | The type of injections into an n-ary sum.------ If you expand the type synonyms and newtypes involved, you get------ > Injection f xs a = (f -.-> K (NS f xs)) a ~= f a -> K (NS f xs) a ~= f a -> NS f xs------ If we pick @a@ to be an element of @xs@, this indeed corresponds to an--- injection into the sum.----type Injection (f :: k -> *) (xs :: [k]) = f -.-> K (NS f xs)---- | Compute all injections into an n-ary sum.------ Each element of the resulting product contains one of the injections.----injections :: forall xs f. SListI xs => NP (Injection f xs) xs-injections = case sList :: SList xs of- SNil -> Nil- SCons -> fn (K . Z) :* liftA_NP shiftInjection injections---- | Shift an injection.------ Given an injection, return an injection into a sum that is one component larger.----shiftInjection :: Injection f xs a -> Injection f (x ': xs) a-shiftInjection (Fn f) = Fn $ K . S . unK . f--{-# DEPRECATED shift "Use 'shiftInjection' instead." #-}--- | Shift an injection.------ Given an injection, return an injection into a sum that is one component larger.----shift :: Injection f xs a -> Injection f (x ': xs) a-shift = shiftInjection---- | Apply injections to a product.------ Given a product containing all possible choices, produce a--- list of sums by applying each injection to the appropriate--- element.------ /Example:/------ >>> apInjs_NP (I 'x' :* I True :* I 2 :* Nil)--- [Z (I 'x'), S (Z (I True)), S (S (Z (I 2)))]----apInjs_NP :: SListI xs => NP f xs -> [NS f xs]-apInjs_NP = hcollapse . apInjs'_NP---- | `apInjs_NP` without `hcollapse`.------ >>> apInjs'_NP (I 'x' :* I True :* I 2 :* Nil)--- K (Z (I 'x')) :* K (S (Z (I True))) :* K (S (S (Z (I 2)))) :* Nil------ @since 0.2.5.0----apInjs'_NP :: SListI xs => NP f xs -> NP (K (NS f xs)) xs-apInjs'_NP = hap injections---- | Apply injections to a product of product.------ This operates on the outer product only. Given a product--- containing all possible choices (that are products),--- produce a list of sums (of products) by applying each--- injection to the appropriate element.------ /Example:/------ >>> apInjs_POP (POP ((I 'x' :* Nil) :* (I True :* I 2 :* Nil) :* Nil))--- [SOP (Z (I 'x' :* Nil)),SOP (S (Z (I True :* (I 2 :* Nil))))]----apInjs_POP :: SListI xss => POP f xss -> [SOP f xss]-apInjs_POP = map SOP . apInjs_NP . unPOP---- | `apInjs_POP` without `hcollapse`.------ /Example:/------ >>> apInjs'_POP (POP ((I 'x' :* Nil) :* (I True :* I 2 :* Nil) :* Nil))--- K (SOP (Z (I 'x' :* Nil))) :* K (SOP (S (Z (I True :* I 2 :* Nil)))) :* Nil------ @since 0.2.5.0----apInjs'_POP :: SListI xss => POP f xss -> NP (K (SOP f xss)) xss-apInjs'_POP = hmap (K . SOP . unK) . hap injections . unPOP--type instance UnProd NP = NS-type instance UnProd POP = SOP--instance HApInjs NS where- hapInjs = apInjs_NP--instance HApInjs SOP where- hapInjs = apInjs_POP---- * Application---- | Specialization of 'hap'.-ap_NS :: NP (f -.-> g) xs -> NS f xs -> NS g xs-ap_NS (Fn f :* _) (Z x) = Z (f x)-ap_NS (_ :* fs) (S xs) = S (ap_NS fs xs)-ap_NS _ _ = error "inaccessible"---- | Specialization of 'hap'.-ap_SOP :: POP (f -.-> g) xss -> SOP f xss -> SOP g xss-ap_SOP (POP fss') (SOP xss') = SOP (go fss' xss')- where- go :: NP (NP (f -.-> g)) xss -> NS (NP f) xss -> NS (NP g) xss- go (fs :* _ ) (Z xs ) = Z (ap_NP fs xs )- go (_ :* fss) (S xss) = S (go fss xss)- go _ _ = error "inaccessible"---- The definition of 'ap_SOP' is a more direct variant of--- '_ap_SOP_spec'. The direct definition has the advantage--- that it avoids the 'SListI' constraint.-_ap_SOP_spec :: SListI xss => POP (t -.-> f) xss -> SOP t xss -> SOP f xss-_ap_SOP_spec (POP fs) (SOP xs) = SOP (liftA2_NS ap_NP fs xs)--type instance Prod NS = NP-type instance Prod SOP = POP--type instance SListIN NS = SListI-type instance SListIN SOP = SListI2--instance HAp NS where hap = ap_NS-instance HAp SOP where hap = ap_SOP---- * Lifting / mapping---- | Specialization of 'hliftA'.-liftA_NS :: SListI xs => (forall a. f a -> g a) -> NS f xs -> NS g xs--- | Specialization of 'hliftA'.-liftA_SOP :: All SListI xss => (forall a. f a -> g a) -> SOP f xss -> SOP g xss--liftA_NS = hliftA-liftA_SOP = hliftA---- | Specialization of 'hliftA2'.-liftA2_NS :: SListI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NS g xs -> NS h xs--- | Specialization of 'hliftA2'.-liftA2_SOP :: All SListI xss => (forall a. f a -> g a -> h a) -> POP f xss -> SOP g xss -> SOP h xss--liftA2_NS = hliftA2-liftA2_SOP = hliftA2---- | Specialization of 'hmap', which is equivalent to 'hliftA'.-map_NS :: SListI xs => (forall a. f a -> g a) -> NS f xs -> NS g xs--- | Specialization of 'hmap', which is equivalent to 'hliftA'.-map_SOP :: All SListI xss => (forall a. f a -> g a) -> SOP f xss -> SOP g xss--map_NS = hmap-map_SOP = hmap---- | Specialization of 'hcliftA'.-cliftA_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NS f xs -> NS g xs--- | Specialization of 'hcliftA'.-cliftA_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> SOP f xss -> SOP g xss--cliftA_NS = hcliftA-cliftA_SOP = hcliftA---- | Specialization of 'hcliftA2'.-cliftA2_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a) -> NP f xs -> NS g xs -> NS h xs--- | Specialization of 'hcliftA2'.-cliftA2_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a) -> POP f xss -> SOP g xss -> SOP h xss--cliftA2_NS = hcliftA2-cliftA2_SOP = hcliftA2---- | Specialization of 'hcmap', which is equivalent to 'hcliftA'.-cmap_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NS f xs -> NS g xs--- | Specialization of 'hcmap', which is equivalent to 'hcliftA'.-cmap_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> SOP f xss -> SOP g xss--cmap_NS = hcmap-cmap_SOP = hcmap---- * Dealing with @'All' c@---- | Specialization of 'hcliftA2''.-{-# DEPRECATED cliftA2'_NS "Use 'cliftA2_NS' instead." #-}-cliftA2'_NS :: All2 c xss => proxy c -> (forall xs. All c xs => f xs -> g xs -> h xs) -> NP f xss -> NS g xss -> NS h xss--cliftA2'_NS = hcliftA2'---- * Collapsing---- | Specialization of 'hcollapse'.-collapse_NS :: NS (K a) xs -> a--- | Specialization of 'hcollapse'.-collapse_SOP :: SListI xss => SOP (K a) xss -> [a]--collapse_NS (Z (K x)) = x-collapse_NS (S xs) = collapse_NS xs--collapse_SOP = collapse_NS . hliftA (K . collapse_NP) . unSOP--type instance CollapseTo NS a = a-type instance CollapseTo SOP a = [a]--instance HCollapse NS where hcollapse = collapse_NS-instance HCollapse SOP where hcollapse = collapse_SOP---- * Sequencing---- | Specialization of 'hsequence''.-sequence'_NS :: Applicative f => NS (f :.: g) xs -> f (NS g xs)---- | Specialization of 'hsequence''.-sequence'_SOP :: (SListI xss, Applicative f) => SOP (f :.: g) xss -> f (SOP g xss)--sequence'_NS (Z mx) = Z <$> unComp mx-sequence'_NS (S mxs) = S <$> sequence'_NS mxs--sequence'_SOP = fmap SOP . sequence'_NS . hliftA (Comp . sequence'_NP) . unSOP--instance HSequence NS where hsequence' = sequence'_NS-instance HSequence SOP where hsequence' = sequence'_SOP---- | Specialization of 'hsequence'.-sequence_NS :: (SListI xs, Applicative f) => NS f xs -> f (NS I xs)---- | Specialization of 'hsequence'.-sequence_SOP :: (All SListI xss, Applicative f) => SOP f xss -> f (SOP I xss)--sequence_NS = hsequence-sequence_SOP = hsequence---- * Catamorphism and anamorphism---- | Catamorphism for 'NS'.------ Takes arguments determining what to do for 'Z'--- and what to do for 'S'. The result type is still--- indexed over the type-level lit.------ @since 0.2.3.0----cata_NS ::- forall r f xs .- (forall y ys . f y -> r (y ': ys))- -> (forall y ys . r ys -> r (y ': ys))- -> NS f xs- -> r xs-cata_NS z s = go- where- go :: forall ys . NS f ys -> r ys- go (Z x) = z x- go (S i) = s (go i)---- | Constrained catamorphism for 'NS'.------ @since 0.2.3.0----ccata_NS ::- forall c proxy r f xs . (All c xs)- => proxy c- -> (forall y ys . c y => f y -> r (y ': ys))- -> (forall y ys . c y => r ys -> r (y ': ys))- -> NS f xs- -> r xs-ccata_NS _ z s = go- where- go :: forall ys . (All c ys) => NS f ys -> r ys- go (Z x) = z x- go (S i) = s (go i)---- | Anamorphism for 'NS'.------ @since 0.2.3.0----ana_NS ::- forall s f xs . (SListI xs)- => (forall r . s '[] -> r)- -> (forall y ys . s (y ': ys) -> Either (f y) (s ys))- -> s xs- -> NS f xs-ana_NS refute decide = go sList- where- go :: forall ys . SList ys -> s ys -> NS f ys- go SNil s = refute s- go SCons s = case decide s of- Left x -> Z x- Right s' -> S (go sList s')---- | Constrained anamorphism for 'NS'.------ @since 0.2.3.0----cana_NS :: forall c proxy s f xs .- (All c xs)- => proxy c- -> (forall r . s '[] -> r)- -> (forall y ys . c y => s (y ': ys) -> Either (f y) (s ys))- -> s xs- -> NS f xs-cana_NS _ refute decide = go sList- where- go :: forall ys . (All c ys) => SList ys -> s ys -> NS f ys- go SNil s = refute s- go SCons s = case decide s of- Left x -> Z x- Right s' -> S (go sList s')---- * Expanding sums to products---- | Specialization of 'hexpand'.------ @since 0.2.5.0----expand_NS :: forall f xs .- (SListI xs)- => (forall x . f x)- -> NS f xs -> NP f xs-expand_NS d = go sList- where- go :: forall ys . SList ys -> NS f ys -> NP f ys- go SCons (Z x) = x :* hpure d- go SCons (S i) = d :* go sList i- go SNil _ = error "inaccessible" -- still required in ghc-8.0.*---- | Specialization of 'hcexpand'.------ @since 0.2.5.0----cexpand_NS :: forall c proxy f xs .- (All c xs)- => proxy c -> (forall x . c x => f x)- -> NS f xs -> NP f xs-cexpand_NS p d = go- where- go :: forall ys . All c ys => NS f ys -> NP f ys- go (Z x) = x :* hcpure p d- go (S i) = d :* go i---- | Specialization of 'hexpand'.------ @since 0.2.5.0----expand_SOP :: forall f xss .- (All SListI xss)- => (forall x . f x)- -> SOP f xss -> POP f xss-expand_SOP d =- POP . cexpand_NS (Proxy :: Proxy SListI) (hpure d) . unSOP---- | Specialization of 'hcexpand'.------ @since 0.2.5.0----cexpand_SOP :: forall c proxy f xss .- (All2 c xss)- => proxy c -> (forall x . c x => f x)- -> SOP f xss -> POP f xss-cexpand_SOP p d =- POP . cexpand_NS (allP p) (hcpure p d) . unSOP--allP :: proxy c -> Proxy (All c)-allP _ = Proxy--instance HExpand NS where- hexpand = expand_NS- hcexpand = cexpand_NS--instance HExpand SOP where- hexpand = expand_SOP- hcexpand = cexpand_SOP+import Data.SOP.NS
src/Generics/SOP/Sing.hs view
@@ -1,117 +1,6 @@-{-# LANGUAGE PolyKinds, StandaloneDeriving #-}-#if MIN_VERSION_base(4,7,0)-{-# LANGUAGE NoAutoDeriveTypeable #-}-#endif--- | Singleton types corresponding to type-level data structures.------ The implementation is similar, but subtly different to that of the--- @<https://hackage.haskell.org/package/singletons singletons>@ package.--- See the <http://www.andres-loeh.de/TrueSumsOfProducts "True Sums of Products">--- paper for details.--- module Generics.SOP.Sing- ( -- * Singletons- SList(..)- , SListI(..)- , Sing- , SingI(..)- -- ** Shape of type-level lists- , Shape(..)- , shape- , lengthSList- , lengthSing+ (+ module Data.SOP.Sing ) where --- * Singletons---- | Explicit singleton list.------ A singleton list can be used to reveal the structure of--- a type-level list argument that the function is quantified--- over. For every type-level list @xs@, there is one non-bottom--- value of type @'SList' xs@.------ Note that these singleton lists are polymorphic in the--- list elements; we do not require a singleton representation--- for them.------ @since 0.2----data SList :: [k] -> * where- SNil :: SList '[]- SCons :: SListI xs => SList (x ': xs)--deriving instance Show (SList (xs :: [k]))-deriving instance Eq (SList (xs :: [k]))-deriving instance Ord (SList (xs :: [k]))---- | Implicit singleton list.------ A singleton list can be used to reveal the structure of--- a type-level list argument that the function is quantified--- over.------ The class 'SListI' should have instances that match the--- constructors of 'SList'.------ @since 0.2----class SListI (xs :: [k]) where- -- | Get hold of the explicit singleton (that one can then- -- pattern match on).- sList :: SList xs--instance SListI '[] where- sList = SNil--instance SListI xs => SListI (x ': xs) where- sList = SCons---- | General class for implicit singletons.------ Just provided for limited backward compatibility.----{-# DEPRECATED SingI "Use 'SListI' instead." #-}-{-# DEPRECATED sing "Use 'sList' instead." #-}-class SListI xs => SingI (xs :: [k]) where- sing :: Sing xs---- | Explicit singleton type.------ Just provided for limited backward compatibility.-{-# DEPRECATED Sing "Use 'SList' instead." #-}-type Sing = SList---- * Shape of type-level lists---- | Occassionally it is useful to have an explicit, term-level, representation--- of type-level lists (esp because of https://ghc.haskell.org/trac/ghc/ticket/9108)-data Shape :: [k] -> * where- ShapeNil :: Shape '[]- ShapeCons :: SListI xs => Shape xs -> Shape (x ': xs)--deriving instance Show (Shape xs)-deriving instance Eq (Shape xs)-deriving instance Ord (Shape xs)---- | The shape of a type-level list.-shape :: forall (xs :: [k]). SListI xs => Shape xs-shape = case sList :: SList xs of- SNil -> ShapeNil- SCons -> ShapeCons shape---- | The length of a type-level list.------ @since 0.2----lengthSList :: forall (xs :: [k]) proxy. SListI xs => proxy xs -> Int-lengthSList _ = lengthShape (shape :: Shape xs)- where- lengthShape :: forall xs'. Shape xs' -> Int- lengthShape ShapeNil = 0- lengthShape (ShapeCons s) = 1 + lengthShape s---- | Old name for 'lengthSList'.-{-# DEPRECATED lengthSing "Use 'lengthSList' instead." #-}-lengthSing :: SListI xs => proxy xs -> Int-lengthSing = lengthSList+import Data.SOP.Sing
src/Generics/SOP/TH.hs view
@@ -1,19 +1,30 @@+{-# 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 (replicateM)+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.Syntax+import Language.Haskell.TH.Datatype as TH+import Language.Haskell.TH.Datatype.TyVarBndr 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@@ -48,29 +59,49 @@ -- > -- > to (SOP (Z (I x :* Nil))) = Leaf x -- > to (SOP (S (Z (I l :* I r :* Nil)))) = Node l r--- > to _ = error "unreachable" -- to avoid GHC warnings+-- > to (SOP (S (S x))) = x `seq` error "inaccessible" -- > -- > instance HasDatatypeInfo Tree where--- > datatypeInfo _ = ADT "Main" "Tree"--- > (Constructor "Leaf" :* Constructor "Node" :* Nil)+-- > 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 = do- dec <- reifyDec n- ds1 <- withDataDec dec deriveGenericForDataDec- ds2 <- withDataDec dec deriveMetadataForDataDec- return (ds1 ++ ds2)+deriveGeneric n =+ deriveGenericSubst n varT -- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance. deriveGenericOnly :: Name -> Q [Dec]-deriveGenericOnly n = do- dec <- reifyDec n- withDataDec dec deriveGenericForDataDec+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@@ -88,24 +119,25 @@ -- > 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 _ = error "unreachable" -- to avoid GHC warnings+-- > 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 codeName' = mkName codeName let fromName' = mkName fromName let toName' = mkName toName- dec <- reifyDec n- withDataDec dec $ \_isNewtype _cxt name _bndrs cons _derivs -> do- let codeType = codeFor cons -- '[ '[Int], '[Tree, Tree] ]- let repType = [t| SOP I $(conT codeName') |] -- SOP I TreeCode+ 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' [] codeType -- type TreeCode = '[ '[Int], '[Tree, Tree] ]- , sigD fromName' [t| $(conT name) -> $repType |] -- fromTree :: Tree -> SOP I TreeCode+ [ 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 -> $(conT name) |] -- toTree :: SOP I TreeCode -> Tree+ , sigD toName' [t| $repType -> $origType |] -- toTree :: SOP I TreeCode -> Tree , projection toName' cons -- toTree ... = ] @@ -121,7 +153,7 @@ -- > treeDatatypeInfo = ADT "Main" "Tree" -- > (Constructor "Leaf" :* Constructor "Node" :* Nil) ----- /Note:/ CodeType need to be derived with 'deriveGenericFunctions'.+-- /Note:/ CodeType needs to be derived with 'deriveGenericFunctions'. -- -- @since 0.2 --@@ -129,58 +161,99 @@ deriveMetadataValue n codeName datatypeInfoName = do let codeName' = mkName codeName let datatypeInfoName' = mkName datatypeInfoName- dec <- reifyDec n- withDataDec dec $ \isNewtype _cxt name _bndrs cons _derivs -> do- sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode- , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ...+ 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." #-} -deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]-deriveGenericForDataDec _isNewtype _cxt name bndrs cons _derivs = do- let typ = appTyVars name bndrs-#if MIN_VERSION_template_haskell(2,9,0)- let codeSyn = tySynInstD ''Code $ tySynEqn [typ] (codeFor cons)-#else- let codeSyn = tySynInstD ''Code [typ] (codeFor cons)-#endif+-- | 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 -> [TyVarBndrVis] -> [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 :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]-deriveMetadataForDataDec isNewtype _cxt name bndrs cons _derivs = do- let typ = appTyVars name bndrs+deriveMetadataForDataDec ::+ (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrVis] -> [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 |]- [metadata isNewtype name cons]+ [ 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 :: [Con] -> Q Type-codeFor = promotedTypeList . map go+codeFor :: (Name -> Q Type) -> [TH.ConstructorInfo] -> Q Type+codeFor f = promotedTypeList . map go where- go :: Con -> Q Type+ go :: TH.ConstructorInfo -> Q Type go c = do (_, ts) <- conInfo c- promotedTypeList ts+ promotedTypeListSubst f ts {------------------------------------------------------------------------------- Computing the embedding/projection pair -------------------------------------------------------------------------------} -embedding :: Name -> [Con] -> Q Dec-embedding fromName = funD fromName . go (\e -> [| Z $e |])+embedding :: Name -> [TH.ConstructorInfo] -> Q Dec+embedding fromName = funD fromName . go' (\e -> [| Z $e |]) where- go :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause]+ 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) -> Con -> Q Clause+ mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x")@@ -188,81 +261,200 @@ (normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |]) [] -projection :: Name -> [Con] -> Q Dec-projection toName = funD toName . go (\p -> conP 'Z [p])+projection :: Name -> [TH.ConstructorInfo] -> Q Dec+projection toName = funD toName . go' where- go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause]- go _ [] = [unreachable]+ 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 - mkClause :: (Q Pat -> Q Pat) -> Con -> Q Clause+ -- 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 . npP . map (\v -> conP 'I [varP v]) $ vars]]+ clause [conP 'SOP [br . conP 'Z . (:[]) . npP . map (\v -> conP 'I [varP v]) $ vars]] (normalB . appsE $ conE n : map varE vars) [] -unreachable :: Q Clause-unreachable = clause [wildP]- (normalB [| error "unreachable" |])- []- {------------------------------------------------------------------------------- Compute metadata -------------------------------------------------------------------------------} -metadata :: Bool -> Name -> [Con] -> Q Dec-metadata isNewtype typeName cs =- funD 'datatypeInfo [clause [wildP] (normalB $ metadata' isNewtype typeName cs) []]+metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec+metadataType typ variant typeName cs =+ tySynInstDCompat ''DatatypeInfoOf Nothing [typ] (metadataType' variant typeName cs) -metadata' :: Bool -> Name -> [Con] -> Q Exp-metadata' isNewtype typeName cs = md+-- | Derive term-level metadata.+metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp+metadata' dataVariant typeName cs = md where md :: Q Exp- md | isNewtype = [| SOP.Newtype $(stringE (nameModule' typeName))- $(stringE (nameBase typeName))- $(mdCon (head cs))- |]- | otherwise = [| SOP.ADT $(stringE (nameModule' typeName))- $(stringE (nameBase typeName))- $(npE $ map mdCon cs)- |]+ 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)+ |] - mdCon :: Con -> Q Exp- mdCon (NormalC n _) = [| SOP.Constructor $(stringE (nameBase n)) |]- mdCon (RecC n ts) = [| SOP.Record $(stringE (nameBase n))- $(npE (map mdField ts))- |]- mdCon (InfixC _ n _) = do-#if MIN_VERSION_template_haskell(2,11,0)- fixity <- reifyFixity n- case fromMaybe defaultFixity fixity of- Fixity f a ->-#else- i <- reify n- case i of- DataConI _ _ _ (Fixity f a) ->-#endif- [| SOP.Infix $(stringE (nameBase n)) $(mdAssociativity a) f |]-#if !MIN_VERSION_template_haskell(2,11,0)- _ -> fail "Strange infix operator"-#endif- mdCon (ForallC _ _ _) = fail "Existentials not supported"-#if MIN_VERSION_template_haskell(2,11,0)- mdCon (GadtC _ _ _) = fail "GADTs not supported"- mdCon (RecGadtC _ _ _) = fail "GADTs not supported"-#endif+ mdStrictness :: TH.ConstructorInfo -> Q [Q Exp]+ mdStrictness ci@(ConstructorInfo { constructorName = n+ , constructorStrictness = bs }) =+ checkForGADTs ci $ mdConStrictness n bs - mdField :: VarStrictType -> Q Exp- mdField (n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |]+ 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 @@ -281,6 +473,11 @@ 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 []@@ -290,49 +487,125 @@ Some auxiliary definitions for working with TH -------------------------------------------------------------------------------} -conInfo :: Con -> Q (Name, [Q Type])-conInfo (NormalC n ts) = return (n, map (return . (\(_, t) -> t)) ts)-conInfo (RecC n ts) = return (n, map (return . (\(_, _, t) -> t)) ts)-conInfo (InfixC (_, t) n (_, t')) = return (n, map return [t, t'])-conInfo (ForallC _ _ _) = fail "Existentials not supported"-#if MIN_VERSION_template_haskell(2,11,0)-conInfo (GadtC _ _ _) = fail "GADTs not supported"-conInfo (RecGadtC _ _ _) = fail "GADTs not supported"-#endif+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) |] -appTyVars :: Name -> [TyVarBndr] -> Q Type-appTyVars n = go (conT n)+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 -> [TyVarBndrVis] -> 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 :: Q Type -> [TyVarBndr] -> Q Type- go t [] = t- go t (PlainTV v : vs) = go [t| $t $(varT v) |] vs- go t (KindedTV v _ : vs) = go [t| $t $(varT v) |] vs+ 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. -reifyDec :: Name -> Q Dec-reifyDec name =- do info <- reify name- case info of TyConI dec -> return dec- _ -> fail "Info must be type declaration type."+-- 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+ -> [TyVarBndrVis]+ -- 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 (changeTVFlags bndrReq bndrs) instTypes cons -withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a) -> Q a-#if MIN_VERSION_template_haskell(2,11,0)-withDataDec (DataD ctxt name bndrs _ cons derivs) f = f False ctxt name bndrs cons derivs-withDataDec (NewtypeD ctxt name bndrs _ con derivs) f = f True ctxt name bndrs [con] derivs-#else-withDataDec (DataD ctxt name bndrs cons derivs) f = f False ctxt name bndrs cons derivs-withDataDec (NewtypeD ctxt name bndrs con derivs) f = f True ctxt name bndrs [con] derivs+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-withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes."+ _ -> return ()+ q --- | Utility type synonym to cover changes in the TH code-#if MIN_VERSION_template_haskell(2,12,0)-type Derivings = [DerivClause]-#elif MIN_VERSION_template_haskell(2,11,0)-type Derivings = Cxt-#else-type Derivings = [Name]+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
+ src/Generics/SOP/Type/Metadata.hs view
@@ -0,0 +1,376 @@+{-# 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+
src/Generics/SOP/Universe.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif -- | 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.Sing import Generics.SOP.GGP import Generics.SOP.Metadata+import qualified Generics.SOP.Type.Metadata as T -- | The (generic) representation of a datatype. --@@ -26,7 +28,7 @@ -- -- 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 are datatype+-- 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@@ -92,7 +94,7 @@ -- -- still holds. ---class (All SListI (Code a)) => Generic (a :: *) where+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@@ -110,7 +112,7 @@ -- > , '[ Tree, Tree ] -- > ] --- type Code a :: [[*]]+ type Code a :: [[Type]] type Code a = GCode a -- | Converts from a value to its structural representation.@@ -136,8 +138,135 @@ -- rather derive the class instance automatically. See the documentation -- of 'Generic' for the options. ---class HasDatatypeInfo a where+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, Code a ~ GCode a)- => 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 #-}
test/Example.hs view
@@ -1,16 +1,23 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-module Main (main, toTreeC) where+{-# 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)@@ -23,7 +30,19 @@ 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)@@ -31,40 +50,191 @@ 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) -deriveGenericOnly ''TreeB+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
+ test/HTransExample.hs view
@@ -0,0 +1,27 @@+{-# 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