-- | template Haskell generator
module Data.Serde.Internal.TH
  ( runqq1,
    runusercoercion,
    RunUserCoercion (..),
  )
where

import Data.Coerce
import Data.Data
import Data.Foldable
import Data.List (partition)
import Data.Maybe
import Data.Serde.Internal.Syn
import Data.Serde.Internal.Type
import Data.Traversable
import Language.Haskell.TH.Lib as TH
import Language.Haskell.TH.Syntax as TH

bang0 :: Bang
bang0 :: Bang
bang0 = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

-- regular field type (ignore via)
genfld :: SynFld -> VarBangType
genfld :: SynFld -> VarBangType
genfld SynFld {Name
synfnam :: Name
synfnam :: SynFld -> Name
synfnam, Type
synftyp :: Type
synftyp :: SynFld -> Type
synftyp} =
  let n :: Name
n = Name -> Name
cvtnam Name
synfnam
      t :: Type
t = Type -> Type
forall a. ToTH a => a -> Type
toth Type
synftyp
   in (Name
n, Bang
bang0, Type
t)

-- suffix with two underscores
shadownamcore :: String -> String
shadownamcore :: String -> String
shadownamcore = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__")

shadownam :: TH.Name -> TH.Name
shadownam :: Name -> Name
shadownam (TH.Name (OccName String
o) NameFlavour
s) = OccName -> NameFlavour -> Name
TH.Name (String -> OccName
OccName (String -> String
shadownamcore String
o)) NameFlavour
s

-- shadow field type (ignore type, use via)
genshafld :: SynFld -> VarBangType
genshafld :: SynFld -> VarBangType
genshafld SynFld {Name
synfnam :: SynFld -> Name
synfnam :: Name
synfnam, Type
synftyp :: SynFld -> Type
synftyp :: Type
synftyp, Maybe Type
synfvia :: Maybe Type
synfvia :: SynFld -> Maybe Type
synfvia} =
  let n :: Name
n = Name -> Name
shadownam (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
synfnam
      t :: Type
t
        | Just Type
v <- Maybe Type
synfvia = Type -> Type
forall a. ToTH a => a -> Type
toth Type
v
        | Bool
otherwise = Type -> Type
forall a. ToTH a => a -> Type
toth Type
synftyp
   in (Name
n, Bang
bang0, Type
t)

-- generate regular data
gendat :: Syn -> Dec
gendat :: Syn -> Dec
gendat SynData {Name
synnam :: Name
synnam :: Syn -> Name
synnam, [SynFld]
synflds :: [SynFld]
synflds :: Syn -> [SynFld]
synflds, [Name]
synders :: [Name]
synders :: Syn -> [Name]
synders} =
  let n :: Name
n = Name -> Name
cvtnam Name
synnam
      flds :: [VarBangType]
flds = (SynFld -> VarBangType) -> [SynFld] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map SynFld -> VarBangType
genfld [SynFld]
synflds
      der :: DerivClause
der = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
c | Name
c <- [Name]
synders]
   in Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
n [] Maybe Type
forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
n [VarBangType]
flds] [DerivClause
der]
gendat Syn
_ = String -> Dec
forall a. HasCallStack => String -> a
error String
"gendat: not a data type"

