generics-sop 0.2.2.0 → 0.2.3.0

raw patch · 10 files changed

+268/−37 lines, 10 filesdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−1
• generics-sop.cabal +2/−2
• src/Generics/SOP.hs +5/−0
• src/Generics/SOP/BasicFunctors.hs +11/−0
• src/Generics/SOP/Dict.hs +12/−2
• src/Generics/SOP/GGP.hs +2/−2
• src/Generics/SOP/Metadata.hs +20/−0
• src/Generics/SOP/NP.hs +94/−0
• src/Generics/SOP/NS.hs +81/−1
• src/Generics/SOP/TH.hs +30/−29

@@ -1,4 +1,14 @@-# 0.2.2.0+# 0.2.3.0++* Add various metadata getters++* Add `hdicts`.++* Add catamorphisms and anamorphisms for `NP` and `NS`.++* TH compatibility changes for GHC 8.1 (master).++# 0.2.2.0 (2016-07-10)  * Introduced `unZ` to destruct a unary sum. 

@@ -1,5 +1,5 @@ name:                generics-sop-version:             0.2.2.0+version:             0.2.3.0 synopsis:            Generic Programming using True Sums of Products description:   A library to support the definition of generic functions.@@ -59,7 +59,7 @@                        Generics.SOP.Universe                        Generics.SOP.Sing   build-depends:       base                 >= 4.6  && < 5,-                       template-haskell     >= 2.8  && < 2.12,+                       template-haskell     >= 2.8  && < 2.13,                        ghc-prim             >= 0.3  && < 0.6   if impl (ghc < 7.8)     build-depends:     tagged               >= 0.7  && < 0.9

@@ -228,8 +228,13 @@   , unPOP     -- * Metadata   , DatatypeInfo(..)+  , moduleName+  , datatypeName+  , constructorInfo   , ConstructorInfo(..)+  , constructorName   , FieldInfo(..)+  , fieldName   , HasDatatypeInfo(..)   , DatatypeName   , ModuleName

@@ -9,6 +9,17 @@ -- library, they're primarily used as parameters for -- the 'NP', 'NS', 'POP', and 'SOP' types. --+-- We define own variants of 'Control.Applicative.Const',+-- 'Data.Functor.Identity.Identity' and 'Data.Functor.Compose.Compose' for+-- various reasons.+--+-- * 'Control.Applicative.Const' and 'Data.Functor.Compose.Compose' become+-- kind polymorphic only in @base-4.9.0.0@ (@transformers-0.5.0.0@).+--+-- * Shorter names are convenient, and pattern synonyms aren't+-- (yet) powerful enough, particularly exhaustiveness check doesn't work+-- properly. See <https://ghc.haskell.org/trac/ghc/ticket/8779>.+-- module Generics.SOP.BasicFunctors   ( K(..)   , unK

@@ -1,4 +1,5 @@ {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-} -- | Explicit dictionaries. -- -- When working with compound constraints such as constructed@@ -35,6 +36,8 @@ data Dict (c :: k -> Constraint) (a :: k) where   Dict :: c a => Dict c a +deriving instance Show (Dict c a)+ -- | A proof that the trivial constraint holds -- over all type-level lists. --@@ -97,7 +100,7 @@ -- @since 0.2 -- unAll_NP :: forall c xs . Dict (All c) xs -> NP (Dict c) xs-unAll_NP Dict = hcpure (Proxy :: Proxy c) Dict+unAll_NP d = withDict d hdicts  -- | If we have a constraint 'c' that holds over a type-level -- list of lists 'xss', we can create a product of products@@ -106,7 +109,7 @@ -- @since 0.2 -- unAll_POP :: forall c xss . Dict (All2 c) xss -> POP (Dict c) xss-unAll_POP Dict = hcpure (Proxy :: Proxy c) Dict+unAll_POP d = withDict d hdicts  -- | If we have a product containing proofs that each element -- of 'xs' satisfies 'c', then 'All c' holds for 'xs'.@@ -148,3 +151,10 @@ -- withDict :: Dict c a -> (c a => r) -> r withDict Dict x = x++-- | A structure of dictionaries.+--+-- @since 0.2.3.0+--+hdicts :: forall h c xs . (AllN h c xs, HPure h) => h (Dict c) xs+hdicts = hcpure (Proxy :: Proxy c) Dict

