{-# LANGUAGE CPP #-}
{-# 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 #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
module Barbies.TH (FieldNamesB(..)
  , LensB(..)
  , getLensB
  , AccessorsB(..)
  , declareBareB
  , declareBareBWith
  , declareBareBWithOtherBarbies
  , passthroughBareB
  ) where

import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Syntax (VarBangType, Name(..), mkOccName, occString)
import Data.Bifunctor (first)
import Data.String
import Data.Foldable (foldl')
import Data.List (partition, nub)
import qualified Data.List.NonEmpty as NE
import Barbies
import Barbies.Constraints
import Barbies.Bare
import Barbies.TH.Config
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

-- | A pair of a getter and a setter
-- Not van Laarhoven to avoid dictionary passing
data LensB b a = LensB
  { forall {k} (b :: (k -> *) -> *) (a :: k).
LensB b a -> forall (h :: k -> *). b h -> h a
viewB :: forall h. b h -> h a
  , forall {k} (b :: (k -> *) -> *) (a :: k).
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 {k} (a :: (k -> *) -> *) (b :: (k -> *) -> *) (c :: k).
(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 {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 (forall (h :: k -> *). b h -> h c
lv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (h :: k -> *). a h -> (b h -> a h, b h)
l a h
h in b h -> a h
s (forall (h :: k -> *). h c -> b h -> b h
ls h c
n b h
x))

-- | Obtain a van-laarhoven lens (compatible with the lens library) from 'LensB'
getLensB :: Functor f => LensB b a -> (h a -> f (h a)) -> b h -> f (b h)
getLensB :: forall {k} (f :: * -> *) (b :: (k -> *) -> *) (a :: k)
       (h :: k -> *).
Functor f =>
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 -> forall (h :: k -> *). h a -> b h -> b h
s h a
x b h
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h a -> f (h a)
f (forall (h :: k -> *). b h -> h a
v b h
b)
{-# INLINE getLensB #-}

-- | The class of higher-kinded datatypes where lenses can be defined
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)

  -- | A collection of field names, prefixed by the names of the parent.
  bnestedFieldNames :: IsString a => b (Const (NE.NonEmpty 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 = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
classic

-- | Defines a synonym for the bare type with the same name.
-- The strippable definition is suffixed by B, and the covered type is suffixed by H.
passthroughBareB :: DecsQ -> DecsQ
passthroughBareB :: DecsQ -> DecsQ
passthroughBareB = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
passthrough

-- | 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]
xs = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
classic { friends :: [Name]
friends = [Name]
xs }

-- | Generate a higher-kinded data declaration using a custom config
declareBareBWith :: DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith :: DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig{[Name]
Q Name
String -> String
String -> Maybe String
wrapperName :: DeclareBareBConfig -> Q Name
switchName :: DeclareBareBConfig -> Q Name
barbieName :: DeclareBareBConfig -> String -> String
coveredName :: DeclareBareBConfig -> String -> Maybe String
bareName :: DeclareBareBConfig -> String -> Maybe String
wrapperName :: Q Name
switchName :: Q Name
barbieName :: String -> String
coveredName :: String -> Maybe String
bareName :: String -> Maybe String
friends :: [Name]
friends :: DeclareBareBConfig -> [Name]
..} DecsQ
decsQ = do
  [Dec]
decs <- DecsQ
decsQ
  let otherBarbieNames :: [(Name, Name)]
otherBarbieNames = [ (Name
k, String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String -> String
barbieName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
k) | Name
k <- [Dec] -> [Name]
dataDecNames [Dec]
decs ]
          forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> (Name
x, Name
x)) [Name]
friends
  [[Dec]]
decs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([(Name, Name)] -> Dec -> DecsQ
go [(Name, Name)]
otherBarbieNames) [Dec]
decs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs'
  where
    go :: [(Name, Name)] -> Dec -> DecsQ
go [(Name, Name)]
otherBarbieNames (DataD [Pred]
_ Name
dataName0 [TyVarBndr ()]
tvbs Maybe Pred
_ [con :: Con
con@(RecC Name
nDataCon [VarBangType]
mangledfields)] [DerivClause]
classes) = do
      let dataName :: Name
dataName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String -> String
barbieName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0
      let fields :: [VarBangType]
fields = [(Name -> Name
unmangle Name
name, Bang
c, Pred
t) | (Name
name, Bang
c, Pred
t) <- [VarBangType]
mangledfields]
      Name
nSwitch <- Q Name
switchName
      Name
nWrap <- Q Name
wrapperName
      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 :: [Maybe Name]
otherBarbieMask = [ case Pred
t of
                                ConT Name
n | Just Name
v <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
otherBarbieNames -> forall a. a -> Maybe a
Just Name
v
                                Pred
_ -> forall a. Maybe a
Nothing
                            | (Name
_, Bang
_, Pred
t) <- [VarBangType]
fields
                            ]
      let mapMembers :: (b -> c) -> (b -> c) -> [b] -> [c]
          mapMembers :: forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers b -> c
normal b -> c
otherBarbie = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall b a. b -> (a -> b) -> Maybe a -> b
maybe b -> c
normal (forall a b. a -> b -> a
const b -> c
otherBarbie)) [Maybe Name]
otherBarbieMask
      Name
nData <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"
      Name
nConstr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
      Name
nX <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      let transformed :: Con
transformed = [(Name, Name)] -> Name -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
nSwitch Name
nWrap Con
con
      let reconE :: [Q Exp] -> Q Exp
reconE = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
nDataCon)
          -- field names for FieldNamesB
          strLit :: String -> m Exp
strLit String
str = [|fromString $(litE $ StringL str)|]
          fieldNamesE :: Q Exp
fieldNamesE = [Q Exp] -> Q Exp
reconE forall a b. (a -> b) -> a -> b
$ forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
            (\(Name
name,Bang
_,Pred
_) -> forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Const forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall {m :: * -> *}. Quote m => String -> m Exp
strLit (Name -> String
nameBase Name
name))
            (\VarBangType
_ -> [|bfieldNames|])
            [VarBangType]
fields
          nestedFieldNamesE :: Q Exp
nestedFieldNamesE = [Q Exp] -> Q Exp
reconE forall a b. (a -> b) -> a -> b
$ forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
            (\(Name
name,Bang
_,Pred
_) -> [|Const $ pure $(strLit $ nameBase name)|])
            (\(Name
name,Bang
_,Pred
_) -> [|first (NE.cons $(strLit $ nameBase name)) `bmap` bnestedFieldNames|])
            [VarBangType]
fields
          accessors :: Q Exp
accessors = [Q Exp] -> Q Exp
reconE forall a b. (a -> b) -> a -> b
$ 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
_,Pred
_) <- [VarBangType]
fields]


          -- Turn TyVarBndr into just a Name such that we can
          -- reconstruct the constructor applied to already-present
          -- type variables below.
#if MIN_VERSION_template_haskell(2,17,0)
          varName :: TyVarBndr flag -> Name
varName (PlainTV Name
n flag
_) = Name
n
          varName (KindedTV Name
n flag
_ Pred
_) = Name
n
#else
          varName (PlainTV n) = n
          varName (KindedTV n _) = n
#endif

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

      -- bare/covered types
      Pred
bareType <- [t| $(vanillaType) Bare Identity |]
      Pred
coveredType <- [t| $(vanillaType) Covered |]

      -- max arity = 62
      let typeChunks :: [[Q Pred]]
typeChunks = forall e. Int -> [e] -> [[e]]
chunksOf Int
62
            [ case Maybe Name
mask of
              Just Name
t' -> [t| AllB $(varT nConstr) ($(conT t') Covered)|]
              Maybe Name
