{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use <=<" #-}

-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause

{-  The code before modification is licensed under the BSD3 License as
    shown in [1].  The modified code, in its entirety, is licensed under
    MPL 2.0. When redistributing, please ensure that you do not remove
    the BSD3 License text as indicated in [1].
    <https://github.com/pa-ba/compdata/blob/master/src/Data/Comp/Multi/Derive/HFunctor.hs>

    [1] Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved

        All rights reserved.

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

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

        2. 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.

        3. Neither the name of the author nor the names of his contributors
        may be used to endorse or promote products derived from this software
        without specific prior written permission.

        THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
-}

{- |
Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
               (c) 2023 Sayo contributors
License     :  MPL-2.0 (see the LICENSE file) AND BSD-3-Clause
Maintainer  :  ymdfield@outlook.jp
-}
module Data.Effect.HFunctor.TH.Internal where

import Control.Monad (replicateM, zipWithM)
import Data.Effect.HFunctor (HFunctor, hfmap)
import Data.Effect.TH.Internal (
    ConInfo (ConInfo),
    DataInfo (DataInfo),
    conArgs,
    conGadtReturnType,
    conName,
    occurs,
    tyVarName,
    tyVarType,
    unkindType,
 )
import Data.Foldable (foldl')
import Data.Functor ((<&>))
import Data.List.Infinite (Infinite, prependList)
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Formatting (int, sformat, shown, stext, (%))
import Language.Haskell.TH (
    Body (NormalB),
    Clause (Clause),
    Dec (FunD, InstanceD, PragmaD),
    Exp (AppE, CaseE, ConE, LamE, TupE, VarE),
    Inline (Inline),
    Match (Match),
    Name,
    Pat (ConP, TupP, VarP),
    Phases (AllPhases),
    Pragma (InlineP),
    Q,
    Quote (..),
    RuleMatch (FunLike),
    TyVarBndr (PlainTV),
    Type (AppT, ArrowT, ConT, ForallT, SigT, TupleT, VarT),
    appE,
    nameBase,
    pprint,
 )
import Language.Haskell.TH qualified as TH

{- |
Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order
kind taking at least two arguments.
-}
deriveHFunctor :: (Infinite (Q TH.Type) -> Q TH.Type) -> DataInfo -> Q [Dec]
deriveHFunctor :: (Infinite (Q Type) -> Q Type) -> DataInfo -> Q [Dec]
deriveHFunctor Infinite (Q Type) -> Q Type
manualCxt (DataInfo Cxt
_ Name
name [TyVarBndr ()]
args [ConInfo]
cons) = do
    Name
mapFnName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"_f"
    let mapFn :: Exp
mapFn = Name -> Exp
VarE Name
mapFnName

        initArgs :: [TyVarBndr ()]
initArgs = [TyVarBndr ()] -> [TyVarBndr ()]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr ()]
args
        hfArgs :: [TyVarBndr ()]
hfArgs = [TyVarBndr ()] -> [TyVarBndr ()]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr ()]
initArgs

        hfArgNames :: Cxt
hfArgNames = (TyVarBndr () -> Type) -> [TyVarBndr ()] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr () -> Name) -> TyVarBndr () -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName) [TyVarBndr ()]
hfArgs

        -- The algorithm is based on: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/derive-functor
        hfmapClause :: ConInfo -> Q Clause
        hfmapClause :: ConInfo -> Q Clause
hfmapClause ConInfo{[BangType]
Maybe Type
Name
conArgs :: ConInfo -> [BangType]
conGadtReturnType :: ConInfo -> Maybe Type
conName :: ConInfo -> Name
conName :: Name
conArgs :: [BangType]
conGadtReturnType :: Maybe Type
..} = do
            let f :: TyVarBndr ()
f = case Maybe Type
conGadtReturnType of
                    Maybe Type
Nothing -> [TyVarBndr ()] -> TyVarBndr ()
forall a. HasCallStack => [a] -> a
last [TyVarBndr ()]
initArgs
                    Just Type