@@ -62,11 +62,11 @@  instance (All SListI (ToSumCode a '[]), Datatype c, GConstructorInfos a) => GDatatypeInfo' (M1 D c a) where   gDatatypeInfo' _ =-    let adt = ADT     (moduleName p) (datatypeName p)+    let adt = ADT     (GHC.moduleName p) (GHC.datatypeName p)         ci  = gConstructorInfos (Proxy :: Proxy a) Nil     in if isNewtype p        then case isNewtypeShape ci of-              NewYes c -> Newtype (moduleName p) (datatypeName p) c+              NewYes c -> Newtype (GHC.moduleName p) (GHC.datatypeName p) c               NewNo    -> adt ci -- should not happen        else adt ci     where

@@ -39,6 +39,18 @@   -- Newtype   Newtype :: ModuleName -> DatatypeName -> ConstructorInfo '[x]   -> DatatypeInfo '[ '[x] ] +moduleName :: DatatypeInfo xss -> ModuleName+moduleName (ADT name _ _) = name+moduleName (Newtype name _ _) = name++datatypeName :: DatatypeInfo xss -> DatatypeName+datatypeName (ADT _ name _ ) = name+datatypeName (Newtype _ name _) = name++constructorInfo :: DatatypeInfo xss -> NP ConstructorInfo xss+constructorInfo (ADT _ _ cs) = cs+constructorInfo (Newtype _ _ c) = c :* Nil+ deriving instance All (Show `Compose` ConstructorInfo) xs => Show (DatatypeInfo xs) deriving instance All (Eq   `Compose` ConstructorInfo) xs => Eq   (DatatypeInfo xs) deriving instance (All (Eq `Compose` ConstructorInfo) xs, All (Ord `Compose` ConstructorInfo) xs) => Ord (DatatypeInfo xs)@@ -55,6 +67,11 @@   -- Record constructor   Record :: SListI xs => ConstructorName -> NP FieldInfo xs -> ConstructorInfo xs +constructorName :: ConstructorInfo xs -> ConstructorName+constructorName (Constructor name) = name+constructorName (Infix name _ _)   = name+constructorName (Record name _)    = name+ deriving instance All (Show `Compose` FieldInfo) xs => Show (ConstructorInfo xs) deriving instance All (Eq   `Compose` FieldInfo) xs => Eq   (ConstructorInfo xs) deriving instance (All (Eq `Compose` FieldInfo) xs, All (Ord `Compose` FieldInfo) xs) => Ord (ConstructorInfo xs)@@ -63,6 +80,9 @@ data FieldInfo :: * -> * where   FieldInfo :: FieldName -> FieldInfo a   deriving (Show, Eq, Ord, Functor)++fieldName :: FieldInfo a -> FieldName+fieldName (FieldInfo n) = n  -- | The name of a datatype. type DatatypeName    = String

@@ -59,6 +59,11 @@   , sequence'_POP   , sequence_NP   , sequence_POP+    -- * Catamorphism and anamorphism+  , cata_NP+  , ccata_NP+  , ana_NP+  , cana_NP   ) where  #if !(MIN_VERSION_base(4,8,0))@@ -497,3 +502,92 @@ sequence_NP   = hsequence sequence_POP  = hsequence +-- * Catamorphism and anamorphism++-- | Catamorphism for 'NP'.+--+-- This is a suitable generalization of 'foldr'. It takes+-- parameters on what to do for 'Nil' and ':*'. Since the+-- input list is heterogeneous, the result is also indexed+-- by a type-level list.+--+-- @since 0.2.3.0+--+cata_NP ::+     forall r f xs .+     r '[]+  -> (forall y ys . f y -> r ys -> r (y ': ys))+  -> NP f xs+  -> r xs+cata_NP nil cons = go+  where+    go :: forall ys . NP f ys -> r ys+    go Nil       = nil+    go (x :* xs) = cons x (go xs)++-- | Constrained catamorphism for 'NP'.+--+-- The difference compared to 'cata_NP' is that the function+-- for the cons-case can make use of the fact that the specified+-- constraint holds for all the types in the signature of the+-- product.+--+-- @since 0.2.3.0+--+ccata_NP ::+     forall c proxy r f xs . (All c xs)+  => proxy c+  -> r '[]+  -> (forall y ys . c y => f y -> r ys -> r (y ': ys))+  -> NP f xs+  -> r xs+ccata_NP _ nil cons = go+  where+    go :: forall ys . (All c ys) => NP f ys -> r ys+    go Nil       = nil+    go (x :* xs) = cons x (go xs)++-- | Anamorphism for 'NP'.+--+-- In contrast to the anamorphism for normal lists, the+-- generating function does not return an 'Either', but+-- simply an element and a new seed value.+--+-- This is because the decision on whether to generate a+-- 'Nil' or a ':*' is determined by the types.+--+-- @since 0.2.3.0+--+ana_NP ::+     forall s f xs .+     SListI xs+  => (forall y ys . s (y ': ys) -> (f y, s ys))+  -> s xs+  -> NP f xs+ana_NP uncons = go sList+  where+    go :: forall ys . SList ys -> s ys -> NP f ys+    go SNil  _ = Nil+    go SCons s = case uncons s of+      (x, s') -> x :* go sList s'++-- | Constrained anamorphism for 'NP'.+--+-- Compared to 'ana_NP', the generating function can+-- make use of the specified constraint here for the+-- elements that it generates.+--+-- @since 0.2.3.0+--+cana_NP ::+     forall c proxy s f xs . (All c xs)+  => proxy c+  -> (forall y ys . c y => s (y ': ys) -> (f y, s ys))+  -> s xs+  -> NP f xs+cana_NP _ uncons = go sList+  where+    go :: forall ys . (All c ys) => SList ys -> s ys -> NP f ys+    go SNil  _ = Nil+    go SCons s = case uncons s of+      (x, s') -> x :* go sList s'

@@ -40,6 +40,11 @@   , sequence'_SOP   , sequence_NS   , sequence_SOP+    -- * Catamorphism and anamorphism+  , cata_NS+  , ccata_NS+  , ana_NS+  , cana_NS   ) where  #if !(MIN_VERSION_base(4,8,0))@@ -92,7 +97,7 @@ -- -- > Z (I 'x')      :: NS I       '[ Char, Bool ] -- > S (Z (I True)) :: NS I       '[ Char, Bool ]--- > S (Z (I 1))    :: NS (K Int) '[ Char, Bool ]+-- > S (Z (K 1))    :: NS (K Int) '[ Char, Bool ] -- data NS :: (k -> *) -> [k] -> * where   Z :: f x -> NS f (x ': xs)@@ -340,3 +345,78 @@ sequence_NS   = hsequence sequence_SOP  = hsequence +-- * Catamorphism and anamorphism++-- | Catamorphism for 'NS'.+--+-- Takes arguments determining what to do for 'Z'+-- and what to do for 'S'. The result type is still+-- indexed over the type-level lit.+--+-- @since 0.2.3.0+--+cata_NS ::+     forall r f xs .+     (forall y ys . f y -> r (y ': ys))+  -> (forall y ys . r ys -> r (y ': ys))+  -> NS f xs+  -> r xs+cata_NS z s = go+  where+    go :: forall ys . NS f ys -> r ys+    go (Z x) = z x+    go (S i) = s (go i)++-- | Constrained catamorphism for 'NS'.+--+-- @since 0.2.3.0+--+ccata_NS ::+     forall c proxy r f xs . (All c xs)+  => proxy c+  -> (forall y ys . c y => f y -> r (y ': ys))+  -> (forall y ys . c y => r ys -> r (y ': ys))+  -> NS f xs+  -> r xs+ccata_NS _ z s = go+  where+    go :: forall ys . (All c ys) => NS f ys -> r ys+    go (Z x) = z x+    go (S i) = s (go i)++-- | Anamorphism for 'NS'.+--+-- @since 0.2.3.0+--+ana_NS ::+     forall s f xs . (SListI xs)+  => (forall r . s '[] -> r)+  -> (forall y ys . s (y ': ys) -> Either (f y) (s ys))+  -> s xs+  -> NS f xs+ana_NS refute decide = go sList+  where+    go :: forall ys . SList ys -> s ys -> NS f ys+    go SNil  s = refute s+    go SCons s = case decide s of+      Left x   -> Z x+      Right s' -> S (go sList s')++-- | Constrained anamorphism for 'NS'.+--+-- @since 0.2.3.0+--+cana_NS :: forall c proxy s f xs .+     (All c xs)+  => proxy c+  -> (forall r . s '[] -> r)+  -> (forall y ys . c y => s (y ': ys) -> Either (f y) (s ys))+  -> s xs+  -> NS f xs+cana_NS _ refute decide = go sList+  where+    go :: forall ys . (All c ys) => SList ys -> s ys -> NS f ys+    go SNil  s = refute s+    go SCons s = case decide s of+      Left x   -> Z x+      Right s' -> S (go sList s')

@@ -10,10 +10,10 @@ import Control.Monad (replicateM) import Data.Maybe (fromMaybe) import Language.Haskell.TH-import Language.Haskell.TH.Syntax hiding (Infix)+import Language.Haskell.TH.Syntax  import Generics.SOP.BasicFunctors-import Generics.SOP.Metadata+import qualified Generics.SOP.Metadata as SOP import Generics.SOP.NP import Generics.SOP.NS import Generics.SOP.Universe@@ -131,15 +131,11 @@   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+    sequence [ sigD datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |]                    -- treeDatatypeInfo :: DatatypeInfo TreeCode              , funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []] -- treeDatatypeInfo = ...              ] -#if MIN_VERSION_template_haskell(2,11,0)-deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> Q [Dec]-#else-deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Q [Dec]-#endif+deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] deriveGenericForDataDec _isNewtype _cxt name bndrs cons _derivs = do   let typ = appTyVars name bndrs #if MIN_VERSION_template_haskell(2,9,0)@@ -153,11 +149,7 @@             [codeSyn, embedding 'from cons, projection 'to cons]   return [inst] -#if MIN_VERSION_template_haskell(2,11,0)-deriveMetadataForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> Q [Dec]-#else-deriveMetadataForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Q [Dec]-#endif+deriveMetadataForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec] deriveMetadataForDataDec isNewtype _cxt name bndrs cons _derivs = do   let typ = appTyVars name bndrs   md   <- instanceD (cxt [])@@ -165,6 +157,7 @@             [metadata isNewtype name cons]   return [md] + {-------------------------------------------------------------------------------   Computing the code for a data type -------------------------------------------------------------------------------}@@ -227,20 +220,20 @@ metadata' isNewtype typeName cs = md   where     md :: Q Exp-    md | isNewtype = [| Newtype $(stringE (nameModule' typeName))-                                $(stringE (nameBase typeName))-                                $(mdCon (head cs))+    md | isNewtype = [| SOP.Newtype $(stringE (nameModule' typeName))+                                    $(stringE (nameBase typeName))+                                    $(mdCon (head cs))                       |]-       | otherwise = [| ADT     $(stringE (nameModule' typeName))-                                $(stringE (nameBase typeName))-                                $(npE $ map mdCon cs)+       | otherwise = [| SOP.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 (NormalC n _)   = [| SOP.Constructor $(stringE (nameBase n)) |]+    mdCon (RecC n ts)     = [| SOP.Record      $(stringE (nameBase n))+                                               $(npE (map mdField ts))                              |]     mdCon (InfixC _ n _)  = do #if MIN_VERSION_template_haskell(2,11,0)@@ -252,7 +245,7 @@       case i of         DataConI _ _ _ (Fixity f a) -> #endif-                            [| Infix       $(stringE (nameBase n)) $(mdAssociativity a) f |]+                            [| SOP.Infix       $(stringE (nameBase n)) $(mdAssociativity a) f |] #if !MIN_VERSION_template_haskell(2,11,0)         _                -> fail "Strange infix operator" #endif@@ -263,12 +256,12 @@ #endif      mdField :: VarStrictType -> Q Exp-    mdField (n, _, _) = [| FieldInfo $(stringE (nameBase n)) |]+    mdField (n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |]      mdAssociativity :: FixityDirection -> Q Exp-    mdAssociativity InfixL = [| LeftAssociative  |]-    mdAssociativity InfixR = [| RightAssociative |]-    mdAssociativity InfixN = [| NotAssociative   |]+    mdAssociativity InfixL = [| SOP.LeftAssociative  |]+    mdAssociativity InfixR = [| SOP.RightAssociative |]+    mdAssociativity InfixN = [| SOP.NotAssociative   |]  nameModule' :: Name -> String nameModule' = fromMaybe "" . nameModule@@ -325,13 +318,21 @@      case info of TyConI dec -> return dec                   _          -> fail "Info must be type declaration type." +withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a) -> Q a #if MIN_VERSION_template_haskell(2,11,0)-withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> 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 #else-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 #endif withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes."++-- | Utility type synonym to cover changes in the TH code+#if MIN_VERSION_template_haskell(2,12,0)+type Derivings = [DerivClause]+#elif MIN_VERSION_template_haskell(2,11,0)+type Derivings = Cxt+#else+type Derivings = [Name]+#endif