{-# LANGUAGE TemplateHaskell, CPP #-}

module Hyper.TH.Morph
    ( makeHMorph
    ) where

import qualified Control.Lens as Lens
import qualified Data.Map as Map
import           Hyper.Class.Morph (HMorph(..))
import           Hyper.TH.Internal.Utils
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D

import           Hyper.Internal.Prelude

makeHMorph :: Name -> DecsQ
makeHMorph :: Name -> DecsQ
makeHMorph Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName Q TypeInfo -> (TypeInfo -> DecsQ) -> DecsQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHMorphForType

{-# ANN module "HLint: ignore Use id" #-}
makeHMorphForType :: TypeInfo -> DecsQ
makeHMorphForType :: TypeInfo -> DecsQ
makeHMorphForType TypeInfo
info =
    -- TODO: Contexts
    CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Pred] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t|HMorph $(pure src) $(pure dst)|]
    [ Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> DecQ
D.tySynInstDCompat
        ''MorphConstraint
        ([Q TyVarBndrUnit] -> Maybe [Q TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> TyVarBndrUnit
plainTV Name
constraintVar)])
        ([Pred
src, Pred
dst, Name -> Pred
VarT Name
constraintVar] [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
        ([Pred] -> CxtQ
simplifyContext [Pred]
morphConstraint CxtQ -> ([Pred] -> Pred) -> TypeQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Pred] -> Pred
forall (t :: * -> *). Foldable t => t Pred -> Pred
toTuple)
    , CxtQ
-> Name
-> [TypeQ]
-> Maybe Pred
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataInstD
        ([Pred] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ''MorphWitness [Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
src, Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
dst, [t|_|], [t|_|]]
        Maybe Pred
forall a. Maybe a
Nothing (Map Pred (Name, ConQ)
witnesses Map Pred (Name, ConQ)
-> Getting (Endo [ConQ]) (Map Pred (Name, ConQ)) ConQ -> [ConQ]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConQ) -> Const (Endo [ConQ]) (Name, ConQ))
-> Map Pred (Name, ConQ)
-> Const (Endo [ConQ]) (Map Pred (Name, ConQ))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConQ) -> Const (Endo [ConQ]) (Name, ConQ))
 -> Map Pred (Name, ConQ)
 -> Const (Endo [ConQ]) (Map Pred (Name, ConQ)))
-> ((ConQ -> Const (Endo [ConQ]) ConQ)
    -> (Name, ConQ) -> Const (Endo [ConQ]) (Name, ConQ))
-> Getting (Endo [ConQ]) (Map Pred (Name, ConQ)) ConQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConQ -> Const (Endo [ConQ]) ConQ)
-> (Name, ConQ) -> Const (Endo [ConQ]) (Name, ConQ)
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2) []
    , Name -> [ClauseQ] -> DecQ
funD 'morphMap (TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
    -> ClauseQ)
-> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
mkMorphCon)
    , Name -> [ClauseQ] -> DecQ
funD 'morphLiftConstraint [ClauseQ]
liftConstraintClauses
    ]
    DecQ -> (Dec -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[])
    where
        (Map Name Pred
s0, Map Name Pred
s1) = TypeInfo -> (Map Name Pred, Map Name Pred)
paramSubsts TypeInfo
info
        src :: Pred
src = Map Name Pred -> Pred -> Pred
forall a. TypeSubstitution a => Map Name Pred -> a -> a
D.applySubstitution Map Name Pred
s0 (TypeInfo -> Pred
tiInstance TypeInfo
info)
        dst :: Pred
dst = Map Name Pred -> Pred -> Pred
forall a. TypeSubstitution a => Map Name Pred -> a -> a
D.applySubstitution Map Name Pred
s1 (TypeInfo -> Pred
tiInstance TypeInfo
info)
        constraintVar :: Name
constraintVar = String -> Name
mkName String
"constraint"
        contents :: TypeContents
contents = TypeInfo -> TypeContents
childrenTypes TypeInfo
info
        morphConstraint :: [Pred]
morphConstraint =
            (TypeContents -> Set Pred
tcChildren TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> Pred) -> [Pred]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Pred -> Pred -> Pred
appSubsts (Name -> Pred
VarT Name
constraintVar))
            [Pred] -> [Pred] -> [Pred]
forall a. Semigroup a => a -> a -> a
<> (TypeContents -> Set Pred
tcEmbeds TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> Pred) -> [Pred]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
                \Pred
x -> Name -> Pred
ConT ''MorphConstraint Pred -> Pred -> Pred
`appSubsts` Pred
x Pred -> Pred -> Pred
`AppT` Name -> Pred
VarT Name
constraintVar)
        appSubsts :: Pred -> Pred -> Pred