-- generate shadow data
genshadata :: Syn -> Dec
genshadata :: Syn -> Dec
genshadata SynData {Name
synnam :: Syn -> Name
synnam :: Name
synnam, [SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} =
  let n :: Name
n = Name -> Name
shadownam (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
synnam
      flds :: [VarBangType]
flds = (SynFld -> VarBangType) -> [SynFld] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map SynFld -> VarBangType
genshafld [SynFld]
synflds
   in Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
n [] Maybe Type
forall a. Maybe a
Nothing [Name -> [VarBangType] -> Con
RecC Name
n [VarBangType]
flds] [] -- derive nothing
genshadata Syn
_ = String -> Dec
forall a. HasCallStack => String -> a
error String
"genshadata: not a data type"

-- generate newtype
gennew :: Syn -> Dec
gennew :: Syn -> Dec
gennew SynNewtype {Name
synnam :: Syn -> Name
synnam :: Name
synnam, Either ViaInfo SynFld
synfld :: Either ViaInfo SynFld
synfld :: Syn -> Either ViaInfo SynFld
synfld, [Name]
synders :: Syn -> [Name]
synders :: [Name]
synders} =
  let n :: Name
n = Name -> Name
cvtnam Name
synnam
      der :: Maybe Type -> DerivClause
der Maybe Type
Nothing = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
c | Name
c <- [Name]
synders]
      der (Just Type
t) =
        Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
          (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just (Type -> DerivStrategy
ViaStrategy Type
t))
          [Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
c | Name
c <- [Name]
synders]
      mk :: Con -> Maybe Type -> Dec
mk Con
a Maybe Type
v = Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
n [] Maybe Type
forall a. Maybe a
Nothing Con
a [Maybe Type -> DerivClause
der Maybe Type
v]
   in case Either ViaInfo SynFld
synfld of
        Left (Plain String
t) -> Con -> Maybe Type -> Dec
mk (Name -> [BangType] -> Con
NormalC Name
n [(Bang
bang0, Name -> Type
ConT (String -> Name
mkName String
t))]) Maybe Type
forall a. Maybe a
Nothing
        Left (WithVia String
t String
v) ->
          Con -> Maybe Type -> Dec
mk (Name -> [BangType] -> Con
NormalC Name
n [(Bang
bang0, Name -> Type
ConT (String -> Name
mkName String
t))]) (Type -> Maybe Type
forall a. a -> Maybe a
Just (Name -> Type
ConT (String -> Name
mkName String
v)))
        Right f :: SynFld
f@SynFld {Maybe Type
synfvia :: SynFld -> Maybe Type
synfvia :: Maybe Type
synfvia} -> Con -> Maybe Type -> Dec
mk (Name -> [VarBangType] -> Con
RecC Name
n [SynFld -> VarBangType
genfld SynFld
f]) (Type -> Type
forall a. ToTH a => a -> Type
toth (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Type
synfvia)
gennew Syn
_ = String -> Dec
forall a. HasCallStack => String -> a
error String
"gennew: not a newtype"

-- generate an alias
genalias :: Syn -> Dec
genalias :: Syn -> Dec
genalias SynAlias {Name
synnam :: Syn -> Name
synnam :: Name
synnam, Type
syndest :: Type
syndest :: Syn -> Type
syndest} =
  let n :: Name
n = Name -> Name
cvtnam Name
synnam
      t :: Type
t = Type -> Type
forall a. ToTH a => a -> Type
toth Type
syndest
   in Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD Name
n [] Type
t
genalias Syn
_ = String -> Dec
forall a. HasCallStack => String -> a
error String
"genalias: not an alias"

-- has a shadowing field?
shadowing :: Syn -> Bool
shadowing :: Syn -> Bool
shadowing SynData {[SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} = (SynFld -> Bool) -> [SynFld] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Type -> Bool) -> (SynFld -> Maybe Type) -> SynFld -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynFld -> Maybe Type
synfvia) [SynFld]
synflds
shadowing Syn
_ = Bool
False

-- generate declarations for a 'Syn' object (e.g., data, newtype, alias)
gendecs :: Syn -> [Dec]
gendecs :: Syn -> [Dec]
gendecs s :: Syn
s@SynData {} = Syn -> Dec
gendat Syn
s Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
sha
  where
    sha :: [Dec]
sha
      | Syn -> Bool
shadowing Syn
s = [Syn -> Dec
genshadata Syn
s]
      | Bool
otherwise = []
gendecs s :: Syn
s@SynNewtype {} = [Syn -> Dec
gennew Syn
s]
gendecs s :: Syn
s@SynAlias {} = [Syn -> Dec
genalias Syn
s]

-- generate a pattern to deconstruct a normal constructor
genfuncctor :: Syn -> Q Pat
genfuncctor :: Syn -> Q Pat
genfuncctor SynData {Name
synnam :: Syn -> Name
synnam :: Name
synnam, [SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} =
  let n :: Name
n = Name -> Name
cvtnam Name
synnam
   in Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n ((SynFld -> Q Pat) -> [SynFld] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> (SynFld -> Name) -> SynFld -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynFld -> Name
synfnam) [SynFld]
synflds)
genfuncctor Syn
_ = String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"genfuncctor: not a data type"

-- generate a pattern to deconstruct a shadow constructor
--
-- fields will have a shadow suffix
genfuncctorsha :: Syn -> Q Pat
genfuncctorsha :: Syn -> Q Pat
genfuncctorsha SynData {Name
synnam :: Syn -> Name
synnam :: Name
synnam, [SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} =
  let n :: Name
n = Name -> Name
shadownam (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
synnam
   in Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n ((SynFld -> Q Pat) -> [SynFld] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> (SynFld -> Name) -> SynFld -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
shadownam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynFld -> Name
synfnam) [SynFld]
synflds)
genfuncctorsha Syn
_ = String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"genfuncctorsha: not a data type"

-- apply shadow fields to a normal constructor
genapp :: Syn -> Q Exp
genapp :: Syn -> Q Exp
genapp SynData {Name
synnam :: Syn -> Name
synnam :: Name
synnam, [SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} =
  let n :: Name
n = Name -> Name
cvtnam Name
synnam
      v :: [Q Exp]
v = ((SynFld -> Q Exp) -> [SynFld] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (SynFld -> Name) -> SynFld -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
shadownam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynFld -> Name
synfnam) [SynFld]
synflds)
   in (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
n) (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
varE 'coerce) (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Exp]
v)
genapp Syn
_ = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"genapp: not a data type"

-- apply normal fields to a shadow constructor
genappsha :: Syn -> Q Exp
genappsha :: Syn -> Q Exp
genappsha SynData {Name
synnam :: Syn -> Name
synnam :: Name
synnam, [SynFld]
synflds :: Syn -> [SynFld]
synflds :: [SynFld]
synflds} =
  let n :: Name
n = Name -> Name
shadownam (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
cvtnam Name
synnam
      v :: [Q Exp]
v = ((SynFld -> Q Exp) -> [SynFld] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (SynFld -> Name) -> SynFld -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (SynFld -> Name) -> SynFld -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynFld -> Name
synfnam) [SynFld]
synflds)
   in (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
n) (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
varE 'coerce) (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Exp]
v)
genappsha Syn
_ = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"genappsha: not a data type"

-- to prevent getQ from silently failing (by fixing the type)
-- remember: getQ relies on Typeable
newtype QQState = QQState {QQState -> [Syn]
qqstate :: [Syn]} -- declarations
  deriving (Typeable)

-- | run quasi-quote body, and replace Q state (to get the
-- shadowable data types)
runqq1 :: String -> Q [Dec]
runqq1 :: String -> Q [Dec]
runqq1 String
s = case String -> Either String Parsed
parse String
s of
  Left String
e -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
  Right Parsed
p -> do
    QQState -> Q ()
forall a. Typeable a => a -> Q ()
putQ ([Syn] -> QQState
QQState (Parsed -> [Syn]
declarations Parsed
p))
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Syn -> [Dec]
gendecs Syn
t | Syn
t <- Parsed -> [Syn]
declarations Parsed
p])

