{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Derive.SmartConstructors
-- Copyright   :  Original (c) 2011 Patrick Bahr; current version (c) 2024 James Koppel
-- License     :  BSD3
-- Maintainer  :  James Koppel <jkoppel@mit.edu>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive smart constructors for mutually recursive types.
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.Derive.SmartConstructors
    (
      smartConstructors
    , patternSynonyms
    ) where

import Control.Arrow ((&&&))
import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.Sum
import Data.Comp.Multi.Term
import Language.Haskell.TH hiding (Cxt)

-----------------------------------------------------------------------------------

getSortsFromConstructorType :: Name -> Con -> Maybe ([Type], Type)
getSortsFromConstructorType :: Name -> Con -> Maybe ([Type], Type)
getSortsFromConstructorType Name
iVar (ForallC [TyVarBndr Specificity]
_ [Type]
cxt Con
t) =
-- Check if the GADT phantom type is constrained
  case [Type
y | AppT (AppT (ConT Name
eqN) Type
x) Type
y <- [Type]
cxt, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
iVar, Name
eqN Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(~)] of
    [] -> Name -> Con -> Maybe ([Type], Type)
getSortsFromConstructorType Name
iVar Con
t
    Type
tp:[Type]
_ -> let args :: [Type]
args = case Con
t of
                        NormalC Name
_ [BangType]
vs -> (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
vs
                        RecC Name
_ [VarBangType]
vs -> (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
v) -> Type
v) [VarBangType]
vs
                        Con
_ -> []
            in ([Type], Type) -> Maybe ([Type], Type)
forall a. a -> Maybe a
Just ([Type]
args, Type
tp)
getSortsFromConstructorType Name
_iVar (GadtC [Name]
_ [BangType]
vs (AppT Type
_ Type
tp)) =
  case Type
tp of
    VarT Name
_ -> Maybe ([Type], Type)
forall a. Maybe a
Nothing
    Type
_      -> ([Type], Type) -> Maybe ([Type], Type)
forall a. a -> Maybe a
Just ((BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
vs, Type
tp)
getSortsFromConstructorType Name
_iVar (RecGadtC [Name]
_ [VarBangType]
vs (AppT Type
_ Type
tp)) =
  case Type
tp of
    VarT Name
_ -> Maybe ([Type], Type)
forall a. Maybe a
Nothing
    Type
_      -> ([Type], Type) -> Maybe ([Type], Type)
forall a. a -> Maybe a
Just ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
v) -> Type
v) [VarBangType]
vs, Type
tp)
getSortsFromConstructorType Name
_ Con
_ = Maybe ([Type], Type)
forall a. Maybe a
Nothing

{-| Derive smart constructors for a type constructor of any higher-order kind
 taking at least two arguments. The smart constructors are similar to the
 ordinary constructors, but an 'inject' is automatically inserted. -}
