{-# 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
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
baccessors :: b (LensB b)
class FieldNamesB b where
bfieldNames :: IsString a => b (Const a)
bnestedFieldNames :: IsString a => b (Const (NE.NonEmpty a))
declareBareB :: DecsQ -> DecsQ
declareBareB :: DecsQ -> DecsQ
declareBareB = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
classic
passthroughBareB :: DecsQ -> DecsQ
passthroughBareB :: DecsQ -> DecsQ
passthroughBareB = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
passthrough
declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ
declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ
declareBareBWithOtherBarbies [Name]
xs = DeclareBareBConfig -> DecsQ -> DecsQ
declareBareBWith DeclareBareBConfig
classic { friends :: [Name]
friends = [Name]
xs }
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 (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
barbieName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
k) | Name
k <- [Dec] -> [Name]
dataDecNames [Dec]
decs ]
[(Name, Name)] -> [(Name, Name)] -> [(Name, Name)]
forall a. [a] -> [a] -> [a]
++ (Name -> (Name, Name)) -> [Name] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> (Name
x, Name
x)) [Name]
friends
[[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, Name)] -> Dec -> DecsQ
go [(Name, Name)]
otherBarbieNames) [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, Name)] -> Dec -> DecsQ
go [(Name, Name)]
otherBarbieNames (DataD Cxt
_ Name
dataName0 [TyVarBndr]
tvbs Maybe Kind
_ [con :: Con
con@(RecC Name
nDataCon [VarBangType]
mangledfields)] [DerivClause]
classes) = do
let dataName :: Name
dataName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
barbieName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0
let fields :: [VarBangType]
fields = [(Name -> Name
unmangle Name
name, Bang
c, Kind
t) | (Name
name, Bang
c, Kind
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
let otherBarbieMask :: [Maybe Name]
otherBarbieMask = [ case Kind
t of
ConT Name
n | Just Name
v <- Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Name)]
otherBarbieNames -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
v
Kind
_ -> Maybe Name
forall a. Maybe a
Nothing
| (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 = (Maybe Name -> b -> c) -> [Maybe Name] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((b -> c) -> (Name -> b -> c) -> Maybe Name -> b -> c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b -> c
normal ((b -> c) -> Name -> b -> c
forall a b. a -> b -> a
const b -> c
otherBarbie)) [Maybe Name]
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 -> Name -> Con -> Con
transformCon [(Name, 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)
strLit :: String -> ExpQ
strLit String
str = [|fromString $(litE $ StringL str)|]
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
_) -> Name -> ExpQ
conE 'Const ExpQ -> ExpQ -> ExpQ
`appE` String -> ExpQ
strLit (Name -> String
nameBase Name
name))
(\VarBangType
_ -> [|bfieldNames|])
[VarBangType]
fields
nestedFieldNamesE :: ExpQ
nestedFieldNamesE = [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 $ pure $(strLit $ nameBase name)|])
(\(Name
name,Bang
_,Kind
_) -> [|first (NE.cons $(strLit $ nameBase name)) `bmap` bnestedFieldNames|])
[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]
#if MIN_VERSION_template_haskell(2,17,0)
varName (PlainTV n _) = n
varName (KindedTV n _ _) = n
#else
varName :: TyVarBndr -> Name
varName (PlainTV Name
n) = Name
n
varName (KindedTV Name
n Kind
_) = Name
n
#endif
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)
Kind
bareType <- [t| $(vanillaType) Bare Identity |]
Kind
coveredType <- [t| $(vanillaType) Covered |]
let typeChunks :: [[TypeQ]]
typeChunks = Int -> [TypeQ] -> [[TypeQ]]
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 -> Name -> TypeQ
varT Name
nConstr TypeQ -> TypeQ -> TypeQ
`appT` Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
| ((Name
_, Bang
_, Kind
t), Maybe Name
mask) <- [VarBangType] -> [Maybe Name] -> [(VarBangType, Maybe Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarBangType]
fields [Maybe Name]
otherBarbieMask
]
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 = Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
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 $
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) = $(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))
|]
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
[[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 ]
[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) $(pure bareType)|])
[ (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
#if MIN_VERSION_template_haskell(2,17,0)
(tvbs ++ [PlainTV nSwitch (), PlainTV nWrap ()])
#else
([TyVarBndr]
tvbs [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr
PlainTV Name
nSwitch, Name -> TyVarBndr
PlainTV Name
nWrap])
#endif
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
[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [ Name -> [TyVarBndr] -> Kind -> Dec
TySynD (String -> Name
mkName String
name) [TyVarBndr]
tvbs Kind
bareType | String
name <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
bareName (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0]
[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [ Name -> [TyVarBndr] -> Kind -> Dec
TySynD (String -> Name
mkName String
name) [TyVarBndr]
tvbs Kind
coveredType | String
name <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
coveredName (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
dataName0]
go [(Name, 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, Name)]
-> Name
-> Name
-> Con
-> 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, Kind
t')
| (Name
v, Bang
b, Kind
t) <- [VarBangType]
xs
, let
t' :: Kind
t' = case Kind
t of
ConT Name
n | Just Name
n' <- Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, 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, 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 -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
var Name
w Con
con
transformCon [(Name, 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 :: 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