Nothing -> forall (m :: * -> *). Quote m => Name -> m Pred
varT Name
nConstr forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
t
            | ((Name
_, Bang
_, Pred
t), Maybe Name
mask) <- forall a b. [a] -> [b] -> [(a, b)]
zip [VarBangType]
fields [Maybe Name]
otherBarbieMask
            ]
          mkConstraints :: t (m Pred) -> m Pred
mkConstraints t (m Pred)
ps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (forall (m :: * -> *). Quote m => Int -> m Pred
tupleT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length t (m Pred)
ps) t (m Pred)
ps
          allConstr :: Q Pred
allConstr = case [[Q Pred]]
typeChunks of
            [[Q Pred]
ps] -> forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints [Q Pred]
ps
            [[Q Pred]]
pss -> forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints [[Q Pred]]
pss


      let datC :: Q Pred
datC = forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
coveredType
      [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 $(pure coveredType) where
          bfieldNames = $(fieldNamesE)
          bnestedFieldNames = $(nestedFieldNamesE)
        instance AccessorsB $(pure coveredType) where baccessors = $(accessors)
        instance FunctorB $(pure coveredType) where
          bmap f $(conP nDataCon $ map varP xs)
            = $(reconE (mapMembers (appE (varE 'f)) (appE [|bmap f|]) (varE <$> xs)))
        instance DistributiveB $(pure coveredType) where
          bdistribute fb = $(reconE $
              -- TODO: NoFieldSelectors
              mapMembers
                (\fd -> [| Compose ($fd <$> fb) |])
                (\fd -> [| bdistribute ($fd <$> fb) |])
                [varE fd | (fd, _, _) <- fields]
            )
        instance TraversableB $(pure coveredType) where
          btraverse f $(conP nDataCon $ map varP xs) = $(
              case xs of
                [] -> appE (varE 'pure) (conE nDataCon)
                _ -> 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 $(pure coveredType) where
          type AllB $(varT nConstr) $(pure coveredType) = $(allConstr)
          baddDicts $(conP nDataCon $ map varP xs)
            = $(reconE $ mapMembers
                 (\x -> [|Pair Dict $x|])
                 (\x -> [|baddDicts $x|])
                 (varE <$> xs)
               )
        instance ApplicativeB $(pure coveredType) 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 isJust 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' :: [([Pred], DerivClause)]
classes' = forall a b. (a -> b) -> [a] -> [b]
map (\(DerivClause Maybe DerivStrategy
strat [Pred]
cs) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe DerivStrategy -> [Pred] -> DerivClause
DerivClause Maybe DerivStrategy
strat) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a. Eq a => a -> a -> Bool
== Name -> Pred
ConT ''Generic) [Pred]
cs) [DerivClause]
classes

      -- For the covered type, derive instances via 'Barbie' wrapper instead.
      [[Dec]]
coverDrvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Q Pred
cls ->
        [d|deriving via Barbie $(datC) $(varT nWrap)
            instance ($(cls) (Barbie $(datC) $(varT nWrap))) => $(cls) ($(datC) $(varT nWrap))|])
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
t | ([Pred]
_, DerivClause Maybe DerivStrategy
_ [Pred]
preds) <- [([Pred], DerivClause)]
classes', Pred
t <- [Pred]
preds ]
      -- Redefine instances of the bare type with the original strategy
      [Dec]
bareDrvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Maybe DerivStrategy
strat, Q Pred
cls) ->
        forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> m [Pred] -> m Pred -> m Dec
standaloneDerivWithStrategyD Maybe DerivStrategy
strat (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|$(cls) $(pure bareType)|])
        [ (Maybe DerivStrategy
strat, forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
t) | ([Pred]
_, DerivClause Maybe DerivStrategy
strat [Pred]
preds) <- [([Pred], DerivClause)]
classes', Pred
t <- [Pred]
preds ]
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pred]
-> Name
-> [TyVarBndr ()]
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dataName
#if MIN_VERSION_template_haskell(2,17,0)
        ([TyVarBndr ()]
tvbs forall a. [a] -> [a] -> [a]
++ [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nSwitch (), forall flag. Name -> flag -> Pred -> TyVarBndr flag
KindedTV Name
nWrap () (Pred -> Pred -> Pred
AppT (Pred -> Pred -> Pred
AppT Pred
ArrowT Pred
StarT) Pred
StarT)])
#else
        (tvbs ++ [PlainTV nSwitch, KindedTV nWrap (AppT (AppT ArrowT StarT) StarT)])