appSubsts Pred
x Pred
t = Pred
x Pred -> Pred -> Pred
`AppT` Map Name Pred -> Pred -> Pred
forall a. TypeSubstitution a => Map Name Pred -> a -> a
D.applySubstitution Map Name Pred
s0 Pred
t Pred -> Pred -> Pred
`AppT` Map Name Pred -> Pred -> Pred
forall a. TypeSubstitution a => Map Name Pred -> a -> a
D.applySubstitution Map Name Pred
s1 Pred
t
        nodeWits :: [(Pred, (Name, ConQ))]
nodeWits =
            TypeContents -> Set Pred
tcChildren TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> (Pred, (Name, ConQ))) -> [(Pred, (Name, ConQ))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
            \Pred
x ->
            let n :: Name
n = String
witPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Pred -> String
mkNiceTypeName Pred
x String -> (String -> Name) -> Name
forall a b. a -> (a -> b) -> b
& String -> Name
mkName in
            ( Pred
x
            , (Name
n, [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC [Name
n] [] (Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Pred -> Pred
appSubsts Pred
morphWithNessOf Pred
x)))
            )
        embedWits :: [(Pred, (Name, ConQ))]
embedWits =
            TypeContents -> Set Pred
tcEmbeds TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> (Pred, (Name, ConQ))) -> [(Pred, (Name, ConQ))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
            \Pred
x ->
            let n :: Name
n = String
witPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Pred -> String
mkNiceTypeName Pred
x String -> (String -> Name) -> Name
forall a b. a -> (a -> b) -> b
& String -> Name
mkName in
            ( Pred
x
            , ( Name
n
                , [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC [Name
n]
                    [ BangQ -> TypeQ -> StrictTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
                        (Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pred
ConT ''MorphWitness Pred -> Pred -> Pred
`appSubsts` Pred
x Pred -> Pred -> Pred
`AppT` Pred
varA Pred -> Pred -> Pred
`AppT` Pred
varB))
                    ] (Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred
morphWithNessOf Pred -> Pred -> Pred
`AppT` Pred
varA Pred -> Pred -> Pred
`AppT` Pred
varB))
              )
            )
        witnesses :: Map Pred (Name, ConQ)
witnesses = [(Pred, (Name, ConQ))]
nodeWits [(Pred, (Name, ConQ))]
-> [(Pred, (Name, ConQ))] -> [(Pred, (Name, ConQ))]
forall a. Semigroup a => a -> a -> a
<> [(Pred, (Name, ConQ))]
embedWits [(Pred, (Name, ConQ))]
-> ([(Pred, (Name, ConQ))] -> Map Pred (Name, ConQ))
-> Map Pred (Name, ConQ)
forall a b. a -> (a -> b) -> b
& [(Pred, (Name, ConQ))] -> Map Pred (Name, ConQ)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        varA :: Pred
varA = Name -> Pred
VarT (String -> Name
mkName String
"a")
        varB :: Pred
varB = Name -> Pred
VarT (String -> Name
mkName String
"b")
        witPrefix :: String
witPrefix = String
"M_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
niceName (TypeInfo -> Name
tiName TypeInfo
info) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_"
        morphWithNessOf :: Pred
morphWithNessOf = Name -> Pred
ConT ''MorphWitness Pred -> Pred -> Pred
`AppT` Pred
src Pred -> Pred -> Pred
`AppT` Pred
dst
        liftConstraintClauses :: [ClauseQ]
liftConstraintClauses
            | Map Pred (Name, ConQ) -> Bool
forall k a. Map k a -> Bool
Map.null Map Pred (Name, ConQ)
witnesses = [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ([MatchQ] -> ExpQ
lamCaseE [])) []]
            | Bool
otherwise =
                ([(Pred, (Name, ConQ))]
nodeWits [(Pred, (Name, ConQ))]
-> Getting (Endo [Name]) [(Pred, (Name, ConQ))] Name -> [Name]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> [(Pred, (Name, ConQ))]
-> Const (Endo [Name]) [(Pred, (Name, ConQ))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ)))
 -> [(Pred, (Name, ConQ))]
 -> Const (Endo [Name]) [(Pred, (Name, ConQ))])