-- | arguments to user code that generates coercions
data RunUserCoercion = RunUserCoercion
  { -- | regular (non-record syntax) pattern for deconstruction (normal)
    RunUserCoercion -> Q Pat
patnormal :: Q Pat,
    -- | regular (non-record syntax) pattern for deconstruction (shadow)
    RunUserCoercion -> Q Pat
patshadow :: Q Pat,
    -- | apply shadow fields to a normal constructor
    RunUserCoercion -> Q Exp
appnormal :: Q Exp,
    -- | apply normal fields to a shadow constructor
    RunUserCoercion -> Q Exp
appshadow :: Q Exp,
    -- | class to derive
    RunUserCoercion -> Q Type
datatyp :: Q TH.Type,
    -- | shadow data type
    RunUserCoercion -> Q Type
shadowdatatyp :: Q TH.Type
  }

-- | using the stored state (from last quasi-quote run), run user code
-- to generate coercions
runusercoercion ::
  -- | generate coercions between shadow and regular data types
  (RunUserCoercion -> Q [Dec]) ->
  -- | derive coercions for shadow data, regular data with no shadows,
  -- and newtypes
  (TH.Name -> Q [Dec]) ->
  -- | preparations for shadow types
  [TH.Name] ->
  -- | generated coercions
  Q [Dec]
runusercoercion :: (RunUserCoercion -> Q [Dec])
-> (Name -> Q [Dec]) -> [Name] -> Q [Dec]
runusercoercion RunUserCoercion -> Q [Dec]
f Name -> Q [Dec]
g ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
ConT -> Cxt
preps) = do
  let ++++ :: Q [a] -> Q [a] -> Q [a]
(++++) = ([a] -> [a] -> [a]) -> Q [a] -> Q [a] -> Q [a]
forall a b c. (a -> b -> c) -> Q a -> Q b -> Q c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
  -- get all the shadowable data types and the regular data types
  let isnotalias :: Syn -> Bool
isnotalias SynAlias {} = Bool
False
      isnotalias Syn
_ = Bool
True
  ([Syn]
ss, [Syn]
ns) <-
    Q (Maybe QQState)
