From 8c8e6f95500345f6eea22fb0ee697a98c5bf2498 Mon Sep 17 00:00:00 2001
From: Lukas Epple <lukas.epple@possehl-analytics.com>
Date: Fri, 12 Aug 2022 16:40:30 +0200
Subject: [PATCH 1/6] Superrecord.Variant*: make FromJSON (Variant '[]) always
 fail

Arguably, emptyVariant is more like Void than (), given that it is
actually not possible to obtain its value via fromVariant and if it
were, a program would explode due to undefined.

In JSON there is not really a way to have a void value, a JSON value is
always *something*, so it makes no sense to have a Variant '[] parser
that succeeds in any condition. More importantly, the FromJSON instance
for Variant (t ': ts) actually *requires* the instance for Variant '[]
to fail! If parseJSON is called for Variant '[] from that instance, it
means that the value didn't match any of the types the Variant accepts.

This causes the bug that, if parseJSON :: Parser () succeeds for a JSON
value, we can obtain an arbitrary Variant that would fail to evaluate,
as it'd be constructed via extendVariant emptyVariant. For aeson < 1.6
this is a pretty obscure bug, since FromJSON () only accepts the empty
array:

    >>> decode "[]" :: Maybe (Variant '[Int])
    Just *** Exception: Prelude.undefined

Since aeson 2.0, FromJSON () [accepts] all JSON values, meaning that any
failed parse to Variant results in a program crash!

Tagged Variants also exhibit this problem, of course. The bug is fixed
by making the FromJSON (Variant '[]) instance fail always via parseFail.

[accepts]: https://github.com/haskell/aeson/commit/677daf0cfc66bad182764eded5e2f08f7293cb0b
---
 src/SuperRecord/Variant.hs        | 7 +++----
 src/SuperRecord/Variant/Tagged.hs | 7 +++----
 2 files changed, 6 insertions(+), 8 deletions(-)

diff --git a/src/SuperRecord/Variant.hs b/src/SuperRecord/Variant.hs
index 372d4ef..3653277 100644
--- a/src/SuperRecord/Variant.hs
+++ b/src/SuperRecord/Variant.hs
@@ -20,7 +20,7 @@ where
 import Control.Applicative
 import Control.DeepSeq
 import Data.Aeson
-import Data.Aeson.Types (Parser)
+import Data.Aeson.Types (Parser, parseFail)
 import Data.Maybe
 import Data.Proxy
 import GHC.Base (Any)
@@ -53,9 +53,8 @@ instance (ToJSON t, ToJSON (Variant ts)) => ToJSON (Variant (t ': ts)) where
         in fromMaybe (toJSON $ shrinkVariant v1) $ toJSON <$> w1
 
 instance FromJSON (Variant '[]) where
-    parseJSON r =
-        do () <- parseJSON r
-           pure emptyVariant
+    parseJSON _ =
+        parseFail "There is no JSON value devoid of a value, so no way to represent an emptyVariant"
 
 instance ( FromJSON t, FromJSON (Variant ts)
          ) => FromJSON (Variant (t ': ts)) where
diff --git a/src/SuperRecord/Variant/Tagged.hs b/src/SuperRecord/Variant/Tagged.hs
index ba47fe4..8e6f181 100644
--- a/src/SuperRecord/Variant/Tagged.hs
+++ b/src/SuperRecord/Variant/Tagged.hs
@@ -19,7 +19,7 @@ import SuperRecord.Variant
 
 import Control.Applicative
 import Data.Aeson
-import Data.Aeson.Types (Parser)
+import Data.Aeson.Types (Parser, parseFail)
 import Data.Maybe
 import GHC.TypeLits
 import qualified Data.Text as T
@@ -47,9 +47,8 @@ instance (KnownSymbol lbl, ToJSON t, ToJSON (JsonTaggedVariant ts)) => ToJSON (J
            in val
 
 instance FromJSON (JsonTaggedVariant '[]) where
-    parseJSON r =
-        do () <- parseJSON r
-           pure $ JsonTaggedVariant emptyVariant
+    parseJSON _ =
+        parseFail "There is no JSON value devoid of a value, so no way to represent an emptyVariant"
 
 instance ( FromJSON t, FromJSON (JsonTaggedVariant ts)
          , KnownSymbol lbl

From f9072365cefa70661e83b708a4c132bfb4c13dbf Mon Sep 17 00:00:00 2001
From: Philip Patsch <philip.patsch@possehl-analytics.com>
Date: Wed, 18 May 2022 12:58:31 +0200
Subject: [PATCH 2/6] Make compatible with aeson >= 2.0
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This adds a bit more ifdef zoo to be compatible with the breaking
change in aeson. Tested manually against aeson 2.0.3.0 and 1.5.6.0.

Might want to update the CI as well, but I don’t have the time to
touch CircleCI yaml.

Co-authored-by: Lukas Epple <lukas.epple@possehl-analytics.com>
---
 src/SuperRecord.hs                | 25 ++++++++++++++++++++-----
 src/SuperRecord/Variant/Tagged.hs | 19 +++++++++++++++++--
 2 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs
index 5cd8290..bb582a3 100644
--- a/src/SuperRecord.hs
+++ b/src/SuperRecord.hs
@@ -86,7 +86,6 @@ import GHC.Generics
 import GHC.Exts
 import GHC.TypeLits
 import qualified Control.Monad.State as S
-import qualified Data.Text as T
 import Data.Semigroup as Sem (Semigroup(..))
 
 #ifdef JS_RECORD
@@ -98,6 +97,22 @@ import qualified JavaScript.Object.Internal as JS
 import GHC.ST ( ST(..) , runST)
 #endif
 
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.Key as Key
+#else
+import qualified Data.Text as T
+#endif
+
+#if MIN_VERSION_aeson(2, 0, 0)
+jsonKey :: String -> Key.Key
+jsonKey = Key.fromString
+#else
+jsonKey :: String -> T.Text
+jsonKey = T.pack
+#endif
+{-# INLINE jsonKey #-}
+
+
 -- | Sort a list of fields using merge sort, alias to 'FieldListSort'
 type Sort xs = FieldListSort xs
 
@@ -696,10 +711,10 @@ showRec :: forall lts. (RecApply lts lts (ConstC Show)) => Rec lts -> [(String,
 showRec = reflectRec @(ConstC Show) (\(_ :: FldProxy lbl) v -> (symbolVal' (proxy# :: Proxy# lbl), show v))
 
 recToValue :: forall lts. (RecApply lts lts (ConstC ToJSON)) => Rec lts -> Value
-recToValue r = object $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (T.pack $ symbolVal' (proxy# :: Proxy# lbl), toJSON v)) r
+recToValue r = object $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (jsonKey $ symbolVal' (proxy# :: Proxy# lbl), toJSON v)) r
 
 recToEncoding :: forall lts. (RecApply lts lts (ConstC ToJSON)) => Rec lts -> Encoding
-recToEncoding r = pairs $ mconcat $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (T.pack (symbolVal' (proxy# :: Proxy# lbl)) .= v)) r
+recToEncoding r = pairs $ mconcat $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (jsonKey (symbolVal' (proxy# :: Proxy# lbl))) .= v) r
 
 recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts)
 recJsonParser =
@@ -762,7 +777,7 @@ instance TraversalCHelper bs as bs c => TraversalC c as bs where
 --
 -- Effects are performed in the same order as the fields.
 traverseC ::
-  forall c f as bs. ( TraversalC c as bs, Applicative f ) => 
+  forall c f as bs. ( TraversalC c as bs, Applicative f ) =>
   ( forall (l :: Symbol) a b. (KnownSymbol l, c l a b) => FldProxy l -> a -> f b ) -> Rec as -> f ( Rec bs )
 traverseC = traversalCHelper @bs @as @bs @c @f
 
@@ -835,7 +850,7 @@ instance
         do let lbl :: FldProxy l
                lbl = FldProxy
            rest <- recJsonParse initSize obj
-           (v :: t) <- obj .: T.pack (symbolVal lbl)
+           (v :: t) <- obj .: jsonKey (symbolVal lbl)
            pure $ unsafeRCons (lbl := v) rest
 
 -- | Conversion helper to bring a Haskell type to a record. Note that the
diff --git a/src/SuperRecord/Variant/Tagged.hs b/src/SuperRecord/Variant/Tagged.hs
index 8e6f181..2427853 100644
--- a/src/SuperRecord/Variant/Tagged.hs
+++ b/src/SuperRecord/Variant/Tagged.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -22,7 +23,21 @@ import Data.Aeson
 import Data.Aeson.Types (Parser, parseFail)
 import Data.Maybe
 import GHC.TypeLits
+
+#if MIN_VERSION_aeson(2, 0, 0)
+import qualified Data.Aeson.Key as Key
+#else
 import qualified Data.Text as T
+#endif
+
+#if MIN_VERSION_aeson(2, 0, 0)
+jsonKey :: String -> Key.Key
+jsonKey = Key.fromString
+#else
+jsonKey :: String -> T.Text
+jsonKey = T.pack
+#endif
+{-# INLINE jsonKey #-}
 
 -- | Just a type alias vor 'Variant'
 type TaggedVariant opts = Variant opts
@@ -40,7 +55,7 @@ instance (KnownSymbol lbl, ToJSON t, ToJSON (JsonTaggedVariant ts)) => ToJSON (J
     toJSON (JsonTaggedVariant v1) =
         let w1 :: Maybe t
             w1 = fromTaggedVariant (FldProxy :: FldProxy lbl) v1
-            tag = T.pack $ symbolVal (FldProxy :: FldProxy lbl)
+            tag = jsonKey $ symbolVal (FldProxy :: FldProxy lbl)
         in let val =
                    fromMaybe (toJSON $ JsonTaggedVariant $ shrinkVariant v1) $
                    (\x -> object [tag .= x]) <$> w1
@@ -54,7 +69,7 @@ instance ( FromJSON t, FromJSON (JsonTaggedVariant ts)
          , KnownSymbol lbl
          ) => FromJSON (JsonTaggedVariant (lbl := t ': ts)) where
     parseJSON r =
-        do let tag = T.pack $ symbolVal (FldProxy :: FldProxy lbl)
+        do let tag = jsonKey $ symbolVal (FldProxy :: FldProxy lbl)
                myParser :: Parser t
                myParser = withObject ("Tagged " ++ show tag) (\o -> o .: tag) r
                myPackedParser :: Parser (JsonTaggedVariant (lbl := t ': ts))

From f011e7146a766d03290ebcb62eed623592bd0b01 Mon Sep 17 00:00:00 2001
From: Philip Patsch <philip.patsch@possehl-analytics.com>
Date: Wed, 18 May 2022 13:05:19 +0200
Subject: [PATCH 3/6] Use Data.Kind.Type instead of the * syntax

Support for * is disabled in GHC 9.2 by default and causes a lot of
annoying warnings in 9.0.

Tested against 8.10.7, 9.0.2 and 9.2.4. The base constraint seems to be
correct, as Data.Kind was added in base 4.9.

Co-authored-by: Lukas Epple <lukas.epple@possehl-analytics.com>
---
 src/SuperRecord.hs         | 44 ++++++++++++++++++++------------------
 src/SuperRecord/Variant.hs |  3 ++-
 2 files changed, 25 insertions(+), 22 deletions(-)

diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs
index bb582a3..1491fb3 100644
--- a/src/SuperRecord.hs
+++ b/src/SuperRecord.hs
@@ -97,6 +97,8 @@ import qualified JavaScript.Object.Internal as JS
 import GHC.ST ( ST(..) , runST)
 #endif
 
+import Data.Kind (Type)
+
 #if MIN_VERSION_aeson(2, 0, 0)
 import qualified Data.Aeson.Key as Key
 #else
@@ -123,7 +125,7 @@ type Record lts = Rec (Sort lts)
 -- | Internal record type. When manually writing an explicit type signature for
 -- a record, use 'Record' instead. For abstract type signatures 'Rec' will work
 -- well.
-data Rec (lts :: [*])
+data Rec (lts :: [Type])
    = Rec
    {
 #ifndef JS_RECORD
@@ -256,7 +258,7 @@ rcons (lbl := val) (Rec obj) =
 
 infixr 5 `rcons`
 
-class RecCopy (pts :: [*]) (lts :: [*]) (rts :: [*]) where
+class RecCopy (pts :: [Type]) (lts :: [Type]) (rts :: [Type]) where
     recCopyInto ::
         Proxy pts -> Rec lts -> Proxy rts
         -> SmallMutableArray# s Any
@@ -340,7 +342,7 @@ type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where
   RecAll c '[] = ()
   RecAll c (r ': rs) = (c r, RecAll c rs)
 
-type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
+type family KeyDoesNotExist (l :: Symbol) (lts :: [Type]) :: Constraint where
     KeyDoesNotExist l '[] = 'True ~ 'True
     KeyDoesNotExist l (l := t ': lts) =
         TypeError
@@ -350,27 +352,27 @@ type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
 
 type RecAppend lhs rhs = RecAppendH lhs rhs rhs '[]
 
-type family ListConcat (xs :: [*]) (ys :: [*]) :: [*] where
+type family ListConcat (xs :: [Type]) (ys :: [Type]) :: [Type] where
     ListConcat '[] ys = ys
     ListConcat xs '[] = xs
     ListConcat (x ': xs) ys = x ': (ListConcat xs ys)
 
-type family ListReverse (xs :: [*]) :: [*] where
+type family ListReverse (xs :: [Type]) :: [Type] where
     ListReverse (x ': xs) = ListConcat (ListReverse xs) '[x]
     ListReverse '[] = '[]
 
-type family RecAppendH (lhs ::[*]) (rhs :: [*]) (rhsall :: [*]) (accum :: [*]) :: [*] where
+type family RecAppendH (lhs ::[Type]) (rhs :: [Type]) (rhsall :: [Type]) (accum :: [Type]) :: [Type] where
     RecAppendH (l := t ': lhs) (m := u ': rhs) rhsall acc = RecAppendH (l := t ': lhs) rhs rhsall acc
     RecAppendH (l := t ': lhs) '[] rhsall acc = RecAppendH lhs rhsall rhsall (l := t ': acc)
     RecAppendH '[] rhs rhsall acc = ListConcat (ListReverse acc) rhsall
 
-type family RecSize (lts :: [*]) :: Nat where
+type family RecSize (lts :: [Type]) :: Nat where
     RecSize '[] = 0
     RecSize (l := t ': lts) = 1 + RecSize lts
 
 type RecVecIdxPos l lts = RecSize lts - RecTyIdxH 0 l lts - 1
 
-type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where
+type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [Type]) :: Nat where
     RecTyIdxH idx l (l := t ': lts) = idx
     RecTyIdxH idx m (l := t ': lts) = RecTyIdxH (1 + idx) m lts
     RecTyIdxH idx m '[] =
@@ -379,13 +381,13 @@ type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where
           ':<>: 'Text m
         )
 
-type family RecTy (l :: Symbol) (lts :: [*]) :: Maybe * where
+type family RecTy (l :: Symbol) (lts :: [Type]) :: Maybe Type where
     RecTy l '[]             = 'Nothing
     RecTy l (l := t ': lts) = 'Just t
     RecTy q (l := t ': lts) = RecTy q lts
 
 -- | Require a record to contain at least the listed labels
-type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where
+type family HasOf (req :: [Type]) (lts :: [Type]) :: Constraint where
     HasOf (l := t ': req) lts = (Has lts l t, HasOf req lts)
     HasOf '[] lts = 'True ~ 'True
 
@@ -393,11 +395,11 @@ type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where
 --
 -- Retains the order of fields in the *first* argument.
 -- Throw a type error if a label is associated with distinct types in each of the arguments.
-type family Intersect (as :: [*]) (bs :: [*]) :: [*] where
+type family Intersect (as :: [Type]) (bs :: [Type]) :: [Type] where
     Intersect '[] _ = '[]
     Intersect (k := a ': as) bs = IntersectHelper (RecTy k bs) k a as bs
 
-type family IntersectHelper (lk :: Maybe *) (k :: Symbol) (a :: *) (as :: [*]) (bs :: [*]) :: [*] where
+type family IntersectHelper (lk :: Maybe Type) (k :: Symbol) (a :: Type) (as :: [Type]) (bs :: [Type]) :: [Type] where
     IntersectHelper 'Nothing    _ _ as bs = Intersect as bs
     IntersectHelper ( 'Just a ) k a as bs = ( k := a ) ': Intersect as bs
     IntersectHelper ( 'Just b ) k a _  bs =
@@ -516,7 +518,7 @@ infixr 8 &:-
 fld :: FldProxy l -> FldProxy l
 fld = id
 
-type family RecDeepTy (ps :: r) (lts :: [*]) :: * where
+type family RecDeepTy (ps :: r) (lts :: [Type]) :: Type where
     RecDeepTy (l :& more) (l := Rec t ': lts) = RecDeepTy more t
     RecDeepTy (l :& more) (l := t ': lts) = t
     RecDeepTy (l :& more) (q := t ': lts) = RecDeepTy (l :& more) lts
@@ -641,7 +643,7 @@ inject small
 class    (a ~ b, Lookup kvs k a (RecTy k kvs)) => Inject kvs k a b where
 instance (a ~ b, Lookup kvs k a (RecTy k kvs)) => Inject kvs k a b where
 
-class ( r ~ RecTy k kvs ) => Lookup (kvs :: [*]) (k :: Symbol) (a :: *) (r :: Maybe *) where
+class ( r ~ RecTy k kvs ) => Lookup (kvs :: [Type]) (k :: Symbol) (a :: Type) (r :: Maybe Type) where
     lookupWithDefault :: FldProxy k -> a -> Rec kvs -> a
 instance (RecTy k kvs ~ 'Nothing)
       => Lookup kvs k a 'Nothing
@@ -657,7 +659,7 @@ data RecFields (flds :: [Symbol]) where
     RFNil :: RecFields '[]
     RFCons :: KnownSymbol f => FldProxy f -> RecFields xs -> RecFields (f ': xs)
 
-recKeys :: forall t (lts :: [*]). RecKeys lts => t lts -> [String]
+recKeys :: forall t (lts :: [Type]). RecKeys lts => t lts -> [String]
 recKeys = recKeys' . recFields
 
 recKeys' :: RecFields lts -> [String]
@@ -667,7 +669,7 @@ recKeys' x =
       RFCons q qs -> symbolVal q : recKeys' qs
 
 -- | Get keys of a record on value and type level
-class RecKeys (lts :: [*]) where
+class RecKeys (lts :: [Type]) where
     type RecKeysT lts :: [Symbol]
     recFields :: t lts -> RecFields (RecKeysT lts)
 
@@ -724,7 +726,7 @@ recJsonParser =
         initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)
 
 -- | Machinery needed to implement 'reflectRec'
-class RecApply (rts :: [*]) (lts :: [*]) c where
+class RecApply (rts :: [Type]) (lts :: [Type]) c where
     recApply :: (forall (l :: Symbol) a. (KnownSymbol l, c l a) => FldProxy l -> a -> b -> b) -> Rec rts -> b -> b
 
 instance RecApply rts '[] c where
@@ -744,7 +746,7 @@ instance
         in recApply @rts @(RemoveAccessTo l lts) @c f r res
 
 
-class ( KnownNat ( RecSize bs ) ) => TraversalCHelper (bs_acc ::[*]) (as :: [*]) (bs :: [*]) c where
+class ( KnownNat ( RecSize bs ) ) => TraversalCHelper (bs_acc ::[Type]) (as :: [Type]) (bs :: [Type]) c where
     traversalCHelper :: forall f. Applicative f => ( forall (l :: Symbol) a b. (KnownSymbol l, c l a b) => FldProxy l -> a -> f b ) -> Rec as -> f ( Rec bs_acc )
 
 instance ( RecSize bs ~ s, KnownNat s )
@@ -782,12 +784,12 @@ traverseC ::
 traverseC = traversalCHelper @bs @as @bs @c @f
 
 
-type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
+type family RemoveAccessTo (l :: Symbol) (lts :: [Type]) :: [Type] where
     RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts
     RemoveAccessTo q (l := t ': lts) = (l := t ': RemoveAccessTo l lts)
     RemoveAccessTo q '[] = '[]
 
-class UnsafeRecBuild (rts :: [*]) (lts :: [*]) c where
+class UnsafeRecBuild (rts :: [Type]) (lts :: [Type]) c where
     -- | Build a record from a constrained applicative function.
     --
     -- Effects are performed in order of the given (potentially unsorted) fields.
@@ -833,7 +835,7 @@ recBuildPure f = runIdentity $ recBuild @c @Identity @lts @sortedLts ( \ k v ->
 
 
 -- | Machinery to implement parseJSON
-class RecJsonParse (lts :: [*]) where
+class RecJsonParse (lts :: [Type]) where
     recJsonParse :: Int -> Object -> Parser (Rec lts)
 
 instance RecJsonParse '[] where
diff --git a/src/SuperRecord/Variant.hs b/src/SuperRecord/Variant.hs
index 3653277..6938f36 100644
--- a/src/SuperRecord/Variant.hs
+++ b/src/SuperRecord/Variant.hs
@@ -23,13 +23,14 @@ import Data.Aeson
 import Data.Aeson.Types (Parser, parseFail)
 import Data.Maybe
 import Data.Proxy
+import Data.Kind (Type)
 import GHC.Base (Any)
 import GHC.TypeLits
 import Unsafe.Coerce
 
 -- | A variant is used to express that a values type is of any of
 -- the types tracked in the type level list.
-data Variant (opts :: [*])
+data Variant (opts :: [Type])
     = Variant {-# UNPACK #-} !Word Any
 
 type role Variant representational

From 5a7d6867c6c2a182f25ac5ebb9f2b193218f2b13 Mon Sep 17 00:00:00 2001
From: Lukas Epple <lukas.epple@possehl-analytics.com>
Date: Fri, 12 Aug 2022 16:55:06 +0200
Subject: [PATCH 4/6] SuperRecord.Variant*: enable FlexibleContexts for GHC 9.2

This seems to be required now to compile the Variant code.
---
 src/SuperRecord/Variant.hs        | 1 +
 src/SuperRecord/Variant/Tagged.hs | 1 +
 2 files changed, 2 insertions(+)

diff --git a/src/SuperRecord/Variant.hs b/src/SuperRecord/Variant.hs
index 6938f36..6648138 100644
--- a/src/SuperRecord/Variant.hs
+++ b/src/SuperRecord/Variant.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE UndecidableInstances #-}
diff --git a/src/SuperRecord/Variant/Tagged.hs b/src/SuperRecord/Variant/Tagged.hs
index 2427853..34e9ef2 100644
--- a/src/SuperRecord/Variant/Tagged.hs
+++ b/src/SuperRecord/Variant/Tagged.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE UndecidableInstances #-}

From 05c8fdd724af5189a9a8be2f30dfa55a67f8b656 Mon Sep 17 00:00:00 2001
From: Philip Patsch <philip.patsch@possehl-analytics.com>
Date: Thu, 10 Nov 2022 19:57:20 +0100
Subject: [PATCH 5/6] Change Show-instances to use `"#field := val"`
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The previous show instance would add another layer of quoting for each
nesting:

```
ghci> show (rcons (#foo := "bar") rnil)
"[(\"foo\",\"\\\"bar\\\"\")]"
```

Instead, what we want is to display a nicely readable variant of the
record, using the infix field syntax for both label/value pairs and
full records:

```
ghci> show (rcons (#hi := (rcons (#lea := "hi") rnil)) (rcons (#foo := "bar") rnil ))
"[#foo := \"bar\",#hi := [(#lea := \"hi\")]]"

ghci> show (#hi := "lea")
"#hi := \"lea\""
```

That’s better!

Note that we can’t have a roundtripping `Read` instance anyway, so we
might as well have `Show` be readable.

Fixes https://github.com/agrafix/superrecord/issues/36
---
 src/SuperRecord.hs       | 10 +++++++++-
 src/SuperRecord/Field.hs |  8 ++++++--
 test/Spec.hs             |  2 +-
 3 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/src/SuperRecord.hs b/src/SuperRecord.hs
index 1491fb3..4f94e5b 100644
--- a/src/SuperRecord.hs
+++ b/src/SuperRecord.hs
@@ -101,6 +101,7 @@ import Data.Kind (Type)
 
 #if MIN_VERSION_aeson(2, 0, 0)
 import qualified Data.Aeson.Key as Key
+import Text.Show (showListWith)
 #else
 import qualified Data.Text as T
 #endif
@@ -160,7 +161,7 @@ class    ( c1 k a b, c2 k a b ) => Tuple222C c1 c2 k a b
 instance ( c1 k a b, c2 k a b ) => Tuple222C c1 c2 k a b
 
 instance (RecApply lts lts (ConstC Show)) => Show (Rec lts) where
-    show = show . showRec
+    showsPrec = showsPrecRec
 
 instance RecApply lts lts (Tuple22C (ConstC Eq) (Has lts)) => Eq (Rec lts) where
     r1 == r2 = recApply @lts @lts @(Tuple22C (ConstC Eq) (Has lts)) ( \lbl v b -> get lbl r2 == v && b ) r1 True
@@ -712,6 +713,13 @@ reflectRecFold f r =
 showRec :: forall lts. (RecApply lts lts (ConstC Show)) => Rec lts -> [(String, String)]
 showRec = reflectRec @(ConstC Show) (\(_ :: FldProxy lbl) v -> (symbolVal' (proxy# :: Proxy# lbl), show v))
 
+showsPrecRec :: forall lts. (RecApply lts lts (ConstC Show)) => Int -> Rec lts -> ShowS
+showsPrecRec d r =
+    showListWith id $
+        reflectRec
+        @(ConstC Show) (\(lbl :: FldProxy lbl) v -> showsPrec (d+1) (lbl := v))
+        r
+
 recToValue :: forall lts. (RecApply lts lts (ConstC ToJSON)) => Rec lts -> Value
 recToValue r = object $ reflectRec @(ConstC ToJSON) (\(_ :: FldProxy lbl) v -> (jsonKey $ symbolVal' (proxy# :: Proxy# lbl), toJSON v)) r
 
diff --git a/src/SuperRecord/Field.hs b/src/SuperRecord/Field.hs
index dddc2ae..35cdb9c 100644
--- a/src/SuperRecord/Field.hs
+++ b/src/SuperRecord/Field.hs
@@ -29,8 +29,12 @@ instance (Ord value) => Ord (label := value) where
 
 instance (Show t) =>
          Show (l := t) where
-  showsPrec p (l := t) =
-      showParen (p > 10) (showString ("#" ++ symbolVal l ++ " := " ++ show t))
+  showsPrec d (l := t) =
+      showParen (d > labelPrec) $
+        showString ("#" ++ symbolVal l ++ " := ")
+        . showsPrec (labelPrec+1) t
+    where
+      labelPrec = 6
 
 -- | A proxy witness for a label. Very similar to 'Proxy', but needed to implement
 -- a non-orphan 'IsLabel' instance
diff --git a/test/Spec.hs b/test/Spec.hs
index a85fc3c..29b2737 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -351,7 +351,7 @@ recordTests =
            do let vals = showRec r1
               vals `shouldBe` [("foo", "\"Hi\""), ("int", "213")]
        it "show works" $
-           show r1 `shouldBe` "[(\"foo\",\"\\\"Hi\\\"\"),(\"int\",\"213\")]"
+           show r1 `shouldBe` "[#foo := \"Hi\",#int := 213]"
        it "equality works" $
            do r1 == r1 `shouldBe` True
               r1 == set #foo "Hai" r1 `shouldBe` False

From 085540be48ee8ef768878f9ce5f99307cfa087ef Mon Sep 17 00:00:00 2001
From: Philip Patsch <philip.patsch@possehl-analytics.com>
Date: Sat, 12 Nov 2022 10:49:58 +0100
Subject: [PATCH 6/6] WIP try reproducing `project` problem

---
 superrecord.cabal |  4 +++-
 test/Spec.hs      | 19 +++++++++++++++++++
 2 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/superrecord.cabal b/superrecord.cabal
index edd27d2..c321463 100644
--- a/superrecord.cabal
+++ b/superrecord.cabal
@@ -53,7 +53,9 @@ test-suite superrecord-test
                      , aeson
                      , mtl
                      , text
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+                       -- we test with -O2 in order to provoke bugs caused by optimizations,
+                       -- e.g. https://github.com/agrafix/superrecord/issues/38
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2
   default-language:    Haskell2010
 
 benchmark superrecord-bench
diff --git a/test/Spec.hs b/test/Spec.hs
index 29b2737..1de4b27 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -23,6 +23,7 @@ import Data.Aeson.Encoding
 import GHC.Generics (Generic)
 import Test.Hspec
 import qualified Data.Text as T
+import Data.Functor ((<&>))
 
 data V1
 data V2
@@ -412,6 +413,16 @@ recordTests =
           ( project @_ @'[ "f3" := Int, "f5" := Int ] bigRec )
             `shouldBe`
           ( #f3 := 3 & #f5 := 5 & rnil )
+
+       it "projecting a list works ( https://github.com/agrafix/superrecord/issues/38 )" $ do
+          recs <- twoRecordsFromJson
+          (     recs
+            <&> project @_ @'[ "f3" := Int, "f10" := Int ]
+            <&> get #f3
+           )
+            `shouldBe`
+            [3, 8]
+
        it "inject works" $
           ( inject
               ( #f3 := 33 & #f5 := 55 & rnil :: Record '[ "f3" := Int, "f5" := Int ] )
@@ -430,3 +441,11 @@ recordTests =
           & #f10  := 10
           & rnil
           )
+
+{-# NOINLINE twoRecordsFromJson #-}
+twoRecordsFromJson :: IO [Record BigFieldList]
+twoRecordsFromJson = do
+  let Just recs = decode @[Record BigFieldList] "[{ \"f1\": 1, \"f2\": 2, \"f3\": 3, \"f4\": 4, \"f5\": 5, \"f6\": 6, \"f7\": 7, \"f8\": 8, \"f9\": 9, \"f10\": 10}, { \"f1\": 10, \"f2\": 9, \"f3\": 8, \"f4\": 7, \"f5\": 6, \"f6\": 5, \"f7\": 4, \"f8\": 3, \"f9\": 2, \"f10\": 1}]"
+  -- print a field in order to avoid inlining
+  print (map (get #f10) recs)
+  pure recs