-> ((Name -> Const (Endo [Name]) Name)
    -> (Pred, (Name, ConQ))
    -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> Getting (Endo [Name]) [(Pred, (Name, ConQ))] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
-> (Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ))
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 (((Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
 -> (Pred, (Name, ConQ))
 -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> ((Name -> Const (Endo [Name]) Name)
    -> (Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
-> (Name -> Const (Endo [Name]) Name)
-> (Pred, (Name, ConQ))
-> Const (Endo [Name]) (Pred, (Name, ConQ))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> (Name, ConQ) -> Const (Endo [Name]) (Name, ConQ)
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftNodeConstraint) [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. Semigroup a => a -> a -> a
<>
                ([(Pred, (Name, ConQ))]
embedWits [(Pred, (Name, ConQ))]
-> Getting (Endo [Name]) [(Pred, (Name, ConQ))] Name -> [Name]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> [(Pred, (Name, ConQ))]
-> Const (Endo [Name]) [(Pred, (Name, ConQ))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ)))
 -> [(Pred, (Name, ConQ))]
 -> Const (Endo [Name]) [(Pred, (Name, ConQ))])
-> ((Name -> Const (Endo [Name]) Name)
    -> (Pred, (Name, ConQ))
    -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> Getting (Endo [Name]) [(Pred, (Name, ConQ))] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
-> (Pred, (Name, ConQ)) -> Const (Endo [Name]) (Pred, (Name, ConQ))
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 (((Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
 -> (Pred, (Name, ConQ))
 -> Const (Endo [Name]) (Pred, (Name, ConQ)))
-> ((Name -> Const (Endo [Name]) Name)
    -> (Name, ConQ) -> Const (Endo [Name]) (Name, ConQ))
-> (Name -> Const (Endo [Name]) Name)
-> (Pred, (Name, ConQ))
-> Const (Endo [Name]) (Pred, (Name, ConQ))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> (Name, ConQ) -> Const (Endo [Name]) (Name, ConQ)
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftEmbedConstraint)
        liftNodeConstraint :: Name -> ClauseQ
liftNodeConstraint Name
n = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
n [], PatQ
wildP] (ExpQ -> BodyQ
normalB [|\x -> x|]) []
        liftEmbedConstraint :: Name -> ClauseQ
liftEmbedConstraint Name
n =
            [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
n [Name -> PatQ
varP Name
varW], Name -> PatQ
varP Name
varProxy]
            (ExpQ -> BodyQ
normalB [|morphLiftConstraint $(varE varW) $(varE varProxy)|]) []
        varW :: Name
varW = String -> Name
mkName String
"w"
        varProxy :: Name
varProxy = String -> Name
mkName String
"p"
        mkMorphCon :: (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
mkMorphCon (Name, ConstructorVariant, [Either Pred CtrTypePattern])
con =
            [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
varF, PatQ
p] BodyQ
b []
            where
                (PatQ
p, BodyQ
b) = Int
-> Map Pred (Name, ConQ)
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> (PatQ, BodyQ)
forall a b c.
Int
-> Map Pred (Name, a)
-> (Name, b, [Either c CtrTypePattern])
-> (PatQ, BodyQ)
morphCon Int
0 Map Pred (Name, ConQ)
witnesses (Name, ConstructorVariant, [Either Pred CtrTypePattern])
con

varF :: Name
varF :: Name
varF = String -> Name
mkName String
"_f"

morphCon :: Int -> Map Type (Name, a) -> (Name, b, [Either c CtrTypePattern]) -> (Q Pat, Q Body)
morphCon :: Int
-> Map Pred (Name, a)
-> (Name, b, [Either c CtrTypePattern])
-> (PatQ, BodyQ)
morphCon Int
i Map Pred (Name, a)
witnesses (Name
n, b
_, [Either c CtrTypePattern]
fields) =
    ( Name -> [PatQ] -> PatQ
conP Name
n ([Name]
cVars [Name] -> (Name -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> PatQ
varP)
    , ExpQ -> BodyQ
normalB ((ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
n) ((Either c CtrTypePattern -> Name -> ExpQ)
-> [Either c CtrTypePattern] -> [Name] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Either c CtrTypePattern -> Name -> ExpQ
bodyFor [Either c CtrTypePattern]
fields [Name]
cVars))
    )
    where
        cVars :: [Name]
cVars =
            [Int
i ..] [Int] -> (Int -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> String
forall a. Show a => a -> String
show [String] -> (String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:) [String] -> (String -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Name
mkName
            [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take ([Either c CtrTypePattern] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either c CtrTypePattern]
fields)
        f :: ExpQ
f = Name -> ExpQ
varE Name
varF
        bodyFor :: Either c CtrTypePattern -> Name -> ExpQ
bodyFor Left{} Name
v = Name -> ExpQ
varE Name
v
        bodyFor (Right CtrTypePattern
x) Name
v = [|$(bodyForPat x) $(varE v)|]
        bodyForPat :: CtrTypePattern -> ExpQ
bodyForPat (Node Pred
x) = [|$f $(conE (witnesses ^?! Lens.ix x . Lens._1))|]
        bodyForPat (InContainer Pred
_ CtrTypePattern
pat) = [|fmap $(bodyForPat pat)|]
        bodyForPat (FlatEmbed TypeInfo
x) =
            [MatchQ] -> ExpQ
lamCaseE
            (TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
x
                [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
    -> (PatQ, BodyQ))
-> [(PatQ, BodyQ)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int
-> Map Pred (Name, a)
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> (PatQ, BodyQ)
forall a b c.
Int
-> Map Pred (Name, a)
-> (Name, b, [Either c CtrTypePattern])
-> (PatQ, BodyQ)
morphCon (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
cVars) Map Pred (Name, a)
witnesses
                [(PatQ, BodyQ)] -> ((PatQ, BodyQ) -> MatchQ) -> [MatchQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PatQ
p, BodyQ
b) -> PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
p BodyQ
b []
            )
        bodyForPat (GenEmbed Pred
t) = [|morphMap ($f . $(conE (witnesses ^?! Lens.ix t . Lens._1)))|]

type MorphSubsts = (Map Name Type, Map Name Type)

paramSubsts :: TypeInfo -> MorphSubsts
paramSubsts :: TypeInfo -> (Map Name Pred, Map Name Pred)
paramSubsts TypeInfo
info =
    (TypeInfo -> [TyVarBndrUnit]
tiParams TypeInfo
info [TyVarBndrUnit] -> (TyVarBndrUnit -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName) [Name]
-> Getting
     (Map Name Pred, Map Name Pred)
     [Name]
     (Map Name Pred, Map Name Pred)
-> (Map Name Pred, Map Name Pred)
forall s a. s -> Getting a s a -> a
^. (Name -> Const (Map Name Pred, Map Name Pred) Name)
-> [Name] -> Const (Map Name Pred, Map Name Pred) [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name -> Const (Map Name Pred, Map Name Pred) Name)
 -> [Name] -> Const (Map Name Pred, Map Name Pred) [Name])
-> (((Map Name Pred, Map Name Pred)
     -> Const
          (Map Name Pred, Map Name Pred) (Map Name Pred, Map Name Pred))
    -> Name -> Const (Map Name Pred, Map Name Pred) Name)
-> Getting
     (Map Name Pred, Map Name Pred)
     [Name]
     (Map Name Pred, Map Name Pred)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> (Map Name Pred, Map Name Pred))
-> ((Map Name Pred, Map Name Pred)
    -> Const
         (Map Name Pred, Map Name Pred) (Map Name Pred, Map Name Pred))
-> Name
-> Const (Map Name Pred, Map Name Pred) Name
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
Lens.to Name -> (Map Name Pred, Map Name Pred)
mkInfo
    where
        pinned :: Set Name
pinned = TypeInfo -> Set Name
pinnedParams TypeInfo
info
        mkInfo :: Name -> (Map Name Pred, Map Name Pred)
mkInfo Name
name
            | Set Name
pinned Set Name -> Getting Bool (Set Name) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Index (Set Name) -> Lens' (Set Name) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains Name
Index (Set Name)
name = (Map Name Pred, Map Name Pred)
forall a. Monoid a => a
mempty
            | Bool
otherwise = (Name -> String -> Map Name Pred
forall b.
(Monoid b, At b, IxValue b ~ Pred, Index b ~ Name) =>
Name -> String -> b
side Name
name String
"0", Name -> String -> Map Name Pred
forall b.
(Monoid b, At b, IxValue b ~ Pred, Index b ~ Name) =>
Name -> String -> b
side Name
name String
"1")
        side :: Name -> String -> b
side Name
name String
suffix = b
forall a. Monoid a => a
mempty b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& Index b -> Lens' b (Maybe (IxValue b))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at Name
Index b
name ((Maybe (IxValue b) -> Identity (Maybe Pred)) -> b -> Identity b)
-> Pred -> b -> b
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Name -> Pred
VarT (String -> Name
mkName (Name -> String
nameBase Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix))

pinnedParams :: TypeInfo -> Set Name
pinnedParams :: TypeInfo -> Set Name
pinnedParams = (TypeInfo -> Getting (Set Name) TypeInfo (Set Name) -> Set Name
forall s a. s -> Getting a s a -> a
^. (TypeInfo
 -> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])])
-> Optic'
     (->)
     (Const (Set Name))
     TypeInfo
     [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
Lens.to TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors Optic'
  (->)
  (Const (Set Name))
  TypeInfo
  [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Set Name -> Const (Set Name) (Set Name))
    -> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
    -> Const
         (Set Name)
         [(Name, ConstructorVariant, [Either Pred CtrTypePattern])])
-> Getting (Set Name) TypeInfo (Set Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
 -> Const
      (Set Name)
      (Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> Const
     (Set Name)
     [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Pred CtrTypePattern])
  -> Const
       (Set Name)
       (Name, ConstructorVariant, [Either Pred CtrTypePattern]))
 -> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
 -> Const
      (Set Name)
      [(Name, ConstructorVariant, [Either Pred CtrTypePattern])])
-> ((Set Name -> Const (Set Name) (Set Name))
    -> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
    -> Const
         (Set Name)
         (Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> (Set Name -> Const (Set Name) (Set Name))
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> Const
     (Set Name)
     [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Pred CtrTypePattern]
 -> Const (Set Name) [Either Pred CtrTypePattern])
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
     (Set Name) (Name, ConstructorVariant, [Either Pred CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Pred CtrTypePattern]
  -> Const (Set Name) [Either Pred CtrTypePattern])
 -> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
 -> Const
      (Set Name)
      (Name, ConstructorVariant, [Either Pred CtrTypePattern]))
-> ((Set Name -> Const (Set Name) (Set Name))
    -> [Either Pred CtrTypePattern]
    -> Const (Set Name) [Either Pred CtrTypePattern])
-> (Set Name -> Const (Set Name) (Set Name))
-> (Name, ConstructorVariant, [Either Pred CtrTypePattern])
-> Const
     (Set Name) (Name, ConstructorVariant, [Either Pred CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Pred CtrTypePattern
 -> Const (Set Name) (Either Pred CtrTypePattern))
-> [Either Pred CtrTypePattern]
-> Const (Set Name) [Either Pred CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Pred CtrTypePattern
  -> Const (Set Name) (Either Pred CtrTypePattern))
 -> [Either Pred CtrTypePattern]
 -> Const (Set Name) [Either Pred CtrTypePattern])
-> ((Set Name -> Const (Set Name) (Set Name))
    -> Either Pred CtrTypePattern
    -> Const (Set Name) (Either Pred CtrTypePattern))
-> (Set Name -> Const (Set Name) (Set Name))
-> [Either Pred CtrTypePattern]
-> Const (Set Name) [Either Pred CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Pred CtrTypePattern -> Set Name)
-> (Set Name -> Const (Set Name) (Set Name))
-> Either Pred CtrTypePattern
-> Const (Set Name) (Either Pred CtrTypePattern)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
Lens.to Either Pred CtrTypePattern -> Set Name
ctrPinnedParams)

ctrPinnedParams :: Either Type CtrTypePattern -> Set Name
ctrPinnedParams :: Either Pred CtrTypePattern -> Set Name
ctrPinnedParams (Left Pred
t) = Pred -> Set Name
typeParams Pred
t
ctrPinnedParams (Right Node{}) = Set Name
forall a. Monoid a => a
mempty
ctrPinnedParams (Right GenEmbed{}) = Set Name
forall a. Monoid a => a
mempty
ctrPinnedParams (Right (FlatEmbed TypeInfo
info)) = TypeInfo -> Set Name
pinnedParams TypeInfo
info
ctrPinnedParams (Right (InContainer Pred
c CtrTypePattern
p)) = Pred -> Set Name
typeParams Pred
c Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Either Pred CtrTypePattern -> Set Name
ctrPinnedParams (CtrTypePattern -> Either Pred CtrTypePattern
forall a b. b -> Either a b
Right CtrTypePattern
p)

typeParams :: Type -> Set Name
typeParams :: Pred -> Set Name
typeParams (VarT Name
x) = Set Name
forall a. Monoid a => a
mempty Set Name -> (Set Name -> Set Name) -> Set Name
forall a b. a -> (a -> b) -> b
& Index (Set Name) -> Lens' (Set Name) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains Name
Index (Set Name)
x ((Bool -> Identity Bool) -> Set Name -> Identity (Set Name))
-> Bool -> Set Name -> Set Name
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
typeParams (AppT Pred
f Pred
x) = Pred -> Set Name
typeParams Pred
f Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Pred -> Set Name
typeParams Pred
x
typeParams (InfixT Pred
x Name
_ Pred
y) = Pred -> Set Name
typeParams Pred
x Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Pred -> Set Name
typeParams Pred
y
-- TODO: Missing cases
typeParams Pred
_ = Set Name
forall a. Monoid a => a
mempty