forall a. Typeable a => Q (Maybe a)
getQ Q (Maybe QQState)
-> (Maybe QQState -> Q ([Syn], [Syn])) -> Q ([Syn], [Syn])
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just QQState
t -> ([Syn], [Syn]) -> Q ([Syn], [Syn])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Syn], [Syn]) -> Q ([Syn], [Syn]))
-> ([Syn], [Syn]) -> Q ([Syn], [Syn])
forall a b. (a -> b) -> a -> b
$ (Syn -> Bool) -> [Syn] -> ([Syn], [Syn])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Syn -> Bool
shadowing ([Syn] -> ([Syn], [Syn])) -> [Syn] -> ([Syn], [Syn])
forall a b. (a -> b) -> a -> b
$ (Syn -> Bool) -> [Syn] -> [Syn]
forall a. (a -> Bool) -> [a] -> [a]
filter Syn -> Bool
isnotalias ([Syn] -> [Syn]) -> [Syn] -> [Syn]
forall a b. (a -> b) -> a -> b
$ QQState -> [Syn]
qqstate QQState
t
      Maybe QQState
Nothing -> String -> Q ([Syn], [Syn])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"runusercoercion: run serde quasi-quote first"
  -- standaloneDerivD is used to generate standalone deriving instances
  -- for the shadow types
  let toderive :: [(Q Type, Type)]
toderive =
        [[(Q Type, Type)]] -> [(Q Type, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [ (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Syn -> Name) -> Syn -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
shadownam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Q Type) -> Syn -> Q Type
forall a b. (a -> b) -> a -> b
$ Syn
s, Type
c),
              (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Syn -> Name) -> Syn -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Q Type) -> Syn -> Q Type
forall a b. (a -> b) -> a -> b
$ Syn
s, Type
c)
            ]
          | Syn
s <- [Syn]
ss,
            Type
c <- Cxt
preps
          ]
          [(Q Type, Type)] -> [(Q Type, Type)] -> [(Q Type, Type)]
forall a. [a] -> [a] -> [a]
++ [(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Syn -> Name) -> Syn -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Q Type) -> Syn -> Q Type
forall a b. (a -> b) -> a -> b
$ Syn
n, Type
c) | Syn
n <- [Syn]
ns, Type
c <- Cxt
preps]
      derives :: Q [Dec]
derives = [(Q Type, Type)] -> ((Q Type, Type) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Q Type, Type)]
toderive \(Q Type
s, Type
c) ->
        Q Cxt -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
c) Q Type
s)
  Q [Dec]
derives
    Q [Dec] -> Q [Dec] -> Q [Dec]
forall {a}. Q [a] -> Q [a] -> Q [a]
++++ [Q [Dec]] -> Q [Dec]
forall a. Monoid a => [a] -> a
mconcat [Name -> Q [Dec]
g (Name -> Name
shadownam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Name) -> Syn -> Name
forall a b. (a -> b) -> a -> b
$ Syn
s) | Syn
s <- [Syn]
ss]
    Q [Dec] -> Q [Dec] -> Q [Dec]
forall {a}. Q [a] -> Q [a] -> Q [a]
++++ [Q [Dec]] -> Q [Dec]
forall a. Monoid a => [a] -> a
mconcat [Name -> Q [Dec]
g (Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Name) -> Syn -> Name
forall a b. (a -> b) -> a -> b
$ Syn
n) | Syn
n <- [Syn]
ns]
    Q [Dec] -> Q [Dec] -> Q [Dec]
forall {a}. Q [a] -> Q [a] -> Q [a]
++++ [Q [Dec]] -> Q [Dec]
forall a. Monoid a => [a] -> a
mconcat
      [ RunUserCoercion -> Q [Dec]
f
          RunUserCoercion
            { patnormal :: Q Pat
patnormal = Syn -> Q Pat
genfuncctor Syn
s,
              patshadow :: Q Pat
patshadow = Syn -> Q Pat
genfuncctorsha Syn
s,
              appnormal :: Q Exp
appnormal = Syn -> Q Exp
genapp Syn
s,
              appshadow :: Q Exp
appshadow = Syn -> Q Exp
genappsha Syn
s,
              datatyp :: Q Type
datatyp = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Syn -> Name) -> Syn -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Q Type) -> Syn -> Q Type
forall a b. (a -> b) -> a -> b
$ Syn
s,
              shadowdatatyp :: Q Type
shadowdatatyp = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (Syn -> Name) -> Syn -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
shadownam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
cvtnam (Name -> Name) -> (Syn -> Name) -> Syn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syn -> Name
synnam (Syn -> Q Type) -> Syn -> Q Type
forall a b. (a -> b) -> a -> b
$ Syn
s
            }
      | Syn
s <- [Syn]
ss
      ]