generic-data 0.8.2.0 → 0.8.3.0

raw patch · 10 files changed

+371/−16 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +1/−3
• generic-data.cabal +4/−3
• src/Generic/Data.hs +10/−0
• src/Generic/Data/Internal/Generically.hs +23/−0
• src/Generic/Data/Internal/Read.hs +259/−0
• src/Generic/Data/Internal/Show.hs +1/−9
• src/Generic/Data/Internal/Utils.hs +15/−1
• test/record.hs +5/−0
• test/unit.hs +49/−0

@@ -1,3 +1,7 @@+# 0.8.3.0++- Add generic `Read`. Thanks to RyanGlScott.+ # 0.8.2.0  - Add microsurgery `CopyRep`.

@@ -62,11 +62,9 @@ Other classes from base are also supported, even though GHC can already derive them: -- `Eq`, `Ord`, `Enum`, `Bounded`, `Show` (derivable by the standard);+- `Eq`, `Ord`, `Enum`, `Bounded`, `Show`, `Read` (derivable by the standard); - `Functor`, `Foldable`, `Traversable` (derivable via extensions,   `DeriveFunctor`, etc.).--(`Read` is currently not implemented.)  To derive type classes outside of the standard library, it might be worth taking a look at [one-liner](https://hackage.haskell.org/package/one-liner).

@@ -1,5 +1,5 @@ name:                generic-data-version:             0.8.2.0+version:             0.8.3.0 synopsis:            Deriving instances with GHC.Generics and related utilities description:   Generic implementations of standard type classes.@@ -10,8 +10,8 @@ license-file:        LICENSE author:              Li-yao Xia maintainer:          lysxia@gmail.com-copyright:           2018 Li-yao Xia-category:            Other+copyright:           2018-2020 Li-yao Xia+category:            Generics build-type:          Simple extra-source-files:  README.md, CHANGELOG.md cabal-version:       >=1.10@@ -34,6 +34,7 @@     Generic.Data.Internal.Microsurgery     Generic.Data.Internal.Newtype     Generic.Data.Internal.Prelude+    Generic.Data.Internal.Read     Generic.Data.Internal.Resolvers     Generic.Data.Internal.Show     Generic.Data.Internal.Utils

@@ -30,6 +30,11 @@     -- | Can also be derived by GHC as part of the standard.   , gcompare +    -- ** 'Read'+    -- | Can also be derived by GHC as part of the standard.+  , greadPrec+  , GRead0+     -- ** 'Show'     -- | Can also be derived by GHC as part of the standard.   , gshowsPrec@@ -101,6 +106,10 @@     -- ** 'Data.Functor.Classes.Ord1'   , gliftCompare +    -- ** 'Data.Functor.Classes.Read1'+  , gliftReadPrec+  , GRead1+     -- ** 'Data.Functor.Classes.Show1'   , gliftShowsPrec   , GShow1@@ -176,6 +185,7 @@ import Generic.Data.Internal.Enum import Generic.Data.Internal.Generically import Generic.Data.Internal.Meta+import Generic.Data.Internal.Read import Generic.Data.Internal.Show import Generic.Data.Internal.Newtype import Generic.Data.Internal.Resolvers

@@ -20,10 +20,12 @@ import Data.Semigroup import Data.Ix import GHC.Generics+import Text.Read  import Generic.Data.Internal.Prelude import Generic.Data.Internal.Enum import Generic.Data.Internal.Error+import Generic.Data.Internal.Read import Generic.Data.Internal.Show  -- | Type with instances derived via 'Generic'.@@ -40,6 +42,10 @@ instance (Generic a, Ord (Rep a ())) => Ord (Generically a) where   compare = gcompare +instance (Generic a, GRead0 (Rep a)) => Read (Generically a) where+  readPrec = greadPrec+  readListPrec = readListPrecDefault+ instance (Generic a, GShow0 (Rep a)) => Show (Generically a) where   showsPrec = gshowsPrec @@ -110,6 +116,23 @@  instance (Generic1 f, Ord1 (Rep1 f), Ord a) => Ord (Generically1 f a) where   compare = compare1++instance (Generic1 f, GRead1 (Rep1 f)) => Read1 (Generically1 f) where+#if MIN_VERSION_base(4,10,0)+  liftReadPrec = gliftReadPrec+  liftReadListPrec = liftReadListPrecDefault+#else+  liftReadsPrec rp rl = readPrec_to_S $+    gliftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))+#endif++instance (Generic1 f, GRead1 (Rep1 f), Read a) => Read (Generically1 f a) where+#if MIN_VERSION_base(4,10,0)+  readPrec = readPrec1+  readListPrec = readListPrecDefault+#else+  readsPrec = readsPrec1+#endif  instance (Generic1 f, GShow1 (Rep1 f)) => Show1 (Generically1 f) where   liftShowsPrec = gliftShowsPrec

@@ -0,0 +1,259 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Trustworthy #-}++-- | Generic implementation of Read+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.++module Generic.Data.Internal.Read where++import Data.Coerce+import Data.Functor.Classes (Read1(..))+import Data.Functor.Identity+import Data.Proxy+import Generic.Data.Internal.Utils (isSymDataCon, isSymVar)+import GHC.Generics hiding (prec)+import GHC.Read (expectP, list)+import GHC.Show (appPrec, appPrec1)+import Text.ParserCombinators.ReadPrec+import Text.Read (Read(..), parens)+import Text.Read.Lex (Lexeme(..))++-- | Generic 'readPrec'.+--+-- @+-- instance 'Read' MyType where+--   'readPrec' = 'greadPrec'+--   'readListPrec' = 'readListPrecDefault'+-- @+greadPrec :: (Generic a, GRead0 (Rep a)) => ReadPrec a+greadPrec = to <$> gPrecRead Proxy++-- | Generic representation of 'Read' types.+type GRead0 = GRead Proxy++-- | Generic 'liftReadPrec'.+gliftReadPrec+  :: (Generic1 f, GRead1 (Rep1 f))+  => ReadPrec a -> ReadPrec [a]+  -> ReadPrec (f a)+gliftReadPrec readPrec' readList' =+  to1 <$> gPrecRead (Identity (readPrec', readList'))++-- | Generic representation of 'Data.Functor.Classes.Read1' types.+type GRead1 = GRead Identity++class GRead p f where+  gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)++instance (GRead p f, IsNullaryDataType f) => GRead p (M1 D d f) where+  gPrecRead p = coerceM1 (parensIfNonNullary (gPrecRead p))+    where+      x :: f a+      x = undefined++      parensIfNonNullary :: ReadPrec a -> ReadPrec a+      parensIfNonNullary = if isNullaryDataType x+                              then id+                              else parens++instance (GRead p f, GRead p g) => GRead p (f :+: g) where+  gPrecRead p = fmap L1 (gPrecRead p) +++ fmap R1 (gPrecRead p)++instance (Constructor c, GReadC p c f) => GRead p (M1 C c f) where+  gPrecRead p = gPrecReadC p (conName x) (conFixity x)+    where+      x :: M1 C c f a+      x = undefined++instance GRead p V1 where+  gPrecRead _ = pfail++class IsNullaryDataType f where+  isNullaryDataType :: f a -> Bool++instance IsNullaryDataType (f :+: g) where+  isNullaryDataType _ = False++instance IsNullaryDataType (C1 c f) where+  isNullaryDataType _ = False++instance IsNullaryDataType V1 where+  isNullaryDataType _ = True++class GReadC p c f where+  gPrecReadC :: p (ReadPrec a, ReadPrec [a]) -> String -> Fixity -> ReadPrec (M1 C c f a)++instance GReadFields p f => GReadC p ('MetaCons s y 'False) f where+  gPrecReadC :: forall a. p (ReadPrec a, ReadPrec [a]) -> String -> Fixity+             -> ReadPrec (M1 C ('MetaCons s y 'False) f a)+  gPrecReadC p name fixity+    | Infix _ fy <- fixity, Branch k1 k2 <- fields+    = coerceM1 $ prec fy $ do+        k1' <- toReadPrec k1+        if isSymDataCon name+           then expectP (Symbol name)+           else mapM_ expectP ([Punc "`"] ++ identHLexemes name ++ [Punc "`"])+        k2' <- toReadPrec k2+        pure (k1' :*: k2')+    | otherwise+    = coerceM1 $ prec appPrec $ do+        readPrefixCon name+        toReadPrec fields+    where+      fields :: ReadPrecTree (f a)+      fields = gPrecReadFields p++instance GReadNamed p f => GReadC p ('MetaCons s y 'True) f where+  gPrecReadC p name _fixity = coerceM1 $ prec appPrec1 $ do+    readPrefixCon name+    readSurround '{' fields '}'+    where+      fields = gPrecReadNamed p++class GReadFields p f where+  gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a)++instance (GReadFields p f, GReadFields p g) => GReadFields p (f :*: g) where+  gPrecReadFields p = Branch (gPrecReadFields p) (gPrecReadFields p)++instance GReadSingle p f => GReadFields p (M1 S c f) where+  gPrecReadFields p = M1Leaf (step (gPrecReadSingle p))++instance GReadFields p U1 where+  gPrecReadFields _ = U1Leaf++class GReadNamed p f where+  gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)++instance (GReadNamed p f, GReadNamed p g) => GReadNamed p (f :*: g) where+  gPrecReadNamed p = do+    l <- gPrecReadNamed p+    expectP (Punc ",")+    r <- gPrecReadNamed p+    pure (l :*: r)++instance (Selector c, GReadSingle p f) => GReadNamed p (M1 S c f) where+  gPrecReadNamed p = coerceM1 $ do+    mapM_ expectP snameLexemes+    expectP (Punc "=")+    reset (gPrecReadSingle p)+    where+      x :: M1 S c f a+      x = undefined++      sname :: String+      sname = selName x++      snameLexemes :: [Lexeme]+      snameLexemes | isSymVar sname+                   = [Punc "(", Symbol sname, Punc ")"]+                   | otherwise+                   = identHLexemes sname++instance GReadNamed p U1 where+  gPrecReadNamed _ = pure U1++class GReadSingle p f where+  gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)++instance Read a => GReadSingle p (K1 i a) where+  gPrecReadSingle _ = coerceK1 readPrec+    where+      coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x)+      coerceK1 = coerce++instance Read1 f => GReadSingle Identity (Rec1 f) where+  gPrecReadSingle (Identity p) = coerceRec1 (liftReadPrecCompat p)+    where+      coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)+      coerceRec1 = coerce++instance GReadSingle Identity Par1 where+  gPrecReadSingle (Identity (readPrec', _)) = coercePar1 readPrec'+    where+      coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)+      coercePar1 = coerce++instance (Read1 f, GReadSingle p g) => GReadSingle p (f :.: g) where+  gPrecReadSingle :: forall a. p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((f :.: g) a)+  gPrecReadSingle p = coerceComp1 (liftReadPrecCompat (readPrec_, readList_))+    where+      readPrec_ :: ReadPrec (g a)+      readPrec_ = gPrecReadSingle p++      readList_ :: ReadPrec [g a]+      readList_ = list readPrec_++      coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a)+      coerceComp1 = coerce++-- Helpers++coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)+coerceM1 = coerce++-- | A backwards-compatible version of 'liftReadPrec'. This is needed for+-- compatibility with @base-4.9@, where 'Read1' only offers 'liftReadsPrec',+-- not 'liftReadPrec'.+liftReadPrecCompat :: Read1 f => (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a)+liftReadPrecCompat (readPrec', readList') =+#if MIN_VERSION_base(4,10,0)+    liftReadPrec readPrec' readList'+#else+    readS_to_Prec (liftReadsPrec (readPrec_to_S readPrec')+                                 (readPrec_to_S readList' 0))+#endif++data ReadPrecTree a where+  U1Leaf :: ReadPrecTree (U1 a)+  M1Leaf :: ReadPrec (f a) -> ReadPrecTree (M1 i c f a)+  Branch :: ReadPrecTree (f a) -> ReadPrecTree (g a) -> ReadPrecTree ((f :*: g) a)++toReadPrec :: ReadPrecTree a -> ReadPrec a+toReadPrec U1Leaf       = pure U1+toReadPrec (M1Leaf f)   = coerceM1 f+toReadPrec (Branch f g) = (:*:) <$> toReadPrec f <*> toReadPrec g++identHLexemes :: String -> [Lexeme]+identHLexemes s | Just (ss, '#') <- snocView s = [Ident ss, Symbol "#"]+                | otherwise                    = [Ident s]++readPrefixCon :: String -> ReadPrec ()+readPrefixCon name+  | isSymDataCon name+  = readSurround '(' (expectP (Symbol name)) ')'+  | otherwise+  = mapM_ expectP (identHLexemes name)++readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a+readSurround c1 r c2 = do+  expectP (Punc [c1])+  r' <- r+  expectP (Punc [c2])+  pure r'++-- Split off the last element.+snocView :: [a] -> Maybe ([a], a)+snocView [] = Nothing+snocView xs = go [] xs+  where+    -- Invariant: second arg is non-empty+    go acc [a]    = Just (reverse acc, a)+    go acc (a:as) = go (a:acc) as+    go _   []     = error "Util: snocView"

@@ -23,7 +23,7 @@ import Data.Functor.Classes (Show1(..)) import Data.Functor.Identity import Data.Proxy-import GHC.Lexeme (startsConSym, startsVarSym)+import Generic.Data.Internal.Utils (isSymDataCon, isSymVar) import GHC.Generics import Text.Show.Combinators @@ -157,11 +157,3 @@       | otherwise -> "`" ++ name ++ "`"   where     isSymName = isSymDataCon name--isSymDataCon :: String -> Bool-isSymDataCon ""    = False-isSymDataCon (c:_) = startsConSym c--isSymVar :: String -> Bool-isSymVar ""    = False-isSymVar (c:_) = startsVarSym c

@@ -2,7 +2,8 @@     BangPatterns,     EmptyCase,     FlexibleContexts,-    PolyKinds #-}+    PolyKinds,+    Trustworthy #-}  -- | Utilities. --@@ -18,6 +19,7 @@  import Data.Coerce import GHC.Generics+import GHC.Lexeme (startsConSym, startsVarSym)  -- | Convert between types with representationally equivalent generic -- representations.@@ -54,3 +56,15 @@ -- | Lift binary combinators generically. liftG2 :: Generic1 f => (Rep1 f a -> Rep1 f b -> Rep1 f c) -> f a -> f b -> f c liftG2 = \(<?>) a b -> to1 (from1 a <?> from1 b)++-- | Returns 'True' if the argument is a symbolic data constructor name+-- (e.g., @(:+:)@). Returns 'False' otherwise.+isSymDataCon :: String -> Bool+isSymDataCon ""    = False+isSymDataCon (c:_) = startsConSym c++-- | Returns 'True' if the argument is a symbolic value name (e.g., @(+++)@).+-- Returns 'False' otherwise.+isSymVar :: String -> Bool+isSymVar ""    = False+isSymVar (c:_) = startsVarSym c

@@ -12,6 +12,7 @@ import Data.Semigroup import Data.Monoid (Alt(..)) import GHC.Generics (Generic)+import Text.Read  import Generic.Data import Generic.Data.Orphans ()@@ -20,6 +21,10 @@   { _field1 :: f Int   , _field2 :: f Bool   } deriving Generic++instance Read1 f => Read (MyRecord f) where+  readPrec = coerce (greadPrec @(MyRecord (Id1 f)))+  readListPrec = readListPrecDefault  instance Show1 f => Show (MyRecord f) where   showsPrec = coerce (gshowsPrec @(MyRecord (Id1 f)))

@@ -11,6 +11,7 @@ import Data.Functor.Classes import Test.Tasty import Test.Tasty.HUnit+import Text.Read  import GHC.Generics import Generic.Data@@ -78,6 +79,29 @@ newtype MyCompose f g a = MyCompose (f (g a))   deriving Generic1 +instance (Functor f, Eq1 f, Eq1 g) => Eq1 (MyCompose f g) where+  liftEq = gliftEq++instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (MyCompose f g a) where+  (==) = eq1++instance (Functor f, Read1 f, Read1 g) => Read1 (MyCompose f g) where+#if MIN_VERSION_base(4,10,0)+  liftReadPrec = gliftReadPrec+  liftReadListPrec = liftReadListPrecDefault+#else+  liftReadsPrec rp rl = readPrec_to_S $+    gliftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))+#endif++instance (Functor f, Read1 f, Read1 g, Read a) => Read (MyCompose f g a) where+#if MIN_VERSION_base(4,10,0)+  readPrec = readPrec1+  readListPrec = readListPrecDefault+#else+  readsPrec = readsPrec1+#endif+ instance (Functor f, Show1 f, Show1 g) => Show1 (MyCompose f g) where   liftShowsPrec = gliftShowsPrec @@ -92,9 +116,23 @@           | () `MkT30b` ()   deriving Generic +instance Eq T30a where+  (==) = geq++instance Read T30a where+  readPrec = greadPrec+  readListPrec = readListPrecDefault+ instance Show T30a where   showsPrec = gshowsPrec +instance Eq T30b where+  (==) = geq++instance Read T30b where+  readPrec = greadPrec+  readListPrec = readListPrecDefault+ instance Show T30b where   showsPrec = gshowsPrec @@ -186,6 +224,14 @@         ]       , testCase "single nullary constructor" $ 0 @=? gindex (Unit, Unit) Unit       ]+  , testGroup "Read"+      [ testCase "read" $ p' 1 2 @=? read "(P 1 2)"+      , testGroup "T30"+        [ testCase "MkT30a" $ MkT30a {(##) = ()} @=? read "(MkT30a {(##) = ()})"+        , testCase "(:!:)" $ (:!:) () () @=? read "(:!:) () ()"+        , testCase "MkT30b" $ (() `MkT30b` ()) @=? read "() `MkT30b` ()"+        ]+      ]   , testGroup "Show"       [ testCase "show" $ "P 1 2" @=? show (p' 1 2)       , testCase "showsPrec" $ "(P 1 2)" @=? showsPrec 11 (p' 1 2) ""@@ -196,6 +242,9 @@         ]       ] +  , testGroup "Read1"+      [ testCase "read1" $ MyCompose (Just [()]) @?= read "(MyCompose (Just [()]))"+      ]   , testGroup "Show1"       [ testCase "show1" $ "MyCompose (Just [()])" @?= show (MyCompose (Just [()]))       ]