generics-sop 0.3.2.0 → 0.4.0.0

raw patch · 23 files changed

+1138/−3815 lines, 23 filesdep +criteriondep +sop-coredep −transformersdep −transformers-compatdep ~basedep ~deepseqdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, sop-core

Dependencies removed: transformers, transformers-compat

Dependency ranges changed: base, deepseq, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−0
• 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 +1/−0
• generics-sop.cabal +52/−20
• src/Generics/SOP.hs +6/−4
• src/Generics/SOP/BasicFunctors.hs +3/−473
• src/Generics/SOP/Classes.hs +3/−682
• src/Generics/SOP/Constraint.hs +3/−232
• src/Generics/SOP/Dict.hs +5/−159
• src/Generics/SOP/GGP.hs +29/−114
• src/Generics/SOP/Instances.hs +206/−24
• src/Generics/SOP/Metadata.hs +4/−4
• src/Generics/SOP/NP.hs +3/−886
• src/Generics/SOP/NS.hs +3/−981
• src/Generics/SOP/Sing.hs +3/−114
• src/Generics/SOP/TH.hs +105/−76
• src/Generics/SOP/Type/Metadata.hs +10/−31
• src/Generics/SOP/Universe.hs +93/−15
• test/Example.hs +111/−0

@@ -1,3 +1,29 @@+# 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

@@ -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      )+        ]+      ]+    ]

@@ -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

@@ -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+

@@ -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

@@ -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++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)++deriveGenericSubst ''S20 (const (promotedT 'SOPTH))++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++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)++deriveGenericSubst ''PB2 (const (promotedT 'SOPTH))++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++

@@ -21,4 +21,5 @@   -XKindSignatures \   -XDataKinds \   -XFunctionalDependencies \+  -i../sop/src \   $(find src -name '*.hs')

@@ -1,5 +1,5 @@ name:                generics-sop-version:             0.3.2.0+version:             0.4.0.0 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:   .@@ -37,7 +42,7 @@ build-type:          Simple cabal-version:       >=1.10 extra-source-files:  CHANGELOG.md doctest.sh-tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.2.2, GHC == 8.3.*+tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1  source-repository head   type:                git@@ -47,26 +52,23 @@   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.7  && < 5,-                       template-haskell     >= 2.8  && < 2.14,-                       ghc-prim             >= 0.3  && < 0.6,-                       deepseq              >= 1.3  && < 1.5-  if !impl (ghc >= 8.0)-    build-depends:     transformers-compat  >= 0.3  && < 0.6,-                       transformers         >= 0.3  && < 0.6-+  build-depends:       base                 >= 4.9  && < 5,+                       sop-core             == 0.4.0.*,+                       template-haskell     >= 2.8  && < 2.15,+                       ghc-prim             >= 0.3  && < 0.6   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall@@ -89,14 +91,14 @@                        DataKinds                        FunctionalDependencies                        AutoDeriveTypeable-  other-extensions:    OverloadedStrings-                       PolyKinds+  -- 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 generics-sop-examples   type:                exitcode-stdio-1.0@@ -105,5 +107,35 @@   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

@@ -345,6 +345,8 @@     -- ** Mapping constraints   , All   , All2+  , cpara_SList+  , ccase_SList   , AllZip   , AllZip2   , AllN@@ -357,15 +359,15 @@   , 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:

@@ -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

