{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Data.EvalRecord.TH
  ( mkEvalRecord
  , mkEvalRecordWith
  , DeclareRecordConfig(..)
  , passthrough
  ) where
-- This file is a modified version of Barbies.TH from the barbies-th package.
-- The original license is reproduced below.
--
-- Copyright Fumiaki Kinoshita (c) 2019

-- All rights reserved.

-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:

--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.

--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.

--     * Neither the name of Fumiaki Kinoshita nor the names of other
--       contributors may be used to endorse or promote products derived
--       from this software without specific prior written permission.

-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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] -- ^ Members with these types won't be wrapped with 'f @@'
  , DeclareRecordConfig -> [Char] -> Maybe [Char]
unwrappedName :: String -> Maybe String
  -- ^ generate a type synonym for the 'Pure' version of the type?
  , DeclareRecordConfig -> [Char] -> [Char]
baseName :: String -> String
  -- ^ modify the name of the datatype
  , DeclareRecordConfig -> Q Name
wrapperName :: Q Name
  -- ^ the name of the type parameter of the wrapper for each field
  }

-- | Defines a synonym for the bare type with the same name.
-- The basic definition is suffixed by F, and the unwrapped basic type has no suffix.
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"
  }

-- | Doesn't define a synonym for the bare type.
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"
  }

-- | 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.
mkEvalRecord :: DecsQ -> DecsQ
mkEvalRecord :: DecsQ -> DecsQ
mkEvalRecord = DeclareRecordConfig -> DecsQ -> DecsQ
mkEvalRecordWith DeclareRecordConfig
classic

-- | Generate a higher-kinded data declaration using a custom config.
--
-- Note that sum types are not currently supported.
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
      -- 'mapMembers' applies one of two functions to elements of a list
      -- according to whether or not they align with another barbie
      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)
          -- field names for FieldNamesB
          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]

          -- 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 (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 -> 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)

      -- bare/covered types
      bareType <- [t| $(vanillaType) Pure |]
      coveredType <- [t| $(vanillaType) |]

      -- max arity = 62
      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
          -- fieldNamesAndTypesAsTupleList = foldr
          --   (\(n, _, t) fs -> PromotedConsT `AppT` (PromotedTupleT 2 `AppT` LitT (StrTyLit $ nameBase n) `AppT` t) `AppT` fs)
          --   PromotedNilT
          --   fields
          --   --strTyLit

      -- let datC = pure coveredType
      decs <- [d|
        instance Rec.WitnessFieldTypes $(pure coveredType) where
          -- type FieldMetadata $(pure coveredType) = $(pure fieldNamesAndTypesAsTupleList)
          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 $
              -- TODO: NoFieldSelectors
              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))
        |]
      -- strip deriving Generic
      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
      -- Redefine instances of the bare type with the original strategy
      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)] -- ^ Names of other barbies
  -> Name -- ^ wrapper variable
  -> Con -- ^ original constructor
  -> 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 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) -> [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