smartConstructors :: Name -> Q [Dec]
smartConstructors :: Name -> Q [Dec]
smartConstructors Name
fname = do
    Just (DataInfo [Type]
_cxt Name
tname [TyVarBndr BndrVis]
targs [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
    let iVar :: Name
iVar = TyVarBndr BndrVis -> Name
tyVarBndrName (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> TyVarBndr BndrVis
forall a. HasCallStack => [a] -> a
last [TyVarBndr BndrVis]
targs
    let cons :: [((Name, Int), Maybe Type)]
cons = (Con -> ((Name, Int), Maybe Type))
-> [Con] -> [((Name, Int), Maybe Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Int)
abstractConType (Con -> (Name, Int))
-> (Con -> Maybe Type) -> Con -> ((Name, Int), Maybe Type)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((([Type], Type) -> Type) -> Maybe ([Type], Type) -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Type], Type) -> Type
forall a b. (a, b) -> b
snd (Maybe ([Type], Type) -> Maybe Type)
-> (Con -> Maybe ([Type], Type)) -> Con -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Con -> Maybe ([Type], Type)
getSortsFromConstructorType Name
iVar)) [Con]
constrs
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe Type) -> Q [Dec])
-> [((Name, Int), Maybe Type)] -> Q [[Dec]]
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 ([Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr ((TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Name
tyVarBndrName [TyVarBndr BndrVis]
targs) Name
tname) [((Name, Int), Maybe Type)]
cons
        where 
              genSmartConstr :: [Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr [Name]
targs Name
tname ((Name
name, Int
args), Maybe Type
mgetSortsFromConstructorType) = do
                let bname :: String
bname = Name -> String
nameBase Name
name
                [Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'j' Char -> String -> String
forall a. a -> [a] -> [a]
: String
bname) Name
name Int
args Maybe Type
mgetSortsFromConstructorType
              genSmartConstr' :: [Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname Name
sname Name
name Int
args Maybe Type
mgetSortsFromConstructorType = do
                [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args String
"x"
                let pats :: [Q Pat]
pats = (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
varNs
                    vars :: [Q Exp]
vars = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
                    val :: Q Exp
val = (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
name) [Q Exp]
vars
                    sig :: [Q Dec]
sig = [Name] -> Name -> Name -> Int -> Maybe Type -> [Q Dec]
forall {a} {m :: * -> *}.
(Eq a, Num a, Quote m) =>
[Name] -> Name -> Name -> a -> Maybe Type -> [m Dec]
genSig [Name]
targs Name
tname Name
sname Int
args Maybe Type
mgetSortsFromConstructorType
                    function :: [Q Dec]
function = [Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
sname [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|inject $Q Exp
val|]) []]]
                [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q Dec]
sig [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
function
              genSig :: [Name] -> Name -> Name -> a -> Maybe Type -> [m Dec]
genSig [Name]
targs Name
tname Name
sname a
0 Maybe Type
mgetSortsFromConstructorType = (m Dec -> [m Dec] -> [m Dec]
forall a. a -> [a] -> [a]
:[]) (m Dec -> [m Dec]) -> m Dec -> [m Dec]
forall a b. (a -> b) -> a -> b
$ do
                Name
fvar <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
                Name
hvar <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"h"
                Name
avar <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                Name
ivar <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"i"
                let targs' :: [Name]
targs' = [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
init ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
init [Name]
targs
                    vars :: [Name]
vars = Name
hvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
fvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
avarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name] -> (Type -> [Name]) -> Maybe Type -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Name
ivar] ([Name] -> Type -> [Name]
forall a b. a -> b -> a
const []) Maybe Type
mgetSortsFromConstructorType[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Name]
targs'
                    f :: m Type
f = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
fvar
                    h :: m Type
h = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
hvar
                    a :: m Type
a = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
avar
                    i :: m Type
i = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
ivar
                    ftype :: m Type
ftype = (m Type -> m Type -> m Type) -> m Type -> [m Type] -> m Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tname) ((Name -> m Type) -> [Name] -> [m Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
targs')
                    constr :: m Type
constr = Name -> [m Type] -> m Type
forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
classP ''(:<:) [m Type
ftype, m Type
f]
                    typ :: m Type
typ = (m Type -> m Type -> m Type) -> m Type -> [m Type] -> m Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Cxt) [m Type
h, m Type
f, m Type
a, m Type -> (Type -> m Type) -> Maybe Type -> m Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Type
i Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
mgetSortsFromConstructorType]

                    -- NOTE 2023.06.29: Unsure if SpecifiedSpec is actually what we want to get
                    --                  reasonable type application on smart constructors
                    typeSig :: m Type
typeSig = [TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
v -> Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
v Specificity
SpecifiedSpec) [Name]
vars) ([m Type] -> m [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m Type
constr]) m Type
typ
                Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
sname m Type
typeSig
              genSig [Name]
_ Name
_ Name
_ a
_ Maybe Type
_ = []

{-| 
  Example:
  data ExpL
  ...
 
  data Arith e l where
      Add :: e ExpL -> e ExpL -> Arith e ExpL

  patternSynonyms ''Arith

  ===>

  pattern Add' :: (Arith :<: f) => Cxt h f a ExpL -> Cxt h f a ExpL -> Cxt h f a ExpL
  pattern Add' a b <- (project -> Just (Add a b)) where
    Add' a b = inject $ Add a b
-}

patternSynonyms :: Name -> Q [Dec]
patternSynonyms :: Name -> Q [Dec]
patternSynonyms Name
fname = do
    Just (DataInfo [Type]
_cxt Name
tname [TyVarBndr BndrVis]
targs [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
    let iVar :: Name
iVar = TyVarBndr BndrVis -> Name
tyVarBndrName (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> TyVarBndr BndrVis
forall a. HasCallStack => [a] -> a
last [TyVarBndr BndrVis]
targs
    let cons :: [((Name, Int), Maybe ([Type], Type))]
cons = (Con -> ((Name, Int), Maybe ([Type], Type)))
-> [Con] -> [((Name, Int), Maybe ([Type], Type))]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Int)
abstractConType (Con -> (Name, Int))
-> (Con -> Maybe ([Type], Type))
-> Con
-> ((Name, Int), Maybe ([Type], Type))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Con -> Maybe ([Type], Type)
getSortsFromConstructorType Name
iVar) [Con]
constrs
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe ([Type], Type)) -> Q [Dec])
-> [((Name, Int), Maybe ([Type], Type))] -> Q [[Dec]]
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 ([Name] -> Name -> ((Name, Int), Maybe ([Type], Type)) -> Q [Dec]
genPatternSyn ((TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Name
tyVarBndrName [TyVarBndr BndrVis]
targs) Name
tname) [((Name, Int), Maybe ([Type], Type))]
cons
        where           
              genPatternSyn :: [Name] -> Name -> ((Name, Int), Maybe ([Type], Type)) -> Q [Dec]
              genPatternSyn :: [Name] -> Name -> ((Name, Int), Maybe ([Type], Type)) -> Q [Dec]
genPatternSyn [Name]
targs Name
tname ((Name
constructorName, Int
nArgs), Maybe ([Type], Type)
maybeSorts) = do
                let constructorBaseName :: String
constructorBaseName = Name -> String
nameBase Name
constructorName
                let patternSynName :: Name
patternSynName = String -> Name
mkName (String
constructorBaseName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'")
                [Name]
patSynArgNames <- Int -> String -> Q [Name]
newNames Int
nArgs String
"x"
                let patSynArgs :: PatSynArgs
patSynArgs = [Name] -> PatSynArgs
PrefixPatSyn [Name]
patSynArgNames 

                let pats :: [Q Pat]
pats = (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
patSynArgNames
                    vars :: [Q Exp]
vars = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
patSynArgNames
                    val :: Q Exp
val = (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
constructorName) [Q Exp]
vars
                Clause
forwardBody <- [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|inject $Q Exp
val|]) []

                Pat
backwardBody <- Q Exp -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP [|project|] (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Type] -> [Pat] -> Pat
ConP 'Just [] [Name -> [Type] -> [Pat] -> Pat
ConP Name
constructorName [] ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
patSynArgNames)])
                let patternSyn :: Dec