#endif
        forall a. Maybe a
Nothing
        [Con
transformed]
        [Maybe DerivStrategy -> [Pred] -> DerivClause
DerivClause forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([Pred], DerivClause)]
classes']
        forall a. a -> [a] -> [a]
: [Dec]
decs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
coverDrvs forall a. [a] -> [a] -> [a]
++ [Dec]
bareDrvs
        forall a. [a] -> [a] -> [a]
++ [ Name -> [TyVarBndr ()] -> Pred -> Dec
TySynD (String -> Name
mkName String
name) [TyVarBndr ()]
tvbs Pred
bareType | String
name <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ String -> Maybe String
bareName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0]
        forall a. [a] -> [a] -> [a]
++ [ Name -> [TyVarBndr ()] -> Pred -> Dec
TySynD (String -> Name
mkName String
name) [TyVarBndr ()]
tvbs Pred
coveredType | String
name <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ String -> Maybe String
coveredName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0]
    go [(Name, Name)]
_ Dec
d = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
d]

dataDecNames :: [Dec] -> [Name]
dataDecNames :: [Dec] -> [Name]
dataDecNames = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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    [Pred]
_ Name
n [TyVarBndr ()]
_ Maybe Pred
_ [Con]
_ [DerivClause]
_ -> forall a. a -> Maybe a
Just Name
n
    Dec