t -> case Type
t of
                        Type
_ `AppT` VarT Name
n `AppT` Type
_ -> Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()
                        Type
_ `AppT` (VarT Name
n `SigT` Type
_) `AppT` Type
_ -> Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()
                        Type
_ -> [Char] -> TyVarBndr ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> TyVarBndr ()) -> [Char] -> TyVarBndr ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Encounted unknown structure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t

                hfmapE :: TH.Type -> Exp -> Q Exp
                hfmapE :: Type -> Exp -> Q Exp
hfmapE Type
tk
                    | Type -> Bool
fNotOccurs Type
t = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    | Bool
otherwise = \Exp
x -> case Type
t of
                        VarT Name
n `AppT` Type
a | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
f Bool -> Bool -> Bool
&& Type -> Bool
fNotOccurs Type
a -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
mapFn Exp -> Exp -> Exp
`AppE` Exp
x
                        Type
ArrowT `AppT` Type
c `AppT` Type
d ->
                            (Exp -> Q Exp) -> Q Exp
wrapLam \Exp
y -> Type -> Exp -> Q Exp
hfmapE Type
d (Exp -> Q Exp) -> (Exp -> Exp) -> Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp
x `AppE`) (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Exp -> Q Exp
cohfmapE Type
c Exp
y
                        Type
g `AppT` Type
a
                            | Type -> Bool
fNotOccurs Type
g ->
                                ((Name -> Exp
VarE 'fmap `AppE`) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Q Exp) -> Q Exp
wrapLam (Type -> Exp -> Q Exp
hfmapE Type
a)) Q Exp -> (Exp -> Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Exp -> Exp -> Exp
`AppE` Exp
x)
                        Type
ff `AppT` Type
g `AppT` Type
a
                            | Type -> Bool
fNotOccurs Type
ff Bool -> Bool -> Bool
&& Type -> Bool
fNotOccurs Type
a ->
                                ((Name -> Exp
VarE 'hfmap `AppE`) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Q Exp) -> Q Exp
wrapLam (Type -> Exp -> Q Exp
hfmapE (Type -> Exp -> Q Exp) -> Type -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type
g Type -> Type -> Type
`AppT` Type
a)) Q Exp -> (Exp -> Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Exp -> Exp -> Exp
`AppE` Exp
x)
                        -- todo: tuple support
                        ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
a -> Type -> Exp -> Q Exp
hfmapE Type
a Exp
x
                        Type
_ ->
                            case (Type -> Exp -> Q Exp) -> Type -> Exp -> Maybe (Q Exp)
mapTupleE Type -> Exp -> Q Exp
hfmapE Type
t Exp
x of
                                Just Q Exp
e -> Q Exp
e
                                Maybe (Q Exp)
Nothing -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Encounted unsupported structure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t
                  where
                    t :: Type
t = Type -> Type
unkindType Type
tk

                cohfmapE :: TH.Type -> Exp -> Q Exp
                cohfmapE :: Type -> Exp -> Q Exp
cohfmapE Type
tk
                    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
f Name -> Type -> Bool
`occurs` Type
t = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    | Bool
otherwise = \Exp
x -> case Type
t of
                        VarT Name
n `AppT` Type
a
                            | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
f Bool -> Bool -> Bool
&& Type -> Bool
fNotOccurs Type
a ->
                                [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Functor type variable occurs in contravariant position: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t
                        Type
ArrowT `AppT` Type
c `AppT` Type
d ->
                            (Exp -> Q Exp) -> Q Exp
wrapLam \Exp
y -> Type -> Exp -> Q Exp
cohfmapE Type
d (Exp -> Q Exp) -> (Exp -> Exp) -> Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp
x `AppE`) (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Exp -> Q Exp
hfmapE Type
c Exp
y
                        Type
g `AppT` Type
a
                            | Type -> Bool
fNotOccurs Type
g ->
                                ((Name -> Exp
VarE 'fmap `AppE`) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Q Exp) -> Q Exp
wrapLam (Type -> Exp -> Q Exp
cohfmapE Type
a)) Q Exp -> (Exp -> Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Exp -> Exp -> Exp
`AppE` Exp
x)
                        Type
ff `AppT` Type
_ `AppT` Type
a
                            | Type -> Bool
fNotOccurs Type
ff Bool -> Bool -> Bool
&& Type -> Bool
fNotOccurs Type
a ->
                                [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Functor type variable occurs in contravariant position: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t
                        ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
b' -> Type -> Exp -> Q Exp
cohfmapE Type
b' Exp
x
                        Type
_ ->
                            case (Type -> Exp -> Q Exp) -> Type -> Exp -> Maybe (Q Exp)
mapTupleE Type -> Exp -> Q Exp
cohfmapE Type
t Exp
x of
                                Just Q Exp
e -> Q Exp
e
                                Maybe (Q Exp)
Nothing -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Encounted unsupported structure: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t
                  where
                    t :: Type
t = Type -> Type
unkindType Type
tk

                fNotOccurs :: Type -> Bool
fNotOccurs = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
f `occurs`)

            [Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
conArgs) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
            [Exp]
mappedArgs <- (Type -> Exp -> Q Exp) -> Cxt -> [Exp] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Exp -> Q Exp
hfmapE ((BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
conArgs) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
vars)
            let body :: Exp
body = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) [Exp]
mappedArgs
            Clause -> Q Clause
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
mapFnName, Name -> Cxt -> [Pat] -> Pat
ConP Name
conName [] ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)] (Exp -> Body
NormalB Exp
body) []

    Type
cxt <-
        Infinite (Q Type) -> Q Type
manualCxt (Infinite (Q Type) -> Q Type) -> Infinite (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$
            (TyVarBndr () -> Q Type) -> [TyVarBndr ()] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type)
-> (TyVarBndr () -> Type) -> TyVarBndr () -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Type
forall a. TyVarBndr a -> Type
tyVarType) [TyVarBndr ()]
hfArgs
                [Q Type] -> Infinite (Q Type) -> Infinite (Q Type)
forall a. [a] -> Infinite a -> Infinite a
`prependList` [Char] -> Infinite (Q Type)
forall a. HasCallStack => [Char] -> a
error
                    ( Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$
                        Format Text (Name -> Int -> Text -> Text)
-> Name -> Int -> Text -> Text
forall a. Format Text a -> a
sformat
                            ( Format (Name -> Int -> Text -> Text) (Name -> Int -> Text -> Text)
"Too many data type arguments in use. The number of usable type arguments in the data type ‘"
                                Format (Name -> Int -> Text -> Text) (Name -> Int -> Text -> Text)
-> Format Text (Name -> Int -> Text -> Text)
-> Format Text (Name -> Int -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Text -> Text) (Name -> Int -> Text -> Text)
forall a r. Show a => Format r (a -> r)
shown
                                Format (Int -> Text -> Text) (Name -> Int -> Text -> Text)
-> Format Text (Int -> Text -> Text)
-> Format Text (Name -> Int -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Text -> Text) (Int -> Text -> Text)
"’ to be derived is "
                                Format (Int -> Text -> Text) (Int -> Text -> Text)
-> Format Text (Int -> Text -> Text)
-> Format Text (Int -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Text -> Text) (Int -> Text -> Text)
forall a r. Integral a => Format r (a -> r)
int
                                Format (Text -> Text) (Int -> Text -> Text)
-> Format Text (Text -> Text) -> Format Text (Int -> Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Text -> Text) (Text -> Text)
". ("
                                Format (Text -> Text) (Text -> Text)
-> Format Text (Text -> Text) -> Format Text (Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text (Text -> Text)
forall r. Format r (Text -> r)
stext
                                Format Text (Text -> Text)
-> Format Text Text -> Format Text (Text -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
")"
                            )
                            Name
name
                            ([TyVarBndr ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
hfArgs)
                            (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TyVarBndr () -> Text) -> [TyVarBndr ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((\Text
t -> Text
"‘" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"’") (Text -> Text) -> (TyVarBndr () -> Text) -> TyVarBndr () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text)
-> (TyVarBndr () -> [Char]) -> TyVarBndr () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase (Name -> [Char])
-> (TyVarBndr () -> Name) -> TyVarBndr () -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr () -> Name
forall a. TyVarBndr a -> Name
tyVarName) [TyVarBndr ()]
hfArgs)
                    )

    Dec
hfmapDecls <- Name -> [Clause] -> Dec
FunD 'hfmap ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConInfo -> Q Clause) -> [ConInfo] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ConInfo -> Q Clause
hfmapClause [ConInfo]
cons
    let fnInline :: Dec
fnInline = Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hfmap Inline
Inline RuleMatch
FunLike Phases
AllPhases)

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
            Maybe Overlap
forall a. Maybe a
Nothing
            (Cxt -> Maybe Cxt -> Cxt
forall a. a -> Maybe a -> a
fromMaybe [Type
cxt] (Maybe Cxt -> Cxt) -> Maybe Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Cxt
decomposeTupleT Type
cxt)
            (Name -> Type
ConT ''HFunctor Type -> Type -> Type
`AppT` (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
hfArgNames)
            [Dec
hfmapDecls, Dec
fnInline]
        ]

wrapLam :: (Exp -> Q Exp) -> Q Exp
wrapLam :: (Exp -> Q Exp) -> Q Exp
wrapLam Exp -> Q Exp
f = do
    Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
    [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Q Exp
f (Name -> Exp
VarE Name
x)

mapTupleE :: (TH.Type -> Exp -> Q Exp) -> TH.Type -> Exp -> Maybe (Q Exp)
mapTupleE :: (Type -> Exp -> Q Exp) -> Type -> Exp -> Maybe (Q Exp)
mapTupleE Type -> Exp -> Q Exp
f Type
t Exp
e = do
    Cxt
es <- Type -> Maybe Cxt
decomposeTupleT Type
t
    let n :: Int
n = Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
es
    Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just do
        [Name]
xs <- Int -> [Char] -> Q [Name]
newNames Int
n [Char]
"x"
        [Exp]
ys <- (Type -> Exp -> Q Exp) -> Cxt -> [Exp] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Exp -> Q Exp
f Cxt
es ([Exp] -> Q [Exp]) -> [Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
xs
        Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
e [Pat -> Body -> [Dec] -> Match
Match ([Pat] -> Pat
TupP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just [Exp]
ys) []]

decomposeTupleT :: TH.Type -> Maybe [TH.Type]
decomposeTupleT :: Type -> Maybe Cxt
decomposeTupleT = Cxt -> Int -> Type -> Maybe Cxt
go [] Int
0
  where
    go :: [TH.Type] -> Int -> TH.Type -> Maybe [TH.Type]
    go :: Cxt -> Int -> Type -> Maybe Cxt
go Cxt
acc !Int
n = \case
        TupleT Int
m | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just Cxt
acc
        Type
f `AppT` Type
a -> Cxt -> Int -> Type -> Maybe Cxt
go (Type
a Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
acc) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Type
f
        Type
_ -> Maybe Cxt
forall a. Maybe a
Nothing
{-# INLINE decomposeTupleT #-}

-- * Utility functions

{- |
This function provides a list (of the given length) of new names based
on the given string.
-}
newNames :: Int -> String -> Q [Name]
newNames :: Int -> [Char] -> Q [Name]
newNames Int
n [Char]
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
name)

iter :: (Eq t, Num t, Quote m) => t -> m Exp -> m Exp -> m Exp
iter :: forall t (m :: * -> *).
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter t
0 m Exp
_ m Exp
e = m Exp
e
iter t
n m Exp
f m Exp
e = t -> m Exp -> m Exp -> m Exp
forall t (m :: * -> *).
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) m Exp
f (m Exp
f m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
e)