generics-sop-0.3.1.0/0000755000000000000000000000000013117242337012440 5ustar0000000000000000generics-sop-0.3.1.0/LICENSE0000644000000000000000000000277613117242337013461 0ustar0000000000000000Copyright (c) 2014-2015, Well-Typed LLP, Edsko de Vries, Andres Löh All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generics-sop-0.3.1.0/Setup.hs0000644000000000000000000000005613117242337014075 0ustar0000000000000000import Distribution.Simple main = defaultMain generics-sop-0.3.1.0/CHANGELOG.md0000644000000000000000000001635213117242337014260 0ustar0000000000000000# 0.3.1.0 (2017-06-11) * Add AllZip, htrans, hcoerce, hfromI, htoI. These functions are for converting between related structures that do not have common signatures. The most common application of these functions seems to be the scenario where a datatype has components that are all wrapped in a common type constructor application, e.g. a datatype where every component is a `Maybe`. Then we can use `hfromI` after `from` to turn the generically derived `SOP` of `I`s into an `SOP` of `Maybe`s (and back). * Add `IsProductType`, `IsEnumType`, `IsWrappedType` and `IsNewtype` constraint synonyms capturing specific classes of datypes. # 0.3.0.0 (2017-04-29) * No longer compatible with GHC 7.6, due to the lack of support for type-level literals. * Support type-level metadata. This is provided by the `Generics.SOP.Type.Metadata` module. The two modules `Generics.SOP.Metadata` and `Generics.SOP.Type.Metadata` export nearly the same names, so for backwards compatibility, we keep exporting `Generics.SOP.Metadata` directly from `Generics.SOP`, whereas `Generics.SOP.Type.Metadata` is supposed to be imported explicitly (and qualified). Term-level metadata is still available, but is now usually computed automatically from the type-level metadata which contains the same information, using the function `demoteDatatypeInfo`. Term-level metadata is unchanged from generics-sop-0.2, so in most cases, even if your code makes use of metadata, you should not need to change anything. If you use TH deriving, then both type-level metadata and term-level metadata is generated for you automatically, for all supported GHC versions. If you use GGP deriving, then type-level metadata is available if you use GHC 8.0 or newer. If you use GHC 7.x, then GHC.Generics supports only term-level metadata, so we cannot translate that into type-level metadata. In this combination, you cannot use code that relies on type-level metadata, so you should either upgrade GHC or switch to TH-based deriving. # 0.2.5.0 (2017-04-21) * GHC 8.2 compatibility. * Make `:.:` an instance of `Applicative`, `Foldable` and `Traversable`. * Add functions `apInjs'_NP` and `apInjs'_POP`. These are variants of `apInjs_NP` and `apInjs'_POP` that return their result as an n-ary product, rather than collapsing it into a list. * Add `hexpand` (and `expand_NS` and `expand_SOP`). These functions expand sums into products, given a default value to fill the other slots. * Add utility functions such as `mapII` or `mapIK` that lift functions into different combinations of identity and constant functors. * Add `NFData` (and lifted variants) instances for basic functors, products and sums. # 0.2.4.0 (2017-02-02) * Add `hindex` (and `index_NS` and `index_SOP`). * Add `hapInjs` as a generalization of `apInjs_NP` and `apInjs_POP`. * Make basic functors instances of lifted classes (such as `Eq1` etc). # 0.2.3.0 (2016-12-04) * Add various metadata getters * Add `hdicts`. * Add catamorphisms and anamorphisms for `NP` and `NS`. * TH compatibility changes for GHC 8.1 (master). # 0.2.2.0 (2016-07-10) * Introduced `unZ` to destruct a unary sum. * Add Haddock `@since` annotations for various functions. # 0.2.1.0 (2016-02-08) * Now includes a CHANGELOG. * Should now work with ghc-8.0.1-rc1 and -rc2 (thanks to Oleg Grenrus). * Introduced `hd` and `tl` to project out of a product, and `Projection` and `projections` as duals of `Injection` and `injections`. # 0.2.0.0 (2015-10-23) * Now tested with ghc-7.10 * Introduced names `hmap`, `hcmap`, `hzipWith`, `hczipWith` for `hliftA`, `hcliftA`, `hliftA2`, `hcliftA2`, respectively. Similarly for the specialized versions of these functions. * The constraint transformers `All` and `All2` are now defined as type classes, not type families. As a consequence, the partial applications `All c` and `All2 c` are now possible. * Because of the redefinition of `All` and `All2`, some special cases are no longer necessary. For example, `cpure_POP` can now be implemented as a nested application of `pure_NP`. * Because of the redefinition of `All` and `All2`, the functions `hcliftA'` and variants (with prime!) are now deprecated. One can easily use the normal versions instead. For example, the definition of `hcliftA'` is now simply hcliftA' p = hcliftA (allP p) where allP :: proxy c -> Proxy (All c) allP _ = Proxy * Because `All` and `All2` are now type classes, they now have superclass constraints implying that the type-level lists they are ranging over must have singletons. class (SListI xs, ...) => All c xs class (SListI xss, ...) => All2 c xss Some type signatures can be simplified due to this. * The `SingI` typeclass and `Sing` datatypes are now deprecated. The replacements are called `SListI` and `SList`. The `sing` method is now called `sList`. The difference is that the new versions reveal only the spine of the list, and contain no singleton representation for the elements anymore. For one-dimensional type-level lists, replace SingI xs => ... by SListI xs => ... For two-dimensional type-level lists, replace SingI xss => ... by All SListI xss => ... Because All itself implies `SListI xss` (see above), this constraint is equivalent to the old `Sing xss`. The old names are provided for (limited) backward compatibility. They map to the new constructs. This will work in some, but not all scenarios. The function `lengthSing` has also been renamed to `lengthSList` for consistency, and the old name is deprecated. * All `Proxy c` arguments have been replaced by `proxy c` flexible arguments, so that other type constructors can be used as proxies. * Class-level composition (`Compose`), pairing (`And`), and a trivial constraint (`Top`) have been added. Type-level map (`Map`) has been removed. Occurrences such as All c (Map f xs) should now be replaced with All (c `Compose` f) xs * There is a new module called `Generics.SOP.Dict` that contains functions for manipulating dictionaries explicitly. These can be used to prove theorems about non-trivial class constraints such as the ones that get built using `All` and `All2`. Some such theorems are provided. * There is a new TH function `deriveGenericFunctions` that derives the code of a datatype and conversion functions, but does not create a class instance. (Contributed by Oleg Grenrus.) * There is a new TH function `deriveMetadataValue` that derives a `DatatypeInfo` value for a datatype, but does not create an instance of `HasDatatypeInfo`. (Contributed by Oleg Grenrus.) * There is a very simple example file. (Contributed by Oleg Grenrus.) * The function `hcollapse` for `NS` now results in an `a` rather than an `I a`, matching the specialized version `collapse_NS`. (Suggested by Roman Cheplyaka.) # 0.1.1.2 (2015-03-27) * Updated version bounds for ghc-prim (for ghc-7.10). # 0.1.1.1 (2015-03-20) * Preparations for ghc-7.10. * Documentation fix. (Contributed by Roman Cheplyaka.) # 0.1.1 (2015-01-06) * Documentation fixes. * Add superclass constraint (TODO). * Now derive tuple instance for tuples up to 30 components. (Contributed by Michael Orlitzky.) generics-sop-0.3.1.0/generics-sop.cabal0000644000000000000000000001044213117242337016023 0ustar0000000000000000name: generics-sop version: 0.3.1.0 synopsis: Generic Programming using True Sums of Products description: A library to support the definition of generic functions. Datatypes are viewed in a uniform, structured way: the choice between constructors is represented using an n-ary sum, and the arguments of each constructor are represented using an n-ary product. . The module "Generics.SOP" is the main module of this library and contains more detailed documentation. . Examples of using this library are provided by the following packages: . * @@ basic examples, . * @@ generic pretty printing, . * @@ generically computed lenses, . * @@ generic JSON conversions. . A detailed description of the ideas behind this library is provided by the paper: . * Edsko de Vries and Andres Löh. . Workshop on Generic Programming (WGP) 2014. . license: BSD3 license-file: LICENSE author: Edsko de Vries , Andres Löh maintainer: andres@well-typed.com category: Generics build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.1.* source-repository head type: git location: https://github.com/well-typed/generics-sop library exposed-modules: Generics.SOP Generics.SOP.GGP Generics.SOP.TH Generics.SOP.Dict Generics.SOP.Type.Metadata -- exposed via Generics.SOP: 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.13, ghc-prim >= 0.3 && < 0.6, deepseq >= 1.3 && < 1.5 if !impl (ghc >= 7.8) build-depends: tagged >= 0.7 && < 0.9 if !impl (ghc >= 8.0) build-depends: transformers-compat >= 0.3 && < 0.6, transformers >= 0.3 && < 0.6 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall default-extensions: CPP ScopedTypeVariables TypeFamilies RankNTypes TypeOperators GADTs ConstraintKinds MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts DeriveFunctor DeriveFoldable DeriveTraversable DefaultSignatures KindSignatures DataKinds FunctionalDependencies if impl (ghc >= 7.8) default-extensions: AutoDeriveTypeable other-extensions: OverloadedStrings PolyKinds UndecidableInstances TemplateHaskell DeriveGeneric StandaloneDeriving if impl (ghc < 7.10) other-extensions: OverlappingInstances test-suite generics-sop-examples type: exitcode-stdio-1.0 main-is: Example.hs other-modules: HTransExample hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall build-depends: base >= 4.6 && < 5, generics-sop generics-sop-0.3.1.0/src/0000755000000000000000000000000013117242337013227 5ustar0000000000000000generics-sop-0.3.1.0/src/Generics/0000755000000000000000000000000013117242337014766 5ustar0000000000000000generics-sop-0.3.1.0/src/Generics/SOP.hs0000644000000000000000000002627413117242337015776 0ustar0000000000000000{-# LANGUAGE PolyKinds, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | Main module of @generics-sop@ -- -- In most cases, you will probably want to import just this module, -- and possibly "Generics.SOP.TH" if you want to use Template Haskell -- to generate 'Generic' instances for you. -- -- = Generic programming with sums of products -- -- You need this library if you want to define your own generic functions -- in the sum-of-products SOP style. Generic programming in the SOP style -- follows the following idea: -- -- 1. A large class of datatypes can be viewed in a uniform, structured -- way: the choice between constructors is represented using an n-ary -- sum (called 'NS'), and the arguments of each constructor are -- represented using an n-ary product (called 'NP'). -- -- 2. The library captures the notion of a datatype being representable -- in the following way. There is a class 'Generic', which for a given -- datatype @A@, associates the isomorphic SOP representation with -- the original type under the name @'Rep' A@. The class also provides -- functions 'from' and 'to' that convert between @A@ and @'Rep' A@ and -- witness the isomorphism. -- -- 3. Since all 'Rep' types are sums of products, you can define -- functions over them by performing induction on the structure, of -- by using predefined combinators that the library provides. Such -- functions then work for all 'Rep' types. -- -- 4. By combining the conversion functions 'from' and 'to' with the -- function that works on 'Rep' types, we obtain a function that works -- on all types that are in the 'Generic' class. -- -- 5. Most types can very easily be made an instance of 'Generic'. For -- example, if the datatype can be represented using GHC's built-in -- approach to generic programming and has an instance for the -- 'GHC.Generics.Generic' class from module "GHC.Generics", then an -- instance of the SOP 'Generic' can automatically be derived. There -- is also Template Haskell code in "Generics.SOP.TH" that allows to -- auto-generate an instance of 'Generic' for most types. -- -- = Example -- -- == Instantiating a datatype for use with SOP generics -- -- Let's assume we have the datatypes: -- -- > data A = C Bool | D A Int | E (B ()) -- > data B a = F | G a Char Bool -- -- To create 'Generic' instances for @A@ and @B@ via "GHC.Generics", we say -- -- > {-# LANGUAGE DeriveGeneric #-} -- > -- > import qualified GHC.Generics as GHC -- > import Generics.SOP -- > -- > data A = C Bool | D A Int | E (B ()) -- > deriving (Show, GHC.Generic) -- > data B a = F | G a Char Bool -- > deriving (Show, GHC.Generic) -- > -- > instance Generic A -- empty -- > instance Generic (B a) -- empty -- -- Now we can convert between @A@ and @'Rep' A@ (and between @B@ and @'Rep' B@). -- For example, -- -- >>> from (D (C True) 3) :: Rep A -- SOP (S (Z (I (C True) :* I 3 :* Nil))) -- >>> to it :: A -- D (C True) 3 -- -- Note that the transformation is shallow: In @D (C True) 3@, the -- inner value @C True@ of type @A@ is not affected by the -- transformation. -- -- For more details about @'Rep' A@, have a look at the -- "Generics.SOP.Universe" module. -- -- == Defining a generic function -- -- As an example of a generic function, let us define a generic -- version of 'Control.DeepSeq.rnf' from the @deepseq@ package. -- -- The type of 'Control.DeepSeq.rnf' is -- -- @ -- NFData a => a -> () -- @ -- -- and the idea is that for a term @x@ of type @a@ in the -- 'Control.DeepSeq.NFData' class, @rnf x@ forces complete evaluation -- of @x@ (i.e., evaluation to /normal form/), and returns @()@. -- -- We call the generic version of this function @grnf@. A direct -- definition in SOP style, making use of structural recursion on the -- sums and products, looks as follows: -- -- @ -- grnf :: ('Generic' a, 'All2' NFData ('Code' a)) => a -> () -- grnf x = grnfS ('from' x) -- -- grnfS :: ('All2' NFData xss) => 'SOP' 'I' xss -> () -- grnfS ('SOP' ('Z' xs)) = grnfP xs -- grnfS ('SOP' ('S' xss)) = grnfS ('SOP' xss) -- -- grnfP :: ('All' NFData xs) => 'NP' 'I' xs -> () -- grnfP 'Nil' = () -- grnfP ('I' x ':*' xs) = x \`deepseq\` (grnfP xs) -- @ -- -- The @grnf@ function performs the conversion between @a@ and @'Rep' a@ -- by applying 'from' and then applies @grnfS@. The type of @grnf@ -- indicates that @a@ must be in the 'Generic' class so that we can -- apply 'from', and that all the components of @a@ (i.e., all the types -- that occur as constructor arguments) must be in the 'NFData' class -- ('All2'). -- -- The function @grnfS@ traverses the outer sum structure of the -- sum of products (note that @'Rep' a = 'SOP' 'I' ('Code' a)@). It -- encodes which constructor was used to construct the original -- argument of type @a@. Once we've found the constructor in question -- ('Z'), we traverse the arguments of that constructor using @grnfP@. -- -- The function @grnfP@ traverses the product structure of the -- constructor arguments. Each argument is evaluated using the -- 'Control.DeepSeq.deepseq' function from the 'Control.DeepSeq.NFData' -- class. This requires that all components of the product must be -- in the 'NFData' class ('All') and triggers the corresponding -- constraints on the other functions. Once the end of the product -- is reached ('Nil'), we return @()@. -- -- == Defining a generic function using combinators -- -- In many cases, generic functions can be written in a much more -- concise way by avoiding the explicit structural recursion and -- resorting to the powerful combinators provided by this library -- instead. -- -- For example, the @grnf@ function can also be defined as a one-liner -- as follows: -- -- @ -- grnf :: ('Generic' a, 'All2' NFData ('Code' a)) => a -> () -- grnf = 'rnf' . 'hcollapse' . 'hcliftA' ('Proxy' :: 'Proxy' NFData) (\\ ('I' x) -> 'K' (rnf x)) . 'from' -- @ -- -- The following interaction should provide an idea of the individual -- transformation steps: -- -- >>> let x = G 2.5 'A' False :: B Double -- >>> from x -- SOP (S (Z (I 2.5 :* I 'A' :* I False :* Nil))) -- >>> hcliftA (Proxy :: Proxy NFData) (\ (I x) -> K (rnf x)) it -- SOP (S (Z (K () :* K () :* K () :* Nil))) -- >>> hcollapse it -- [(),(),()] -- >>> rnf it -- () -- -- The 'from' call converts into the structural representation. -- Via 'hcliftA', we apply 'rnf' to all the components. The result -- is a sum of products of the same shape, but the components are -- no longer heterogeneous ('I'), but homogeneous (@'K' ()@). A -- homogeneous structure can be collapsed ('hcollapse') into a -- normal Haskell list. Finally, 'rnf' actually forces evaluation -- of this list (and thereby actually drives the evaluation of all -- the previous steps) and produces the final result. -- -- == Using a generic function -- -- We can directly invoke 'grnf' on any type that is an instance of -- class 'Generic'. -- -- >>> grnf (G 2.5 'A' False) -- () -- >>> grnf (G 2.5 undefined False) -- *** Exception: Prelude.undefined -- -- Note that the type of 'grnf' requires that all components of the -- type are in the 'Control.DeepSeq.NFData' class. For a recursive -- datatype such as @B@, this means that we have to make @A@ -- (and in this case, also @B@) an instance of 'Control.DeepSeq.NFData' -- in order to be able to use the 'grnf' function. But we can use 'grnf' -- to supply the instance definitions: -- -- > instance NFData A where rnf = grnf -- > instance NFData a => NFData (B a) where rnf = grnf -- -- = More examples -- -- The best way to learn about how to define generic functions in the SOP style -- is to look at a few simple examples. Examples are provided by the following -- packages: -- -- * @@ basic examples, -- * @@ generic pretty printing, -- * @@ generically computed lenses, -- * @@ generic JSON conversions. -- -- The generic functions in these packages use a wide variety of the combinators -- that are offered by the library. -- -- = Paper -- -- A detailed description of the ideas behind this library is provided by -- the paper: -- -- * Edsko de Vries and Andres Löh. -- . -- Workshop on Generic Programming (WGP) 2014. -- -- module Generics.SOP ( -- * Codes and interpretations Generic(..) , Rep , IsProductType , IsEnumType , IsWrappedType , IsNewtype -- * n-ary datatypes , NP(..) , NS(..) , SOP(..) , unSOP , POP(..) , unPOP -- * Metadata , DatatypeInfo(..) , moduleName , datatypeName , constructorInfo , ConstructorInfo(..) , constructorName , FieldInfo(..) , fieldName , HasDatatypeInfo(..) , DatatypeName , ModuleName , ConstructorName , FieldName , Associativity(..) , Fixity -- * Combinators -- ** Constructing products , HPure(..) -- ** Destructing products , hd , tl , Projection , projections , shiftProjection -- ** Application , type (-.->)(..) , fn , fn_2 , fn_3 , fn_4 , Prod , HAp(..) -- ** Lifting / mapping , hliftA , hliftA2 , hliftA3 , hcliftA , hcliftA2 , hcliftA3 , hmap , hzipWith , hzipWith3 , hcmap , hczipWith , hczipWith3 -- ** Constructing sums , Injection , injections , shift , shiftInjection , UnProd , HApInjs(..) , apInjs_NP -- deprecated export , apInjs_POP -- deprecated export -- ** Destructing sums , unZ , HIndex(..) -- ** Dealing with @'All' c@ , hcliftA' , hcliftA2' , hcliftA3' -- ** Collapsing , CollapseTo , HCollapse(..) -- ** Sequencing , HSequence(..) , hsequence , hsequenceK -- ** Expanding sums to products , HExpand(..) -- ** Transformation of index lists and coercions , HTrans(..) , hfromI , htoI -- ** Partial operations , fromList -- * Utilities -- ** Basic functors , K(..) , unK , I(..) , unI , (:.:)(..) , unComp -- *** Mapping functions , mapII , mapIK , mapKI , mapKK , mapIII , mapIIK , mapIKI , mapIKK , mapKII , mapKIK , mapKKI , mapKKK -- ** Mapping constraints , All , All2 , AllZip , AllZip2 , AllN , AllZipN -- ** Other constraints , Compose , And , Top , LiftedCoercible , SameShapeAs -- ** Singletons , SList(..) , SListI(..) , SListI2 , Sing , SingI(..) -- *** Shape of type-level lists , Shape(..) , shape , lengthSList , lengthSing -- ** Re-exports -- Workaround for lack of MIN_TOOL_VERSION macro in Cabal 1.18, see: -- https://github.com/well-typed/generics-sop/issues/3 #ifndef MIN_TOOL_VERSION_haddock #define MIN_TOOL_VERSION_haddock(x,y,z) 0 #endif #if !(defined(__HADDOCK_VERSION__)) || MIN_TOOL_VERSION_haddock(2,14,0) , Proxy(..) -- hidden from old Haddock versions, because it triggers an internal error #endif ) where import Data.Proxy (Proxy(..)) import Generics.SOP.BasicFunctors import Generics.SOP.Classes import Generics.SOP.Constraint import Generics.SOP.Instances () import Generics.SOP.Metadata import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe import Generics.SOP.Sing generics-sop-0.3.1.0/src/Generics/SOP/0000755000000000000000000000000013117242337015427 5ustar0000000000000000generics-sop-0.3.1.0/src/Generics/SOP/TH.hs0000644000000000000000000003623113117242337016303 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Generate @generics-sop@ boilerplate instances using Template Haskell. module Generics.SOP.TH ( deriveGeneric , deriveGenericOnly , deriveGenericFunctions , deriveMetadataValue , deriveMetadataType ) where import Control.Monad (replicateM) import Data.Maybe (fromMaybe) import Data.Proxy import Language.Haskell.TH import Language.Haskell.TH.Syntax import Generics.SOP.BasicFunctors import qualified Generics.SOP.Metadata as SOP import qualified Generics.SOP.Type.Metadata as SOP.T import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe -- | Generate @generics-sop@ boilerplate for the given datatype. -- -- This function takes the name of a datatype and generates: -- -- * a 'Code' instance -- * a 'Generic' instance -- * a 'HasDatatypeInfo' instance -- -- Note that the generated code will require the @TypeFamilies@ and -- @DataKinds@ extensions to be enabled for the module. -- -- /Example:/ If you have the datatype -- -- > data Tree = Leaf Int | Node Tree Tree -- -- and say -- -- > deriveGeneric ''Tree -- -- then you get code that is equivalent to: -- -- > instance Generic Tree where -- > -- > type Code Tree = '[ '[Int], '[Tree, Tree] ] -- > -- > from (Leaf x) = SOP ( Z (I x :* Nil)) -- > from (Node l r) = SOP (S (Z (I l :* I r :* Nil))) -- > -- > to (SOP (Z (I x :* Nil))) = Leaf x -- > to (SOP (S (Z (I l :* I r :* Nil)))) = Node l r -- > to _ = error "unreachable" -- to avoid GHC warnings -- > -- > instance HasDatatypeInfo Tree where -- > type DatatypeInfoOf Tree = -- > T.ADT "Main" "Tree" -- > '[ T.Constructor "Leaf", T.Constructor "Node" ] -- > -- > datatypeInfo _ = -- > T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree)) -- -- /Limitations:/ Generation does not work for GADTs, for -- datatypes that involve existential quantification, for -- datatypes with unboxed fields. -- deriveGeneric :: Name -> Q [Dec] deriveGeneric n = do dec <- reifyDec n ds1 <- withDataDec dec deriveGenericForDataDec ds2 <- withDataDec dec deriveMetadataForDataDec return (ds1 ++ ds2) -- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance. deriveGenericOnly :: Name -> Q [Dec] deriveGenericOnly n = do dec <- reifyDec n withDataDec dec deriveGenericForDataDec -- | Like 'deriveGenericOnly', but don't derive class instance, only functions. -- -- /Example:/ If you say -- -- > deriveGenericFunctions ''Tree "TreeCode" "fromTree" "toTree" -- -- then you get code that is equivalent to: -- -- > type TreeCode = '[ '[Int], '[Tree, Tree] ] -- > -- > fromTree :: Tree -> SOP I TreeCode -- > fromTree (Leaf x) = SOP ( Z (I x :* Nil)) -- > fromTree (Node l r) = SOP (S (Z (I l :* I r :* Nil))) -- > -- > toTree :: SOP I TreeCode -> Tree -- > toTree (SOP (Z (I x :* Nil))) = Leaf x -- > toTree (SOP (S (Z (I l :* I r :* Nil)))) = Node l r -- > toTree _ = error "unreachable" -- to avoid GHC warnings -- -- @since 0.2 -- deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec] deriveGenericFunctions n codeName fromName toName = do let codeName' = mkName codeName let fromName' = mkName fromName let toName' = mkName toName dec <- reifyDec n withDataDec dec $ \_isNewtype _cxt name _bndrs cons _derivs -> do let codeType = codeFor cons -- '[ '[Int], '[Tree, Tree] ] let repType = [t| SOP I $(conT codeName') |] -- SOP I TreeCode sequence [ tySynD codeName' [] codeType -- type TreeCode = '[ '[Int], '[Tree, Tree] ] , sigD fromName' [t| $(conT name) -> $repType |] -- fromTree :: Tree -> SOP I TreeCode , embedding fromName' cons -- fromTree ... = , sigD toName' [t| $repType -> $(conT name) |] -- toTree :: SOP I TreeCode -> Tree , projection toName' cons -- toTree ... = ] -- | Derive @DatatypeInfo@ value for the type. -- -- /Example:/ If you say -- -- > deriveMetadataValue ''Tree "TreeCode" "treeDatatypeInfo" -- -- then you get code that is equivalent to: -- -- > treeDatatypeInfo :: DatatypeInfo TreeCode -- > treeDatatypeInfo = ADT "Main" "Tree" -- > (Constructor "Leaf" :* Constructor "Node" :* Nil) -- -- /Note:/ CodeType need to be derived with 'deriveGenericFunctions'. -- -- @since 0.2 -- deriveMetadataValue :: Name -> String -> String -> Q [Dec] deriveMetadataValue n codeName datatypeInfoName = do let codeName' = mkName codeName let datatypeInfoName' = mkName datatypeInfoName dec <- reifyDec n withDataDec dec $ \isNewtype _cxt name _bndrs cons _derivs -> do sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ... ] {-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-} -- | Derive @DatatypeInfo@ type for the type. -- -- /Example:/ If you say -- -- > deriveMetadataType ''Tree "TreeDatatypeInfo" -- -- then you get code that is equivalent to: -- -- > type TreeDatatypeInfo = -- > T.ADT "Main" "Tree" -- > [ T.Constructor "Leaf", T.Constructor "Node" ] -- -- @since 0.3.0.0 -- deriveMetadataType :: Name -> String -> Q [Dec] deriveMetadataType n datatypeInfoName = do let datatypeInfoName' = mkName datatypeInfoName dec <- reifyDec n withDataDec dec $ \ isNewtype _ctx name _bndrs cons _derivs -> 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 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 md <- instanceD (cxt []) [t| HasDatatypeInfo $typ |] [ metadataType typ isNewtype name cons , funD 'datatypeInfo [ clause [wildP] (normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |]) [] ] ] -- [metadata isNewtype name cons] return [md] {------------------------------------------------------------------------------- Computing the code for a data type -------------------------------------------------------------------------------} codeFor :: [Con] -> Q Type codeFor = promotedTypeList . map go where go :: Con -> Q Type go c = do (_, ts) <- conInfo c promotedTypeList ts {------------------------------------------------------------------------------- Computing the embedding/projection pair -------------------------------------------------------------------------------} embedding :: Name -> [Con] -> Q Dec embedding fromName = funD fromName . go (\e -> [| Z $e |]) where go :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause] go _ [] = [] go br (c:cs) = mkClause br c : go (\e -> [| S $(br e) |]) cs mkClause :: (Q Exp -> Q Exp) -> Con -> Q Clause mkClause br c = do (n, ts) <- conInfo c vars <- replicateM (length ts) (newName "x") clause [conP n (map varP vars)] (normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |]) [] projection :: Name -> [Con] -> Q Dec projection toName = funD toName . go (\p -> conP 'Z [p]) where go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause] go _ [] = [unreachable] go br (c:cs) = mkClause br c : go (\p -> conP 'S [br p]) cs 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]] (normalB . appsE $ conE n : map varE vars) [] unreachable :: Q Clause unreachable = clause [wildP] (normalB [| error "unreachable" |]) [] {------------------------------------------------------------------------------- Compute metadata -------------------------------------------------------------------------------} metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec metadataType typ isNewtype typeName cs = tySynInstD ''DatatypeInfoOf (tySynEqn [typ] (metadataType' isNewtype typeName cs)) -- | Derive term-level metadata. metadata' :: Bool -> Name -> [Con] -> Q Exp metadata' isNewtype typeName cs = md where md :: Q Exp md | isNewtype = [| SOP.Newtype $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(mdCon (head cs)) |] | otherwise = [| SOP.ADT $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(npE $ map mdCon cs) |] mdCon :: Con -> Q Exp mdCon (NormalC n _) = [| SOP.Constructor $(stringE (nameBase n)) |] mdCon (RecC n ts) = [| SOP.Record $(stringE (nameBase n)) $(npE (map mdField ts)) |] mdCon (InfixC _ n _) = do #if MIN_VERSION_template_haskell(2,11,0) fixity <- reifyFixity n case fromMaybe defaultFixity fixity of Fixity f a -> #else i <- reify n case i of DataConI _ _ _ (Fixity f a) -> #endif [| SOP.Infix $(stringE (nameBase n)) $(mdAssociativity a) f |] #if !MIN_VERSION_template_haskell(2,11,0) _ -> fail "Strange infix operator" #endif mdCon (ForallC _ _ _) = fail "Existentials not supported" #if MIN_VERSION_template_haskell(2,11,0) mdCon (GadtC _ _ _) = fail "GADTs not supported" mdCon (RecGadtC _ _ _) = fail "GADTs not supported" #endif mdField :: VarStrictType -> Q Exp mdField (n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |] mdAssociativity :: FixityDirection -> Q Exp mdAssociativity InfixL = [| SOP.LeftAssociative |] mdAssociativity InfixR = [| SOP.RightAssociative |] mdAssociativity InfixN = [| SOP.NotAssociative |] -- | Derive type-level metadata. metadataType' :: Bool -> Name -> [Con] -> Q Type metadataType' isNewtype typeName cs = md where md :: Q Type md | isNewtype = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName)) $(stringT (nameBase typeName)) $(mdCon (head cs)) |] | otherwise = [t| 'SOP.T.ADT $(stringT (nameModule' typeName)) $(stringT (nameBase typeName)) $(promotedTypeList $ map mdCon cs) |] mdCon :: Con -> Q Type mdCon (NormalC n _) = [t| 'SOP.T.Constructor $(stringT (nameBase n)) |] mdCon (RecC n ts) = [t| 'SOP.T.Record $(stringT (nameBase n)) $(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)) |] mdAssociativity :: FixityDirection -> Q Type mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |] mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |] mdAssociativity InfixN = [t| 'SOP.T.NotAssociative |] nameModule' :: Name -> String nameModule' = fromMaybe "" . nameModule {------------------------------------------------------------------------------- Constructing n-ary pairs -------------------------------------------------------------------------------} -- Given -- -- > [a, b, c] -- -- Construct -- -- > a :* b :* c :* Nil npE :: [Q Exp] -> Q Exp npE [] = [| Nil |] npE (e:es) = [| $e :* $(npE es) |] -- Like npE, but construct a pattern instead npP :: [Q Pat] -> Q Pat npP [] = conP 'Nil [] npP (p:ps) = conP '(:*) [p, npP ps] {------------------------------------------------------------------------------- Some auxiliary definitions for working with TH -------------------------------------------------------------------------------} conInfo :: Con -> Q (Name, [Q Type]) conInfo (NormalC n ts) = return (n, map (return . (\(_, t) -> t)) ts) conInfo (RecC n ts) = return (n, map (return . (\(_, _, t) -> t)) ts) conInfo (InfixC (_, t) n (_, t')) = return (n, map return [t, t']) conInfo (ForallC _ _ _) = fail "Existentials not supported" #if MIN_VERSION_template_haskell(2,11,0) conInfo (GadtC _ _ _) = fail "GADTs not supported" conInfo (RecGadtC _ _ _) = fail "GADTs not supported" #endif stringT :: String -> Q Type stringT = litT . strTyLit natT :: Int -> Q Type natT = litT . numTyLit . fromIntegral promotedTypeList :: [Q Type] -> Q Type promotedTypeList [] = promotedNilT promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] appTyVars :: Name -> [TyVarBndr] -> Q Type appTyVars n = go (conT n) 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 reifyDec :: Name -> Q Dec reifyDec name = do info <- reify name case info of TyConI dec -> return dec _ -> 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] #endif generics-sop-0.3.1.0/src/Generics/SOP/Metadata.hs0000644000000000000000000000772513117242337017516 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-} -- | Metadata about what a datatype looks like -- -- In @generics-sop@, the metadata is completely independent of the main -- universe. Many generic functions will use this metadata, but other don't, -- and yet others might need completely different metadata. -- -- This module defines a datatype to represent standard metadata, i.e., names -- of the datatype, its constructors, and possibly its record selectors. -- Metadata descriptions are in general GADTs indexed by the code of the -- datatype they're associated with, so matching on the metadata will reveal -- information about the shape of the datatype. -- module Generics.SOP.Metadata ( module Generics.SOP.Metadata -- * re-exports , Associativity(..) ) where import GHC.Generics (Associativity(..)) import Generics.SOP.Constraint import Generics.SOP.NP import Generics.SOP.Sing -- | Metadata for a datatype. -- -- A value of type @'DatatypeInfo' c@ contains the information about a datatype -- that is not contained in @'Code' c@. This information consists -- primarily of the names of the datatype, its constructors, and possibly its -- record selectors. -- -- The constructor indicates whether the datatype has been declared using @newtype@ -- or not. -- data DatatypeInfo :: [[*]] -> * where -- Standard algebraic datatype ADT :: ModuleName -> DatatypeName -> NP ConstructorInfo xss -> DatatypeInfo xss -- Newtype Newtype :: ModuleName -> DatatypeName -> ConstructorInfo '[x] -> DatatypeInfo '[ '[x] ] -- | The module name where a datatype is defined. -- -- @since 0.2.3.0 -- moduleName :: DatatypeInfo xss -> ModuleName moduleName (ADT name _ _) = name moduleName (Newtype name _ _) = name -- | The name of a datatype (or newtype). -- -- @since 0.2.3.0 -- datatypeName :: DatatypeInfo xss -> DatatypeName datatypeName (ADT _ name _ ) = name datatypeName (Newtype _ name _) = name -- | The constructor info for a datatype (or newtype). -- -- @since 0.2.3.0 -- constructorInfo :: DatatypeInfo xss -> NP ConstructorInfo xss constructorInfo (ADT _ _ cs) = cs constructorInfo (Newtype _ _ c) = c :* Nil deriving instance All (Show `Compose` ConstructorInfo) xs => Show (DatatypeInfo xs) deriving instance All (Eq `Compose` ConstructorInfo) xs => Eq (DatatypeInfo xs) deriving instance (All (Eq `Compose` ConstructorInfo) xs, All (Ord `Compose` ConstructorInfo) xs) => Ord (DatatypeInfo xs) -- | Metadata for a single constructors. -- -- This is indexed by the product structure of the constructor components. -- data ConstructorInfo :: [*] -> * where -- Normal constructor Constructor :: SListI xs => ConstructorName -> ConstructorInfo xs -- Infix constructor Infix :: ConstructorName -> Associativity -> Fixity -> ConstructorInfo '[ x, y ] -- Record constructor Record :: SListI xs => ConstructorName -> NP FieldInfo xs -> ConstructorInfo xs -- | The name of a constructor. -- -- @since 0.2.3.0 -- constructorName :: ConstructorInfo xs -> ConstructorName constructorName (Constructor name) = name constructorName (Infix name _ _) = name constructorName (Record name _) = name deriving instance All (Show `Compose` FieldInfo) xs => Show (ConstructorInfo xs) deriving instance All (Eq `Compose` FieldInfo) xs => Eq (ConstructorInfo xs) deriving instance (All (Eq `Compose` FieldInfo) xs, All (Ord `Compose` FieldInfo) xs) => Ord (ConstructorInfo xs) -- | For records, this functor maps the component to its selector name. data FieldInfo :: * -> * where FieldInfo :: FieldName -> FieldInfo a deriving (Show, Eq, Ord, Functor) -- | The name of a field. -- -- @since 0.2.3.0 -- fieldName :: FieldInfo a -> FieldName fieldName (FieldInfo n) = n -- | The name of a datatype. type DatatypeName = String -- | The name of a module. type ModuleName = String -- | The name of a data constructor. type ConstructorName = String -- | The name of a field / record selector. type FieldName = String -- | The fixity of an infix constructor. type Fixity = Int generics-sop-0.3.1.0/src/Generics/SOP/GGP.hs0000644000000000000000000002541513117242337016407 0ustar0000000000000000{-# LANGUAGE PolyKinds, UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 780 {-# 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: -- -- * José Pedro Magalhães and Andres Löh. -- . -- Practical Aspects of Declarative Languages (PADL) 2014. -- module Generics.SOP.GGP ( GCode , GFrom , GTo , GDatatypeInfo #if MIN_VERSION_base(4,9,0) , GDatatypeInfoOf #endif , gfrom , gto , gdatatypeInfo ) where import Data.Proxy 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 instance ToSingleCode (K1 _i a) = a type family ToProductCode (a :: * -> *) (xs :: [*]) :: [*] 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 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 #if MIN_VERSION_base(4,9,0) type family ToInfo (a :: * -> *) :: 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 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 instance ToSingleConstructorInfo (M1 C (MetaCons n PrefixI False) a) = SOP.T.Constructor n type instance ToSingleConstructorInfo (M1 C (MetaCons n (InfixI assoc fix) False) a) = SOP.T.Infix n assoc fix type instance ToSingleConstructorInfo (M1 C (MetaCons n f True) a) = SOP.T.Record n (ToProductInfo a '[]) type family ToProductInfo (a :: * -> *) (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 instance ToSingleInfo (M1 S (MetaSel (Just n) _su _ss _ds) a) = 'SOP.T.FieldInfo n #endif class GFieldInfos (a :: * -> *) where gFieldInfos :: proxy a -> NP FieldInfo xs -> NP FieldInfo (ToProductCode a xs) instance (GFieldInfos a, GFieldInfos b) => GFieldInfos (a :*: b) where gFieldInfos _ xs = gFieldInfos (Proxy :: Proxy a) (gFieldInfos (Proxy :: Proxy b) xs) instance GFieldInfos U1 where gFieldInfos _ xs = xs instance (Selector c) => GFieldInfos (M1 S c a) where gFieldInfos _ xs = FieldInfo (selName p) :* xs where p :: InfoProxy c a x p = InfoProxy class GSingleFrom (a :: * -> *) where gSingleFrom :: a x -> ToSingleCode a instance GSingleFrom (K1 i a) where gSingleFrom (K1 a) = a class GProductFrom (a :: * -> *) where gProductFrom :: a x -> NP I xs -> NP I (ToProductCode a xs) instance (GProductFrom a, GProductFrom b) => GProductFrom (a :*: b) where gProductFrom (a :*: b) xs = gProductFrom a (gProductFrom b xs) instance GProductFrom U1 where gProductFrom U1 xs = xs instance GSingleFrom a => GProductFrom (M1 S c a) where gProductFrom (M1 a) xs = I (gSingleFrom a) :* xs class GSingleTo (a :: * -> *) where gSingleTo :: ToSingleCode a -> a x instance GSingleTo (K1 i a) where gSingleTo a = K1 a class GProductTo (a :: * -> *) where gProductTo :: NP I (ToProductCode a xs) -> (a x -> NP I xs -> r) -> r instance (GProductTo a, GProductTo b) => GProductTo (a :*: b) where gProductTo xs k = gProductTo xs (\ a ys -> gProductTo ys (\ b zs -> k (a :*: b) zs)) instance GSingleTo a => GProductTo (M1 S c a) where gProductTo (SOP.I a :* xs) k = k (M1 (gSingleTo a)) xs #if __GLASGOW_HASKELL__ < 800 gProductTo _ _ = error "inaccessible" #endif instance GProductTo U1 where gProductTo xs k = k U1 xs -- This can most certainly be simplified class GSumFrom (a :: * -> *) where gSumFrom :: a x -> SOP I xss -> SOP I (ToSumCode a xss) gSumSkip :: proxy a -> SOP I xss -> SOP I (ToSumCode a 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) gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) (gSumSkip (Proxy :: Proxy b) xss) instance (GSumFrom a) => GSumFrom (M1 D c a) where gSumFrom (M1 a) xss = gSumFrom a xss gSumSkip _ xss = gSumSkip (Proxy :: Proxy a) xss instance (GProductFrom a) => GSumFrom (M1 C c a) where gSumFrom (M1 a) _ = SOP (Z (gProductFrom a Nil)) gSumSkip _ (SOP xss) = SOP (S xss) class GSumTo (a :: * -> *) where gSumTo :: SOP I (ToSumCode a xss) -> (a x -> r) -> (SOP I xss -> r) -> r instance (GSumTo a, GSumTo b) => GSumTo (a :+: b) where gSumTo xss s k = gSumTo xss (s . L1) (\ r -> gSumTo r (s . R1) k) instance (GProductTo a) => GSumTo (M1 C c a) where gSumTo (SOP (Z xs)) s _ = s (M1 (gProductTo xs ((\ x Nil -> x) :: a x -> NP I '[] -> a x))) gSumTo (SOP (S xs)) _ k = k (SOP xs) instance (GSumTo a) => GSumTo (M1 D c a) where gSumTo xss s k = gSumTo xss (s . M1) k -- | Compute the SOP code of a datatype. -- -- This requires that 'GHC.Rep' is defined, which in turn requires that -- the type has a 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.Code'. -- For more info, see 'Generics.SOP.Generic'. -- type GCode (a :: *) = ToSumCode (GHC.Rep a) '[] -- | Constraint for the class that computes 'gfrom'. type GFrom a = GSumFrom (GHC.Rep a) -- | Constraint for the class that computes 'gto'. type GTo a = GSumTo (GHC.Rep a) -- | Constraint for the class that computes 'gdatatypeInfo'. #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 -- | An automatically computed version of 'Generics.SOP.from'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.from'. -- For more info, see 'Generics.SOP.Generic'. -- gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a) gfrom x = gSumFrom (GHC.from x) (error "gfrom: internal error" :: SOP.SOP SOP.I '[]) -- | An automatically computed version of 'Generics.SOP.to'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.to'. -- For more info, see 'Generics.SOP.Generic'. -- gto :: forall a. (GTo a, GHC.Generic a) => SOP I (GCode a) -> a gto x = GHC.to (gSumTo x id ((\ _ -> error "inaccessible") :: SOP I '[] -> (GHC.Rep a) x)) -- | An automatically computed version of 'Generics.SOP.datatypeInfo'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.datatypeInfo'. -- For more info, see 'Generics.SOP.HasDatatypeInfo'. -- gdatatypeInfo :: forall proxy a. (GDatatypeInfo a) => proxy a -> DatatypeInfo (GCode a) #if MIN_VERSION_base(4,9,0) gdatatypeInfo _ = SOP.T.demoteDatatypeInfo (Proxy :: Proxy (GDatatypeInfoOf a)) #else gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a)) #endif generics-sop-0.3.1.0/src/Generics/SOP/Instances.hs0000644000000000000000000001266713117242337017726 0ustar0000000000000000{-# 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 -- | Instances for 'Generic' and 'HasMetadata'. -- -- We define instances for datatypes from @generics-sop@ and -- @base@ that are supported. -- -- (There are only instances defined in this module, so the -- documentation is empty.) -- module Generics.SOP.Instances () where import Control.Exception import Data.Char import Data.Complex import Data.Data import Data.Fixed import Data.Monoid import Data.Ord #if !(MIN_VERSION_base(4,7,0)) import Data.Proxy #endif import Data.Version import Foreign.C.Error import Foreign.C.Types 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.TH -- Types from Generics.SOP: deriveGeneric ''I deriveGeneric ''K deriveGeneric ''(:.:) -- Cannot derive instances for Sing -- Cannot derive instances for Shape -- Cannot derive instances for NP, NS, POP, SOP -- Cannot derive instances for metadata types -- Types from the Prelude: deriveGeneric ''Bool deriveGeneric ''Ordering deriveGeneric ''Maybe deriveGeneric ''Either deriveGeneric ''() deriveGeneric ''(,) -- 2 deriveGeneric ''(,,) deriveGeneric ''(,,,) deriveGeneric ''(,,,,) -- 5 deriveGeneric ''(,,,,,) deriveGeneric ''(,,,,,,) deriveGeneric ''(,,,,,,,) deriveGeneric ''(,,,,,,,,) deriveGeneric ''(,,,,,,,,,) -- 10 deriveGeneric ''(,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,) -- 15 deriveGeneric ''(,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30 deriveGeneric ''[] -- Other types from base: -- From Control.Exception: deriveGeneric ''IOException deriveGeneric ''ArithException deriveGeneric ''ArrayException deriveGeneric ''AssertionFailed deriveGeneric ''AsyncException deriveGeneric ''NonTermination deriveGeneric ''NestedAtomically deriveGeneric ''BlockedIndefinitelyOnMVar deriveGeneric ''BlockedIndefinitelyOnSTM deriveGeneric ''Deadlock deriveGeneric ''NoMethodError deriveGeneric ''PatternMatchFail deriveGeneric ''RecConError deriveGeneric ''RecSelError deriveGeneric ''RecUpdError deriveGeneric ''ErrorCall deriveGeneric ''MaskingState -- From Data.Char: deriveGeneric ''GeneralCategory -- From Data.Complex: deriveGeneric ''Complex -- From Data.Data: deriveGeneric ''DataRep deriveGeneric ''Fixity deriveGeneric ''ConstrRep -- From Data.Fixed: deriveGeneric ''Fixed -- From Data.Monoid: deriveGeneric ''Dual deriveGeneric ''Endo deriveGeneric ''All deriveGeneric ''Any deriveGeneric ''Sum deriveGeneric ''Product deriveGeneric ''First deriveGeneric ''Last -- From Data.Ord: deriveGeneric ''Down -- From Data.Proxy: deriveGeneric ''Proxy -- From Data.Version: deriveGeneric ''Version -- From Foreign.C.Error: deriveGeneric ''Errno -- From Foreign.C.Types: deriveGeneric ''CChar deriveGeneric ''CSChar deriveGeneric ''CUChar deriveGeneric ''CShort deriveGeneric ''CUShort deriveGeneric ''CInt deriveGeneric ''CUInt deriveGeneric ''CLong deriveGeneric ''CULong deriveGeneric ''CPtrdiff deriveGeneric ''CSize deriveGeneric ''CWchar deriveGeneric ''CSigAtomic deriveGeneric ''CLLong deriveGeneric ''CULLong deriveGeneric ''CIntPtr deriveGeneric ''CUIntPtr deriveGeneric ''CIntMax deriveGeneric ''CUIntMax deriveGeneric ''CClock deriveGeneric ''CTime deriveGeneric ''CUSeconds deriveGeneric ''CSUSeconds deriveGeneric ''CFloat deriveGeneric ''CDouble -- From System.Console.GetOpt: deriveGeneric ''ArgOrder deriveGeneric ''OptDescr deriveGeneric ''ArgDescr -- From System.Exit: deriveGeneric ''ExitCode -- From System.IO: deriveGeneric ''IOMode deriveGeneric ''BufferMode deriveGeneric ''SeekMode deriveGeneric ''Newline deriveGeneric ''NewlineMode -- From Text.Printf: #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): -- -- Ratio -- Integer -- ThreadId -- Chan -- MVar -- QSem -- QSemN -- DataType -- Dynamic -- IORef -- TypeRep -- TyCon -- TypeRepKey -- KProxy -- not abstract, but intended for kind-level use -- STRef -- Unique -- ForeignPtr -- CFile -- CFpos -- CJmpBuf -- Pool -- Ptr -- FunPtr -- IntPtr -- WordPtr -- StablePtr -- Char -- Double -- Float -- Int -- Int8 -- Int16 -- Int32 -- Int64 -- Word -- Word8 -- Word16 -- Word32 -- Word64 -- IO -- ST -- (->) -- RealWorld -- Handle -- HandlePosn -- TextEncoding -- StableName -- Weak -- ReadP -- ReadPrec -- -- Datatypes we cannot currently handle: -- -- SomeException -- SomeAsyncException -- Handler -- Coercion -- (:~:) generics-sop-0.3.1.0/src/Generics/SOP/Sing.hs0000644000000000000000000000632513117242337016671 0ustar0000000000000000{-# 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 -- @@ package. -- See the -- paper for details. -- module Generics.SOP.Sing ( -- * Singletons SList(..) , SListI(..) , Sing , SingI(..) -- ** Shape of type-level lists , Shape(..) , shape , lengthSList , lengthSing ) 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 generics-sop-0.3.1.0/src/Generics/SOP/Universe.hs0000644000000000000000000001351213117242337017565 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif -- | Codes and interpretations module Generics.SOP.Universe where import Data.Coerce (Coercible) import qualified GHC.Generics as GHC import Generics.SOP.BasicFunctors import Generics.SOP.Constraint import Generics.SOP.NS import Generics.SOP.Sing import Generics.SOP.GGP import Generics.SOP.Metadata import qualified Generics.SOP.Type.Metadata as T -- | The (generic) representation of a datatype. -- -- A datatype is isomorphic to the sum-of-products of its code. -- The isomorphism is witnessed by 'from' and 'to' from the -- 'Generic' class. -- type Rep a = SOP I (Code a) -- | The class of representable datatypes. -- -- The SOP approach to generic programming is based on viewing -- datatypes as a representation ('Rep') built from the sum of -- products of its components. The components of are datatype -- are specified using the 'Code' type family. -- -- The isomorphism between the original Haskell datatype and its -- representation is witnessed by the methods of this class, -- 'from' and 'to'. So for instances of this class, the following -- laws should (in general) hold: -- -- @ -- 'to' '.' 'from' === 'id' :: a -> a -- 'from' '.' 'to' === 'id' :: 'Rep' a -> 'Rep' a -- @ -- -- You typically don't define instances of this class by hand, but -- rather derive the class instance automatically. -- -- /Option 1:/ Derive via the built-in GHC-generics. For this, you -- need to use the @DeriveGeneric@ extension to first derive an -- instance of the 'GHC.Generics.Generic' class from module "GHC.Generics". -- With this, you can then give an empty instance for 'Generic', and -- the default definitions will just work. The pattern looks as -- follows: -- -- @ -- import qualified "GHC.Generics" as GHC -- import "Generics.SOP" -- -- ... -- -- data T = ... deriving (GHC.'GHC.Generics.Generic', ...) -- -- instance 'Generic' T -- empty -- instance 'HasDatatypeInfo' T -- empty, if you want/need metadata -- @ -- -- /Option 2:/ Derive via Template Haskell. For this, you need to -- enable the @TemplateHaskell@ extension. You can then use -- 'Generics.SOP.TH.deriveGeneric' from module "Generics.SOP.TH" -- to have the instance generated for you. The pattern looks as -- follows: -- -- @ -- import "Generics.SOP" -- import "Generics.SOP.TH" -- -- ... -- -- data T = ... -- -- 'Generics.SOP.TH.deriveGeneric' \'\'T -- derives 'HasDatatypeInfo' as well -- @ -- -- /Tradeoffs:/ Whether to use Option 1 or 2 is mainly a matter -- of personal taste. The version based on Template Haskell probably -- has less run-time overhead. -- -- /Non-standard instances:/ -- It is possible to give 'Generic' instances manually that deviate -- from the standard scheme, as long as at least -- -- @ -- 'to' '.' 'from' === 'id' :: a -> a -- @ -- -- still holds. -- class (All SListI (Code a)) => Generic (a :: *) where -- | The code of a datatype. -- -- This is a list of lists of its components. The outer list contains -- one element per constructor. The inner list contains one element -- per constructor argument (field). -- -- /Example:/ The datatype -- -- > data Tree = Leaf Int | Node Tree Tree -- -- is supposed to have the following code: -- -- > type instance Code (Tree a) = -- > '[ '[ Int ] -- > , '[ Tree, Tree ] -- > ] -- type Code a :: [[*]] type Code a = GCode a -- | Converts from a value to its structural representation. from :: a -> Rep a default from :: (GFrom a, GHC.Generic a, Rep a ~ SOP I (GCode a)) => a -> Rep a from = gfrom -- | Converts from a structural representation back to the -- original value. to :: Rep a -> a default to :: (GTo a, GHC.Generic a, Rep a ~ SOP I (GCode a)) => Rep a -> a to = gto -- | A class of datatypes that have associated metadata. -- -- It is possible to use the sum-of-products approach to generic programming -- without metadata. If you need metadata in a function, an additional -- constraint on this class is in order. -- -- You typically don't define instances of this class by hand, but -- rather derive the class instance automatically. See the documentation -- of 'Generic' for the options. -- class 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. -- datatypeInfo :: proxy a -> DatatypeInfo (Code a) default datatypeInfo :: (GDatatypeInfo a, GCode a ~ Code a) => proxy a -> DatatypeInfo (Code a) datatypeInfo = gdatatypeInfo -- | Constraint that captures that a datatype is a product type, -- i.e., a type with a single constructor. -- -- It also gives access to the code for the arguments of that -- constructor. -- -- @since 0.3.1.0 -- type IsProductType (a :: *) (xs :: [*]) = (Generic a, Code a ~ '[ xs ]) -- | 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 :: *) = (Generic a, All ((~) '[]) (Code a)) -- | Constraint that captures that a datatype is a single-constructor, -- single-field datatype. This always holds for newtype-defined types, -- but it can also be true for data-defined types. -- -- The constraint also gives access to the type that is wrapped. -- -- @since 0.3.1.0 -- type IsWrappedType (a :: *) (x :: *) = (Generic a, Code a ~ '[ '[ x ] ]) -- | 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 :: *) = (IsWrappedType a x, Coercible a x) generics-sop-0.3.1.0/src/Generics/SOP/Constraint.hs0000644000000000000000000001452613117242337020117 0ustar0000000000000000{-# 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 ) 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 generics-sop-0.3.1.0/src/Generics/SOP/NS.hs0000644000000000000000000004544313117242337016315 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | n-ary sums (and sums of products) module Generics.SOP.NS ( -- * Datatypes NS(..) , SOP(..) , unSOP -- * Constructing sums , Injection , injections , shift , shiftInjection , apInjs_NP , apInjs'_NP , apInjs_POP , apInjs'_POP -- * Destructing sums , unZ , index_NS , index_SOP -- * Application , ap_NS , ap_SOP -- * Lifting / mapping , liftA_NS , liftA_SOP , liftA2_NS , liftA2_SOP , cliftA_NS , cliftA_SOP , cliftA2_NS , cliftA2_SOP , map_NS , map_SOP , cmap_NS , cmap_SOP -- * Dealing with @'All' c@ , cliftA2'_NS -- * Collapsing , collapse_NS , collapse_SOP -- * Sequencing , sequence'_NS , sequence'_SOP , sequence_NS , sequence_SOP -- * Catamorphism and anamorphism , cata_NS , ccata_NS , ana_NS , cana_NS -- * Expanding sums to products , expand_NS , cexpand_NS , expand_SOP , cexpand_SOP -- * Transformation of index lists and coercions , trans_NS , trans_SOP , coerce_NS , coerce_SOP , fromI_NS , fromI_SOP , toI_NS , toI_SOP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #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 -- | 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' -- * Collapsing -- | Specialization of 'hcollapse'. collapse_NS :: NS (K a) xs -> a -- | Specialization of 'hcollapse'. collapse_SOP :: SListI xss => SOP (K a) xss -> [a] collapse_NS (Z (K x)) = x collapse_NS (S xs) = collapse_NS xs collapse_SOP = collapse_NS . hliftA (K . collapse_NP) . unSOP type instance CollapseTo NS a = a type instance CollapseTo SOP a = [a] instance HCollapse NS where hcollapse = collapse_NS instance HCollapse SOP where hcollapse = collapse_SOP -- * Sequencing -- | Specialization of 'hsequence''. sequence'_NS :: Applicative f => NS (f :.: g) xs -> f (NS g xs) -- | Specialization of 'hsequence''. sequence'_SOP :: (SListI xss, Applicative f) => SOP (f :.: g) xss -> f (SOP g xss) sequence'_NS (Z mx) = Z <$> unComp mx sequence'_NS (S mxs) = S <$> sequence'_NS mxs sequence'_SOP = fmap SOP . sequence'_NS . hliftA (Comp . sequence'_NP) . unSOP instance HSequence NS where hsequence' = sequence'_NS instance HSequence SOP where hsequence' = sequence'_SOP -- | Specialization of 'hsequence'. sequence_NS :: (SListI xs, Applicative f) => NS f xs -> f (NS I xs) -- | Specialization of 'hsequence'. sequence_SOP :: (All SListI xss, Applicative f) => SOP f xss -> f (SOP I xss) sequence_NS = hsequence sequence_SOP = hsequence -- * Catamorphism and anamorphism -- | Catamorphism for 'NS'. -- -- Takes arguments determining what to do for 'Z' -- and what to do for 'S'. The result type is still -- indexed over the type-level lit. -- -- @since 0.2.3.0 -- cata_NS :: forall r f xs . (forall y ys . f y -> r (y ': ys)) -> (forall y ys . r ys -> r (y ': ys)) -> NS f xs -> r xs cata_NS z s = go where go :: forall ys . NS f ys -> r ys go (Z x) = z x go (S i) = s (go i) -- | Constrained catamorphism for 'NS'. -- -- @since 0.2.3.0 -- ccata_NS :: forall c proxy r f xs . (All c xs) => proxy c -> (forall y ys . c y => f y -> r (y ': ys)) -> (forall y ys . c y => r ys -> r (y ': ys)) -> NS f xs -> r xs ccata_NS _ z s = go where go :: forall ys . (All c ys) => NS f ys -> r ys go (Z x) = z x go (S i) = s (go i) -- | Anamorphism for 'NS'. -- -- @since 0.2.3.0 -- ana_NS :: forall s f xs . (SListI xs) => (forall r . s '[] -> r) -> (forall y ys . s (y ': ys) -> Either (f y) (s ys)) -> s xs -> NS f xs ana_NS refute decide = go sList where go :: forall ys . SList ys -> s ys -> NS f ys go SNil s = refute s go SCons s = case decide s of Left x -> Z x Right s' -> S (go sList s') -- | Constrained anamorphism for 'NS'. -- -- @since 0.2.3.0 -- cana_NS :: forall c proxy s f xs . (All c xs) => proxy c -> (forall r . s '[] -> r) -> (forall y ys . c y => s (y ': ys) -> Either (f y) (s ys)) -> s xs -> NS f xs cana_NS _ refute decide = go sList where go :: forall ys . (All c ys) => SList ys -> s ys -> NS f ys go SNil s = refute s go SCons s = case decide s of Left x -> Z x Right s' -> S (go sList s') -- * Expanding sums to products -- | Specialization of 'hexpand'. -- -- @since 0.2.5.0 -- expand_NS :: forall f xs . (SListI xs) => (forall x . f x) -> NS f xs -> NP f xs expand_NS d = go sList where go :: forall ys . SList ys -> NS f ys -> NP f ys go SCons (Z x) = x :* hpure d go SCons (S i) = d :* go sList i go SNil _ = error "inaccessible" -- still required in ghc-8.0.* -- | Specialization of 'hcexpand'. -- -- @since 0.2.5.0 -- cexpand_NS :: forall c proxy f xs . (All c xs) => proxy c -> (forall x . c x => f x) -> NS f xs -> NP f xs cexpand_NS p d = go where go :: forall ys . All c ys => NS f ys -> NP f ys go (Z x) = x :* hcpure p d go (S i) = d :* go i -- | Specialization of 'hexpand'. -- -- @since 0.2.5.0 -- expand_SOP :: forall f xss . (All SListI xss) => (forall x . f x) -> SOP f xss -> POP f xss expand_SOP d = POP . cexpand_NS (Proxy :: Proxy SListI) (hpure d) . unSOP -- | Specialization of 'hcexpand'. -- -- @since 0.2.5.0 -- cexpand_SOP :: forall c proxy f xss . (All2 c xss) => proxy c -> (forall x . c x => f x) -> SOP f xss -> POP f xss cexpand_SOP p d = POP . cexpand_NS (allP p) (hcpure p d) . unSOP allP :: proxy c -> Proxy (All c) allP _ = Proxy instance HExpand NS where hexpand = expand_NS hcexpand = cexpand_NS instance HExpand SOP where hexpand = expand_SOP hcexpand = cexpand_SOP -- | 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 generics-sop-0.3.1.0/src/Generics/SOP/Dict.hs0000644000000000000000000001113213117242337016644 0ustar0000000000000000{-# 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 -- | 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 generics-sop-0.3.1.0/src/Generics/SOP/Classes.hs0000644000000000000000000005304413117242337017366 0ustar0000000000000000{-# 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(..) -- * Sequencing effects , HSequence(..) -- ** Derived functions , hsequence , hsequenceK -- * Indexing into sums , HIndex(..) -- * Applying all injections , UnProd , HApInjs(..) -- * Expanding sums to products , HExpand(..) -- * Transformation of index lists and coercions , HTrans(..) , hfromI , htoI ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative) #endif import Generics.SOP.BasicFunctors import Generics.SOP.Constraint -- * Generalized applicative functor structure -- ** Generalized 'Control.Applicative.pure' -- | A generalization of 'Control.Applicative.pure' or -- 'Control.Monad.return' to higher kinds. class HPure (h :: (k -> *) -> (l -> *)) where -- | Corresponds to 'Control.Applicative.pure' directly. -- -- /Instances:/ -- -- @ -- 'hpure', 'Generics.SOP.NP.pure_NP' :: 'Generics.SOP.Sing.SListI' xs => (forall a. f a) -> 'Generics.SOP.NP.NP' f xs -- 'hpure', 'Generics.SOP.NP.pure_POP' :: 'SListI2' xss => (forall a. f a) -> 'Generics.SOP.NP.POP' f xss -- @ -- hpure :: SListIN h xs => (forall a. f a) -> h f xs -- | A variant of 'hpure' that allows passing in a constrained -- argument. -- -- Calling @'hcpure' f s@ where @s :: h f xs@ causes @f@ to be -- applied at all the types that are contained in @xs@. Therefore, -- the constraint @c@ has to be satisfied for all elements of @xs@, -- which is what @'AllMap' h c xs@ states. -- -- Morally, 'hpure' is a special case of 'hcpure' where the -- constraint is empty. However, it is in the nature of how 'AllMap' -- is defined as well as current GHC limitations that it is tricky -- to prove to GHC in general that @'AllMap' h c NoConstraint xs@ is -- always satisfied. Therefore, we typically define 'hpure' -- separately and directly, and make it a member of the class. -- -- /Instances:/ -- -- @ -- 'hcpure', 'Generics.SOP.NP.cpure_NP' :: ('All' c xs ) => proxy c -> (forall a. c a => f a) -> 'Generics.SOP.NP.NP' f xs -- 'hcpure', 'Generics.SOP.NP.cpure_POP' :: ('All2' c xss) => proxy c -> (forall a. c a => f a) -> 'Generics.SOP.NP.POP' f xss -- @ -- hcpure :: (AllN h c xs) => proxy c -> (forall a. c a => f a) -> h f xs -- ** Generalized 'Control.Applicative.<*>' -- | Lifted functions. newtype (f -.-> g) a = Fn { apFn :: f a -> g a } infixr 1 -.-> -- | Construct a lifted function. -- -- Same as 'Fn'. Only available for uniformity with the -- higher-arity versions. -- fn :: (f a -> f' a) -> (f -.-> f') a -- | Construct a binary lifted function. fn_2 :: (f a -> f' a -> f'' a) -> (f -.-> f' -.-> f'') a -- | Construct a ternary lifted function. fn_3 :: (f a -> f' a -> f'' a -> f''' a) -> (f -.-> f' -.-> f'' -.-> f''') a -- | Construct a quarternary lifted function. fn_4 :: (f a -> f' a -> f'' a -> f''' a -> f'''' a) -> (f -.-> f' -.-> f'' -.-> f''' -.-> f'''') a fn f = Fn $ \x -> f x fn_2 f = Fn $ \x -> Fn $ \x' -> f x x' fn_3 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> f x x' x'' fn_4 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> Fn $ \x''' -> f x x' x'' x''' -- | Maps a structure 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 -- * Sequencing effects -- | A generalization of 'Data.Traversable.sequenceA'. class HAp h => HSequence (h :: (k -> *) -> (l -> *)) where -- | Corresponds to 'Data.Traversable.sequenceA'. -- -- Lifts an applicative functor out of a structure. -- -- /Instances:/ -- -- @ -- 'hsequence'', 'Generics.SOP.NP.sequence'_NP' :: ('Generics.SOP.Sing.SListI' xs , 'Applicative' f) => 'Generics.SOP.NP.NP' (f ':.:' g) xs -> f ('Generics.SOP.NP.NP' g xs ) -- 'hsequence'', 'Generics.SOP.NS.sequence'_NS' :: ('Generics.SOP.Sing.SListI' xs , 'Applicative' f) => 'Generics.SOP.NS.NS' (f ':.:' g) xs -> f ('Generics.SOP.NS.NS' g xs ) -- 'hsequence'', 'Generics.SOP.NP.sequence'_POP' :: ('SListI2' xss, 'Applicative' f) => 'Generics.SOP.NP.POP' (f ':.:' g) xss -> f ('Generics.SOP.NP.POP' g xss) -- 'hsequence'', 'Generics.SOP.NS.sequence'_SOP' :: ('SListI2' xss, 'Applicative' f) => 'Generics.SOP.NS.SOP' (f ':.:' g) xss -> f ('Generics.SOP.NS.SOP' g xss) -- @ -- hsequence' :: (SListIN h xs, Applicative f) => h (f :.: g) xs -> f (h g xs) -- ** Derived functions -- | Special case of 'hsequence'' where @g = 'I'@. hsequence :: (SListIN h xs, SListIN (Prod h) xs, HSequence h) => Applicative f => h f xs -> f (h I xs) hsequence = hsequence' . hliftA (Comp . fmap I) -- | Special case of 'hsequence'' where @g = 'K' a@. hsequenceK :: (SListIN h xs, SListIN (Prod h) xs, Applicative f, HSequence h) => h (K (f a)) xs -> f (h (K a) xs) hsequenceK = hsequence' . hliftA (Comp . fmap K . unK) -- * Indexing into sums -- | A class for determining which choice in a sum-like structure -- a value represents. -- class HIndex (h :: (k -> *) -> (l -> *)) where -- | If 'h' is a sum-like structure representing a choice -- between @n@ different options, and @x@ is a value of -- type @h f xs@, then @'hindex' x@ returns a number between -- @0@ and @n - 1@ representing the index of the choice -- made by @x@. -- -- /Instances:/ -- -- @ -- 'hindex', 'Generics.SOP.NS.index_NS' :: 'Generics.SOP.NS.NS' f xs -> Int -- 'hindex', 'Generics.SOP.NS.index_SOP' :: 'Generics.SOP.NS.SOP' f xs -> Int -- @ -- -- /Examples:/ -- -- >>> hindex (S (S (Z (I False)))) -- 2 -- >>> hindex (Z (K ())) -- 0 -- >>> hindex (SOP (S (Z (I True :* I 'x' :* Nil)))) -- 1 -- -- @since 0.2.4.0 -- hindex :: h f xs -> Int -- * Applying all injections -- | Maps a structure containing products to the corresponding -- sum structure. -- -- @since 0.2.4.0 -- type family UnProd (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *) -- | A class for applying all injections corresponding to a sum-like -- structure to a table containing suitable arguments. -- class (UnProd (Prod h) ~ h) => HApInjs (h :: (k -> *) -> (l -> *)) where -- | For a given table (product-like structure), produce a list where -- each element corresponds to the application of an injection function -- into the corresponding sum-like structure. -- -- /Instances:/ -- -- @ -- 'hapInjs', 'Generics.SOP.NS.apInjs_NP' :: 'Generics.SOP.Sing.SListI' xs => 'Generics.SOP.NP.NP' f xs -> ['Generics.SOP.NS.NS' f xs ] -- 'hapInjs', 'Generics.SOP.NS.apInjs_SOP' :: 'SListI2' xss => 'Generics.SOP.NP.POP' f xs -> ['Generics.SOP.NS.SOP' f xss] -- @ -- -- /Examples:/ -- -- >>> hapInjs (I 'x' :* I True :* I 2 :* Nil) -- [Z (I 'x'), S (Z (I True)), S (S (Z (I 2)))] -- -- >>> hapInjs (POP ((I 'x' :* Nil) :* (I True :* I 2 :* Nil) :* Nil) -- [SOP (Z (I 'x' :* Nil)), SOP (S (Z (I True :* (I 2 :* Nil))))] -- -- @since 0.2.4.0 -- hapInjs :: (SListIN h xs) => Prod h f xs -> [h f xs] -- * Expanding sums to products -- | A class for expanding sum structures into corresponding product -- structures, filling in the slots not targeted by the sum with -- default values. -- -- @since 0.2.5.0 -- class HExpand (h :: (k -> *) -> (l -> *)) where -- | Expand a given sum structure into a corresponding product -- structure by placing the value contained in the sum into the -- corresponding position in the product, and using the given -- default value for all other positions. -- -- /Instances:/ -- -- @ -- 'hexpand', 'Generics.SOP.NS.expand_NS' :: 'Generics.SOP.Sing.SListI' xs => (forall x . f x) -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NS.NP' f xs -- 'hexpand', 'Generics.SOP.NS.expand_SOP' :: 'SListI2' xss => (forall x . f x) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NP.POP' f xss -- @ -- -- /Examples:/ -- -- >>> hexpand Nothing (S (Z (Just 3))) :: NP Maybe '[Char, Int, Bool] -- Nothing :* Just 3 :* Nothing :* Nil -- >>> hexpand [] (SOP (S (Z ([1,2] :* "xyz" :* Nil)))) :: POP [] '[ '[Bool], '[Int, Char] ] -- POP (([] :* Nil) :* ([1,2] :* "xyz" :* Nil) :* Nil) -- -- @since 0.2.5.0 -- hexpand :: (SListIN (Prod h) xs) => (forall x . f x) -> h f xs -> Prod h f xs -- | Variant of 'hexpand' that allows passing a constrained default. -- -- /Instances:/ -- -- @ -- 'hcexpand', 'Generics.SOP.NS.cexpand_NS' :: 'All' c xs => proxy c -> (forall x . c x => f x) -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NP.NP' f xs -- 'hcexpand', 'Generics.SOP.NS.cexpand_SOP' :: 'All2' c xss => proxy c -> (forall x . c x => f x) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NP.POP' f xss -- @ -- -- /Examples:/ -- -- >>> hcexpand (Proxy :: Proxy Bounded) (I minBound) (S (Z (I 20))) :: NP I '[Bool, Int, Ordering] -- I False :* I 20 :* I LT :* Nil -- >>> hcexpand (Proxy :: Proxy Num) (I 0) (SOP (S (Z (I 1 :* I 2 :* Nil)))) :: POP I '[ '[Double], '[Int, Int] ] -- POP ((I 0.0 :* Nil) :* (I 1 :* I 2 :* Nil) :* Nil) -- -- @since 0.2.5.0 -- hcexpand :: (AllN (Prod h) c xs) => proxy c -> (forall x . c x => f x) -> h f xs -> Prod h f xs -- | 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 generics-sop-0.3.1.0/src/Generics/SOP/NP.hs0000644000000000000000000005240313117242337016304 0ustar0000000000000000{-# LANGUAGE PolyKinds, StandaloneDeriving, UndecidableInstances #-} -- | n-ary products (and products of products) module Generics.SOP.NP ( -- * Datatypes NP(..) , POP(..) , unPOP -- * Constructing products , pure_NP , pure_POP , cpure_NP , cpure_POP -- ** Construction from a list , fromList -- * Application , ap_NP , ap_POP -- * Destructing products , hd , tl , Projection , projections , shiftProjection -- * Lifting / mapping , liftA_NP , liftA_POP , liftA2_NP , liftA2_POP , liftA3_NP , liftA3_POP , map_NP , map_POP , zipWith_NP , zipWith_POP , zipWith3_NP , zipWith3_POP , cliftA_NP , cliftA_POP , cliftA2_NP , cliftA2_POP , cliftA3_NP , cliftA3_POP , cmap_NP , cmap_POP , czipWith_NP , czipWith_POP , czipWith3_NP , czipWith3_POP -- * Dealing with @'All' c@ , hcliftA' , hcliftA2' , hcliftA3' , cliftA2'_NP -- * Collapsing , collapse_NP , collapse_POP -- * Sequencing , sequence'_NP , sequence'_POP , sequence_NP , sequence_POP -- * Catamorphism and anamorphism , cata_NP , ccata_NP , ana_NP , cana_NP -- * Transformation of index lists and coercions , trans_NP , trans_POP , coerce_NP , coerce_POP , fromI_NP , fromI_POP , toI_NP , toI_POP ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #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 :* deriving instance All (Show `Compose` f) xs => Show (NP f xs) deriving instance All (Eq `Compose` f) xs => Eq (NP f xs) deriving instance (All (Eq `Compose` f) xs, All (Ord `Compose` f) xs) => Ord (NP f xs) -- | @since 0.2.5.0 instance All (NFData `Compose` f) xs => NFData (NP f xs) where rnf Nil = () rnf (x :* xs) = rnf x `seq` rnf xs -- | A product of products. -- -- This is a 'newtype' for an 'NP' of an 'NP'. The elements of the -- inner products are applications of the parameter @f@. The type -- 'POP' is indexed by the list of lists that determines the lengths -- of both the outer and all the inner products, as well as the types -- of all the elements of the inner products. -- -- A 'POP' is reminiscent of a two-dimensional table (but the inner -- lists can all be of different length). In the context of the SOP -- approach to generic programming, a 'POP' is useful to represent -- information that is available for all arguments of all constructors -- of a datatype. -- newtype POP (f :: (k -> *)) (xss :: [[k]]) = POP (NP (NP f) xss) deriving instance (Show (NP (NP f) xss)) => Show (POP f xss) deriving instance (Eq (NP (NP f) xss)) => Eq (POP f xss) deriving instance (Ord (NP (NP f) xss)) => Ord (POP f xss) -- | @since 0.2.5.0 instance (NFData (NP (NP f) xss)) => NFData (POP f xss) where rnf (POP xss) = rnf xss -- | Unwrap a product of products. unPOP :: POP f xss -> NP (NP f) xss unPOP (POP xss) = xss type instance AllN NP c = All c type instance AllN POP c = All2 c type instance 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 -- * Sequencing -- | Specialization of 'hsequence''. sequence'_NP :: Applicative f => NP (f :.: g) xs -> f (NP g xs) -- | Specialization of 'hsequence''. sequence'_POP :: (SListI xss, Applicative f) => POP (f :.: g) xss -> f (POP g xss) sequence'_NP Nil = pure Nil sequence'_NP (mx :* mxs) = (:*) <$> unComp mx <*> sequence'_NP mxs sequence'_POP = fmap POP . sequence'_NP . hliftA (Comp . sequence'_NP) . unPOP instance HSequence NP where hsequence' = sequence'_NP instance HSequence POP where hsequence' = sequence'_POP -- | Specialization of 'hsequence'. -- -- /Example:/ -- -- >>> sequence_NP (Just 1 :* Just 2 :* Nil) -- Just (I 1 :* I 2 :* Nil) -- sequence_NP :: (SListI xs, Applicative f) => NP f xs -> f (NP I xs) -- | Specialization of 'hsequence'. -- -- /Example:/ -- -- >>> sequence_POP (POP ((Just 1 :* Nil) :* (Just 2 :* Just 3 :* Nil) :* Nil)) -- Just (POP ((I 1 :* Nil) :* ((I 2 :* (I 3 :* Nil)) :* Nil))) -- sequence_POP :: (All SListI xss, Applicative f) => POP f xss -> f (POP I xss) sequence_NP = hsequence sequence_POP = hsequence -- * Catamorphism and anamorphism -- | Catamorphism for 'NP'. -- -- This is a suitable generalization of 'foldr'. It takes -- parameters on what to do for 'Nil' and ':*'. Since the -- input list is heterogeneous, the result is also indexed -- by a type-level list. -- -- @since 0.2.3.0 -- cata_NP :: forall r f xs . r '[] -> (forall y ys . f y -> r ys -> r (y ': ys)) -> NP f xs -> r xs cata_NP nil cons = go where go :: forall ys . NP f ys -> r ys go Nil = nil go (x :* xs) = cons x (go xs) -- | Constrained catamorphism for 'NP'. -- -- The difference compared to 'cata_NP' is that the function -- for the cons-case can make use of the fact that the specified -- constraint holds for all the types in the signature of the -- product. -- -- @since 0.2.3.0 -- ccata_NP :: forall c proxy r f xs . (All c xs) => proxy c -> r '[] -> (forall y ys . c y => f y -> r ys -> r (y ': ys)) -> NP f xs -> r xs ccata_NP _ nil cons = go where go :: forall ys . (All c ys) => NP f ys -> r ys go Nil = nil go (x :* xs) = cons x (go xs) -- | Anamorphism for 'NP'. -- -- In contrast to the anamorphism for normal lists, the -- generating function does not return an 'Either', but -- simply an element and a new seed value. -- -- This is because the decision on whether to generate a -- 'Nil' or a ':*' is determined by the types. -- -- @since 0.2.3.0 -- ana_NP :: forall s f xs . SListI xs => (forall y ys . s (y ': ys) -> (f y, s ys)) -> s xs -> NP f xs ana_NP uncons = go sList where go :: forall ys . SList ys -> s ys -> NP f ys go SNil _ = Nil go SCons s = case uncons s of (x, s') -> x :* go sList s' -- | Constrained anamorphism for 'NP'. -- -- Compared to 'ana_NP', the generating function can -- make use of the specified constraint here for the -- elements that it generates. -- -- @since 0.2.3.0 -- cana_NP :: forall c proxy s f xs . (All c xs) => proxy c -> (forall y ys . c y => s (y ': ys) -> (f y, s ys)) -> s xs -> NP f xs cana_NP _ uncons = go sList where go :: forall ys . (All c ys) => SList ys -> s ys -> NP f ys go SNil _ = Nil go SCons s = case uncons s of (x, s') -> x :* go sList s' -- | 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 generics-sop-0.3.1.0/src/Generics/SOP/BasicFunctors.hs0000644000000000000000000002775013117242337020543 0ustar0000000000000000{-# 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 . -- 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 ) 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 #-} generics-sop-0.3.1.0/src/Generics/SOP/Type/0000755000000000000000000000000013117242337016350 5ustar0000000000000000generics-sop-0.3.1.0/src/Generics/SOP/Type/Metadata.hs0000644000000000000000000002024413117242337020426 0ustar0000000000000000{-# LANGUAGE PolyKinds, UndecidableInstances #-} -- | Type-level metadata -- -- This module provides datatypes (to be used promoted) that can represent the -- metadata of Haskell datatypes on the type level. -- -- We do not reuse the term-level metadata types, because these are GADTs that -- incorporate additional invariants. We could (at least in GHC 8) impose the -- same invariants on the type level as well, but some tests have revealed that -- the resulting type are rather inconvenient to work with. -- -- So we use simple datatypes to represent the type-level metadata, even if -- this means that some invariants are not explicitly captured. -- -- We establish a relation between the term- and type-level versions of the -- metadata by automatically computing the term-level version from the type-level -- version. -- -- As we now have two versions of metadata (term-level and type-level) -- with very similar, yet slightly different datatype definitions, the names -- between the modules clash, and this module is recommended to be imported -- qualified when needed. -- -- The interface exported by this module is still somewhat experimental. -- -- @since 0.3.0.0 -- module Generics.SOP.Type.Metadata ( module Generics.SOP.Type.Metadata -- * re-exports , Associativity(..) ) where import Data.Proxy import GHC.Generics (Associativity(..)) #if __GLASGOW_HASKELL__ >= 800 import GHC.Types #endif import GHC.TypeLits import qualified Generics.SOP.Metadata as M import Generics.SOP.NP import Generics.SOP.Sing -- Regarding the CPP in the datatype definitions below: -- -- We cannot promote type synonyms in GHC 7, so we -- use equivalent yet less descriptive definitions -- for the older GHCs. -- | Metadata for a datatype (to be used promoted). -- -- A type of kind @'DatatypeInfo'@ contains meta-information about a datatype -- that is not contained in its code. This information consists -- primarily of the names of the datatype, its constructors, and possibly its -- record selectors. -- -- The constructor indicates whether the datatype has been declared using @newtype@ -- or not. -- -- @since 0.3.0.0 -- data DatatypeInfo = #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 -- | The name of a module. type ModuleName = Symbol -- | The name of a data constructor. type ConstructorName = Symbol -- | The name of a field / record selector. type FieldName = Symbol -- | The fixity of an infix constructor. type Fixity = Nat #endif -- Demotion -- -- The following classes are concerned with computing the -- term-level metadata from the type-level metadata. -- | Class for computing term-level datatype information from -- type-level datatype information. -- -- @since 0.3.0.0 -- class DemoteDatatypeInfo (x :: DatatypeInfo) (xss :: [[*]]) where -- | Given a proxy of some type-level datatype information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteDatatypeInfo :: proxy x -> M.DatatypeInfo xss instance (KnownSymbol m, KnownSymbol d, DemoteConstructorInfos cs xss) => DemoteDatatypeInfo ('ADT m d cs) xss where demoteDatatypeInfo _ = M.ADT (symbolVal (Proxy :: Proxy m)) (symbolVal (Proxy :: Proxy d)) (demoteConstructorInfos (Proxy :: Proxy cs)) instance (KnownSymbol m, KnownSymbol d, DemoteConstructorInfo c '[ x ]) => DemoteDatatypeInfo ('Newtype m d c) '[ '[ x ] ] where demoteDatatypeInfo _ = M.Newtype (symbolVal (Proxy :: Proxy m)) (symbolVal (Proxy :: Proxy d)) (demoteConstructorInfo (Proxy :: Proxy c)) -- | Class for computing term-level constructor information from -- type-level constructor information. -- -- @since 0.3.0.0 -- class DemoteConstructorInfos (cs :: [ConstructorInfo]) (xss :: [[*]]) where -- | Given a proxy of some type-level constructor information, -- return the corresponding term-level information as a product. -- -- @since 0.3.0.0 -- demoteConstructorInfos :: proxy cs -> NP M.ConstructorInfo xss instance DemoteConstructorInfos '[] '[] where demoteConstructorInfos _ = Nil instance (DemoteConstructorInfo c xs, DemoteConstructorInfos cs xss) => DemoteConstructorInfos (c ': cs) (xs ': xss) where demoteConstructorInfos _ = demoteConstructorInfo (Proxy :: Proxy c) :* demoteConstructorInfos (Proxy :: Proxy cs) -- | Class for computing term-level constructor information from -- type-level constructor information. -- -- @since 0.3.0.0 -- class DemoteConstructorInfo (x :: ConstructorInfo) (xs :: [*]) where -- | Given a proxy of some type-level constructor information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteConstructorInfo :: proxy x -> M.ConstructorInfo xs instance (KnownSymbol s, SListI xs) => DemoteConstructorInfo ('Constructor s) xs where demoteConstructorInfo _ = M.Constructor (symbolVal (Proxy :: Proxy s)) instance (KnownSymbol s, DemoteAssociativity a, KnownNat f) => DemoteConstructorInfo ('Infix s a f) [y, z] where demoteConstructorInfo _ = M.Infix (symbolVal (Proxy :: Proxy s)) (demoteAssociativity (Proxy :: Proxy a)) (fromInteger (natVal (Proxy :: Proxy f))) instance (KnownSymbol s, DemoteFieldInfos fs xs) => DemoteConstructorInfo ('Record s fs) xs where demoteConstructorInfo _ = M.Record (symbolVal (Proxy :: Proxy s)) (demoteFieldInfos (Proxy :: Proxy fs)) -- | Class for computing term-level field information from -- type-level field information. -- -- @since 0.3.0.0 -- class SListI xs => DemoteFieldInfos (fs :: [FieldInfo]) (xs :: [*]) where -- | Given a proxy of some type-level field information, -- return the corresponding term-level information as a product. -- -- @since 0.3.0.0 -- demoteFieldInfos :: proxy fs -> NP M.FieldInfo xs instance DemoteFieldInfos '[] '[] where demoteFieldInfos _ = Nil instance (DemoteFieldInfo f x, DemoteFieldInfos fs xs) => DemoteFieldInfos (f ': fs) (x ': xs) where demoteFieldInfos _ = demoteFieldInfo (Proxy :: Proxy f) :* demoteFieldInfos (Proxy :: Proxy fs) -- | Class for computing term-level field information from -- type-level field information. -- -- @since 0.3.0.0 -- class DemoteFieldInfo (x :: FieldInfo) (a :: *) where -- | Given a proxy of some type-level field information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteFieldInfo :: proxy x -> M.FieldInfo a instance KnownSymbol s => DemoteFieldInfo ('FieldInfo s) a where demoteFieldInfo _ = M.FieldInfo (symbolVal (Proxy :: Proxy s)) -- | Class for computing term-level associativity information -- from type-level associativity information. -- -- @since 0.3.0.0 -- class DemoteAssociativity (a :: Associativity) where -- | Given a proxy of some type-level associativity information, -- return the corresponding term-level information. -- -- @since 0.3.0.0 -- demoteAssociativity :: proxy a -> M.Associativity instance DemoteAssociativity 'LeftAssociative where demoteAssociativity _ = M.LeftAssociative instance DemoteAssociativity 'RightAssociative where demoteAssociativity _ = M.RightAssociative instance DemoteAssociativity 'NotAssociative where demoteAssociativity _ = M.NotAssociative generics-sop-0.3.1.0/test/0000755000000000000000000000000013117242337013417 5ustar0000000000000000generics-sop-0.3.1.0/test/Example.hs0000644000000000000000000000357613117242337015361 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Main (main, toTreeC) where import qualified GHC.Generics as GHC import Generics.SOP import Generics.SOP.TH import qualified Generics.SOP.Type.Metadata as T import HTransExample -- Generic show, kind of gshow :: (Generic a, All2 Show (Code a)) => a -> String gshow x = gshowS (from x) gshowS :: (All2 Show xss) => SOP I xss -> String gshowS (SOP (Z xs)) = gshowP xs gshowS (SOP (S xss)) = gshowS (SOP xss) gshowP :: (All Show xs) => NP I xs -> String gshowP Nil = "" gshowP (I x :* xs) = show x ++ (gshowP xs) -- GHC.Generics data Tree = Leaf Int | Node Tree Tree deriving (GHC.Generic) tree :: Tree tree = Node (Leaf 1) (Leaf 2) instance Generic Tree instance HasDatatypeInfo Tree instance Show Tree where show = gshow -- Template Haskell data TreeB = LeafB Int | NodeB TreeB TreeB treeB :: TreeB treeB = NodeB (LeafB 1) (LeafB 2) deriveGeneric ''TreeB instance Show TreeB where show = gshow -- Orphan approach data TreeC = LeafC Int | NodeC TreeC TreeC treeC :: TreeC treeC = NodeC (LeafC 1) (LeafC 2) deriveGenericFunctions ''TreeC "TreeCCode" "fromTreeC" "toTreeC" deriveMetadataValue ''TreeC "TreeCCode" "treeDatatypeInfo" deriveMetadataType ''TreeC "TreeDatatypeInfo" demotedTreeDatatypeInfo :: DatatypeInfo TreeCCode demotedTreeDatatypeInfo = T.demoteDatatypeInfo (Proxy :: Proxy TreeDatatypeInfo) instance Show TreeC where show x = gshowS (fromTreeC x) -- Tests main :: IO () main = do print tree print $ datatypeInfo (Proxy :: Proxy Tree) print treeB print $ datatypeInfo (Proxy :: Proxy TreeB) print treeC print treeDatatypeInfo print demotedTreeDatatypeInfo print (treeDatatypeInfo == demotedTreeDatatypeInfo) print $ convertFull tree generics-sop-0.3.1.0/test/HTransExample.hs0000644000000000000000000000164513117242337016474 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module HTransExample where import Generics.SOP class IsTupleTypeOf xs y | xs -> y where toTuple :: NP I xs -> y default toTuple :: (Generic y, Code y ~ '[ xs ]) => NP I xs -> y toTuple = to . SOP . Z instance IsTupleTypeOf '[] () instance IsTupleTypeOf '[x1] x1 where toTuple = unI . hd instance IsTupleTypeOf '[x1, x2] (x1, x2) instance IsTupleTypeOf '[x1, x2, x3] (x1, x2, x3) instance IsTupleTypeOf '[x1, x2, x3, x4] (x1, x2, x3, x4) convert :: (AllZip IsTupleTypeOf xss ys) => NS (NP I) xss -> NS I ys convert = htrans (Proxy :: Proxy IsTupleTypeOf) (I . toTuple) convertFull :: (Generic a, AllZip IsTupleTypeOf (Code a) ys) => a -> NS I ys convertFull = convert . unSOP . from