_                    -> forall a. Maybe a
Nothing

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

transformCon :: [(Name, Name)] -- ^ Names of other barbies
  -> Name -- ^ switch variable
  -> Name -- ^ wrapper variable
  -> Con -- ^ original constructor
  -> Con
transformCon :: [(Name, Name)] -> Name -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
switchName Name
wrapperName (RecC Name
name [VarBangType]
xs) = Name -> [VarBangType] -> Con
RecC
  Name
name
  [ (Name -> Name
unmangle Name
v, Bang
b, Pred
t')
  | (Name
v, Bang
b, Pred
t) <- [VarBangType]
xs
  , let
    t' :: Pred
t' = case Pred
t of
      ConT Name
n | Just Name
n' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
otherBarbieNames ->
        Name -> Pred
ConT Name
n' Pred -> Pred -> Pred
`AppT` Name -> Pred
VarT Name
switchName Pred -> Pred -> Pred
`AppT` Name -> Pred
VarT Name
wrapperName
      Pred
_ -> Name -> Pred
ConT ''Wear Pred -> Pred -> Pred
`AppT` Name -> Pred
VarT Name
switchName Pred -> Pred -> Pred
`AppT` Name -> Pred
VarT Name
wrapperName Pred -> Pred -> Pred
`AppT` Pred
t
  ]
transformCon [(Name, Name)]
otherBarbieNames Name
var Name
w (ForallC [TyVarBndr Specificity]
tvbs [Pred]
cxt Con
con) =
  [TyVarBndr Specificity] -> [Pred] -> Con -> Con
ForallC [TyVarBndr Specificity]
tvbs [Pred]
cxt forall a b. (a -> b) -> a -> b
$ [(Name, Name)] -> Name -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
var Name
w Con
con
transformCon [(Name, Name)]
_ Name
_ Name
_ Con
con = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"transformCon: unsupported " forall a. [a] -> [a] -> [a]
++ 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 forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (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