patternSyn = Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patternSynName PatSynArgs
patSynArgs ([Clause] -> PatSynDir
ExplBidir [Clause
forwardBody]) Pat
backwardBody

                Dec
sig <- [Name] -> Name -> Name -> Maybe ([Type], Type) -> Q Dec
genSig [Name]
targs Name
tname Name
patternSynName Maybe ([Type], Type)
maybeSorts
                [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
sig, Dec
patternSyn]

              genSig :: [Name] -> Name -> Name -> Maybe ([Type], Type) -> Q Dec
              genSig :: [Name] -> Name -> Name -> Maybe ([Type], Type) -> Q Dec
genSig [Name]
targs Name
tname Name
sname Maybe ([Type], Type)
maybeSorts = do
                Name
fvar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
                Name
hvar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"h"
                Name
avar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                Name
jvar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"j"
                let targs' :: [Name]
targs' = [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
init ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
init [Name]
targs
                    vars :: [Name]
vars = Name
hvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
fvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
avarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name
jvar][Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Name]
targs'
                    f :: Q Type
f = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
fvar
                    h :: Q Type
h = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
hvar
                    a :: Q Type
a = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
avar
                    j :: Q Type
j = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
jvar
                    ftype :: Q Type
ftype = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tname) ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
targs')
                    typGen :: Q Type
typGen = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Cxt) [Q Type
h, Q Type
f, Q Type
a]
                    ([Q Type]
args, Q Type
returnType) = case Maybe ([Type], Type)
maybeSorts of
                      Maybe ([Type], Type)
Nothing -> ([], Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
typGen Q Type
j)
                      Just ([Type]
as, Type
ret) -> ((Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Q Type -> Q Type -> Q Type -> Type -> Q Type
mkArgType Q Type
h Q Type
f Q Type
a) [Type]
as, Q Type -> Q Type -> Q Type -> Type -> Q Type
mkRetType Q Type
h Q Type
f Q Type
a Type
ret)
                    typ :: Q Type
typ = [Q Type] -> Q Type
arrow ([Q Type]
args [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
returnType])
                    constr :: Q Type
constr = Name -> [Q Type] -> Q Type
forall (m :: * -> *). Quote m => Name -> [m Type] -> m Type
classP ''(:<:) [Q Type
ftype, Q Type
f]
                    --constr' = classP ''All [conT ''HFunctor, varT fvar]

                    -- NOTE 2023.06.29: Unsure if SpecifiedSpec is what we want here to get working type applications
                    typeSig :: Q Type
typeSig = [TyVarBndr Specificity] -> Q [Type] -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT ((Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
v -> Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
v Specificity
SpecifiedSpec) [Name]
vars) ([Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Type
constr]) Q Type
typ
                Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD Name
sname Q Type
typeSig

              mkArgType :: Q Type -> Q Type -> Q Type -> Type -> Q Type
              mkArgType :: Q Type -> Q Type -> Q Type -> Type -> Q Type
mkArgType Q Type
h Q Type
f Q Type
a (AppT (VarT Name
_) Type
t) =
                -- NOTE: e ( .. ) case
                (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Cxt) [Q Type
h, Q Type
f, Q Type
a, Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t]
              mkArgType Q Type
_ Q Type
_ Q Type
_ Type
t =
                Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t

              mkRetType :: Q Type -> Q Type -> Q Type -> Type -> Q Type
              mkRetType :: Q Type -> Q Type -> Q Type -> Type -> Q Type
mkRetType Q Type
h Q Type
f Q Type
a Type
t =
                (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Cxt) [Q Type
h, Q Type
f, Q Type
a, Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t]

              arrow :: [Q Type] -> Q Type
arrow =
                (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Type
a Q Type
acc -> Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
acc)