generics-sop-0.2.0.0/0000755000000000000000000000000012612360750012435 5ustar0000000000000000generics-sop-0.2.0.0/LICENSE0000644000000000000000000000277612612360750013456 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.2.0.0/generics-sop.cabal0000644000000000000000000000767112612360750016032 0ustar0000000000000000name: generics-sop version: 0.2.0.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 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 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 -- 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.6 && < 5, template-haskell >= 2.8 && < 2.11, ghc-prim >= 0.3 && < 0.5 if impl (ghc < 7.8) build-depends: tagged >= 0.7 && < 0.9 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 generic-sop-examples type: exitcode-stdio-1.0 main-is: Example.hs hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall build-depends: base >= 4.6 && < 5, generics-sop generics-sop-0.2.0.0/Setup.hs0000644000000000000000000000005612612360750014072 0ustar0000000000000000import Distribution.Simple main = defaultMain generics-sop-0.2.0.0/test/0000755000000000000000000000000012612360750013414 5ustar0000000000000000generics-sop-0.2.0.0/test/Example.hs0000644000000000000000000000275212612360750015351 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 -- 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) deriveGenericOnly ''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" instance Show TreeC where show x = gshowS (fromTreeC x) -- Tests main :: IO () main = do print tree print $ datatypeInfo (Proxy :: Proxy Tree) print treeB print treeC print treeDatatypeInfo generics-sop-0.2.0.0/src/0000755000000000000000000000000012612360750013224 5ustar0000000000000000generics-sop-0.2.0.0/src/Generics/0000755000000000000000000000000012612360750014763 5ustar0000000000000000generics-sop-0.2.0.0/src/Generics/SOP.hs0000644000000000000000000002463412612360750015771 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 DeriveGenerics #-} -- > -- > 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 -- * n-ary datatypes , NP(..) , NS(..) , SOP(..) , unSOP , POP(..) , unPOP -- * Metadata , DatatypeInfo(..) , ConstructorInfo(..) , FieldInfo(..) , HasDatatypeInfo(..) , DatatypeName , ModuleName , ConstructorName , FieldName , Associativity(..) , Fixity -- * Combinators -- ** Constructing products , HPure(..) -- ** Application , (-.->)(..) , 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 , apInjs_NP , apInjs_POP -- ** Dealing with @'All' c@ , hcliftA' , hcliftA2' , hcliftA3' -- ** Collapsing , CollapseTo , HCollapse(..) -- ** Sequencing , HSequence(..) , hsequence , hsequenceK -- ** Partial operations , fromList -- * Utilities -- ** Basic functors , K(..) , unK , I(..) , unI , (:.:)(..) , unComp -- ** Mapping constraints , All , All2 , Compose , And , Top , AllN -- ** Singletons , SList(..) , SListI(..) , 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.2.0.0/src/Generics/SOP/0000755000000000000000000000000012612360750015424 5ustar0000000000000000generics-sop-0.2.0.0/src/Generics/SOP/Instances.hs0000644000000000000000000001246412612360750017716 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fcontext-stack=50 #-} -- | 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.2.0.0/src/Generics/SOP/Metadata.hs0000644000000000000000000000603012612360750017477 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] ] 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 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 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.2.0.0/src/Generics/SOP/Classes.hs0000644000000000000000000003545512612360750017371 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 where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative) #endif import Generics.SOP.BasicFunctors import Generics.SOP.Constraint -- | 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' :: '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 {------------------------------------------------------------------------------- Application -------------------------------------------------------------------------------} -- | Lifted functions. newtype (f -.-> g) a = Fn { apFn :: f a -> g a } -- TODO: What is the right precedence? infixr 1 -.-> -- | Construct a lifted function. -- -- Same as 'Fn'. Only available for uniformity with the -- higher-arity versions. -- fn :: (f a -> f' a) -> (f -.-> f') a -- | Construct a binary lifted function. fn_2 :: (f a -> f' a -> f'' a) -> (f -.-> f' -.-> f'') a -- | Construct a ternary lifted function. fn_3 :: (f a -> f' a -> f'' a -> f''' a) -> (f -.-> f' -.-> f'' -.-> f''') a -- | Construct a quarternary lifted function. fn_4 :: (f a -> f' a -> f'' a -> f''' a -> f'''' a) -> (f -.-> f' -.-> f'' -.-> f''' -.-> f'''') a fn f = Fn $ \x -> f x fn_2 f = Fn $ \x -> Fn $ \x' -> f x x' fn_3 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> f x x' x'' fn_4 f = Fn $ \x -> Fn $ \x' -> Fn $ \x'' -> Fn $ \x''' -> f x x' x'' x''' -- | Maps a structure containing sums to the corresponding -- product structure. type family Prod (h :: (k -> *) -> (l -> *)) :: (k -> *) -> (l -> *) -- | A generalization of 'Control.Applicative.<*>'. class (Prod (Prod h) ~ Prod h, HPure (Prod h)) => HAp (h :: (k -> *) -> (l -> *)) where -- | Corresponds to 'Control.Applicative.<*>'. -- -- For products ('Generics.SOP.NP.NP') as well as products of products -- ('Generics.SOP.NP.POP), the correspondence is rather direct. We combine -- a structure containing (lifted) functions and a compatible structure -- containing corresponding arguments into a compatible structure -- containing results. -- -- The same combinator can also be used to combine a product -- structure of functions with a sum structure of arguments, which then -- results in another sum structure of results. The sum structure -- determines which part of the product structure will be used. -- -- /Instances:/ -- -- @ -- 'hap', 'Generics.SOP.NP.ap_NP' :: 'Generics.SOP.NP.NP' (f -.-> g) xs -> 'Generics.SOP.NP.NP' f xs -> 'Generics.SOP.NP.NP' g xs -- 'hap', 'Generics.SOP.NS.ap_NS' :: 'Generics.SOP.NS.NP' (f -.-> g) xs -> 'Generics.SOP.NS.NS' f xs -> 'Generics.SOP.NS.NS' g xs -- 'hap', 'Generics.SOP.NP.ap_POP' :: 'Generics.SOP.NP.POP' (f -.-> g) xss -> 'Generics.SOP.NP.POP' f xss -> 'Generics.SOP.NP.POP' g xss -- 'hap', 'Generics.SOP.NS.ap_SOP' :: 'Generics.SOP.NS.POP' (f -.-> g) xss -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NS.SOP' g xss -- @ -- hap :: Prod h (f -.-> g) xs -> h f xs -> h g xs {------------------------------------------------------------------------------- Derived from application -------------------------------------------------------------------------------} -- | 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' :: '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' :: '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' :: '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' :: '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' :: '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' :: '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'. hmap :: (SListIN (Prod h) xs, HAp h) => (forall a. f a -> f' a) -> h f xs -> h f' xs -- | Another name for 'hliftA2'. 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'. 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'. 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'. 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'. 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 -- | Maps products to lists, and sums to identities. type family CollapseTo (h :: (k -> *) -> (l -> *)) (x :: *) :: * -- | A class for collapsing a heterogeneous structure into -- a homogeneous one. class HCollapse (h :: (k -> *) -> (l -> *)) where -- | Collapse a heterogeneous structure with homogeneous elements -- into a homogeneous structure. -- -- If a heterogeneous structure is instantiated to the constant -- functor 'K', then it is in fact homogeneous. This function -- maps such a value to a simpler Haskell datatype reflecting that. -- An @'NS' ('K' a)@ contains a single @a@, and an @'NP' ('K' a)@ contains -- a list of @a@s. -- -- /Instances:/ -- -- @ -- 'hcollapse', 'Generics.SOP.NP.collapse_NP' :: 'Generics.SOP.NP.NP' ('K' a) xs -> [a] -- 'hcollapse', 'Generics.SOP.NS.collapse_NS' :: 'Generics.SOP.NS.NS' ('K' a) xs -> a -- 'hcollapse', 'Generics.SOP.NP.collapse_POP' :: 'Generics.SOP.NP.POP' ('K' a) xss -> [[a]] -- 'hcollapse', 'Generics.SOP.NS.collapse_SOP' :: 'Generics.SOP.NP.SOP' ('K' a) xss -> [a] -- @ -- hcollapse :: SListIN h xs => h (K a) xs -> CollapseTo h a -- | A generalization of 'Data.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' :: ('SListI' xs , 'Applicative' f) => 'Generics.SOP.NP.NP' (f ':.:' g) xs -> f ('Generics.SOP.NP.NP' g xs ) -- 'hsequence'', 'Generics.SOP.NS.sequence'_NS' :: ('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) -- | 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) generics-sop-0.2.0.0/src/Generics/SOP/NS.hs0000644000000000000000000002357012612360750016307 0ustar0000000000000000{-# LANGUAGE PolyKinds, StandaloneDeriving, 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 , apInjs_NP , apInjs_POP -- * 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 ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif 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 (I 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) -- | 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) -- | Unwrap a sum of products. unSOP :: SOP f xss -> NS (NP f) xss unSOP (SOP xss) = xss -- * 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 shift injections -- | 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 (Fn f) = Fn $ K . S . unK . f -- | 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 . 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 -- * Application -- | Specialization of 'hap'. ap_NS :: NP (f -.-> g) xs -> NS f xs -> NS g xs ap_NS (Fn f :* _) (Z x) = Z (f x) ap_NS (_ :* fs) (S xs) = S (ap_NS fs xs) ap_NS _ _ = error "inaccessible" -- | Specialization of 'hap'. ap_SOP :: POP (f -.-> g) xss -> SOP f xss -> SOP g xss ap_SOP (POP fss') (SOP xss') = SOP (go fss' xss') where go :: NP (NP (f -.-> g)) xss -> NS (NP f) xss -> NS (NP g) xss go (fs :* _ ) (Z xs ) = Z (ap_NP fs xs ) go (_ :* fss) (S xss) = S (go fss xss) go _ _ = error "inaccessible" -- The definition of 'ap_SOP' is a more direct variant of -- '_ap_SOP_spec'. The direct definition has the advantage -- that it avoids the 'SListI' constraint. _ap_SOP_spec :: SListI xss => POP (t -.-> f) xss -> SOP t xss -> SOP f xss _ap_SOP_spec (POP fs) (SOP xs) = SOP (liftA2_NS ap_NP fs xs) type instance Prod NS = NP type instance Prod SOP = POP type instance SListIN NS = SListI type instance SListIN SOP = SListI2 instance HAp NS where hap = ap_NS instance HAp SOP where hap = ap_SOP -- * Lifting / mapping -- | Specialization of 'hliftA'. liftA_NS :: SListI xs => (forall a. f a -> g a) -> NS f xs -> NS g xs -- | Specialization of 'hliftA'. liftA_SOP :: All SListI xss => (forall a. f a -> g a) -> SOP f xss -> SOP g xss liftA_NS = hliftA liftA_SOP = hliftA -- | Specialization of 'hliftA2'. liftA2_NS :: SListI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NS g xs -> NS h xs -- | Specialization of 'hliftA2'. liftA2_SOP :: All SListI xss => (forall a. f a -> g a -> h a) -> POP f xss -> SOP g xss -> SOP h xss liftA2_NS = hliftA2 liftA2_SOP = hliftA2 -- | Specialization of 'hmap', which is equivalent to 'hliftA'. map_NS :: SListI xs => (forall a. f a -> g a) -> NS f xs -> NS g xs -- | Specialization of 'hmap', which is equivalent to 'hliftA'. map_SOP :: All SListI xss => (forall a. f a -> g a) -> SOP f xss -> SOP g xss map_NS = hmap map_SOP = hmap -- | Specialization of 'hcliftA'. cliftA_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NS f xs -> NS g xs -- | Specialization of 'hcliftA'. cliftA_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> SOP f xss -> SOP g xss cliftA_NS = hcliftA cliftA_SOP = hcliftA -- | Specialization of 'hcliftA2'. cliftA2_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a -> h a) -> NP f xs -> NS g xs -> NS h xs -- | Specialization of 'hcliftA2'. cliftA2_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a -> h a) -> POP f xss -> SOP g xss -> SOP h xss cliftA2_NS = hcliftA2 cliftA2_SOP = hcliftA2 -- | Specialization of 'hcmap', which is equivalent to 'hcliftA'. cmap_NS :: All c xs => proxy c -> (forall a. c a => f a -> g a) -> NS f xs -> NS g xs -- | Specialization of 'hcmap', which is equivalent to 'hcliftA'. cmap_SOP :: All2 c xss => proxy c -> (forall a. c a => f a -> g a) -> SOP f xss -> SOP g xss cmap_NS = hcmap cmap_SOP = hcmap -- * Dealing with @'All' c@ -- | Specialization of 'hcliftA2''. {-# DEPRECATED cliftA2'_NS "Use 'cliftA2_NS' instead." #-} cliftA2'_NS :: All2 c xss => proxy c -> (forall xs. All c xs => f xs -> g xs -> h xs) -> NP f xss -> NS g xss -> NS h xss cliftA2'_NS = hcliftA2' -- * Collapsing -- | Specialization of 'hcollapse'. collapse_NS :: NS (K a) xs -> a -- | Specialization of 'hcollapse'. collapse_SOP :: SListI xss => SOP (K a) xss -> [a] collapse_NS (Z (K x)) = x collapse_NS (S xs) = collapse_NS xs collapse_SOP = collapse_NS . hliftA (K . collapse_NP) . unSOP type instance CollapseTo NS a = a type instance CollapseTo SOP a = [a] instance HCollapse NS where hcollapse = collapse_NS instance HCollapse SOP where hcollapse = collapse_SOP -- * Sequencing -- | Specialization of 'hsequence''. sequence'_NS :: Applicative f => NS (f :.: g) xs -> f (NS g xs) -- | Specialization of 'hsequence''. sequence'_SOP :: (SListI xss, Applicative f) => SOP (f :.: g) xss -> f (SOP g xss) sequence'_NS (Z mx) = Z <$> unComp mx sequence'_NS (S mxs) = S <$> sequence'_NS mxs sequence'_SOP = fmap SOP . sequence'_NS . hliftA (Comp . sequence'_NP) . unSOP instance HSequence NS where hsequence' = sequence'_NS instance HSequence SOP where hsequence' = sequence'_SOP -- | Specialization of 'hsequence'. sequence_NS :: (SListI xs, Applicative f) => NS f xs -> f (NS I xs) -- | Specialization of 'hsequence'. sequence_SOP :: (All SListI xss, Applicative f) => SOP f xss -> f (SOP I xss) sequence_NS = hsequence sequence_SOP = hsequence generics-sop-0.2.0.0/src/Generics/SOP/NP.hs0000644000000000000000000003561412612360750016306 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 -- * 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 ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif import Data.Proxy (Proxy(..)) 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) -- | 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) -- | Unwrap a product of products. unPOP :: POP f xss -> NP (NP f) xss unPOP (POP xss) = xss type instance AllN NP c = All c type instance AllN POP c = All2 c type instance SListIN NP = SListI type instance SListIN POP = SListI2 -- * Constructing products -- | Specialization of 'hpure'. -- -- The call @'pure_NP' x@ generates a product that contains 'x' in every -- element position. -- -- /Example:/ -- -- >>> pure_NP [] :: NP [] '[Char, Bool] -- "" :* [] :* Nil -- >>> pure_NP (K 0) :: NP (K Int) '[Double, Int, String] -- K 0 :* K 0 :* K 0 :* Nil -- pure_NP :: forall f xs. SListI xs => (forall a. f a) -> NP f xs pure_NP f = case sList :: SList xs of SNil -> Nil SCons -> f :* pure_NP f -- | Specialization of 'hpure'. -- -- The call @'pure_POP' x@ generates a product of products that contains 'x' -- in every element position. -- pure_POP :: All SListI xss => (forall a. f a) -> POP f xss pure_POP f = POP (cpure_NP sListP (pure_NP f)) sListP :: Proxy SListI sListP = Proxy -- | Specialization of 'hcpure'. -- -- The call @'cpure_NP' p x@ generates a product that contains 'x' in every -- element position. -- cpure_NP :: forall c xs proxy f. All c xs => proxy c -> (forall a. c a => f a) -> NP f xs cpure_NP p f = case sList :: SList xs of SNil -> Nil SCons -> f :* cpure_NP p f -- | Specialization of 'hcpure'. -- -- The call @'cpure_NP' p x@ generates a product of products that contains 'x' -- in every element position. -- cpure_POP :: forall c xss proxy f. All2 c xss => proxy c -> (forall a. c a => f a) -> POP f xss cpure_POP p f = POP (cpure_NP (allP p) (cpure_NP p f)) allP :: proxy c -> Proxy (All c) allP _ = Proxy instance HPure NP where hpure = pure_NP hcpure = cpure_NP instance HPure POP where hpure = pure_POP hcpure = cpure_POP -- ** Construction from a list -- | Construct a homogeneous n-ary product from a normal Haskell list. -- -- Returns 'Nothing' if the length of the list does not exactly match the -- expected size of the product. -- fromList :: SListI xs => [a] -> Maybe (NP (K a) xs) fromList = go sList where go :: SList xs -> [a] -> Maybe (NP (K a) xs) go SNil [] = return Nil go SCons (x:xs) = do ys <- go sList xs ; return (K x :* ys) go _ _ = Nothing -- * Application -- | Specialization of 'hap'. -- -- Applies a product of (lifted) functions pointwise to a product of -- suitable arguments. -- ap_NP :: NP (f -.-> g) xs -> NP f xs -> NP g xs ap_NP Nil Nil = Nil ap_NP (Fn f :* fs) (x :* xs) = f x :* ap_NP fs xs ap_NP _ _ = error "inaccessible" -- | 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 go _ _ = error "inaccessible" -- The definition of 'ap_POP' is a more direct variant of -- '_ap_POP_spec'. The direct definition has the advantage -- that it avoids the 'SListI' constraint. _ap_POP_spec :: SListI xss => POP (f -.-> g) xss -> POP f xss -> POP g xss _ap_POP_spec (POP fs) (POP xs) = POP (liftA2_NP ap_NP fs xs) type instance Prod NP = NP type instance Prod POP = POP instance HAp NP where hap = ap_NP instance HAp POP where hap = ap_POP -- * 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 'hclift' 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 generics-sop-0.2.0.0/src/Generics/SOP/GGP.hs0000644000000000000000000002076212612360750016404 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} -- | 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 , 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 import Generics.SOP.Constraint as SOP import Generics.SOP.Metadata as SOP import Generics.SOP.Sing 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 data InfoProxy (c :: *) (f :: * -> *) (x :: *) = InfoProxy 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 (moduleName p) (datatypeName p) ci = gConstructorInfos (Proxy :: Proxy a) Nil in if isNewtype p then case isNewtypeShape ci of NewYes c -> Newtype (moduleName p) (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 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 gProductTo _ _ = error "inaccessible" 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'. type GDatatypeInfo a = GDatatypeInfo' (GHC.Rep a) -- | An automatically computed version of 'Generics.SOP.from'. -- -- This requires that the type being converted has a -- 'GHC.Generic' (from module "GHC.Generics") instance. -- -- This is the default definition for 'Generics.SOP.from'. -- For more info, see 'Generics.SOP.Generic'. -- gfrom :: (GFrom a, GHC.Generic a) => a -> SOP I (GCode a) gfrom x = gSumFrom (GHC.from x) (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) gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a)) generics-sop-0.2.0.0/src/Generics/SOP/Constraint.hs0000644000000000000000000000747212612360750020116 0ustar0000000000000000{-# LANGUAGE PolyKinds, UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #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 GHC.Exts (Constraint) import Generics.SOP.Sing -- | Require a constraint for every element of a list. -- -- If you have a datatype that is indexed over a type-level -- list, then you can use 'All' to indicate that all elements -- of that type-level list must satisfy a given constraint. -- -- /Example:/ The constraint -- -- > All Eq '[ Int, Bool, Char ] -- -- is equivalent to the constraint -- -- > (Eq Int, Eq Bool, Eq Char) -- -- /Example:/ A type signature such as -- -- > f :: All Eq xs => NP I xs -> ... -- -- means that 'f' can assume that all elements of the n-ary -- product satisfy 'Eq'. -- class (AllF f xs, SListI xs) => All (f :: k -> Constraint) (xs :: [k]) instance (AllF f xs, SListI xs) => All f xs -- | Type family used to implement 'All'. -- type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint type instance AllF c '[] = () type instance AllF c (x ': xs) = (c x, All c xs) -- | Require a singleton for every inner list in a list of lists. type SListI2 = All SListI -- | Require a constraint for every element of a list of lists. -- -- If you have a datatype that is indexed over a type-level -- list of lists, then you can use 'All2' to indicate that all -- elements of the innert lists must satisfy a given constraint. -- -- /Example:/ The constraint -- -- > All2 Eq '[ '[ Int ], '[ Bool, Char ] ] -- -- is equivalent to the constraint -- -- > (Eq Int, Eq Bool, Eq Char) -- -- /Example:/ A type signature such as -- -- > f :: All2 Eq xss => SOP I xs -> ... -- -- means that 'f' can assume that all elements of the sum -- of product satisfy 'Eq'. -- class (AllF (All f) xss, SListI xss) => All2 f xss instance (AllF (All f) xss, SListI xss) => All2 f xss -- -- NOTE: -- -- The definition -- -- type All2 f = All (All f) -- -- is more direct, but has the unfortunate disadvantage the -- it triggers GHC's superclass cycle check when used in a -- class context. -- | Composition of constraints. -- -- Note that the result of the composition must be a constraint, -- and therefore, in @f ':.' g@, the kind of @f@ is @k -> 'Constraint'@. -- The kind of @g@, however, is @l -> k@ and can thus be an normal -- type constructor. -- -- A typical use case is in connection with 'All' on an 'NP' or an -- 'NS'. For example, in order to denote that all elements on an -- @'NP' f xs@ satisfy 'Show', we can say @'All' ('Show' :. f) xs@. -- class (f (g x)) => (f `Compose` g) x instance (f (g x)) => (f `Compose` g) x infixr 9 `Compose` -- | Pairing of constraints. -- 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. -- class Top x instance Top x -- | A generalization of 'All' and 'All2'. -- -- The family 'AllN' expands to 'All' or 'All2' depending on whether -- the argument is indexed by a list or a list of lists. -- type family AllN (h :: (k -> *) -> (l -> *)) (c :: k -> Constraint) :: l -> Constraint -- | A generalization of 'SListI'. -- -- The family 'SListIN' expands to 'SListI' or 'SListI2' depending -- on whether the argument is indexed by a list or a list of lists. -- type family SListIN (h :: (k -> *) -> (l -> *)) :: l -> Constraint instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} #endif SListI xs => SingI (xs :: [k]) where sing = sList instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPING #-} #endif All SListI xss => SingI (xss :: [[k]]) where sing = sList generics-sop-0.2.0.0/src/Generics/SOP/TH.hs0000644000000000000000000002547612612360750016311 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Generate @generics-sop@ boilerplate instances using Template Haskell. module Generics.SOP.TH ( deriveGeneric , deriveGenericOnly , deriveGenericFunctions , deriveMetadataValue ) where import Control.Monad (replicateM) import Data.Maybe (fromMaybe) import Language.Haskell.TH import Language.Haskell.TH.Syntax hiding (Infix) import Generics.SOP.BasicFunctors import Generics.SOP.Metadata 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 -- > datatypeInfo _ = ADT "Main" "Tree" -- > (Constructor "Leaf" :* Constructor "Node" :* Nil) -- -- /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 -- 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'. 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| DatatypeInfo $(conT codeName') |] -- treeDatatypeInfo :: DatatypeInfo TreeCode , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ... ] deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> 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] -> [Name] -> Q [Dec] deriveMetadataForDataDec isNewtype _cxt name bndrs cons _derivs = do let typ = appTyVars name bndrs md <- instanceD (cxt []) [t| HasDatatypeInfo $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 -------------------------------------------------------------------------------} metadata :: Bool -> Name -> [Con] -> Q Dec metadata isNewtype typeName cs = funD 'datatypeInfo [clause [wildP] (normalB $ metadata' isNewtype typeName cs) []] metadata' :: Bool -> Name -> [Con] -> Q Exp metadata' isNewtype typeName cs = md where md :: Q Exp md | isNewtype = [| Newtype $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(mdCon (head cs)) |] | otherwise = [| ADT $(stringE (nameModule' typeName)) $(stringE (nameBase typeName)) $(npE $ map mdCon cs) |] mdCon :: Con -> Q Exp mdCon (NormalC n _) = [| Constructor $(stringE (nameBase n)) |] mdCon (RecC n ts) = [| Record $(stringE (nameBase n)) $(npE (map mdField ts)) |] mdCon (InfixC _ n _) = do i <- reify n case i of DataConI _ _ _ (Fixity f a) -> [| Infix $(stringE (nameBase n)) $(mdAssociativity a) f |] _ -> fail "Strange infix operator" mdCon (ForallC _ _ _) = fail "Existentials not supported" mdField :: VarStrictType -> Q Exp mdField (n, _, _) = [| FieldInfo $(stringE (nameBase n)) |] mdAssociativity :: FixityDirection -> Q Exp mdAssociativity InfixL = [| LeftAssociative |] mdAssociativity InfixR = [| RightAssociative |] mdAssociativity InfixN = [| 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" 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] -> [Name] -> Q a) -> Q a 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 withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes." generics-sop-0.2.0.0/src/Generics/SOP/BasicFunctors.hs0000644000000000000000000000467312612360750020537 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. -- module Generics.SOP.BasicFunctors ( K(..) , unK , I(..) , unI , (:.:)(..) , unComp ) 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 -- | 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 (Show, Functor, Foldable, Traversable, GHC.Generic) #else deriving (Show, 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 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 (Show, Functor, Foldable, Traversable, GHC.Generic) #else deriving (Show, 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 -- | 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 (Show, GHC.Generic) infixr 7 :.: instance (Functor f, Functor g) => Functor (f :.: g) where fmap f (Comp x) = Comp (fmap (fmap f) x) -- | Extract the contents of a 'Comp' value. unComp :: (f :.: g) p -> f (g p) unComp (Comp x) = x generics-sop-0.2.0.0/src/Generics/SOP/Sing.hs0000644000000000000000000000623712612360750016670 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. -- 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'. -- 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. 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.2.0.0/src/Generics/SOP/Dict.hs0000644000000000000000000001017112612360750016643 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} -- | 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'. -- data Dict (c :: k -> Constraint) (a :: k) where Dict :: c a => Dict c a -- | A proof that the trivial constraint holds -- over all type-level lists. 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. pureAll2 :: All SListI xss => Dict (All2 Top) xss pureAll2 = all_POP (hpure Dict) -- | Lifts a dictionary conversion over a type-level list. 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. 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. 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. 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'. unAll_NP :: forall c xs . Dict (All c) xs -> NP (Dict c) xs unAll_NP Dict = hcpure (Proxy :: Proxy c) Dict -- | 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'. unAll_POP :: forall c xss . Dict (All2 c) xss -> POP (Dict c) xss unAll_POP Dict = hcpure (Proxy :: Proxy c) Dict -- | If we have a product containing proofs that each element -- of 'xs' satisfies 'c', then 'All c' holds for 'xs'. 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'. 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)'. unAll2 :: Dict (All2 c) xss -> Dict (All (All c)) xss unAll2 Dict = Dict -- | The constraint 'All (All c)' is convertible to 'All2 c'. 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. withDict :: Dict c a -> (c a => r) -> r withDict Dict x = x generics-sop-0.2.0.0/src/Generics/SOP/Universe.hs0000644000000000000000000001024712612360750017564 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} -- | Codes and interpretations module Generics.SOP.Universe where 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 -- | 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) => a -> SOP I (GCode a) from = gfrom -- | Converts from a structural representation back to the -- original value. to :: Rep a -> a default to :: (GTo a, GHC.Generic a) => SOP I (GCode 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 datatypeInfo :: proxy a -> DatatypeInfo (Code a) default datatypeInfo :: GDatatypeInfo a => proxy a -> DatatypeInfo (GCode a) datatypeInfo = gdatatypeInfo