{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Data.EvalRecord.TH
( mkEvalRecord
, mkEvalRecordWith
, DeclareRecordConfig(..)
, passthrough
) where
import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Syntax (Name(..), mkOccName, occString)
import Control.Monad (void)
import Data.String
import Data.Foldable (foldl')
import Data.List (partition, nub)
import qualified Data.List.NonEmpty as NE
import qualified Data.EvalRecord as Rec
import GHC.Generics (Generic)
import Data.List.Split
import Data.Maybe
import Fcf
data DeclareRecordConfig = DeclareRecordConfig
{ DeclareRecordConfig -> [Name]
friends :: [Name]
, DeclareRecordConfig -> [Char] -> Maybe [Char]
unwrappedName :: String -> Maybe String
, DeclareRecordConfig -> [Char] -> [Char]
baseName :: String -> String
, DeclareRecordConfig -> Q Name
wrapperName :: Q Name
}
passthrough :: DeclareRecordConfig
passthrough :: DeclareRecordConfig
passthrough = DeclareRecordConfig
{ friends :: [Name]
friends = []
, unwrappedName :: [Char] -> Maybe [Char]
unwrappedName = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just
, baseName :: [Char] -> [Char]
baseName = ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"F")
, wrapperName :: Q Name
wrapperName = [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
}
classic :: DeclareRecordConfig
classic :: DeclareRecordConfig
classic = DeclareRecordConfig
{ friends :: [Name]
friends = []
, unwrappedName :: [Char] -> Maybe [Char]
unwrappedName = Maybe [Char] -> [Char] -> Maybe [Char]
forall a b. a -> b -> a
const Maybe [Char]
forall a. Maybe a
Nothing
, baseName :: [Char] -> [Char]
baseName = [Char] -> [Char]
forall a. a -> a
id
, wrapperName :: Q Name
wrapperName = [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
}
mkEvalRecord :: DecsQ -> DecsQ
mkEvalRecord :: DecsQ -> DecsQ
mkEvalRecord = DeclareRecordConfig -> DecsQ -> DecsQ
mkEvalRecordWith DeclareRecordConfig
classic
mkEvalRecordWith :: DeclareRecordConfig -> DecsQ -> DecsQ
mkEvalRecordWith :: DeclareRecordConfig -> DecsQ -> DecsQ
mkEvalRecordWith DeclareRecordConfig{[Name]
Q Name
[Char] -> [Char]
[Char] -> Maybe [Char]
friends :: DeclareRecordConfig -> [Name]
unwrappedName :: DeclareRecordConfig -> [Char] -> Maybe [Char]
baseName :: DeclareRecordConfig -> [Char] -> [Char]
wrapperName :: DeclareRecordConfig -> Q Name
friends :: [Name]
unwrappedName :: [Char] -> Maybe [Char]
baseName :: [Char] -> [Char]
wrapperName :: Q Name
..} DecsQ
decsQ = do
decs <- DecsQ
decsQ
let otherBarbieNames = [ (Name
k, [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
baseName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
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
decs' <- traverse (go otherBarbieNames) decs
return $ concat decs'
where
go :: [(Name, Name)] -> Dec -> DecsQ
go [(Name, Name)]
otherBarbieNames (DataD [Pred]
_ Name
dataName0 [TyVarBndr BndrVis]
tvbs Maybe Pred
_ [con :: Con
con@(RecC Name
nDataCon [VarBangType]
mangledfields)] [DerivClause]
classes) = do
let dataName :: Name
dataName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
baseName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
dataName0
let fields :: [VarBangType]
fields = [(Name -> Name
unmangle Name
name, Bang
c, Pred
t) | (Name
name, Bang
c, Pred
t) <- [VarBangType]
mangledfields]
nWrap <- Q Name
wrapperName
let xs = [Char] -> [VarBangType] -> [Name]
varNames [Char]
"x" [VarBangType]
fields
let ys = [Char] -> [VarBangType] -> [Name]
varNames [Char]
"y" [VarBangType]
fields
let otherBarbieMask = [ case Pred
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
Pred
_ -> Maybe Name
forall a. Maybe a
Nothing
| (Name
_, Bang
_, Pred
t) <- [VarBangType]
fields
]
let 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
nData <- newName "b"
nConstr <- newName "c"
nX <- newName "x"
let transformed = [(Name, Name)] -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
nWrap Con
con
let reconE = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
nDataCon)
strLit [Char]
str = [| fromString $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> m Exp) -> Lit -> m Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
StringL [Char]
str)|]
fieldNamesE = [Q Exp] -> Q Exp
reconE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q Exp)
-> (VarBangType -> Q Exp) -> [VarBangType] -> [Q Exp]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
(\(Name
name,Bang
_,Pred
_) -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Rec.Metadata Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Char] -> Q Exp
forall {m :: * -> *}. Quote m => [Char] -> m Exp
strLit (Name -> [Char]
nameBase Name
name))
(Q Exp -> VarBangType -> Q Exp
forall a b. a -> b -> a
const [|Rec.typeProxies|])
[VarBangType]
fields
nestedFieldNamesE = [Q Exp] -> Q Exp
reconE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q Exp)
-> (VarBangType -> Q Exp) -> [VarBangType] -> [Q Exp]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
(\(Name
name,Bang
_,Pred
_) -> [|pure $([Char] -> Q Exp
forall {m :: * -> *}. Quote m => [Char] -> m Exp
strLit ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
name)|])
(\(Name
name,Bang
_,Pred
_) -> [|(\_ -> NE.cons $([Char] -> Q Exp
forall {m :: * -> *}. Quote m => [Char] -> m Exp
strLit ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
name)) `Rec.map` Rec.nestedFieldNames|])
[VarBangType]
fields
accessorsE = [Q Exp] -> Q Exp
reconE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Q Exp) -> (Name -> Q Exp) -> [Name] -> [Q Exp]
forall b c. (b -> c) -> (b -> c) -> [b] -> [c]
mapMembers
(\Name
name -> [|Rec.LensRec
$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)
(\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nX) $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nData) -> $(Q Exp -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nData) [(Name, Exp) -> Q (Name, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Name -> Exp
VarE Name
nX)])) |]
)
(\Name
name -> [|
(\_ -> nestLens
(\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nData) -> (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nX) -> $(Q Exp -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nData) [(Name, Exp) -> Q (Name, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Name -> Exp
VarE Name
nX)])
, $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nData)
)
)
)
`Rec.map`
getAccessors
|]
)
[Name
name | (Name
name,Bang
_,Pred
_) <- [VarBangType]
fields]
#if MIN_VERSION_template_haskell(2,17,0)
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
vanillaType = (Q Pred -> Q Pred -> Q Pred) -> Q Pred -> [Q Pred] -> Q Pred
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
dataName) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
varT (Name -> Q Pred)
-> (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Q Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr BndrVis -> Name
forall {flag}. TyVarBndr flag -> Name
varName (TyVarBndr BndrVis -> Q Pred) -> [TyVarBndr BndrVis] -> [Q Pred]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr BndrVis]
tvbs)
bareType <- [t| $(vanillaType) Pure |]
coveredType <- [t| $(vanillaType) |]
let typeChunks = Int -> [Q Pred] -> [[Q Pred]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
62
[ case Maybe Name
mask of
Just Name
t' -> [t| Rec.AllRec $(Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
varT Name
nConstr) ($(Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
t'))|]
Maybe Name
Nothing -> Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
varT Name
nConstr Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
`appT` Pred -> Q Pred
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
t
| ((Name
_, Bang
_, Pred
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 (m Pred)
ps = (m Pred -> m Pred -> m Pred) -> m Pred -> t (m Pred) -> m Pred
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Pred -> m Pred -> m Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Int -> m Pred
forall (m :: * -> *). Quote m => Int -> m Pred
tupleT (Int -> m Pred) -> Int -> m Pred
forall a b. (a -> b) -> a -> b
$ t (m Pred) -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t (m Pred)
ps) t (m Pred)
ps
allConstr = case [[Q Pred]]
typeChunks of
[[Q Pred]
ps] -> [Q Pred] -> Q Pred
forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints [Q Pred]
ps
[[Q Pred]]
pss -> [Q Pred] -> Q Pred
forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints ([Q Pred] -> Q Pred) -> [Q Pred] -> Q Pred
forall a b. (a -> b) -> a -> b
$ ([Q Pred] -> Q Pred) -> [[Q Pred]] -> [Q Pred]
forall a b. (a -> b) -> [a] -> [b]
map [Q Pred] -> Q Pred
forall {t :: * -> *} {m :: * -> *}.
(Foldable t, Quote m) =>
t (m Pred) -> m Pred
mkConstraints [[Q Pred]]
pss
decs <- [d|
instance Rec.WitnessFieldTypes $(pure coveredType) where
typeProxies = $(fieldNamesE)
getAccessors = $(accessorsE)
nestedFieldNames = $(nestedFieldNamesE)
instance Rec.FunctorRec $(pure coveredType) where
map f $(conP nDataCon $ map varP xs)
= $(reconE $ mapMembers
(\tup :: VarBangType
tup@(Name
n, Bang
_, Pred
_) -> [|f ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) Rec.typeProxies) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup)|] )
(\VarBangType
tup -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Rec.map f|] (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup))
fields
)
instance Rec.DistributiveRec $(pure coveredType) where
distribute fb = $(reconE $
mapMembers
(\Q Exp
fd -> [| ($Q Exp
fd <$> fb) |])
(\Q Exp
fd -> [| distribute ($Q Exp
fd <$> fb) |])
[varE fd | (fd, _, _) <- fields]
)
instance Rec.TraversableRec $(pure coveredType) where
traverse f $(conP nDataCon $ map varP xs) = $(fst $ foldl'
(\(Q Exp
l, Name
op) Q Exp
r -> (Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
l) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
op) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
r), '(<*>)))
(conE nDataCon, '(<$>))
(mapMembers
(\tup :: VarBangType
tup@(Name
n, Bang
_, Pred
_) -> [|f ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) Rec.typeProxies) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup)|])
(\VarBangType
tup -> [|Rec.traverse f $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup)|])
fields
)
)
{-# INLINE Rec.traverse #-}
traverse_ f $(conP nDataCon $ map varP xs) = $(
case
mapMembers
(\tup :: VarBangType
tup@(Name
n, Bang
_, Pred
_) -> [|f ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) Rec.typeProxies) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup)|])
(\VarBangType
tup -> [|Rec.traverse_ f $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> VarBangType -> Name
mkVarName [Char]
"x" VarBangType
tup)|])
fields
of
[] -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE '()
[Q Exp]
exprs -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'void Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
(\Q Exp
l Q Exp
r -> Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
l) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(*>)) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
r))
[Q Exp]
exprs
)
{-# INLINE Rec.traverse_ #-}
instance Rec.ConstraintsRec $(pure coveredType) where
type AllRec $(varT nConstr) $(pure coveredType) = $allConstr
addDicts $(conP nDataCon $ map varP xs)
= $(reconE $ mapMembers
(\Q Exp
x -> [|(Rec.Dict, $Q Exp
x)|])
(\Q Exp
x -> [|addDicts $Q Exp
x|])
(varE <$> xs)
)
instance Rec.ApplicativeRec $(pure coveredType) where
pure $(varP nX) = $(reconE $ mapMembers
(\(Name
n, Bang
_, Pred
_) -> [|($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nX) ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) Rec.typeProxies))|])
(const [|Rec.pure $(varE nX)|])
fields
)
prod $(conP nDataCon $ map varP xs) $(conP nDataCon $ map varP ys) = $(foldl'
(\Q Exp
r (Maybe Name
isOtherBarbie, Name
x, Name
y) ->
if Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
isOtherBarbie
then [|$Q Exp
r (Rec.prod $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y))|]
else [|$Q Exp
r ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x), $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y))|])
(conE nDataCon) (zip3 otherBarbieMask xs ys))
|]
let classes' = (DerivClause -> ([Pred], DerivClause))
-> [DerivClause] -> [([Pred], DerivClause)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DerivClause Maybe DerivStrategy
strat [Pred]
cs) -> Maybe DerivStrategy -> [Pred] -> DerivClause
DerivClause Maybe DerivStrategy
strat ([Pred] -> DerivClause)
-> ([Pred], [Pred]) -> ([Pred], DerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pred -> Bool) -> [Pred] -> ([Pred], [Pred])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Pred -> Pred -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Pred
ConT ''Generic) [Pred]
cs) [DerivClause]
classes
specifyStockStrategy <- isExtEnabled DerivingStrategies
bareDrvs <- traverse (\(Maybe DerivStrategy
strat, Q Pred
cls) -> do
param <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
standaloneDerivWithStrategyD
strat
(sequence
[ conT ''Rec.AllRecF `appT` cls `appT` varT param `appT` pure coveredType
])
[t|$cls ($(pure coveredType) $(varT param)) |])
[ (strat, pure t) | (_, DerivClause strat preds) <- classes', t <- preds ]
return $ DataD [] dataName
#if MIN_VERSION_template_haskell(2,21,0)
(tvbs ++ [PlainTV nWrap BndrReq])
#elif MIN_VERSION_template_haskell(2,17,0)
(tvbs ++ [PlainTV nWrap ()])
#else
(tvbs ++ [PlainTV nWrap])
#endif
Nothing
[transformed]
[DerivClause (if specifyStockStrategy then Just StockStrategy else Nothing) $ concatMap fst classes']
: decs ++ bareDrvs
++ [ TySynD (mkName name) tvbs bareType | name <- maybeToList $ unwrappedName $ nameBase dataName0]
go [(Name, Name)]
_ Dec
d = [Dec] -> DecsQ
forall a. a -> Q a
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 [Pred]
_ Name
n [TyVarBndr BndrVis]
_ Maybe Pred
_ [Con]
_ [DerivClause]
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
Dec
_ -> Maybe Name
forall a. Maybe a
Nothing
mkVarName :: String -> VarBangType -> Name
mkVarName :: [Char] -> VarBangType -> Name
mkVarName [Char]
p (Name
v, Bang
_, Pred
_) = [Char] -> Name
mkName ([Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
v)
varNames :: String -> [VarBangType] -> [Name]
varNames :: [Char] -> [VarBangType] -> [Name]
varNames [Char]
p [VarBangType]
vbt = [[Char] -> VarBangType -> Name
mkVarName [Char]
p VarBangType
tup | VarBangType
tup <- [VarBangType]
vbt]
transformCon :: [(Name, Name)]
-> Name
-> Con
-> Con
transformCon :: [(Name, Name)] -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames 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' <- Name -> [(Name, Name)] -> Maybe Name
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
wrapperName
Pred
_ -> Pred -> Name -> Pred -> Pred
InfixT (Name -> Pred
VarT Name
wrapperName) ''(@@) Pred
t
]
transformCon [(Name, Name)]
otherBarbieNames Name
w (ForallC [TyVarBndr Specificity]
tvbs [Pred]
cxt Con
con) =
[TyVarBndr Specificity] -> [Pred] -> Con -> Con
ForallC [TyVarBndr Specificity]
tvbs [Pred]
cxt (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ [(Name, Name)] -> Name -> Con -> Con
transformCon [(Name, Name)]
otherBarbieNames Name
w Con
con
transformCon [(Name, Name)]
_ Name
_ Con
con = [Char] -> Con
forall a. HasCallStack => [Char] -> a
error ([Char] -> Con) -> [Char] -> Con
forall a b. (a -> b) -> a -> b
$ [Char]
"transformCon: unsupported " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Con -> [Char]
forall a. Show a => a -> [Char]
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) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (OccName -> [Char]
occString OccName
occ) of
[[Char]
"$sel", [Char]
fd, [Char]
_qual] -> [Char] -> OccName
mkOccName [Char]
fd
[[Char]]
_ -> OccName
occ