{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Barbies.TH (FieldNamesB(..)
  , LensB(..)
  , getLensB
  , AccessorsB(..)
  , declareBareB
  , declareBareBWithOtherBarbies
  ) where

import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Syntax (VarBangType, Name(..), mkOccName, occString)
import Data.String
import Data.Foldable (foldl')
import Data.List (partition, nub)
import Barbies
import Barbies.Constraints
import Barbies.Bare
import Data.Functor.Product
import GHC.Generics (Generic)
import Control.Applicative
import Data.Functor.Identity (Identity(..))
import Data.Functor.Compose (Compose(..))
import Data.List.Split
import Data.Maybe (mapMaybe)
import Data.Bool (bool)

-- | A pair of a getter and a setter
-- Not van Laarhoven to avoid dictionary passing
data LensB b a = LensB
  { LensB b a -> forall (h :: k -> *). b h -> h a
viewB :: forall h. b h -> h a
  , LensB b a -> forall (h :: k -> *). h a -> b h -> b h
setB :: forall h. h a -> b h -> b h
  }

nestLensB :: (forall h . a h -> (b h -> a h, b h)) -> LensB b c -> LensB a c
nestLensB :: (forall (h :: k -> *). a h -> (b h -> a h, b h))
-> LensB b c -> LensB a c
nestLensB forall (h :: k -> *). a h -> (b h -> a h, b h)
l (LensB forall (h :: k -> *). b h -> h c
lv forall (h :: k -> *). h c -> b h -> b h
ls) =
  (forall (h :: k -> *). a h -> h c)
-> (forall (h :: k -> *). h c -> a h -> a h) -> LensB a c
forall k (b :: (k -> *) -> *) (a :: k).
(forall (h :: k -> *). b h -> h a)
-> (forall (h :: k -> *). h a -> b h -> b h) -> LensB b a
LensB (b h -> h c
forall (h :: k -> *). b h -> h c
lv (b h -> h c) -> (a h -> b h) -> a h -> h c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b h -> a h, b h) -> b h
forall a b. (a, b) -> b
snd ((b h -> a h, b h) -> b h)
-> (a h -> (b h -> a h, b h)) -> a h -> b h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a h -> (b h -> a h, b h)
forall (h :: k -> *). a h -> (b h -> a h, b h)
l) (\h c
n a h
h -> let (b h -> a h
s, b h
x) = a h -> (b h -> a h, b h)
forall (h :: k -> *). a h -> (b h -> a h, b h)
l a h
h in b h -> a h
s (h c -> b h -> b h
forall (h :: k -> *). h c -> b h -> b h
ls h c
n b h
x))

getLensB :: Functor f => LensB b a -> (h a -> f (h a)) -> b h -> f (b h)
getLensB :: LensB b a -> (h a -> f (h a)) -> b h -> f (b h)
getLensB (LensB forall (h :: k -> *). b h -> h a
v forall (h :: k -> *). h a -> b h -> b h
s) h a -> f (h a)
f b h
b = (\h a
x -> h a -> b h -> b h
forall (h :: k -> *). h a -> b h -> b h
s h a
x b h
b) (h a -> b h) -> f (h a) -> f (b h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h a -> f (h a)
f (b h -> h a
forall (h :: k -> *). b h -> h a
v b h
b)
{-# INLINE getLensB #-}

class AccessorsB b where
  -- | A collection of lenses (getter-setter pairs)
  baccessors :: b (LensB b)

-- | barbies doesn't care about field names, but they are useful in many use cases
class FieldNamesB b where
  -- | A collection of field names.
  bfieldNames :: IsString a => b (Const a)

-- | Transform a regular Haskell record declaration into HKD form.
-- 'BareB', 'FieldNamesB', 'FunctorB', 'DistributiveB',
-- 'TraversableB', 'ApplicativeB' and 'ConstraintsB' instances are
-- derived.
--
-- For example,
--
-- @declareBareB [d|data User = User { uid :: Int, name :: String}|]@
--
-- becomes
--
-- @data User t f = User { uid :: Wear t f Int, name :: Wear t f String }@
--
declareBareB :: DecsQ -> DecsQ
declareBareB :: DecsQ -> DecsQ
declareBareB = [Name] -> DecsQ -> DecsQ
declareBareBWithOtherBarbies []

-- | Like 'declareBareB' except that one can specify the 'Name's of other
-- barbies. Members with these types won't be wrapped with 'Wear'.
declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ
declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ
declareBareBWithOtherBarbies [Name]
friends DecsQ
decsQ = do
  [Dec]
decs <- DecsQ
decsQ
  let newTypeNames :: [Name]
newTypeNames = [Dec] -> [Name]
dataDecNames [Dec]
decs
  [[Dec]]
decs' <- (Dec -> DecsQ) -> [Dec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Name] -> Dec -> DecsQ
go ([Name]
newTypeNames [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name]
friends)) [Dec]
decs
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs'
  where
    go :: [Name] -> Dec -> DecsQ
go [Name]
otherBarbieNames (DataD Cxt
_ Name
dataName [TyVarBndr]
tvbs Maybe Kind
_ [con :: Con
con@(RecC Name
nDataCon [VarBangType]
mangledfields)] [DerivClause]
classes) = do
      let fields :: [VarBangType]
fields = [(Name -> Name
unmangle Name
name, Bang
c, Kind
t) | (Name
name, Bang
c, Kind
t) <- [VarBangType]
mangledfields]
      Name
nSwitch <- String -> Q Name
newName String
"sw"
      Name
nWrap <- String -> Q Name
newName String
"h"
      let xs :: [Name]
xs = String -> [VarBangType] -> [Name]
varNames String
"x" [VarBangType]
fields
      let ys :: [Name]
ys = String -> [VarBangType] -> [Name]
varNames String
"y" [VarBangType]
fields
      -- 'mapMembers' applies one of two functions to elements of a list
      -- according to whether or not they align with another barbie
      let otherBarbieMask :: [Bool]
otherBarbieMask = [ case Kind
t of
                                ConT Name
n | Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
otherBarbieNames -> Bool
True
                                Kind
_ -> Bool
False
                            | (Name
_, Bang
_, Kind
t) <- [VarBangType]
fields
                            ]
      let mapMembers :: (b -> c) -> (b -> c) -> [b] -> [c]
          mapMembers :: (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers b -> c
normal b -> c
otherBarbie = (Bool -> b -> c) -> [Bool] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((b -> c) -> (b -> c) -> Bool -> b -> c
forall a. a -> a -> Bool -> a
bool b -> c
normal b -> c
otherBarbie) [Bool]
otherBarbieMask
      Name
nData <- String -> Q Name
newName String
"b"
      Name
nConstr <- String -> Q Name
newName String
"c"
      Name
nX <- String -> Q Name
newName String
"x"
      let transformed :: Con
transformed = [Name] -> Name -> Name -> Con -> Con
transformCon [Name]
otherBarbieNames Name
nSwitch Name
nWrap Con
con
      let reconE :: [ExpQ] -> ExpQ
reconE = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
nDataCon)
          -- field names for FieldNamesB
          fieldNamesE :: ExpQ
fieldNamesE = [ExpQ] -> ExpQ
reconE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (VarBangType -> ExpQ)
-> (VarBangType -> ExpQ) -> [VarBangType] -> [ExpQ]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
            (\(Name
name,Bang
_,Kind
_) -> [|Const $ fromString $(litE $ StringL $ nameBase name)|])
            (ExpQ -> VarBangType -> ExpQ
forall a b. a -> b -> a
const [|bfieldNames|])
            [VarBangType]
fields
          accessors :: ExpQ
accessors = [ExpQ] -> ExpQ
reconE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> ExpQ) -> (Name -> ExpQ) -> [Name] -> [ExpQ]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
            (\Name
name -> [|LensB
                $(varE name)
                (\ $(varP nX) $(varP nData) -> $(recUpdE (varE nData) [pure (name, VarE nX)])) |]
            )
            (\Name
name -> [|bmap
                          (nestLensB
                             (\ $(varP nData) -> (\ $(varP nX) -> $(recUpdE (varE nData) [pure (name, VarE nX)])
                                                 ,$(varE name) $(varE nData)
                                                 )
                             )
                          )
                          baccessors
                      |]
            )
            [Name
name | (Name
name,Bang
_,Kind
_) <- [VarBangType]
fields]


          -- Turn TyVarBndr into just a Name such that we can
          -- reconstruct the constructor applied to already-present
          -- type variables below.
          varName :: TyVarBndr -> Name
varName (PlainTV Name
n) = Name
n
          varName (KindedTV Name
n Kind
_) = Name
n

          -- The type name as present originally along with its type
          -- variables.
          vanillaType :: TypeQ
vanillaType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
dataName) (Name -> TypeQ
varT (Name -> TypeQ) -> (TyVarBndr -> Name) -> TyVarBndr -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
varName (TyVarBndr -> TypeQ) -> [TyVarBndr] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
tvbs)

          -- max arity = 62
          typeChunks :: [[TypeQ]]