@@ -1,685 +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-  , Same-  , Prod-  , HAp(..)-    -- ** Derived functions-  , hliftA-  , hliftA2-  , hliftA3-  , hmap-  , hzipWith-  , hzipWith3-  , hcliftA-  , hcliftA2-  , hcliftA3-  , hcmap-  , hczipWith-  , hczipWith3-    -- * Collapsing homogeneous structures-  , CollapseTo-  , HCollapse(..)-    -- * Folding and sequencing-  , HTraverse_(..)-  , HSequence(..)-    -- ** Derived functions-  , hcfoldMap-  , hcfor_-  , hsequence-  , hsequenceK-  , hctraverse-  , hcfor-    -- * Indexing into sums-  , HIndex(..)-    -- * Applying all injections-  , UnProd-  , HApInjs(..)-    -- * Expanding sums to products-  , HExpand(..)-    -- * Transformation of index lists and coercions-  , HTrans(..)-  , hfromI-  , htoI+  (+    module Data.SOP.Classes   ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative (Applicative)-import Data.Monoid (Monoid)-#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 to the same structure.-type family Same (h :: (k1 -> *) -> (l1 -> *)) :: (k2 -> *) -> (l2 -> *)---- | 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---- | A generalization of 'Data.Foldable.traverse_' or 'Data.Foldable.foldMap'.------ @since 0.3.2.0----class HTraverse_ (h :: (k -> *) -> (l -> *)) where--  -- | Corresponds to 'Data.Foldable.traverse_'.-  ---  -- /Instances:/-  ---  -- @-  -- 'hctraverse_', 'Generics.SOP.NP.ctraverse__NP'  :: ('All'  c xs , 'Applicative' g) => proxy c -> (forall a. c a => f a -> g ()) -> 'Generics.SOP.NP.NP'  f xs  -> g ()-  -- 'hctraverse_', 'Generics.SOP.NS.ctraverse__NS'  :: ('All2' c xs , 'Applicative' g) => proxy c -> (forall a. c a => f a -> g ()) -> 'Generics.SOP.NS.NS'  f xs  -> g ()-  -- 'hctraverse_', 'Generics.SOP.NP.ctraverse__POP' :: ('All'  c xss, 'Applicative' g) => proxy c -> (forall a. c a => f a -> g ()) -> 'Generics.SOP.NP.POP' f xss -> g ()-  -- 'hctraverse_', 'Generics.SOP.NS.ctraverse__SOP' :: ('All2' c xss, 'Applicative' g) => proxy c -> (forall a. c a => f a -> g ()) -> 'Generics.SOP.NS.SOP' f xss -> g ()-  -- @-  ---  -- @since 0.3.2.0-  ---  hctraverse_ :: (AllN h c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g ()) -> h f xs -> g ()--  -- | Unconstrained version of 'hctraverse_'.-  ---  -- /Instances:/-  ---  -- @-  -- 'traverse_', 'Generics.SOP.NP.traverse__NP'  :: ('SListI'  xs , 'Applicative g') => (forall a. f a -> g ()) -> 'Generics.SOP.NP.NP'  f xs  -> g ()-  -- 'traverse_', 'Generics.SOP.NS.traverse__NS'  :: ('SListI'  xs , 'Applicative g') => (forall a. f a -> g ()) -> 'Generics.SOP.NS.NS'  f xs  -> g ()-  -- 'traverse_', 'Generics.SOP.NP.traverse__POP' :: ('SListI2' xss, 'Applicative g') => (forall a. f a -> g ()) -> 'Generics.SOP.NP.POP' f xss -> g ()-  -- 'traverse_', 'Generics.SOP.NS.traverse__SOP' :: ('SListI2' xss, 'Applicative g') => (forall a. f a -> g ()) -> 'Generics.SOP.NS.SOP' f xss -> g ()-  -- @-  ---  -- @since 0.3.2.0-  ---  htraverse_ :: (SListIN h xs, Applicative g) => (forall a. f a -> g ()) -> h f xs -> g ()---- | Flipped version of 'hctraverse_'.------ @since 0.3.2.0----hcfor_ :: (HTraverse_ h, AllN h c xs, Applicative g) => proxy c -> h f xs -> (forall a. c a => f a -> g ()) -> g ()-hcfor_ p xs f = hctraverse_ p f xs---- | Special case of 'hctraverse_'.------ @since 0.3.2.0----hcfoldMap :: (HTraverse_ h, AllN h c xs, Monoid m) => proxy c -> (forall a. c a => f a -> m) -> h f xs -> m-hcfoldMap p f = unK . hctraverse_ p (K . f)---- * 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)---  -- | Corresponds to 'Data.Traversable.traverse'.-  ---  -- /Instances:/-  ---  -- @-  -- 'hctraverse'', 'Generics.SOP.NP.ctraverse'_NP'  :: ('All'  c xs , 'Applicative' g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NP.NP'  f xs  -> g ('Generics.SOP.NP.NP'  f' xs )-  -- 'hctraverse'', 'Generics.SOP.NS.ctraverse'_NS'  :: ('All2' c xs , 'Applicative' g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NS.NS'  f xs  -> g ('Generics.SOP.NS.NS'  f' xs )-  -- 'hctraverse'', 'Generics.SOP.NP.ctraverse'_POP' :: ('All'  c xss, 'Applicative' g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NP.POP' f xss -> g ('Generics.SOP.NP.POP' f' xss)-  -- 'hctraverse'', 'Generics.SOP.NS.ctraverse'_SOP' :: ('All2' c xss, 'Applicative' g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NS.SOP' f xss -> g ('Generics.SOP.NS.SOP' f' xss)-  -- @-  ---  -- @since 0.3.2.0-  ---  hctraverse' :: (AllN h c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> h f xs -> g (h f' xs)--  -- | Unconstrained variant of `htraverse'`.-  ---  -- /Instances:/-  ---  -- @-  -- 'htraverse'', 'Generics.SOP.NP.traverse'_NP'  :: ('SListI'  xs , 'Applicative' g) => (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NP.NP'  f xs  -> g ('Generics.SOP.NP.NP'  f' xs )-  -- 'htraverse'', 'Generics.SOP.NS.traverse'_NS'  :: ('SListI2' xs , 'Applicative' g) => (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NS.NS'  f xs  -> g ('Generics.SOP.NS.NS'  f' xs )-  -- 'htraverse'', 'Generics.SOP.NP.traverse'_POP' :: ('SListI'  xss, 'Applicative' g) => (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NP.POP' f xss -> g ('Generics.SOP.NP.POP' f' xss)-  -- 'htraverse'', 'Generics.SOP.NS.traverse'_SOP' :: ('SListI2' xss, 'Applicative' g) => (forall a. c a => f a -> g (f' a)) -> 'Generics.SOP.NS.SOP' f xss -> g ('Generics.SOP.NS.SOP' f' xss)-  -- @-  ---  -- @since 0.3.2.0-  ---  htraverse' :: (SListIN h xs, Applicative g) => (forall a. f a -> g (f' a)) -> h f xs -> g (h f' xs)---- ** Derived functions---- | Special case of 'hctraverse'' where @f' = 'I'@.------ @since 0.3.2.0----hctraverse :: (HSequence h, AllN h c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g a) -> h f xs -> g (h I xs)-hctraverse p f = hctraverse' p (fmap I . f)---- | Flipped version of 'hctraverse'.------ @since 0.3.2.0----hcfor :: (HSequence h, AllN h c xs, Applicative g) => proxy c -> h f xs -> (forall a. c a => f a -> g a) -> g (h I xs)-hcfor p xs f = hctraverse p f xs---- | 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) :: [NS I '[Char, Bool, Int]]-  -- [Z (I 'x'),S (Z (I True)),S (S (Z (I 2)))]-  ---  -- >>> hapInjs (POP ((I 'x' :* Nil) :* (I True :* I 2 :* Nil) :* Nil)) :: [SOP I '[ '[Char], '[Bool, Int]]]-  -- [SOP (Z (I 'x' :* Nil)),SOP (S (Z (I True :* I 2 :* Nil)))]-  ---  -- Unfortunately the type-signatures are required in GHC-7.10 and older.-  ---  -- @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---- | A class for transforming structures into related structures with--- a different index list, as long as the index lists have the same shape--- and the elements and interpretation functions are suitably related.------ @since 0.3.1.0----class (Same h1 ~ h2, Same h2 ~ h1) => HTrans (h1 :: (k1 -> *) -> (l1 -> *)) (h2 :: (k2 -> *) -> (l2 -> *)) where--  -- | Transform a structure into a related structure given a conversion-  -- function for the elements.-  ---  -- @since 0.3.1.0-  ---  htrans ::-       AllZipN (Prod h1) c xs ys-    => proxy c-    -> (forall x y . c x y => f x -> g y)-    -> h1 f xs -> h2 g ys--  -- | Coerce a structure into a representationally equal structure.-  ---  -- /Examples:/-  ---  -- >>> hcoerce (I (Just LT) :* I (Just 'x') :* I (Just True) :* Nil) :: NP Maybe '[Ordering, Char, Bool]-  -- Just LT :* Just 'x' :* Just True :* Nil-  -- >>> hcoerce (SOP (Z (K True :* K False :* Nil))) :: SOP I '[ '[Bool, Bool], '[Bool] ]-  -- SOP (Z (I True :* I False :* Nil))-  ---  -- @since 0.3.1.0-  hcoerce ::-       (AllZipN (Prod h1) (LiftedCoercible f g) xs ys, HTrans h1 h2)-    => h1 f xs -> h2 g ys---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----hfromI ::-       (AllZipN (Prod h1) (LiftedCoercible I f) xs ys, HTrans h1 h2)-    => h1 I xs -> h2 f ys-hfromI = hcoerce---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----htoI ::-       (AllZipN (Prod h1) (LiftedCoercible f I) xs ys, HTrans h1 h2)-    => h1 f xs -> h2 I ys-htoI = hcoerce---- $setup--- >>> import Generics.SOP+import Data.SOP.Classes

@@ -1,235 +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 Data.Coerce-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 where-  AllF _c '[]       = ()-  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.---- | Require a constraint for pointwise for every pair of--- elements from two lists.------ /Example:/ The constraint------ > All (~) '[ Int, Bool, Char ] '[ a, b, c ]------ is equivalent to the constraint------ > (Int ~ a, Bool ~ b, Char ~ c)------ @since 0.3.1.0----class-  ( SListI xs, SListI ys-  , SameShapeAs xs ys, SameShapeAs ys xs-  , AllZipF c xs ys-  ) => AllZip (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b])-instance-  ( SListI xs, SListI ys-  , SameShapeAs xs ys, SameShapeAs ys xs-  , AllZipF c xs ys-  ) => AllZip c xs ys---- | Type family used to implement 'AllZip'.------ @since 0.3.1.0----type family-  AllZipF (c :: a -> b -> Constraint) (xs :: [a]) (ys :: [b])-    :: Constraint where-  AllZipF _c '[]      '[]        = ()-  AllZipF  c (x ': xs) (y ': ys) = (c x y, AllZip c xs ys)---- | Type family that forces a type-level list to be of the same--- shape as the given type-level list.------ The main use of this constraint is to help type inference to--- learn something about otherwise unknown type-level lists.------ @since 0.3.1.0----type family-  SameShapeAs (xs :: [a]) (ys :: [b]) :: Constraint where-  SameShapeAs '[]       ys = (ys ~ '[])-  SameShapeAs (x ': xs) ys =-    (ys ~ (Head ys ': Tail ys), SameShapeAs xs (Tail ys))---- | Utility function to compute the head of a type-level list.------ @since 0.3.1.0----type family Head (xs :: [a]) :: a where-  Head (x ': xs) = x---- | Utility function to compute the tail of a type-level list.------ @since 0.3.1.0----type family Tail (xs :: [a]) :: [a] where-  Tail (x ': xs) = xs---- | The constraint @LiftedCoercible f g x y@ is equivalent--- to @Coercible (f x) (g y)@.------ @since 0.3.1.0----class Coercible (f x) (g y) => LiftedCoercible f g x y-instance Coercible (f x) (g y) => LiftedCoercible f g x y---- | Require a constraint for pointwise for every pair of--- elements from two lists of lists.-------class (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss-instance (AllZipF (AllZip f) xss yss, SListI xss, SListI yss, SameShapeAs xss yss, SameShapeAs yss xss) => AllZip2 f xss yss---- | 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 'AllZip' and 'AllZip2'.------ The family 'AllZipN' expands to 'AllZip' or 'AllZip2' depending on--- whther the argument is indexed by a list or a list of lists.----type family AllZipN (h :: (k -> *) -> (l -> *)) (c :: k1 -> k2 -> Constraint) :: l1 -> l2 -> 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

@@ -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

@@ -1,7 +1,5 @@-{-# LANGUAGE PolyKinds, UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 780+{-# LANGUAGE EmptyCase, PolyKinds, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-#endif -- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'. -- -- The technique being used here is described in the following paper:@@ -15,125 +13,49 @@   , GFrom   , GTo   , GDatatypeInfo-#if MIN_VERSION_base(4,9,0)   , GDatatypeInfoOf-#endif   , 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-#if !(MIN_VERSION_base(4,9,0))-import Generics.SOP.Constraint as SOP-#endif-#if MIN_VERSION_base(4,9,0) import qualified Generics.SOP.Type.Metadata as SOP.T-#endif import Generics.SOP.Metadata as SOP-#if !(MIN_VERSION_base(4,9,0))-import Generics.SOP.Sing-#endif -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--#if !(MIN_VERSION_base(4,9,0))-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--#endif--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--data IsNewtypeShape (xss :: [[*]]) where-  NewYes :: ConstructorInfo '[x] -> IsNewtypeShape '[ '[x] ]-  NewNo  :: IsNewtypeShape xss--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--class GConstructorInfos (a :: * -> *) where-  gConstructorInfos :: proxy a -> NP ConstructorInfo xss -> NP ConstructorInfo (ToSumCode a xss)--instance (GConstructorInfos a, GConstructorInfos b) => GConstructorInfos (a :+: b) where-  gConstructorInfos _ xss = gConstructorInfos (Proxy :: Proxy a) (gConstructorInfos (Proxy :: Proxy b) xss)--instance GConstructorInfos GHC.V1 where-  gConstructorInfos _ xss = xss--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-#endif+data InfoProxy (c :: Meta) (f :: Type -> Type) (x :: Type) = InfoProxy -#if MIN_VERSION_base(4,9,0)-type family ToInfo (a :: * -> *) :: SOP.T.DatatypeInfo+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 '[]) type instance ToInfo (M1 D (MetaData n m p True) a) =   SOP.T.Newtype m n (ToSingleConstructorInfo a) -type family ToSumInfo (a :: * -> *) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo]+type family ToSumInfo (a :: Type -> Type) (xs :: [SOP.T.ConstructorInfo]) :: [SOP.T.ConstructorInfo] type instance ToSumInfo (a :+: b)  xs = ToSumInfo a (ToSumInfo b xs) type instance ToSumInfo V1         xs = xs type instance ToSumInfo (M1 C c a) xs = ToSingleConstructorInfo (M1 C c a) ': xs -type family ToSingleConstructorInfo (a :: * -> *) :: SOP.T.ConstructorInfo+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) =@@ -141,16 +63,15 @@ type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) =   SOP.T.Record n (ToProductInfo a '[]) -type family ToProductInfo (a :: * -> *) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo]+type family ToProductInfo (a :: Type -> Type) (xs :: [SOP.T.FieldInfo]) :: [SOP.T.FieldInfo] type instance ToProductInfo (a :*: b)  xs = ToProductInfo a (ToProductInfo b xs) type instance ToProductInfo U1         xs = xs type instance ToProductInfo (M1 S c a) xs = ToSingleInfo (M1 S c a) ': xs -type family ToSingleInfo (a :: * -> *) :: SOP.T.FieldInfo+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-#endif -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@@ -165,13 +86,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@@ -183,13 +104,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@@ -197,18 +118,19 @@  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+class GSumFrom (a :: Type -> Type) where   gSumFrom :: a x -> SOP I 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 (R1 b) xss = gSumSkip (Proxy :: Proxy a) (gSumFrom b xss)@@ -223,9 +145,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) @@ -244,7 +169,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)@@ -253,19 +178,13 @@ type GTo a = GSumTo (GHC.Rep a)  -- | Constraint for the class that computes 'gdatatypeInfo'.-#if MIN_VERSION_base(4,9,0) type GDatatypeInfo a = SOP.T.DemoteDatatypeInfo (GDatatypeInfoOf a) (GCode a)-#else-type GDatatypeInfo a = GDatatypeInfo' (GHC.Rep a)-#endif -#if MIN_VERSION_base(4,9,0) -- | Compute the datatype info of a datatype. -- -- @since 0.3.0.0 ---type GDatatypeInfoOf (a :: *) = ToInfo (GHC.Rep a)-#endif+type GDatatypeInfoOf (a :: Type) = ToInfo (GHC.Rep a)  -- | An automatically computed version of 'Generics.SOP.from'. --@@ -287,7 +206,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'. --@@ -298,9 +217,5 @@ -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a)-#if MIN_VERSION_base(4,9,0) gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a))-#else-gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a))-#endif 

@@ -1,11 +1,8 @@+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE TemplateHaskell #-} {-# 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 +13,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.Event -- new+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 +76,7 @@ deriveGeneric ''I deriveGeneric ''K deriveGeneric ''(:.:)+deriveGeneric ''(-.->) -- new  -- Cannot derive instances for Sing -- Cannot derive instances for Shape@@ -101,6 +133,7 @@ deriveGeneric ''NestedAtomically deriveGeneric ''BlockedIndefinitelyOnMVar deriveGeneric ''BlockedIndefinitelyOnSTM+deriveGeneric ''AllocationLimitExceeded -- new deriveGeneric ''Deadlock deriveGeneric ''NoMethodError deriveGeneric ''PatternMatchFail@@ -108,6 +141,7 @@ deriveGeneric ''RecSelError deriveGeneric ''RecUpdError deriveGeneric ''ErrorCall+deriveGeneric ''TypeError -- new deriveGeneric ''MaskingState  -- From Data.Char:@@ -123,16 +157,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 +200,21 @@ -- 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+deriveGeneric ''Data.Semigroup.Option -- new+deriveGeneric ''Data.Semigroup.Arg -- new+ -- From Data.Version: deriveGeneric ''Version +-- From Data.Void:+deriveGeneric ''Void -- new+ -- From Foreign.C.Error: deriveGeneric ''Errno @@ -173,6 +245,113 @@ 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.Event(.Inernal):+deriveGeneric ''Lifetime -- new++-- From GHC.ExecutionStack:+deriveGeneric ''Location -- new+deriveGeneric ''SrcLoc -- new++-- From GHC.Exts:+deriveGeneric ''RuntimeRep -- new+deriveGeneric ''VecCount -- new+deriveGeneric ''VecElem -- new+deriveGeneric ''SpecConstrAnnotation -- new++-- 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 +372,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 +434,13 @@ -- Weak -- ReadP -- ReadPrec+-- STM+-- TVar+-- Natural+-- Event+-- EventManager+-- CostCentre+-- CostCentreStack -- -- Datatypes we cannot currently handle: --

@@ -17,11 +17,11 @@   , Associativity(..)   ) where +import Data.Kind (Type) import GHC.Generics (Associativity(..))  import Generics.SOP.Constraint import Generics.SOP.NP-import Generics.SOP.Sing  -- | Metadata for a datatype. --@@ -33,7 +33,7 @@ -- 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   -- Newtype@@ -71,7 +71,7 @@ -- -- 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@@ -93,7 +93,7 @@ deriving instance (All (Eq `Compose` FieldInfo) xs, All (Ord `Compose` FieldInfo) xs) => Ord (ConstructorInfo xs)  -- | 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) 

@@ -1,889 +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-    -- * Folding and sequencing-  , ctraverse__NP-  , ctraverse__POP-  , traverse__NP-  , traverse__POP-  , cfoldMap_NP-  , cfoldMap_POP-  , sequence'_NP-  , sequence'_POP-  , sequence_NP-  , sequence_POP-  , ctraverse'_NP-  , ctraverse'_POP-  , traverse'_NP-  , traverse'_POP-  , ctraverse_NP-  , ctraverse_POP-    -- * Catamorphism and anamorphism-  , cata_NP-  , ccata_NP-  , ana_NP-  , cana_NP-    -- * Transformation of index lists and coercions-  , trans_NP-  , trans_POP-  , coerce_NP-  , coerce_POP-  , fromI_NP-  , fromI_POP-  , toI_NP-  , toI_POP+  (+    module Data.SOP.NP   ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Monoid (Monoid (..))-#endif-import Data.Coerce-import Data.Proxy (Proxy(..))-import Unsafe.Coerce--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 :*---- This is written manually,--- because built-in deriving doesn't use associativity information!-instance All (Show `Compose` f) xs => Show (NP f xs) where-  showsPrec _ Nil       = showString "Nil"-  showsPrec d (f :* fs) = showParen (d > 5)-    $ showsPrec (5 + 1) f-    . showString " :* "-    . showsPrec 5 fs--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 AllZipN NP  c = AllZip  c-type instance AllZipN POP c = AllZip2 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 Same NP  = NP-type instance Same POP = POP--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---- * Folding---- | Specialization of 'hctraverse_'.------ @since 0.3.2.0----ctraverse__NP ::-     forall c proxy xs f g. (All c xs, Applicative g)-  => proxy c -> (forall a. c a => f a -> g ()) -> NP f xs -> g ()-ctraverse__NP _ f = go-  where-    go :: All c ys => NP f ys -> g ()-    go Nil       = pure ()-    go (x :* xs) = f x *> go xs---- | Specialization of 'htraverse_'.------ @since 0.3.2.0----traverse__NP ::-     forall xs f g. (SListI xs, Applicative g)-  => (forall a. f a -> g ()) -> NP f xs -> g ()-traverse__NP f = go-  where-    go :: NP f ys -> g ()-    go Nil       = pure ()-    go (x :* xs) = f x *> go xs---- | Specialization of 'hctraverse_'.------ @since 0.3.2.0----ctraverse__POP ::-     forall c proxy xss f g. (All2 c xss, Applicative g)-  => proxy c -> (forall a. c a => f a -> g ()) -> POP f xss -> g ()-ctraverse__POP p f = ctraverse__NP (allP p) (ctraverse__NP p f) . unPOP---- | Specialization of 'htraverse_'.------ @since 0.3.2.0----traverse__POP ::-     forall xss f g. (SListI2 xss, Applicative g)-  => (forall a. f a -> g ()) -> POP f xss -> g ()-traverse__POP f = ctraverse__NP sListP (traverse__NP f) . unPOP--instance HTraverse_ NP  where-  hctraverse_ = ctraverse__NP-  htraverse_  = traverse__NP--instance HTraverse_ POP where-  hctraverse_ = ctraverse__POP-  htraverse_  = traverse__POP---- | Specialization of 'hcfoldMap'.------ @since 0.3.2.0----cfoldMap_NP :: (All c xs, Monoid m) => proxy c -> (forall a. c a => f a -> m) -> NP f xs -> m-cfoldMap_NP  = hcfoldMap---- | Specialization of 'hcfoldMap'.------ @since 0.3.2.0----cfoldMap_POP :: (All2 c xs, Monoid m) => proxy c -> (forall a. c a => f a -> m) -> POP f xs -> m-cfoldMap_POP = hcfoldMap---- * Sequencing---- | Specialization of 'hsequence''.-sequence'_NP  ::              Applicative f  => NP  (f :.: g) xs  -> f (NP  g xs)-sequence'_NP Nil         = pure Nil-sequence'_NP (mx :* mxs) = (:*) <$> unComp mx <*> sequence'_NP mxs---- | Specialization of 'hsequence''.-sequence'_POP :: (SListI xss, Applicative f) => POP (f :.: g) xss -> f (POP g xss)-sequence'_POP = fmap POP . sequence'_NP . hliftA (Comp . sequence'_NP) . unPOP---- | Specialization of 'hctraverse''.------ @since 0.3.2.0----ctraverse'_NP  ::-     forall c proxy xs f f' g. (All c xs,  Applicative g)-  => proxy c -> (forall a. c a => f a -> g (f' a)) -> NP f xs  -> g (NP f' xs)-ctraverse'_NP _ f = go where-  go :: All c ys => NP f ys -> g (NP f' ys)-  go Nil       = pure Nil-  go (x :* xs) = (:*) <$> f x <*> go xs---- | Specialization of 'htraverse''.------ @since 0.3.2.0----traverse'_NP  ::-     forall xs f f' g. (SListI xs,  Applicative g)-  => (forall a. f a -> g (f' a)) -> NP f xs  -> g (NP f' xs)-traverse'_NP f = go where-  go :: NP f ys -> g (NP f' ys)-  go Nil       = pure Nil-  go (x :* xs) = (:*) <$> f x <*> go xs---- | Specialization of 'hctraverse''.------ @since 0.3.2.0----ctraverse'_POP :: (All2 c xss, Applicative g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> POP f xss -> g (POP f' xss)-ctraverse'_POP p f = fmap POP . ctraverse'_NP (allP p) (ctraverse'_NP p f) . unPOP---- | Specialization of 'hctraverse''.------ @since 0.3.2.0----traverse'_POP :: (SListI2 xss, Applicative g) => (forall a. f a -> g (f' a)) -> POP f xss -> g (POP f' xss)-traverse'_POP f = fmap POP . ctraverse'_NP sListP (traverse'_NP f) . unPOP--instance HSequence NP  where-  hsequence'  = sequence'_NP-  hctraverse' = ctraverse'_NP-  htraverse'  = traverse'_NP--instance HSequence POP where-  hsequence'  = sequence'_POP-  hctraverse' = ctraverse'_POP-  htraverse'  = traverse'_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---- | Specialization of 'hctraverse'.------ @since 0.3.2.0----ctraverse_NP  :: (All  c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g a) -> NP  f xs -> g (NP  I xs)---- | Specialization of 'hctraverse'.------ @since 0.3.2.0----ctraverse_POP :: (All2 c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g a) -> POP f xs -> g (POP I xs)--ctraverse_NP  = hctraverse-ctraverse_POP = hctraverse---- * 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'---- | Specialization of 'htrans'.------ @since 0.3.1.0----trans_NP ::-     AllZip c xs ys-  => proxy c-  -> (forall x y . c x y => f x -> g y)-  -> NP f xs -> NP g ys-trans_NP _ _t Nil       = Nil-trans_NP p  t (x :* xs) = t x :* trans_NP p t xs---- | Specialization of 'htrans'.------ @since 0.3.1.0----trans_POP ::-     AllZip2 c xss yss-  => proxy c-  -> (forall x y . c x y => f x -> g y)-  -> POP f xss -> POP g yss-trans_POP p t =-  POP . trans_NP (allZipP p) (trans_NP p t) . unPOP--allZipP :: proxy c -> Proxy (AllZip c)-allZipP _ = Proxy---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----coerce_NP ::-     forall f g xs ys .-     AllZip (LiftedCoercible f g) xs ys-  => NP f xs -> NP g ys-coerce_NP =-  unsafeCoerce---- There is a bug in the way coerce works for higher-kinded--- type variables that seems to occur only in GHC 7.10.------ Therefore, the safe versions of the coercion functions--- are excluded below. This is harmless because they're only--- present for documentation purposes and not exported.--#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800-_safe_coerce_NP ::-     forall f g xs ys .-     AllZip (LiftedCoercible f g) xs ys-  => NP f xs -> NP g ys-_safe_coerce_NP =-  trans_NP (Proxy :: Proxy (LiftedCoercible f g)) coerce-#endif---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----coerce_POP ::-     forall f g xss yss .-     AllZip2 (LiftedCoercible f g) xss yss-  => POP f xss -> POP g yss-coerce_POP =-  unsafeCoerce--#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800-_safe_coerce_POP ::-     forall f g xss yss .-     AllZip2 (LiftedCoercible f g) xss yss-  => POP f xss -> POP g yss-_safe_coerce_POP =-  trans_POP (Proxy :: Proxy (LiftedCoercible f g)) coerce-#endif---- | Specialization of 'hfromI'.------ @since 0.3.1.0----fromI_NP ::-     forall f xs ys .-     AllZip (LiftedCoercible I f) xs ys-  => NP I xs -> NP f ys-fromI_NP = hfromI---- | Specialization of 'htoI'.------ @since 0.3.1.0----toI_NP ::-     forall f xs ys .-     AllZip (LiftedCoercible f I) xs ys-  => NP f xs -> NP I ys-toI_NP = htoI---- | Specialization of 'hfromI'.------ @since 0.3.1.0----fromI_POP ::-     forall f xss yss .-     AllZip2 (LiftedCoercible I f) xss yss-  => POP I xss -> POP f yss-fromI_POP = hfromI---- | Specialization of 'htoI'.------ @since 0.3.1.0----toI_POP ::-     forall f xss yss .-     AllZip2 (LiftedCoercible f I) xss yss-  => POP f xss -> POP I yss-toI_POP = htoI--instance HTrans NP NP where-  htrans  = trans_NP-  hcoerce = coerce_NP-instance HTrans POP POP where-  htrans  = trans_POP-  hcoerce = coerce_POP+import Data.SOP.NP

@@ -1,984 +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-    -- * Comparison-  , compare_NS-  , ccompare_NS-  , compare_SOP-  , ccompare_SOP-    -- * Collapsing-  , collapse_NS-  , collapse_SOP-    -- * Folding and sequencing-  , ctraverse__NS-  , ctraverse__SOP-  , traverse__NS-  , traverse__SOP-  , cfoldMap_NS-  , cfoldMap_SOP-  , sequence'_NS-  , sequence'_SOP-  , sequence_NS-  , sequence_SOP-  , ctraverse'_NS-  , ctraverse'_SOP-  , traverse'_NS-  , traverse'_SOP-  , ctraverse_NS-  , ctraverse_SOP-    -- * Catamorphism and anamorphism-  , cata_NS-  , ccata_NS-  , ana_NS-  , cana_NS-    -- * Expanding sums to products-  , expand_NS-  , cexpand_NS-  , expand_SOP-  , cexpand_SOP-    -- * Transformation of index lists and coercions-  , trans_NS-  , trans_SOP-  , coerce_NS-  , coerce_SOP-  , fromI_NS-  , fromI_SOP-  , toI_NS-  , toI_SOP+  (+    module Data.SOP.NS   ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative-import Data.Monoid (Monoid)-#endif-import Data.Coerce-import Data.Proxy-import Unsafe.Coerce--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--type instance AllN NS  c = All  c-type instance AllN SOP c = All2 c---- | 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 Same NS  = NS-type instance Same SOP = SOP--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'---- * Comparison---- | Compare two sums with respect to the choice they--- are making.------ A value that chooses the first option--- is considered smaller than one that chooses the second--- option.------ If the choices are different, then either the first--- (if the first is smaller than the second)--- or the third (if the first is larger than the second)--- argument are called. If both choices are equal, then the--- second argument is called, which has access to the--- elements contained in the sums.------ @since 0.3.2.0----compare_NS ::-     forall r f g xs .-     r                             -- ^ what to do if first is smaller-  -> (forall x . f x -> g x -> r)  -- ^ what to do if both are equal-  -> r                             -- ^ what to do if first is larger-  -> NS f xs -> NS g xs-  -> r-compare_NS lt eq gt = go-  where-    go :: forall ys . NS f ys -> NS g ys -> r-    go (Z x)  (Z y)  = eq x y-    go (Z _)  (S _)  = lt-    go (S _)  (Z _)  = gt-    go (S xs) (S ys) = go xs ys---- | Constrained version of 'compare_NS'.------ @since 0.3.2.0----ccompare_NS ::-     forall c proxy r f g xs .-     (All c xs)-  => proxy c-  -> r                                    -- ^ what to do if first is smaller-  -> (forall x . c x => f x -> g x -> r)  -- ^ what to do if both are equal-  -> r                                    -- ^ what to do if first is larger-  -> NS f xs -> NS g xs-  -> r-ccompare_NS _ lt eq gt = go-  where-    go :: forall ys . (All c ys) => NS f ys -> NS g ys -> r-    go (Z x)  (Z y)  = eq x y-    go (Z _)  (S _)  = lt-    go (S _)  (Z _)  = gt-    go (S xs) (S ys) = go xs ys---- | Compare two sums of products with respect to the--- choice in the sum they are making.------ Only the sum structure is used for comparison.--- This is a small wrapper around 'ccompare_NS' for--- a common special case.------ @since 0.3.2.0----compare_SOP ::-     forall r f g xss .-     r                                      -- ^ what to do if first is smaller-  -> (forall xs . NP f xs -> NP g xs -> r)  -- ^ what to do if both are equal-  -> r                                      -- ^ what to do if first is larger-  -> SOP f xss -> SOP g xss-  -> r-compare_SOP lt eq gt (SOP xs) (SOP ys) =-  compare_NS lt eq gt xs ys---- | Constrained version of 'compare_SOP'.------ @since 0.3.2.0----ccompare_SOP ::-     forall c proxy r f g xss .-     (All2 c xss)-  => proxy c-  -> r                                                  -- ^ what to do if first is smaller-  -> (forall xs . All c xs => NP f xs -> NP g xs -> r)  -- ^ what to do if both are equal-  -> r                                                  -- ^ what to do if first is larger-  -> SOP f xss -> SOP g xss-  -> r-ccompare_SOP p lt eq gt (SOP xs) (SOP ys) =-  ccompare_NS (allP p) lt eq gt xs ys---- * 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---- * Folding---- | Specialization of 'hctraverse_'.------ /Note:/ we don't need 'Applicative' constraint.------ @since 0.3.2.0----ctraverse__NS ::-     forall c proxy xs f g. (All c xs)-  => proxy c -> (forall a. c a => f a -> g ()) -> NS f xs -> g ()-ctraverse__NS _ f = go-  where-    go :: All c ys => NS f ys -> g ()-    go (Z x)  = f x-    go (S xs) = go xs---- | Specialization of 'htraverse_'.------ /Note:/ we don't need 'Applicative' constraint.------ @since 0.3.2.0----traverse__NS ::-     forall xs f g. (SListI xs)-  => (forall a. f a -> g ()) -> NS f xs -> g ()-traverse__NS f = go-  where-    go :: NS f ys -> g ()-    go (Z x)  = f x-    go (S xs) = go xs---- | Specialization of 'hctraverse_'.------ @since 0.3.2.0----ctraverse__SOP ::-     forall c proxy xss f g. (All2 c xss, Applicative g)-  => proxy c -> (forall a. c a => f a -> g ()) -> SOP f xss -> g ()-ctraverse__SOP p f = ctraverse__NS (allP p) (ctraverse__NP p f) . unSOP---- | Specialization of 'htraverse_'.------ @since 0.3.2.0----traverse__SOP ::-     forall xss f g. (SListI2 xss, Applicative g)-  => (forall a. f a -> g ()) -> SOP f xss -> g ()-traverse__SOP f = ctraverse__NS sListP (traverse__NP f) . unSOP--sListP :: Proxy SListI-sListP = Proxy--instance HTraverse_ NS  where-  hctraverse_ = ctraverse__NS-  htraverse_  = traverse__NS--instance HTraverse_ SOP where-  hctraverse_ = ctraverse__SOP-  htraverse_  = traverse__SOP---- | Specialization of 'hcfoldMap'.------ /Note:/ We don't need 'Monoid' instance.------ @since 0.3.2.0----cfoldMap_NS ::-     forall c proxy f xs m. (All c xs)-  => proxy c -> (forall a. c a => f a -> m) -> NS f xs -> m-cfoldMap_NS _ f = go-  where-    go :: All c ys => NS f ys -> m-    go (Z x)  = f x-    go (S xs) = go xs---- | Specialization of 'hcfoldMap'.------ @since 0.3.2.0----cfoldMap_SOP :: (All2 c xs, Monoid m) => proxy c -> (forall a. c a => f a -> m) -> SOP f xs -> m-cfoldMap_SOP = hcfoldMap---- * Sequencing---- | Specialization of 'hsequence''.-sequence'_NS  ::              Applicative f  => NS  (f :.: g) xs  -> f (NS  g xs)-sequence'_NS (Z mx)  = Z <$> unComp mx-sequence'_NS (S mxs) = S <$> sequence'_NS mxs---- | Specialization of 'hsequence''.-sequence'_SOP :: (SListI xss, Applicative f) => SOP (f :.: g) xss -> f (SOP g xss)-sequence'_SOP = fmap SOP . sequence'_NS . hliftA (Comp . sequence'_NP) . unSOP---- | Specialization of 'hctraverse''.------ /Note:/ as 'NS' has exactly one element, the 'Functor' constraint is enough.------ @since 0.3.2.0----ctraverse'_NS  ::-     forall c proxy xs f f' g. (All c xs,  Functor g)-  => proxy c -> (forall a. c a => f a -> g (f' a)) -> NS f xs  -> g (NS f' xs)-ctraverse'_NS _ f = go where-  go :: All c ys => NS f ys -> g (NS f' ys)-  go (Z x)  = Z <$> f x-  go (S xs) = S <$> go xs---- | Specialization of 'htraverse''.------ /Note:/ as 'NS' has exactly one element, the 'Functor' constraint is enough.------ @since 0.3.2.0----traverse'_NS  ::-     forall xs f f' g. (SListI xs,  Functor g)-  => (forall a. f a -> g (f' a)) -> NS f xs  -> g (NS f' xs)-traverse'_NS f = go where-  go :: NS f ys -> g (NS f' ys)-  go (Z x)  = Z <$> f x-  go (S xs) = S <$> go xs---- | Specialization of 'hctraverse''.------ @since 0.3.2.0----ctraverse'_SOP :: (All2 c xss, Applicative g) => proxy c -> (forall a. c a => f a -> g (f' a)) -> SOP f xss -> g (SOP f' xss)-ctraverse'_SOP p f = fmap SOP . ctraverse'_NS (allP p) (ctraverse'_NP p f) . unSOP---- | Specialization of 'htraverse''.------ @since 0.3.2.0----traverse'_SOP :: (SListI2 xss, Applicative g) => (forall a. f a -> g (f' a)) -> SOP f xss -> g (SOP f' xss)-traverse'_SOP f = fmap SOP . ctraverse'_NS sListP (traverse'_NP f) . unSOP--instance HSequence NS  where-  hsequence'  = sequence'_NS-  hctraverse' = ctraverse'_NS-  htraverse'  = traverse'_NS--instance HSequence SOP where-  hsequence'  = sequence'_SOP-  hctraverse' = ctraverse'_SOP-  htraverse'  = traverse'_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---- | Specialization of 'hctraverse'.------ @since 0.3.2.0----ctraverse_NS  :: (All  c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g a) -> NP  f xs -> g (NP  I xs)---- | Specialization of 'hctraverse'.------ @since 0.3.2.0----ctraverse_SOP :: (All2 c xs, Applicative g) => proxy c -> (forall a. c a => f a -> g a) -> POP f xs -> g (POP I xs)--ctraverse_NS = hctraverse-ctraverse_SOP = hctraverse---- * 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---- | Specialization of 'htrans'.------ @since 0.3.1.0----trans_NS ::-     AllZip c xs ys-  => proxy c-  -> (forall x y . c x y => f x -> g y)-  -> NS f xs -> NS g ys-trans_NS _ t (Z x)      = Z (t x)-trans_NS p t (S x)      = S (trans_NS p t x)---- | Specialization of 'htrans'.------ @since 0.3.1.0----trans_SOP ::-     AllZip2 c xss yss-  => proxy c-  -> (forall x y . c x y => f x -> g y)-  -> SOP f xss -> SOP g yss-trans_SOP p t =-  SOP . trans_NS (allZipP p) (trans_NP p t) . unSOP--allZipP :: proxy c -> Proxy (AllZip c)-allZipP _ = Proxy---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----coerce_NS ::-     forall f g xs ys .-     AllZip (LiftedCoercible f g) xs ys-  => NS f xs -> NS g ys-coerce_NS =-  unsafeCoerce---- There is a bug in the way coerce works for higher-kinded--- type variables that seems to occur only in GHC 7.10.------ Therefore, the safe versions of the coercion functions--- are excluded below. This is harmless because they're only--- present for documentation purposes and not exported.--#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800-_safe_coerce_NS ::-     forall f g xs ys .-     AllZip (LiftedCoercible f g) xs ys-  => NS f xs -> NS g ys-_safe_coerce_NS =-  trans_NS (Proxy :: Proxy (LiftedCoercible f g)) coerce-#endif---- | Specialization of 'hcoerce'.------ @since 0.3.1.0----coerce_SOP ::-     forall f g xss yss .-     AllZip2 (LiftedCoercible f g) xss yss-  => SOP f xss -> SOP g yss-coerce_SOP =-  unsafeCoerce--#if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 800-_safe_coerce_SOP ::-     forall f g xss yss .-     AllZip2 (LiftedCoercible f g) xss yss-  => SOP f xss -> SOP g yss-_safe_coerce_SOP =-  trans_SOP (Proxy :: Proxy (LiftedCoercible f g)) coerce-#endif---- | Specialization of 'hfromI'.------ @since 0.3.1.0----fromI_NS ::-     forall f xs ys .-     AllZip (LiftedCoercible I f) xs ys-  => NS I xs -> NS f ys-fromI_NS = hfromI---- | Specialization of 'htoI'.------ @since 0.3.1.0----toI_NS ::-     forall f xs ys .-     AllZip (LiftedCoercible f I) xs ys-  => NS f xs -> NS I ys-toI_NS = htoI---- | Specialization of 'hfromI'.------ @since 0.3.1.0----fromI_SOP ::-     forall f xss yss .-     AllZip2 (LiftedCoercible I f) xss yss-  => SOP I xss -> SOP f yss-fromI_SOP = hfromI---- | Specialization of 'htoI'.------ @since 0.3.1.0----toI_SOP ::-     forall f xss yss .-     AllZip2 (LiftedCoercible f I) xss yss-  => SOP f xss -> SOP I yss-toI_SOP = htoI--instance HTrans NS NS where-  htrans  = trans_NS-  hcoerce = coerce_NS--instance HTrans SOP SOP where-  htrans  = trans_SOP-  hcoerce = coerce_SOP+import Data.SOP.NS

@@ -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

@@ -3,12 +3,15 @@ module Generics.SOP.TH   ( deriveGeneric   , deriveGenericOnly+  , deriveGenericSubst+  , deriveGenericOnlySubst   , deriveGenericFunctions   , deriveMetadataValue   , deriveMetadataType   ) where  import Control.Monad (replicateM)+import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.Proxy import Language.Haskell.TH@@ -51,7 +54,7 @@ -- > -- >   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 -- >   type DatatypeInfoOf Tree =@@ -66,18 +69,34 @@ -- 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+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 <- reifyDec n-  withDataDec dec deriveGenericForDataDec+  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 <- reifyDec n+  withDataDec dec (deriveGenericForDataDec f)+ -- | Like 'deriveGenericOnly', but don't derive class instance, only functions. -- -- /Example:/ If you say@@ -95,7 +114,7 @@ -- > 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 --@@ -106,9 +125,9 @@   let toName'   = mkName toName   dec <- reifyDec n   withDataDec dec $ \_isNewtype _cxt name bndrs cons _derivs -> do-    let codeType = codeFor cons                        -- '[ '[Int], '[Tree, Tree] ]-    let origType = appTyVars name bndrs                -- Tree-    let repType  = [t| SOP I $(appTyVars codeName' bndrs) |] -- SOP I TreeCode+    let codeType = codeFor varT cons                     -- '[ '[Int], '[Tree, Tree] ]+    let origType = appTyVars varT name bndrs             -- Tree+    let repType  = [t| SOP I $(appTyVars varT codeName' bndrs) |] -- SOP I TreeCode     sequence       [ tySynD codeName' bndrs codeType                 -- type TreeCode = '[ '[Int], '[Tree, Tree] ]       , sigD fromName' [t| $origType -> $repType |]     -- fromTree :: Tree -> SOP I TreeCode@@ -166,23 +185,29 @@     sequence       [ tySynD datatypeInfoName' [] (metadataType' isNewtype name cons) ] -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+deriveGenericForDataDec ::+  (Name -> Q Type) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]+deriveGenericForDataDec f _isNewtype _cxt name bndrs cons _derivs = do+  let typ = appTyVars f name bndrs+  deriveGenericForDataType f typ cons++deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [Con] -> Q [Dec]+deriveGenericForDataType f typ cons = do+  let codeSyn = tySynInstD ''Code $ tySynEqn [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) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]+deriveMetadataForDataDec f isNewtype _cxt name bndrs cons _derivs = do+  let typ = appTyVars f name bndrs+  deriveMetadataForDataType isNewtype name typ cons++deriveMetadataForDataType :: Bool -> Name -> Q Type -> [Con] -> Q [Dec]+deriveMetadataForDataType isNewtype name typ cons = do   md   <- instanceD (cxt [])             [t| HasDatatypeInfo $typ |]             [ metadataType typ isNewtype name cons@@ -195,17 +220,16 @@             -- [metadata isNewtype name cons]   return [md] - {-------------------------------------------------------------------------------   Computing the code for a data type -------------------------------------------------------------------------------} -codeFor :: [Con] -> Q Type-codeFor = promotedTypeList . map go+codeFor :: (Name -> Q Type) -> [Con] -> Q Type+codeFor f = promotedTypeList . map go   where     go :: Con -> Q Type     go c = do (_, ts) <- conInfo c-              promotedTypeList ts+              promotedTypeListSubst f ts  {-------------------------------------------------------------------------------   Computing the embedding/projection pair@@ -233,31 +257,44 @@              []  projection :: Name -> [Con] -> Q Dec-projection toName = funD toName . go' (\p -> conP 'Z [p])+projection toName = funD toName . go'   where-    go' :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause]-    go' _ [] = (:[]) $ do+    go' :: [Con] -> [Q Clause]+    go' [] = (:[]) $ do       x <- newName "x"       clause [varP x] (normalB (caseE (varE x) [])) []-    go' br cs = go br cs+    go' cs = go id cs      go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause]-    go _ [] = [unreachable]+    go br [] = [mkUnreachableClause br]     go br (c:cs) = mkClause br c : go (\p -> conP 'S [br p]) cs +    -- Generates a final clause of the form:+    --+    --   to (S (... (S x))) = x `seq` error "inaccessible"+    --+    -- An equivalent way of achieving this would be:+    --+    --   to (S (... (S x))) = case x of {}+    --+    -- This, however, would require clients to enable the EmptyCase extension+    -- in their own code, which is something which we have not previously+    -- required. Therefore, we do not generate this code at the moment.+    mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause+    mkUnreachableClause br = do+      var <- newName "x"+      clause [conP 'SOP [br (varP var)]]+             (normalB [| $(varE var) `seq` error "inaccessible" |])+             []+     mkClause :: (Q Pat -> Q Pat) -> Con -> 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 -------------------------------------------------------------------------------}@@ -287,24 +324,13 @@                                                $(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      mdField :: VarStrictType -> Q Exp     mdField (n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |]@@ -335,24 +361,13 @@                                                    $(promotedTypeList (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                             [t| 'SOP.T.Infix       $(stringT (nameBase n)) $(mdAssociativity a) $(natT 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      mdField :: VarStrictType -> Q Type     mdField (n, _, _) = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |]@@ -394,10 +409,8 @@ 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  stringT :: String -> Q Type stringT = litT . strTyLit@@ -409,13 +422,36 @@ promotedTypeList []     = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] -appTyVars :: Name -> [TyVarBndr] -> Q Type-appTyVars n = go (conT n)+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)++bndrToName :: TyVarBndr -> Name+bndrToName (PlainTV  v  ) = v+bndrToName (KindedTV v _) = v++appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type+appTyVars f n bndrs =+  appsT n (map (f . bndrToName) bndrs)++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 =@@ -424,20 +460,13 @@                   _          -> fail "Info must be type declaration type."  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-#endif withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes."  -- | 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]+type Derivings = Cxt #endif

@@ -1,4 +1,6 @@-{-# LANGUAGE PolyKinds, UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- | Type-level metadata -- -- This module provides datatypes (to be used promoted) that can represent the@@ -31,11 +33,10 @@   , Associativity(..)   ) where -import Data.Proxy+import Data.Kind (Type)+import Data.Proxy (Proxy (..)) import GHC.Generics (Associativity(..))-#if __GLASGOW_HASKELL__ >= 800 import GHC.Types-#endif import GHC.TypeLits  import qualified Generics.SOP.Metadata as M@@ -61,51 +62,30 @@ -- @since 0.3.0.0 -- data DatatypeInfo =-#if __GLASGOW_HASKELL__ >= 800     ADT ModuleName DatatypeName [ConstructorInfo]     -- ^ Standard algebraic datatype   | Newtype ModuleName DatatypeName ConstructorInfo     -- ^ Newtype-#else-    ADT Symbol Symbol [ConstructorInfo]-    -- ^ Standard algebraic datatype-  | Newtype Symbol Symbol ConstructorInfo-    -- ^ Newtype-#endif  -- | Metadata for a single constructors (to be used promoted). -- -- @since 0.3.0.0 -- data ConstructorInfo =-#if __GLASGOW_HASKELL__ >= 800     Constructor ConstructorName     -- ^ Normal constructor   | Infix ConstructorName Associativity Fixity     -- ^ Infix constructor   | Record ConstructorName [FieldInfo]     -- ^ Record constructor-#else-    Constructor Symbol-    -- ^ Normal constructor-  | Infix Symbol Associativity Nat-    -- ^ Infix constructor-  | Record Symbol [FieldInfo]-    -- ^ Record constructor-#endif  -- | Metadata for a single record field (to be used promoted). -- -- @since 0.3.0.0 -- data FieldInfo =-#if __GLASGOW_HASKELL__ >= 800     FieldInfo FieldName-#else-    FieldInfo Symbol-#endif -#if __GLASGOW_HASKELL__ >= 800 -- | The name of a datatype. type DatatypeName    = Symbol @@ -120,7 +100,6 @@  -- | The fixity of an infix constructor. type Fixity          = Nat-#endif  -- Demotion --@@ -132,7 +111,7 @@ -- -- @since 0.3.0.0 ---class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[*]]) where+class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[Type]]) where   -- | Given a proxy of some type-level datatype information,   -- return the corresponding term-level information.   --@@ -163,7 +142,7 @@ -- -- @since 0.3.0.0 ---class DemoteConstructorInfos (cs :: [ConstructorInfo]) (xss :: [[*]]) where+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.   --@@ -185,7 +164,7 @@ -- -- @since 0.3.0.0 ---class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [*]) where+class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [Type]) where   -- | Given a proxy of some type-level constructor information,   -- return the corresponding term-level information.   --@@ -214,7 +193,7 @@ -- -- @since 0.3.0.0 ---class SListI xs => DemoteFieldInfos (fs :: [FieldInfo]) (xs :: [*]) where+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.   --@@ -235,7 +214,7 @@ -- -- @since 0.3.0.0 ---class DemoteFieldInfo (x :: FieldInfo) (a :: *) where+class DemoteFieldInfo (x :: FieldInfo) (a :: Type) where   -- | Given a proxy of some type-level field information,   -- return the corresponding term-level information.   --

@@ -1,17 +1,17 @@ {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif -- | Codes and interpretations module Generics.SOP.Universe where -import Data.Coerce (Coercible)+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@@ -94,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@@ -112,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.@@ -138,14 +138,10 @@ -- 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-#if MIN_VERSION_base(4,9,0)   type DatatypeInfoOf a = GDatatypeInfoOf a-#else-  type DatatypeInfoOf a = DatatypeInfoOf a-#endif    -- | Term-level datatype info; by default, the term-level datatype info is produced   -- from the type-level info.@@ -162,17 +158,55 @@ -- -- @since 0.3.1.0 ---type IsProductType (a :: *) (xs :: [*]) =+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 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.@@ -181,14 +215,58 @@ -- -- @since 0.3.1.0 ---type IsWrappedType (a :: *) (x :: *) =+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 :: *) (x :: *) =+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 #-}

@@ -1,10 +1,13 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Main (main, toTreeC) where  import qualified GHC.Generics as GHC@@ -26,7 +29,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)@@ -34,12 +49,39 @@ 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+ instance Show Tree where   show = gshow +instance Show ABC where+  show = gshow++instance Show Void where+  show = gshow++instance Enumerable ABC where+  enum = genum++instance Enumerable Void where+  enum = genum+ -- Template Haskell data TreeB = LeafB Int | NodeB TreeB TreeB @@ -48,34 +90,103 @@  deriveGeneric ''TreeB +data ABCB = AB | BB | CB++abcB :: ABCB+abcB = BB++deriveGeneric ''ABCB++data VoidB++deriveGeneric ''VoidB+ instance Show TreeB where   show = gshow +instance Show ABCB where+  show = gshow++instance Show VoidB 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+ 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"+ 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)+ 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 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 $ (enum :: [ABC])+  print $ (enum :: [Void])   print $ datatypeInfo (Proxy :: Proxy Tree)+  print $ datatypeInfo (Proxy :: Proxy Void)   print treeB+  print abcB+  print $ (enum :: [ABCB])+  print $ (enum :: [VoidB])   print $ datatypeInfo (Proxy :: Proxy TreeB)+  print $ datatypeInfo (Proxy :: Proxy VoidB)   print treeC+  print abcC+  print $ (enum :: [ABCC])+  print $ (enum :: [VoidC])   print treeDatatypeInfo   print demotedTreeDatatypeInfo   print (treeDatatypeInfo == demotedTreeDatatypeInfo)+  print (abcDatatypeInfo == demotedABCDatatypeInfo)+  print (voidDatatypeInfo == demotedVoidDatatypeInfo)   print $ convertFull tree