diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generics-sop.cabal b/generics-sop.cabal new file mode 100644 --- /dev/null +++ b/generics-sop.cabal @@ -0,0 +1,87 @@ +name: generics-sop +version: 0.1.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 + 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: edsko@well-typed.com +category: Generics +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.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 + -- 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.10, + tagged >= 0.7 && < 0.8, + ghc-prim >= 0.3 && < 0.4 + 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 + OverlappingInstances + PolyKinds + UndecidableInstances + TemplateHaskell diff --git a/src/Generics/SOP.hs b/src/Generics/SOP.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP.hs @@ -0,0 +1,313 @@ +{-# 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 + -- ** Constructing sums + , Injection + , injections + , shift + , apInjs_NP + , apInjs_POP + -- ** Dealing with @'All' c@ + , AllDict(..) + , allDict_NP + , 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 + , Map + , AllMap + -- ** Singletons + , Sing(..) + , SingI(..) + -- *** Shape of type-level lists + , Shape(..) + , shape + , lengthSing + -- ** Re-exports + , Proxy(..) + ) 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 + diff --git a/src/Generics/SOP/BasicFunctors.hs b/src/Generics/SOP/BasicFunctors.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/BasicFunctors.hs @@ -0,0 +1,106 @@ +{-# 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 + +import Control.Applicative +import Data.Foldable (Foldable(..)) +import Data.Monoid (Monoid, mempty, (<>)) +import Data.Traversable (Traversable(..)) +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 + diff --git a/src/Generics/SOP/Classes.hs b/src/Generics/SOP/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Classes.hs @@ -0,0 +1,308 @@ +{-# 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 + +import Control.Applicative (Applicative) +import Data.Proxy (Proxy) + +import Generics.SOP.BasicFunctors +import Generics.SOP.Constraint +import Generics.SOP.Sing + +-- | 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' :: 'SingI' xs => (forall a. f a) -> 'Generics.SOP.NP.NP' f xs + -- 'hpure', 'Generics.SOP.NP.pure_POP' :: 'SingI' xss => (forall a. f a) -> 'Generics.SOP.NP.POP' f xss + -- @ + -- + hpure :: SingI 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' :: ('SingI' xs, 'All' c xs ) => 'Proxy' c -> (forall a. c a => f a) -> 'Generics.SOP.NP.NP' f xs + -- 'hcpure', 'Generics.SOP.NP.cpure_POP' :: ('SingI' xss, 'All2' c xss) => 'Proxy' c -> (forall a. c a => f a) -> 'Generics.SOP.NP.POP' f xss + -- @ + -- + hcpure :: (SingI xs, AllMap 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 as well as products or products, 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' xss => (forall a. f a -> f' a) -> 'Generics.SOP.NS.SOP' f xss -> 'Generics.SOP.NS.SOP' f' xss +-- @ +-- +hliftA :: (SingI 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' 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 :: (SingI 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' 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' :: 'SingI' 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 :: (SingI 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 + +-- | Variant of 'hliftA' that takes a constrained function. +-- +-- /Specification:/ +-- +-- @ +-- 'hcliftA' p f xs = 'hcpure' p ('fn' f) \` 'hap' \` xs +-- @ +-- +hcliftA :: (AllMap (Prod h) c xs, SingI 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 :: (AllMap (Prod h) c xs, SingI 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 :: (AllMap (Prod h) c xs, SingI 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 + +-- | Maps products to lists, and sums to identities. +type family CollapseTo (h :: (k -> *) -> (l -> *)) :: * -> * + +-- | 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 :: SingI 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' :: ('SingI' xs , 'Applicative' f) => 'Generics.SOP.NP.NP' (f ':.:' g) xs -> f ('Generics.SOP.NP.NP' g xs ) + -- 'hsequence'', 'Generics.SOP.NS.sequence'_NS' :: ('SingI' xs , 'Applicative' f) => 'Generics.SOP.NS.NS' (f ':.:' g) xs -> f ('Generics.SOP.NS.NS' g xs ) + -- 'hsequence'', 'Generics.SOP.NP.sequence'_POP' :: ('SingI' xss, 'Applicative' f) => 'Generics.SOP.NP.POP' (f ':.:' g) xss -> f ('Generics.SOP.NP.POP' g xss) + -- 'hsequence'', 'Generics.SOP.NS.sequence'_SOP' :: ('SingI' xss, 'Applicative' f) => 'Generics.SOP.NS.SOP' (f ':.:' g) xss -> f ('Generics.SOP.NS.SOP' g xss) + -- @ + -- + hsequence' :: (SingI xs, Applicative f) => h (f :.: g) xs -> f (h g xs) + +-- | Special case of 'hsequence'' where @g = 'I'@. +hsequence :: (SingI 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 :: (SingI xs, Applicative f, HSequence h) => h (K (f a)) xs -> f (h (K a) xs) +hsequenceK = hsequence' . hliftA (Comp . fmap K . unK) diff --git a/src/Generics/SOP/Constraint.hs b/src/Generics/SOP/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Constraint.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE PolyKinds #-} +-- | 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'. +-- +type family All (c :: k -> Constraint) (xs :: [k]) :: Constraint +type instance All c '[] = () +type instance All c (x ': xs) = (c x, All c xs) + +-- | 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'. +-- +type family All2 (c :: k -> Constraint) (xs :: [[k]]) :: Constraint +type instance All2 c '[] = () +type instance All2 c (x ': xs) = (All c x, All2 c xs) + +-- | A type-level 'map'. +type family Map (f :: k -> l) (xs :: [k]) :: [l] +type instance Map f '[] = '[] +type instance Map f (x ': xs) = f x ': Map f xs + +-- | A generalization of 'All' and 'All2'. +-- +-- The family 'AllMap' expands to 'All' or 'All2' depending on whether +-- the argument is indexed by a list or a list of lists. +-- +type family AllMap (h :: (k -> *) -> (l -> *)) (c :: k -> Constraint) (xs :: l) :: Constraint + +-- | Dictionary for a constraint for all elements of a type-level list. +-- +-- A value of type @'AllDict' c xs@ captures the constraint @'All' c xs@. +-- +data AllDict (c :: k -> Constraint) (xs :: [k]) where + AllDictC :: (SingI xs, All c xs) => AllDict c xs diff --git a/src/Generics/SOP/GGP.hs b/src/Generics/SOP/GGP.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/GGP.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE UndecidableInstances #-} +-- | Derive @generics-sop@ boilerplate instances from GHC's 'GHC.Generic'. +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.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 (SingI (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 sing 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 :: Sing xss -> NP ConstructorInfo xss -> IsNewtypeShape xss +isNewtypeShape SCons (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, SingI (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 a. (GDatatypeInfo a) => Proxy a -> DatatypeInfo (GCode a) +gdatatypeInfo _ = gDatatypeInfo' (Proxy :: Proxy (GHC.Rep a)) + diff --git a/src/Generics/SOP/Instances.hs b/src/Generics/SOP/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Instances.hs @@ -0,0 +1,249 @@ +{-# 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 ''[] + +-- 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 +-- (:~:) diff --git a/src/Generics/SOP/Metadata.hs b/src/Generics/SOP/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Metadata.hs @@ -0,0 +1,81 @@ +{-# 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 (Map ConstructorInfo xs) => Show (DatatypeInfo xs) +deriving instance All Eq (Map ConstructorInfo xs) => Eq (DatatypeInfo xs) +deriving instance (All Eq (Map ConstructorInfo xs), All Ord (Map 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 :: SingI xs => ConstructorName -> ConstructorInfo xs + -- Infix constructor + Infix :: ConstructorName -> Associativity -> Fixity -> ConstructorInfo '[ x, y ] + -- Record constructor + Record :: SingI xs => ConstructorName -> NP FieldInfo xs -> ConstructorInfo xs + +deriving instance All Show (Map FieldInfo xs) => Show (ConstructorInfo xs) +deriving instance All Eq (Map FieldInfo xs) => Eq (ConstructorInfo xs) +deriving instance (All Eq (Map FieldInfo xs), All Ord (Map 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 + diff --git a/src/Generics/SOP/NP.hs b/src/Generics/SOP/NP.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/NP.hs @@ -0,0 +1,376 @@ +{-# 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 + , cliftA_NP + , cliftA_POP + , cliftA2_NP + , cliftA2_POP + -- * Dealing with @'All' c@ + , allDict_NP + , hcliftA' + , hcliftA2' + , hcliftA3' + , cliftA2'_NP + -- * Collapsing + , collapse_NP + , collapse_POP + -- * Sequencing + , sequence'_NP + , sequence'_POP + , sequence_NP + , sequence_POP + ) where + +import Control.Applicative +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 (Map f xs) => Show (NP f xs) +deriving instance All Eq (Map f xs) => Eq (NP f xs) +deriving instance (All Eq (Map f xs), All Ord (Map 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 (Show, Eq, Ord) + +-- | Unwrap a product of products. +unPOP :: POP f xss -> NP (NP f) xss +unPOP (POP xss) = xss + +type instance AllMap NP c xs = All c xs +type instance AllMap POP c xs = All2 c xs + +-- * 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. SingI xs => (forall a. f a) -> NP f xs +pure_NP f = case sing :: Sing 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 :: forall f xss. SingI xss => (forall a. f a) -> POP f xss +pure_POP f = case sing :: Sing xss of + SNil -> POP Nil + SCons -> POP (pure_NP f :* unPOP (pure_POP f)) + +-- | Specialization of 'hcpure'. +-- +-- The call @'cpure_NP' p x@ generates a product that contains 'x' in every +-- element position. +-- +cpure_NP :: forall c xs f. (All c xs, SingI xs) + => Proxy c -> (forall a. c a => f a) -> NP f xs +cpure_NP p f = case sing :: Sing 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 f xss. (All2 c xss, SingI xss) + => Proxy c -> (forall a. c a => f a) -> POP f xss +cpure_POP p f = case sing :: Sing xss of + SNil -> POP Nil + SCons -> POP (cpure_NP p f :* unPOP (cpure_POP p f)) + +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 :: (SingI xs) => [a] -> Maybe (NP (K a) xs) +fromList = go sing + where + go :: Sing xs -> [a] -> Maybe (NP (K a) xs) + go SNil [] = return Nil + go SCons (x:xs) = do ys <- go sing 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) xs -> POP f xs -> POP g xs +ap_POP (POP Nil ) (POP Nil ) = POP Nil +ap_POP (POP (fs :* fss)) (POP (xs :* xss)) = POP (ap_NP fs xs :* unPOP (ap_POP (POP fss) (POP xss))) +ap_POP _ _ = error "inaccessible" + +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 :: SingI xs => (forall a. f a -> g a) -> NP f xs -> NP g xs +-- | Specialization of 'hliftA'. +liftA_POP :: SingI xss => (forall a. f a -> g a) -> POP f xss -> POP g xss + +liftA_NP = hliftA +liftA_POP = hliftA + +-- | Specialization of 'hliftA2'. +liftA2_NP :: SingI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NP g xs -> NP h xs +-- | Specialization of 'hliftA2'. +liftA2_POP :: SingI 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 :: SingI 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 :: SingI 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 'hcliftA'. +cliftA_NP :: (All c xs, SingI 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, SingI 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, SingI 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, SingI 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 + +-- * Dealing with @'All' c@ + +-- | Construct a product of dictionaries for a type-level list of lists. +-- +-- The structure of the product matches the outer list, the dictionaries +-- contained are 'AllDict'-dictionaries for the inner list. +-- +allDict_NP :: forall (c :: k -> Constraint) (xss :: [[k]]). (All2 c xss, SingI xss) + => Proxy c -> NP (AllDict c) xss +allDict_NP p = case sing :: Sing xss of + SNil -> Nil + SCons -> AllDictC :* allDict_NP p + +-- | 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, 'SingI' xss) => 'Proxy' c -> (forall xs. ('SingI' xs, 'All' c xs) => f xs -> f' xs) -> 'NP' f xss -> 'NP' f' xss +-- 'hcliftA'' :: ('All2' c xss, 'SingI' xss) => 'Proxy' c -> (forall xs. ('SingI' xs, 'All' c xs) => f xs -> f' xs) -> 'Generics.SOP.NS.NS' f xss -> 'Generics.SOP.NS.NS' f' xss +-- @ +-- +hcliftA' :: (All2 c xss, SingI xss, Prod h ~ NP, HAp h) => Proxy c -> (forall xs. (SingI xs, All c xs) => f xs -> f' xs) -> h f xss -> h f' xss + +-- | Like 'hcliftA'', but for binary functions. +hcliftA2' :: (All2 c xss, SingI xss, Prod h ~ NP, HAp h) => Proxy c -> (forall xs. (SingI 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. +hcliftA3' :: (All2 c xss, SingI xss, Prod h ~ NP, HAp h) => Proxy c -> (forall xs. (SingI 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 f xs = hpure (fn_2 $ \AllDictC -> f) `hap` allDict_NP p `hap` xs +hcliftA2' p f xs ys = hpure (fn_3 $ \AllDictC -> f) `hap` allDict_NP p `hap` xs `hap` ys +hcliftA3' p f xs ys zs = hpure (fn_4 $ \AllDictC -> f) `hap` allDict_NP p `hap` xs `hap` ys `hap` zs + +-- | Specialization of 'hcliftA2''. +cliftA2'_NP :: (All2 c xss, SingI xss) => Proxy c -> (forall xs. (SingI 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 :: SingI 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 = [] +type instance CollapseTo POP = ([] :.: []) + +instance HCollapse NP where hcollapse = collapse_NP +instance HCollapse POP where hcollapse = Comp . collapse_POP + +-- * Sequencing + +-- | Specialization of 'hsequence''. +sequence'_NP :: Applicative f => NP (f :.: g) xs -> f (NP g xs) + +-- | Specialization of 'hsequence''. +sequence'_POP :: (SingI 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 :: (SingI 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 :: (SingI xss, Applicative f) => POP f xss -> f (POP I xss) + +sequence_NP = hsequence +sequence_POP = hsequence + diff --git a/src/Generics/SOP/NS.hs b/src/Generics/SOP/NS.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/NS.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE PolyKinds, StandaloneDeriving, UndecidableInstances #-} +-- | 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 + -- * Dealing with @'All' c@ + , cliftA2'_NS + -- * Collapsing + , collapse_NS + , collapse_SOP + -- * Sequencing + , sequence'_NS + , sequence'_SOP + , sequence_NS + , sequence_SOP + ) where + +import Control.Applicative +import Data.Proxy (Proxy(..)) + +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 (Map f xs) => Show (NS f xs) +deriving instance All Eq (Map f xs) => Eq (NS f xs) +deriving instance (All Eq (Map f xs), All Ord (Map 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 (Show, Eq, Ord) + +-- | 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 -> K (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. SingI xs => NP (Injection f xs) xs +injections = case sing :: Sing 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 :: SingI 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 :: SingI 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) xs -> SOP f xs -> SOP g xs +ap_SOP (POP (fs :* _) ) (SOP (Z xs) ) = SOP (Z (ap_NP fs xs)) +ap_SOP (POP (_ :* fss)) (SOP (S xss)) = SOP (S (unSOP (ap_SOP (POP fss) (SOP xss)))) +ap_SOP _ _ = error "inaccessible" + +type instance Prod NS = NP +type instance Prod SOP = POP + +instance HAp NS where hap = ap_NS +instance HAp SOP where hap = ap_SOP + +-- * Lifting / mapping + +-- | Specialization of 'hliftA'. +liftA_NS :: SingI xs => (forall a. f a -> g a) -> NS f xs -> NS g xs +-- | Specialization of 'hliftA'. +liftA_SOP :: SingI xss => (forall a. f a -> g a) -> SOP f xss -> SOP g xss + +liftA_NS = hliftA +liftA_SOP = hliftA + +-- | Specialization of 'hliftA2'. +liftA2_NS :: SingI xs => (forall a. f a -> g a -> h a) -> NP f xs -> NS g xs -> NS h xs +-- | Specialization of 'hliftA2'. +liftA2_SOP :: SingI 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 'hcliftA'. +cliftA_NS :: (All c xs, SingI 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, SingI 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, SingI 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, SingI 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 + +-- * Dealing with @'All' c@ + +-- | Specialization of 'hcliftA2''. +cliftA2'_NS :: (All2 c xss, SingI xss) => Proxy c -> (forall xs. (SingI 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 :: SingI 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 = I +type instance CollapseTo SOP = [] + +instance HCollapse NS where hcollapse = I . 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 :: (SingI 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 :: (SingI xs, Applicative f) => NS f xs -> f (NS I xs) + +-- | Specialization of 'hsequence'. +sequence_SOP :: (SingI xss, Applicative f) => SOP f xss -> f (SOP I xss) + +sequence_NS = hsequence +sequence_SOP = hsequence + diff --git a/src/Generics/SOP/Sing.hs b/src/Generics/SOP/Sing.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Sing.hs @@ -0,0 +1,104 @@ +{-# 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 + Sing(..) + , SingI(..) + -- ** Shape of type-level lists + , Shape(..) + , shape + , lengthSing + ) where + +import Data.Proxy (Proxy(..)) + +-- * Singletons + +-- | Explicit singleton. +-- +-- A singleton can be used to reveal the structure of a type +-- argument that the function is quantified over. +-- +-- The family 'Sing' should have at most one instance per kind, +-- and there should be a matching instance for 'SingI'. +-- +data family Sing (a :: k) + +-- | Singleton for type-level lists. +data instance Sing (xs :: [k]) where + SNil :: Sing '[] + SCons :: (SingI x, SingI xs) => Sing (x ': xs) + +deriving instance Show (Sing (xs :: [k])) +deriving instance Eq (Sing (xs :: [k])) +deriving instance Ord (Sing (xs :: [k])) + +-- | Singleton for types of kind '*'. +-- +-- For types of kind '*', we explicitly /don't/ want to reveal +-- more type analysis. Even functions that have a 'Sing' constraint +-- should still be parametric in everything that is of kind '*'. +-- +data instance Sing (x :: *) where + SStar :: Sing (x :: *) + +deriving instance Show (Sing (x :: *)) +deriving instance Eq (Sing (x :: *)) +deriving instance Ord (Sing (x :: *)) + +-- | Implicit singleton. +-- +-- A singleton can be used to reveal the structure of a type +-- argument that the function is quantified over. +-- +-- The class 'SingI' should have instances that match the +-- family instances for 'Sing'. +-- +class SingI (a :: k) where + -- | Get hold of the explicit singleton (that one can then + -- pattern match on). + sing :: Sing a + +instance SingI (x :: *) where + sing = SStar + +instance SingI '[] where + sing = SNil + +instance (SingI x, SingI xs) => SingI (x ': xs) where + sing = SCons + +-- * 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 :: SingI 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]). SingI xs => Shape xs +shape = case sing :: Sing xs of + SNil -> ShapeNil + SCons -> ShapeCons shape + +-- | The length of a type-level list. +lengthSing :: forall (xs :: [k]). SingI xs => Proxy xs -> Int +lengthSing _ = lengthShape (shape :: Shape xs) + where + lengthShape :: forall xs'. Shape xs' -> Int + lengthShape ShapeNil = 0 + lengthShape (ShapeCons s) = 1 + lengthShape s diff --git a/src/Generics/SOP/TH.hs b/src/Generics/SOP/TH.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/TH.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Generate @generics-sop@ boilerplate instances using Template Haskell. +module Generics.SOP.TH + ( deriveGeneric + , deriveGenericOnly + ) 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 deriveMetadataForDataDec + +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 cons, projection 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 :: [Con] -> Q Dec +embedding = funD 'from . 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 :: [Con] -> Q Dec +projection = funD 'to . 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 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." diff --git a/src/Generics/SOP/Universe.hs b/src/Generics/SOP/Universe.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Universe.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE UndecidableInstances #-} +-- | Codes and interpretations +module Generics.SOP.Universe where + +import Data.Proxy +import qualified GHC.Generics as GHC + +import Generics.SOP.BasicFunctors +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 SingI (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