typeChunks = Int -> [TypeQ] -> [[TypeQ]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
62 ((TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> [TypeQ] -> [TypeQ]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
              (\TypeQ
t -> Name -> TypeQ
varT Name
nConstr TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
t)
              (\TypeQ
t -> [t| AllB $(varT nConstr) ($t Covered)|])
              [Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t | (Name
_, Bang
_, Kind
t) <- [VarBangType]
fields]
            )
          mkConstraints :: t TypeQ -> TypeQ
mkConstraints t TypeQ
ps = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> t TypeQ -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ t TypeQ -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t TypeQ
ps) t TypeQ
ps
          allConstr :: TypeQ
allConstr = case [[TypeQ]]
typeChunks of
            [[TypeQ]
ps] -> [TypeQ] -> TypeQ
forall (t :: * -> *). Foldable t => t TypeQ -> TypeQ
mkConstraints [TypeQ]
ps
            [[TypeQ]]
pss -> [TypeQ] -> TypeQ
forall (t :: * -> *). Foldable t => t TypeQ -> TypeQ
mkConstraints ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$ ([TypeQ] -> TypeQ) -> [[TypeQ]] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map [TypeQ] -> TypeQ
forall (t :: * -> *). Foldable t => t TypeQ -> TypeQ
mkConstraints [[TypeQ]]
pss

      let datC :: TypeQ
datC = TypeQ
vanillaType TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT ''Covered
      [Dec]
decs <- [d|
        instance BareB $(vanillaType) where
          bcover $(conP nDataCon $ map varP xs)
            = $(reconE $ mapMembers (appE (conE 'Identity)) (appE (varE 'bcover)) (varE <$> xs))
          {-# INLINE bcover #-}
          bstrip $(conP nDataCon $ map varP xs)
            = $(reconE $ mapMembers (appE (varE 'runIdentity)) (appE (varE 'bstrip)) (varE <$> xs))
          {-# INLINE bstrip #-}
        instance FieldNamesB $(datC) where bfieldNames = $(fieldNamesE)
        instance AccessorsB $(datC) where baccessors = $(accessors)
        instance FunctorB $(datC) where
          bmap f $(conP nDataCon $ map varP xs)
            = $(reconE (mapMembers (appE (varE 'f)) (appE [|bmap f|]) (varE <$> xs)))
        instance DistributiveB $(datC) where
          bdistribute fb = $(reconE $
              -- TODO: NoFieldSelectors
              mapMembers
                (\fd -> [| Compose ($fd <$> fb) |])
                (\fd -> [| bdistribute ($fd <$> fb) |])
                [varE fd | (fd, _, _) <- fields]
            )
        instance TraversableB $(datC) where
          btraverse f $(conP nDataCon $ map varP xs) = $(fst $ foldl'
              (\(l, op) r -> (infixE (Just l) (varE op) (Just r), '(<*>)))
              (conE nDataCon, '(<$>))
              (mapMembers (appE (varE 'f)) (\x -> [|btraverse f $x|]) (varE <$> xs))
            )
          {-# INLINE btraverse #-}
        instance ConstraintsB $(datC) where
          type AllB $(varT nConstr) $(datC) = $(allConstr)
          baddDicts $(conP nDataCon $ map varP xs)
            = $(reconE $ mapMembers
                 (\x -> [|Pair Dict $x|])
                 (\x -> [|baddDicts $x|])
                 (varE <$> xs)
               )
        instance ApplicativeB $(datC) where
          bpure $(varP nX) = $(reconE $ mapMembers
                                 (const (varE nX))
                                 (const [|bpure $(varE nX)|])
                                 xs
                              )
          bprod $(conP nDataCon $ map varP xs) $(conP nDataCon $ map varP ys) = $(foldl'
            (\r (isOtherBarbie, x, y) ->
              if isOtherBarbie
                then [|$r (bprod $(varE x) $(varE y))|]
                else [|$r (Pair $(varE x) $(varE y))|])
            (conE nDataCon) (zip3 otherBarbieMask xs ys))
        |]
      -- strip deriving Generic
      let classes' :: [(Cxt, DerivClause)]
classes' = (DerivClause -> (Cxt, DerivClause))
-> [DerivClause] -> [(Cxt, DerivClause)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DerivClause Maybe DerivStrategy
strat Cxt
cs) -> (Cxt -> DerivClause) -> (Cxt, Cxt) -> (Cxt, DerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
strat) ((Cxt, Cxt) -> (Cxt, DerivClause))
-> (Cxt, Cxt) -> (Cxt, DerivClause)
forall a b. (a -> b) -> a -> b
$ (Kind -> Bool) -> Cxt -> (Cxt, Cxt)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Kind
ConT ''Generic) Cxt
cs) [DerivClause]
classes
      -- For the covered type, derive instances via 'Barbie' wrapper instead.
      [[Dec]]
coverDrvs <- (TypeQ -> DecsQ) -> [TypeQ] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\TypeQ
cls ->
        [d|deriving via Barbie $(datC) $(varT nWrap)
            instance ($(cls) (Barbie $(datC) $(varT nWrap))) => $(cls) ($(datC) $(varT nWrap))|])
        [ Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t | (Cxt
_, DerivClause Maybe DerivStrategy
_ Cxt
preds) <- [(Cxt, DerivClause)]
classes', Kind
t <- Cxt
preds ]
      -- Redefine instances of the bare type with the original strategy
      [Dec]
bareDrvs <- ((Maybe DerivStrategy, TypeQ) -> Q Dec)
-> [(Maybe DerivStrategy, TypeQ)] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Maybe DerivStrategy
strat, TypeQ
cls) ->
        Maybe DerivStrategy -> CxtQ -> TypeQ -> Q Dec
standaloneDerivWithStrategyD Maybe DerivStrategy
strat (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|$(cls) ($(vanillaType) Bare Identity)|])
        [ (Maybe DerivStrategy
strat, Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t) | (Cxt
_, DerivClause Maybe DerivStrategy
strat Cxt
preds) <- [(Cxt, DerivClause)]
classes', Kind
t <- Cxt
preds ]
      [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dataName
        ([TyVarBndr]
tvbs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr
PlainTV Name
nSwitch, Name -> TyVarBndr
PlainTV Name
nWrap])
        Maybe Kind
forall a. Maybe a
Nothing
        [Con
transformed]
        [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Cxt -> DerivClause) -> Cxt -> DerivClause
forall a b. (a -> b) -> a -> b
$ ((Cxt, DerivClause) -> Cxt) -> [(Cxt, DerivClause)] -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cxt, DerivClause) -> Cxt
forall a b. (a, b) -> a
fst [(Cxt, DerivClause)]
classes']
        Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
coverDrvs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
bareDrvs
    go [Name]
_ Dec
d = [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
d]

dataDecNames :: [Dec] -> [Name]
dataDecNames :: [Dec] -> [Name]
dataDecNames = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> ([Dec] -> [Name]) -> [Dec] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Maybe Name) -> [Dec] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe Name
decName
 where
  decName :: Dec -> Maybe Name
  decName :: Dec -> Maybe Name
decName = \case
    DataD    Cxt
_ Name
n [TyVarBndr]
_ Maybe Kind
_ [Con]
_ [DerivClause]
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
    Dec
_                    -> Maybe Name
forall a. Maybe a
Nothing

varNames :: String -> [VarBangType] -> [Name]
varNames :: String -> [VarBangType] -> [Name]
varNames String
p [VarBangType]
vbt = [String -> Name
mkName (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
v) | (Name
v, Bang
_, Kind
_) <- [VarBangType]
vbt]

transformCon :: [Name] -- ^ Names of other barbies
  -> Name -- ^ switch variable
  -> Name -- ^ wrapper variable
  -> Con -- ^ original constructor
  -> Con
transformCon :: [Name] -> Name -> Name -> Con -> Con
transformCon [Name]
otherBarbieNames Name
switchName Name
wrapperName (RecC Name
name [VarBangType]
xs) = Name -> [VarBangType] -> Con
RecC
  Name
name
  [ (Name -> Name
unmangle Name
v, Bang
b, Kind
t')
  | (Name
v, Bang
b, Kind
t) <- [VarBangType]
xs
  , let
    t' :: Kind
t' = case Kind
t of
      ConT Name
n | Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
otherBarbieNames ->
        Name -> Kind
ConT Name
n Kind -> Kind -> Kind
`AppT` Name -> Kind
VarT Name
switchName Kind -> Kind -> Kind
`AppT` Name -> Kind
VarT Name
wrapperName
      Kind
_ -> Name -> Kind
ConT ''Wear Kind -> Kind -> Kind
`AppT` Name -> Kind
VarT Name
switchName Kind -> Kind -> Kind
`AppT` Name -> Kind
VarT Name
wrapperName Kind -> Kind -> Kind
`AppT` Kind
t
  ]
transformCon [Name]
otherBarbieNames Name
var Name
w (ForallC [TyVarBndr]
tvbs Cxt
cxt Con
con) =
  [TyVarBndr] -> Cxt -> Con -> Con
ForallC [TyVarBndr]
tvbs Cxt
cxt (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ [Name] -> Name -> Name -> Con -> Con
transformCon [Name]
otherBarbieNames Name
var Name
w Con
con
transformCon [Name]
_ Name
_ Name
_ Con
con = String -> Con
forall a. HasCallStack => String -> a
error (String -> Con) -> String -> Con
forall a b. (a -> b) -> a -> b
$ String
"transformCon: unsupported " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
con

-- | Unmangle record field names
--
-- When 'DuplicateRecordFields' is turned on, record field names are mangled.
-- (see https://gitlab.haskell.org/ghc/ghc/-/wikis/records/overloaded-record-fields/duplicate-record-fields#mangling-selector-names)
-- We undo that because these mangled field names don't round-trip through TH splices.
unmangle :: Name -> Name
unmangle :: Name -> Name
unmangle (Name OccName
occ NameFlavour
flavour) = OccName -> NameFlavour -> Name
Name OccName
occ' NameFlavour
flavour
  where
    occ' :: OccName
occ' = case (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (OccName -> String
occString OccName
occ) of
        [String
"$sel", String
fd, String
_qual] -> String -> OccName
mkOccName String
fd
        [String]
_ -> OccName
occ