{-# LANGUAGE TemplateHaskell, DerivingVia #-}

-- Helpers for TemplateHaskell instance generators

module Hyper.TH.Internal.Utils
    ( -- Internals for use in TH for sub-classes
      TypeInfo(..), TypeContents(..), CtrTypePattern(..), NodeWitnesses(..)
    , makeTypeInfo, makeNodeOf
    , parts, toTuple, matchType, niceName, mkNiceTypeName
    , applicativeStyle, unapply, getVar, makeConstructorVars
    , consPat, simplifyContext, childrenTypes
    ) where

import qualified Control.Lens as Lens
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.State (State, evalState, execStateT, gets, modify)
import qualified Data.Char as Char
import           Data.List (nub, intercalate)
import qualified Data.Map as Map
import           Generic.Data (Generically(..))
import           Hyper.Class.Nodes (HWitness(..))
import           Hyper.Type (AHyperType(..), GetHyperType, type (:#))
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import           Language.Haskell.TH.Datatype.TyVarBndr

import           Hyper.Internal.Prelude

data TypeInfo = TypeInfo
    { TypeInfo -> Name
tiName :: Name
    , TypeInfo -> Type
tiInstance :: Type
    , TypeInfo -> [TyVarBndrUnit]
tiParams :: [TyVarBndrUnit]
    , TypeInfo -> Name
tiHyperParam :: Name
    , TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors :: [(Name, D.ConstructorVariant, [Either Type CtrTypePattern])]
    } deriving Int -> TypeInfo -> ShowS
[TypeInfo] -> ShowS
TypeInfo -> String
(Int -> TypeInfo -> ShowS)
-> (TypeInfo -> String) -> ([TypeInfo] -> ShowS) -> Show TypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeInfo] -> ShowS
$cshowList :: [TypeInfo] -> ShowS
show :: TypeInfo -> String
$cshow :: TypeInfo -> String
showsPrec :: Int -> TypeInfo -> ShowS
$cshowsPrec :: Int -> TypeInfo -> ShowS
Show

data TypeContents = TypeContents
    { TypeContents -> Set Type
tcChildren :: Set Type
    , TypeContents -> Set Type
tcEmbeds :: Set Type
    , TypeContents -> Set Type
tcOthers :: Set Type
    } deriving (Int -> TypeContents -> ShowS
[TypeContents] -> ShowS
TypeContents -> String
(Int -> TypeContents -> ShowS)
-> (TypeContents -> String)
-> ([TypeContents] -> ShowS)
-> Show TypeContents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeContents] -> ShowS
$cshowList :: [TypeContents] -> ShowS
show :: TypeContents -> String
$cshow :: TypeContents -> String
showsPrec :: Int -> TypeContents -> ShowS
$cshowsPrec :: Int -> TypeContents -> ShowS
Show, (forall x. TypeContents -> Rep TypeContents x)
-> (forall x. Rep TypeContents x -> TypeContents)
-> Generic TypeContents
forall x. Rep TypeContents x -> TypeContents
forall x. TypeContents -> Rep TypeContents x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeContents x -> TypeContents
$cfrom :: forall x. TypeContents -> Rep TypeContents x
Generic)
    deriving (b -> TypeContents -> TypeContents
NonEmpty TypeContents -> TypeContents
TypeContents -> TypeContents -> TypeContents
(TypeContents -> TypeContents -> TypeContents)
-> (NonEmpty TypeContents -> TypeContents)
-> (forall b. Integral b => b -> TypeContents -> TypeContents)
-> Semigroup TypeContents
forall b. Integral b => b -> TypeContents -> TypeContents
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> TypeContents -> TypeContents
$cstimes :: forall b. Integral b => b -> TypeContents -> TypeContents
sconcat :: NonEmpty TypeContents -> TypeContents
$csconcat :: NonEmpty TypeContents -> TypeContents
<> :: TypeContents -> TypeContents -> TypeContents
$c<> :: TypeContents -> TypeContents -> TypeContents
Semigroup, Semigroup TypeContents
TypeContents
Semigroup TypeContents
-> TypeContents
-> (TypeContents -> TypeContents -> TypeContents)
-> ([TypeContents] -> TypeContents)
-> Monoid TypeContents
[TypeContents] -> TypeContents
TypeContents -> TypeContents -> TypeContents
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [TypeContents] -> TypeContents
$cmconcat :: [TypeContents] -> TypeContents
mappend :: TypeContents -> TypeContents -> TypeContents
$cmappend :: TypeContents -> TypeContents -> TypeContents
mempty :: TypeContents
$cmempty :: TypeContents
$cp1Monoid :: Semigroup TypeContents
Monoid) via Generically TypeContents

data CtrTypePattern
    = Node Type
    | FlatEmbed TypeInfo
    | GenEmbed Type
    | InContainer Type CtrTypePattern
    deriving Int -> CtrTypePattern -> ShowS
[CtrTypePattern] -> ShowS
CtrTypePattern -> String
(Int -> CtrTypePattern -> ShowS)
-> (CtrTypePattern -> String)
-> ([CtrTypePattern] -> ShowS)
-> Show CtrTypePattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CtrTypePattern] -> ShowS
$cshowList :: [CtrTypePattern] -> ShowS
show :: CtrTypePattern -> String
$cshow :: CtrTypePattern -> String
showsPrec :: Int -> CtrTypePattern -> ShowS
$cshowsPrec :: Int -> CtrTypePattern -> ShowS
Show

makeTypeInfo :: Name -> Q TypeInfo
makeTypeInfo :: Name -> Q TypeInfo
makeTypeInfo Name
name =
    do
        DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
name
        (Type
dst, Name
var) <- DatatypeInfo -> Q (Type, Name)
parts DatatypeInfo
info
        let makeCons :: ConstructorInfo
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
makeCons ConstructorInfo
c =
                (Type -> Q (Either Type CtrTypePattern))
-> [Type] -> Q [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType Name
name Name
var) (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
c)
                Q [Either Type CtrTypePattern]
-> ([Either Type CtrTypePattern]
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ConstructorInfo -> Name
D.constructorName ConstructorInfo
c, ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
c, )
        [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
cons <- (ConstructorInfo
 -> Q (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [ConstructorInfo]
-> Q [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
makeCons (DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info)
        TypeInfo -> Q TypeInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo :: Name
-> Type
-> [TyVarBndrUnit]
-> Name
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> TypeInfo
TypeInfo
            { tiName :: Name
tiName = Name
name
            , tiInstance :: Type
tiInstance = Type
dst
            , tiParams :: [TyVarBndrUnit]
tiParams = DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
info [TyVarBndrUnit]
-> ([TyVarBndrUnit] -> [TyVarBndrUnit]) -> [TyVarBndrUnit]
forall a b. a -> (a -> b) -> b
& [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a]
init
            , tiHyperParam :: Name
tiHyperParam = Name
var
            , tiConstructors :: [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors = [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
cons
            }

parts :: D.DatatypeInfo -> Q (Type, Name)
parts :: DatatypeInfo -> Q (Type, Name)
parts DatatypeInfo
info =
    case DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
info of
    [] -> String -> Q (Type, Name)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected type constructor which requires arguments"
    [TyVarBndrUnit]
xs ->
        (Name -> Q (Type, Name))
-> (Name -> Type -> Q (Type, Name))
-> TyVarBndrUnit
-> Q (Type, Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndrUnit -> r
elimTV
        ((Type, Name) -> Q (Type, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Type, Name) -> Q (Type, Name))
-> (Name -> (Type, Name)) -> Name -> Q (Type, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Type
res)
        ( \Name
var Type
c ->
            case Type
c of
            ConT Name
aHyper | Name
aHyper Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''AHyperType -> (Type, Name) -> Q (Type, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
res, Name
var)
            Type
_ -> String -> Q (Type, Name)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected last argument to be a AHyperType variable"
        ) ([TyVarBndrUnit] -> TyVarBndrUnit
forall a. [a] -> a
last [TyVarBndrUnit]
xs)
        where
            res :: Type
res =
                (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)) ([TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a]
init [TyVarBndrUnit]
xs [TyVarBndrUnit] -> (TyVarBndrUnit -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName)

childrenTypes :: TypeInfo -> TypeContents
childrenTypes :: TypeInfo -> TypeContents
childrenTypes TypeInfo
info = State (Set Type) TypeContents -> Set Type -> TypeContents
forall s a. State s a -> s -> a
evalState (TypeInfo -> State (Set Type) TypeContents
childrenTypesH TypeInfo
info) Set Type
forall a. Monoid a => a
mempty

childrenTypesH ::
    TypeInfo -> State (Set Type) TypeContents
childrenTypesH :: TypeInfo -> State (Set Type) TypeContents
childrenTypesH TypeInfo
info =
    do
        Bool
did <- (Set Type -> Bool) -> StateT (Set Type) Identity Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Set Type -> Getting Bool (Set Type) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Index (Set Type) -> Lens' (Set Type) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains (TypeInfo -> Type
tiInstance TypeInfo
info))
        if Bool
did
            then TypeContents -> State (Set Type) TypeContents
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeContents
forall a. Monoid a => a
mempty
            else
                (Set Type -> Set Type) -> StateT (Set Type) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Index (Set Type) -> Lens' (Set Type) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains (TypeInfo -> Type
tiInstance TypeInfo
info) ((Bool -> Identity Bool) -> Set Type -> Identity (Set Type))
-> Bool -> Set Type -> Set Type
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) StateT (Set Type) Identity ()
-> StateT (Set Type) Identity [TypeContents]
-> StateT (Set Type) Identity [TypeContents]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                (CtrTypePattern -> State (Set Type) TypeContents)
-> [CtrTypePattern] -> StateT (Set Type) Identity [TypeContents]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CtrTypePattern -> State (Set Type) TypeContents
addPat (TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Const
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Type CtrTypePattern])
  -> Const
       (Endo [CtrTypePattern])
       (Name, ConstructorVariant, [Either Type CtrTypePattern]))
 -> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
 -> Const
      (Endo [CtrTypePattern])
      [(Name, ConstructorVariant, [Either Type CtrTypePattern])])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> Const
         (Endo [CtrTypePattern])
         (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Type CtrTypePattern]
  -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
 -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type CtrTypePattern
 -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> Either Type CtrTypePattern
    -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Type CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right)
                    StateT (Set Type) Identity [TypeContents]
-> ([TypeContents] -> TypeContents)
-> State (Set Type) TypeContents
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [TypeContents] -> TypeContents
forall a. Monoid a => [a] -> a
mconcat
    where
        addPat :: CtrTypePattern -> State (Set Type) TypeContents
addPat (FlatEmbed TypeInfo
inner) = TypeInfo -> State (Set Type) TypeContents
childrenTypesH TypeInfo
inner
        addPat (Node Type
x) = TypeContents -> State (Set Type) TypeContents
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeContents
forall a. Monoid a => a
mempty { tcChildren :: Set Type
tcChildren = Set Type
forall a. Monoid a => a
mempty Set Type -> (Set Type -> Set Type) -> Set Type
forall a b. a -> (a -> b) -> b
& Index (Set Type) -> Lens' (Set Type) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains Type
Index (Set Type)
x ((Bool -> Identity Bool) -> Set Type -> Identity (Set Type))
-> Bool -> Set Type -> Set Type
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True }
        addPat (GenEmbed Type
x) = TypeContents -> State (Set Type) TypeContents
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeContents
forall a. Monoid a => a
mempty { tcEmbeds :: Set Type
tcEmbeds = Set Type
forall a. Monoid a => a
mempty Set Type -> (Set Type -> Set Type) -> Set Type
forall a b. a -> (a -> b) -> b
& Index (Set Type) -> Lens' (Set Type) Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains Type
Index (Set Type)
x ((Bool -> Identity Bool) -> Set Type -> Identity (Set Type))
-> Bool -> Set Type -> Set Type
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True }
        addPat (InContainer Type
_ CtrTypePattern
x) = CtrTypePattern -> State (Set Type) TypeContents
addPat CtrTypePattern
x

unapply :: Type -> (Type, [Type])
unapply :: Type -> (Type, [Type])
unapply =
    [Type] -> Type -> (Type, [Type])
go []
    where
        go :: [Type] -> Type -> (Type, [Type])
go [Type]
as (SigT Type
x Type
_) = [Type] -> Type -> (Type, [Type])
go [Type]
as Type
x
        go [Type]
as (AppT Type
f Type
a) = [Type] -> Type -> (Type, [Type])
go (Type
aType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
as) Type
f
        go [Type]
as Type
x = (Type
x, [Type]
as)

matchType :: Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType :: Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType Name
_ Name
var (ConT Name
get `AppT` VarT Name
h `AppT` (PromotedT Name
aHyper `AppT` Type
x))
    | Name
get Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''GetHyperType Bool -> Bool -> Bool
&& Name
aHyper Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'AHyperType Bool -> Bool -> Bool
&& Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var =
        Type -> CtrTypePattern
Node Type
x CtrTypePattern
-> (CtrTypePattern -> Either Type CtrTypePattern)
-> Either Type CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Either Type CtrTypePattern
forall a b. b -> Either a b
Right Either Type CtrTypePattern
-> (Either Type CtrTypePattern -> Q (Either Type CtrTypePattern))
-> Q (Either Type CtrTypePattern)
forall a b. a -> (a -> b) -> b
& Either Type CtrTypePattern -> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
matchType Name
_ Name
var (InfixT (VarT Name
h) Name
hash Type
x)
    | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(:#) Bool -> Bool -> Bool
&& Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var =
        Type -> CtrTypePattern
Node Type
x CtrTypePattern
-> (CtrTypePattern -> Either Type CtrTypePattern)
-> Either Type CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Either Type CtrTypePattern
forall a b. b -> Either a b
Right Either Type CtrTypePattern
-> (Either Type CtrTypePattern -> Q (Either Type CtrTypePattern))
-> Q (Either Type CtrTypePattern)
forall a b. a -> (a -> b) -> b
& Either Type CtrTypePattern -> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
matchType Name
_ Name
var (ConT Name
hash `AppT` VarT Name
h `AppT` Type
x)
    | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(:#) Bool -> Bool -> Bool
&& Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var =
        Type -> CtrTypePattern
Node Type
x CtrTypePattern
-> (CtrTypePattern -> Either Type CtrTypePattern)
-> Either Type CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Either Type CtrTypePattern
forall a b. b -> Either a b
Right Either Type CtrTypePattern
-> (Either Type CtrTypePattern -> Q (Either Type CtrTypePattern))
-> Q (Either Type CtrTypePattern)
forall a b. a -> (a -> b) -> b
& Either Type CtrTypePattern -> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
matchType Name
top Name
var (Type
x `AppT` VarT Name
h)
    | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var Bool -> Bool -> Bool
&& Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
ConT ''GetHyperType =
        case Type -> (Type, [Type])
unapply Type
x of
        (ConT Name
c, [Type]
args) | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
top ->
            do
                DatatypeInfo
inner <- Name -> Q DatatypeInfo
D.reifyDatatype Name
c
                let innerVars :: [Name]
innerVars = DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
inner [TyVarBndrUnit] -> (TyVarBndrUnit -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName
                let subst :: Map Name Type
subst =
                        [Type]
args [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Name -> Type
VarT Name
var]
                        [Type] -> ([Type] -> [(Name, Type)]) -> [(Name, Type)]
forall a b. a -> (a -> b) -> b
& [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
innerVars
                        [(Name, Type)]
-> ([(Name, Type)] -> Map Name Type) -> Map Name Type
forall a b. a -> (a -> b) -> b
& [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                let makeCons :: ConstructorInfo
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
makeCons ConstructorInfo
i =
                        ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
i
                        [Type] -> (Type -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
D.applySubstitution Map Name Type
subst
                        [Type]
-> ([Type] -> Q [Either Type CtrTypePattern])
-> Q [Either Type CtrTypePattern]
forall a b. a -> (a -> b) -> b
& (Type -> Q (Either Type CtrTypePattern))
-> [Type] -> Q [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType Name
top Name
var)
                        Q [Either Type CtrTypePattern]
-> ([Either Type CtrTypePattern]
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ConstructorInfo -> Name
D.constructorName ConstructorInfo
i, ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
i, )
                [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
cons <- (ConstructorInfo
 -> Q (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [ConstructorInfo]
-> Q [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo
-> Q (Name, ConstructorVariant, [Either Type CtrTypePattern])
makeCons (DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
inner)
                if Name
var Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Type] -> [TyVarBndrUnit]
D.freeVariablesWellScoped ([(Name, ConstructorVariant, [Either Type CtrTypePattern])]
cons [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Getting
     (Endo [Type])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     Type
-> [Type]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [Type])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Const
     (Endo [Type])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Type CtrTypePattern])
  -> Const
       (Endo [Type])
       (Name, ConstructorVariant, [Either Type CtrTypePattern]))
 -> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
 -> Const
      (Endo [Type])
      [(Name, ConstructorVariant, [Either Type CtrTypePattern])])
-> ((Type -> Const (Endo [Type]) Type)
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> Const
         (Endo [Type])
         (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Getting
     (Endo [Type])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Type CtrTypePattern]
 -> Const (Endo [Type]) [Either Type CtrTypePattern])
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [Type])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Type CtrTypePattern]
  -> Const (Endo [Type]) [Either Type CtrTypePattern])
 -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [Type])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> ((Type -> Const (Endo [Type]) Type)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [Type]) [Either Type CtrTypePattern])
-> (Type -> Const (Endo [Type]) Type)
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [Type])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type CtrTypePattern
 -> Const (Endo [Type]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [Type]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [Type]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [Type]) [Either Type CtrTypePattern])
-> ((Type -> Const (Endo [Type]) Type)
    -> Either Type CtrTypePattern
    -> Const (Endo [Type]) (Either Type CtrTypePattern))
-> (Type -> Const (Endo [Type]) Type)
-> [Either Type CtrTypePattern]
-> Const (Endo [Type]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Const (Endo [Type]) Type)
-> Either Type CtrTypePattern
-> Const (Endo [Type]) (Either Type CtrTypePattern)
forall a c b. Prism (Either a c) (Either b c) a b
Lens._Left) [TyVarBndrUnit] -> (TyVarBndrUnit -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName)
                    then
                        TypeInfo -> CtrTypePattern
FlatEmbed TypeInfo :: Name
-> Type
-> [TyVarBndrUnit]
-> Name
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> TypeInfo
TypeInfo
                        { tiName :: Name
tiName = Name
c
                        , tiInstance :: Type
tiInstance = Type
x
                        , tiParams :: [TyVarBndrUnit]
tiParams = DatatypeInfo -> [TyVarBndrUnit]
D.datatypeVars DatatypeInfo
inner [TyVarBndrUnit]
-> ([TyVarBndrUnit] -> [TyVarBndrUnit]) -> [TyVarBndrUnit]
forall a b. a -> (a -> b) -> b
& [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a]
init
                        , tiHyperParam :: Name
tiHyperParam = Name
var
                        , tiConstructors :: [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors = [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
cons
                        } CtrTypePattern
-> (CtrTypePattern -> Q CtrTypePattern) -> Q CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Q CtrTypePattern
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    else
                        Type -> CtrTypePattern
GenEmbed Type
x CtrTypePattern
-> (CtrTypePattern -> Q CtrTypePattern) -> Q CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Q CtrTypePattern
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Type, [Type])
_ -> Type -> CtrTypePattern
GenEmbed Type
x CtrTypePattern
-> (CtrTypePattern -> Q CtrTypePattern) -> Q CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Q CtrTypePattern
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Q CtrTypePattern
-> (CtrTypePattern -> Either Type CtrTypePattern)
-> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CtrTypePattern -> Either Type CtrTypePattern
forall a b. b -> Either a b
Right
matchType Name
top Name
var x :: Type
x@(AppT Type
f Type
a) =
    -- TODO: check if applied over a functor-kinded type.
    Name -> Name -> Type -> Q (Either Type CtrTypePattern)
matchType Name
top Name
var Type
a
    Q (Either Type CtrTypePattern)
-> (Either Type CtrTypePattern -> Either Type CtrTypePattern)
-> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
    \case
    Left{} -> Type -> Either Type CtrTypePattern
forall a b. a -> Either a b
Left Type
x
    Right CtrTypePattern
pat -> Type -> CtrTypePattern -> CtrTypePattern
InContainer Type
f CtrTypePattern
pat CtrTypePattern
-> (CtrTypePattern -> Either Type CtrTypePattern)
-> Either Type CtrTypePattern
forall a b. a -> (a -> b) -> b
& CtrTypePattern -> Either Type CtrTypePattern
forall a b. b -> Either a b
Right
matchType Name
_ Name
_ Type
t = Type -> Either Type CtrTypePattern
forall a b. a -> Either a b
Left Type
t Either Type CtrTypePattern
-> (Either Type CtrTypePattern -> Q (Either Type CtrTypePattern))
-> Q (Either Type CtrTypePattern)
forall a b. a -> (a -> b) -> b
& Either Type CtrTypePattern -> Q (Either Type CtrTypePattern)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

getVar :: Type -> Maybe Name
getVar :: Type -> Maybe Name
getVar (VarT Name
x) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
getVar (SigT Type
x Type
_) = Type -> Maybe Name
getVar Type
x
getVar Type
_ = Maybe Name
forall a. Maybe a
Nothing

toTuple :: Foldable t => t Type -> Type
toTuple :: t Type -> Type
toTuple t Type
xs = (Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT (t Type -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Type
xs)) t Type
xs

applicativeStyle :: Q Exp -> [Q Exp] -> Q Exp
applicativeStyle :: Q Exp -> [Q Exp] -> Q Exp
applicativeStyle Q Exp
f =
    (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
ap [|pure $f|]
    where
        ap :: Q Exp -> Q Exp -> Q Exp
ap Q Exp
x Q Exp
y = [|$x <*> $y|]

makeConstructorVars :: String -> [a] -> [(a, Name)]
makeConstructorVars :: String -> [a] -> [(a, Name)]
makeConstructorVars String
prefix [a]
fields =
    [Int
0::Int ..] [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] -> ShowS -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
:String
prefix) String -> ShowS
forall a. Semigroup 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] -> [(a, Name)]) -> [(a, Name)]
forall a b. a -> (a -> b) -> b
& [a] -> [Name] -> [(a, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
fields

consPat :: Name -> [(a, Name)] -> Q Pat
consPat :: Name -> [(a, Name)] -> Q Pat
consPat Name
c [(a, Name)]
vars = Name -> [Q Pat] -> Q Pat
conP Name
c ([(a, Name)]
vars [(a, Name)] -> ((a, Name) -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (a, Name) -> Name
forall a b. (a, b) -> b
snd [Name] -> (Name -> Q Pat) -> [Q Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> Q Pat
varP)

simplifyContext :: [Pred] -> CxtQ
simplifyContext :: [Type] -> CxtQ
simplifyContext [Type]
preds =
    StateT (Set (Name, [Type]), Set Type) Q ()
-> (Set (Name, [Type]), Set Type)
-> Q (Set (Name, [Type]), Set Type)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ([Type] -> StateT (Set (Name, [Type]), Set Type) Q ()
forall s (t :: (* -> *) -> * -> *) b b.
(MonadState s (t Q), MonadTrans t, Field1 s s b b, Field2 s s b b,
 Contains b, Contains b, Index b ~ (Name, [Type]),
 Index b ~ Type) =>
[Type] -> t Q ()
goPreds [Type]
preds) (Set (Name, [Type])
forall a. Monoid a => a
mempty :: Set (Name, [Type]), Set Type
forall a. Monoid a => a
mempty :: Set Pred)
    Q (Set (Name, [Type]), Set Type)
-> ((Set (Name, [Type]), Set Type) -> [Type]) -> CxtQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Set (Name, [Type]), Set Type)
-> Getting (Endo [Type]) (Set (Name, [Type]), Set Type) Type
-> [Type]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Set Type -> Const (Endo [Type]) (Set Type))
-> (Set (Name, [Type]), Set Type)
-> Const (Endo [Type]) (Set (Name, [Type]), Set Type)
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 ((Set Type -> Const (Endo [Type]) (Set Type))
 -> (Set (Name, [Type]), Set Type)
 -> Const (Endo [Type]) (Set (Name, [Type]), Set Type))
-> ((Type -> Const (Endo [Type]) Type)
    -> Set Type -> Const (Endo [Type]) (Set Type))
-> Getting (Endo [Type]) (Set (Name, [Type]), Set Type) Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Const (Endo [Type]) Type)
-> Set Type -> Const (Endo [Type]) (Set Type)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded)
    where
        goPreds :: [Type] -> t Q ()
goPreds [Type]
ps = [Type]
ps [Type] -> (Type -> (Type, [Type])) -> [(Type, [Type])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Type -> (Type, [Type])
unapply [(Type, [Type])] -> ([(Type, [Type])] -> t Q ()) -> t Q ()
forall a b. a -> (a -> b) -> b
& ((Type, [Type]) -> t Q ()) -> [(Type, [Type])] -> t Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Type, [Type]) -> t Q ()
go
        go :: (Type, [Type]) -> t Q ()
go (Type
c, [VarT Name
v]) =
            -- Work-around reifyInstances returning instances for type variables
            -- by not checking.
            Type -> [Type] -> t Q ()
forall s (m :: * -> *) b (t :: * -> *).
(MonadState s m, Field2 s s b b, Contains b, Foldable t,
 Index b ~ Type) =>
Type -> t Type -> m ()
yep Type
c [Name -> Type
VarT Name
v]
        go (ConT Name
c, [Type]
xs) =
            Getting Bool s Bool -> t Q Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use ((b -> Const Bool b) -> s -> Const Bool s
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 ((b -> Const Bool b) -> s -> Const Bool s)
-> ((Bool -> Const Bool Bool) -> b -> Const Bool b)
-> Getting Bool s Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index b -> Lens' b Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains (Name, [Type])
Index b
key)
            t Q Bool -> (Bool -> t Q ()) -> t Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            \case
            Bool
True -> () -> t Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- already checked
            Bool
False ->
                do
                    (b -> Identity b) -> s -> Identity s
forall s t a b. Field1 s t a b => Lens s t a b
Lens._1 ((b -> Identity b) -> s -> Identity s)
-> ((Bool -> Identity Bool) -> b -> Identity b)
-> (Bool -> Identity Bool)
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index b -> Lens' b Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains (Name, [Type])
Index b
key ((Bool -> Identity Bool) -> s -> Identity s) -> Bool -> t Q ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
                    Name -> [Type] -> Q [InstanceDec]
reifyInstances Name
c [Type]
xs Q [InstanceDec]
-> (Q [InstanceDec] -> t Q [InstanceDec]) -> t Q [InstanceDec]
forall a b. a -> (a -> b) -> b
& Q [InstanceDec] -> t Q [InstanceDec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                        t Q [InstanceDec] -> ([InstanceDec] -> t Q ()) -> t Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        \case
                        [InstanceD Maybe Overlap
_ [Type]
context Type
other [InstanceDec]
_] ->
                            [Type] -> Q (Map Name Type)
D.unifyTypes [Type
other, (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
c) [Type]
xs] Q (Map Name Type)
-> (Q (Map Name Type) -> t Q (Map Name Type))
-> t Q (Map Name Type)
forall a b. a -> (a -> b) -> b
& Q (Map Name Type) -> t Q (Map Name Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                            t Q (Map Name Type) -> (Map Name Type -> [Type]) -> t Q [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
`D.applySubstitution` [Type]
context)
                            t Q [Type] -> ([Type] -> t Q ()) -> t Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type] -> t Q ()
goPreds
                        [InstanceDec]
_ -> Type -> [Type] -> t Q ()
forall s (m :: * -> *) b (t :: * -> *).
(MonadState s m, Field2 s s b b, Contains b, Foldable t,
 Index b ~ Type) =>
Type -> t Type -> m ()
yep (Name -> Type
ConT Name
c) [Type]
xs
            where
                key :: (Name, [Type])
key = (Name
c, [Type]
xs)
        go (Type
c, [Type]
xs) = Type -> [Type] -> t Q ()
forall s (m :: * -> *) b (t :: * -> *).
(MonadState s m, Field2 s s b b, Contains b, Foldable t,
 Index b ~ Type) =>
Type -> t Type -> m ()
yep Type
c [Type]
xs
        yep :: Type -> t Type -> m ()
yep Type
c t Type
xs = (b -> Identity b) -> s -> Identity s
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 ((b -> Identity b) -> s -> Identity s)
-> ((Bool -> Identity Bool) -> b -> Identity b)
-> (Bool -> Identity Bool)
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index b -> Lens' b Bool
forall m. Contains m => Index m -> Lens' m Bool
Lens.contains ((Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
c t Type
xs) ((Bool -> Identity Bool) -> s -> Identity s) -> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True

data NodeWitnesses = NodeWitnesses
    { NodeWitnesses -> Type -> Q Exp
nodeWit :: Type -> Q Exp
    , NodeWitnesses -> Type -> Q Exp
embedWit :: Type -> Q Exp
    , NodeWitnesses -> [Name]
nodeWitCtrs :: [Name]
    , NodeWitnesses -> [Name]
embedWitCtrs :: [Name]
    }

niceName :: Name -> String
niceName :: Name -> String
niceName = ShowS
forall a. [a] -> [a]
reverse ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show

makeNodeOf :: TypeInfo -> ([Type -> Q Con], NodeWitnesses)
makeNodeOf :: TypeInfo -> ([Type -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
info =
    ( ([(Type, Name)]
nodes [(Type, Name)]
-> ((Type, Name) -> Type -> Q Con) -> [Type -> Q Con]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type, Name) -> Type -> Q Con
nodeGadtType) [Type -> Q Con] -> [Type -> Q Con] -> [Type -> Q Con]
forall a. Semigroup a => a -> a -> a
<> ([(Type, Name)]
embeds [(Type, Name)]
-> ((Type, Name) -> Type -> Q Con) -> [Type -> Q Con]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type, Name) -> Type -> Q Con
embedGadtType)
    , NodeWitnesses :: (Type -> Q Exp)
-> (Type -> Q Exp) -> [Name] -> [Name] -> NodeWitnesses
NodeWitnesses
        { nodeWit :: Type -> Q Exp
nodeWit = [(Type, Name)]
nodes [(Type, Name)]
-> ([(Type, Name)] -> Map Type Name) -> Map Type Name
forall a b. a -> (a -> b) -> b
& [(Type, Name)] -> Map Type Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList Map Type Name -> (Map Type Name -> Type -> Name) -> Type -> Name
forall a b. a -> (a -> b) -> b
& Map Type Name -> Type -> Name
getWit (Type -> Name) -> (Name -> Q Exp) -> Type -> Q Exp
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
x -> [|HWitness $(conE x)|]
        , embedWit :: Type -> Q Exp
embedWit = [(Type, Name)]
embeds [(Type, Name)]
-> ([(Type, Name)] -> Map Type Name) -> Map Type Name
forall a b. a -> (a -> b) -> b
& [(Type, Name)] -> Map Type Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList Map Type Name -> (Map Type Name -> Type -> Name) -> Type -> Name
forall a b. a -> (a -> b) -> b
& Map Type Name -> Type -> Name
getWit (Type -> Name) -> (Name -> Q Exp) -> Type -> Q Exp
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
x -> [|HWitness . $(conE x)|]
        , nodeWitCtrs :: [Name]
nodeWitCtrs = [(Type, Name)]
nodes [(Type, Name)] -> ((Type, Name) -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type, Name) -> Name
forall a b. (a, b) -> b
snd
        , embedWitCtrs :: [Name]
embedWitCtrs = [(Type, Name)]
embeds [(Type, Name)] -> ((Type, Name) -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Type, Name) -> Name
forall a b. (a, b) -> b
snd
        }
    )
    where
        niceTypeName :: String
niceTypeName = TypeInfo -> Name
tiName TypeInfo
info Name -> (Name -> String) -> String
forall a b. a -> (a -> b) -> b
& Name -> String
niceName
        nodeBase :: String
nodeBase = String
"W_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
niceTypeName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_"
        embedBase :: String
embedBase = String
"E_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
niceTypeName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_"
        pats :: [Either Type CtrTypePattern]
pats = TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> [Either Type CtrTypePattern])
-> [Either Type CtrTypePattern]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Getting
     [Either Type CtrTypePattern]
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
     [Either Type CtrTypePattern]
-> [Either Type CtrTypePattern]
forall s a. s -> Getting a s a -> a
^. Getting
  [Either Type CtrTypePattern]
  (Name, ConstructorVariant, [Either Type CtrTypePattern])
  [Either Type CtrTypePattern]
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3)
        nodes :: [(Type, Name)]
nodes =
            [Either Type CtrTypePattern]
pats [Either Type CtrTypePattern]
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Either Type CtrTypePattern
 -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> Either Type CtrTypePattern
    -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Type CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right [CtrTypePattern] -> (CtrTypePattern -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> [Type]
nodesForPat [Type] -> ([Type] -> [Type]) -> [Type]
forall a b. a -> (a -> b) -> b
& [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub
            [Type] -> (Type -> (Type, Name)) -> [(Type, Name)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Type
t -> (Type
t, String -> Name
mkName (String
nodeBase String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
mkNiceTypeName Type
t))
        nodesForPat :: CtrTypePattern -> [Type]
nodesForPat (Node Type
t) = [Type
t]
        nodesForPat (InContainer Type
_ CtrTypePattern
pat) = CtrTypePattern -> [Type]
nodesForPat CtrTypePattern
pat
        nodesForPat (FlatEmbed TypeInfo
x) = TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
x [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Const
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Type CtrTypePattern])
  -> Const
       (Endo [CtrTypePattern])
       (Name, ConstructorVariant, [Either Type CtrTypePattern]))
 -> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
 -> Const
      (Endo [CtrTypePattern])
      [(Name, ConstructorVariant, [Either Type CtrTypePattern])])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> Const
         (Endo [CtrTypePattern])
         (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Type CtrTypePattern]
  -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
 -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type CtrTypePattern
 -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> Either Type CtrTypePattern
    -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Type CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right [CtrTypePattern] -> (CtrTypePattern -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> [Type]
nodesForPat
        nodesForPat CtrTypePattern
_ = []
        nodeGadtType :: (Type, Name) -> Type -> Q Con
nodeGadtType (Type
t, Name
n) Type
c = [Name] -> [StrictTypeQ] -> TypeQ -> Q Con
gadtC [Name
n] [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
c Type -> Type -> Type
`AppT` Type
t))
        embeds :: [(Type, Name)]
embeds =
            [Either Type CtrTypePattern]
pats [Either Type CtrTypePattern]
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Either Type CtrTypePattern
 -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> Either Type CtrTypePattern
    -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Type CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right [CtrTypePattern] -> (CtrTypePattern -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> [Type]
embedsForPat [Type] -> ([Type] -> [Type]) -> [Type]
forall a b. a -> (a -> b) -> b
& [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub
            [Type] -> (Type -> (Type, Name)) -> [(Type, Name)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Type
t -> (Type
t, String -> Name
mkName (String
embedBase String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
mkNiceTypeName Type
t))
        embedsForPat :: CtrTypePattern -> [Type]
embedsForPat (GenEmbed Type
t) = [Type
t]
        embedsForPat (InContainer Type
_ CtrTypePattern
pat) = CtrTypePattern -> [Type]
embedsForPat CtrTypePattern
pat
        embedsForPat (FlatEmbed TypeInfo
x) = TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
x [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
-> [CtrTypePattern]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
-> Const
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, ConstructorVariant, [Either Type CtrTypePattern])
  -> Const
       (Endo [CtrTypePattern])
       (Name, ConstructorVariant, [Either Type CtrTypePattern]))
 -> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
 -> Const
      (Endo [CtrTypePattern])
      [(Name, ConstructorVariant, [Either Type CtrTypePattern])])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
    -> Const
         (Endo [CtrTypePattern])
         (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> Getting
     (Endo [CtrTypePattern])
     [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
     CtrTypePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 (([Either Type CtrTypePattern]
  -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
 -> (Name, ConstructorVariant, [Either Type CtrTypePattern])
 -> Const
      (Endo [CtrTypePattern])
      (Name, ConstructorVariant, [Either Type CtrTypePattern]))
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> [Either Type CtrTypePattern]
    -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Const
     (Endo [CtrTypePattern])
     (Name, ConstructorVariant, [Either Type CtrTypePattern])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type CtrTypePattern
 -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Type CtrTypePattern
  -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
 -> [Either Type CtrTypePattern]
 -> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern])
-> ((CtrTypePattern
     -> Const (Endo [CtrTypePattern]) CtrTypePattern)
    -> Either Type CtrTypePattern
    -> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern))
-> (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> [Either Type CtrTypePattern]
-> Const (Endo [CtrTypePattern]) [Either Type CtrTypePattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtrTypePattern -> Const (Endo [CtrTypePattern]) CtrTypePattern)
-> Either Type CtrTypePattern
-> Const (Endo [CtrTypePattern]) (Either Type CtrTypePattern)
forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right [CtrTypePattern] -> (CtrTypePattern -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> [Type]
embedsForPat
        embedsForPat CtrTypePattern
_ = []
        embedGadtType :: (Type, Name) -> Type -> Q Con
embedGadtType (Type
t, Name
n) Type
c =
            [Name] -> [StrictTypeQ] -> TypeQ -> Q Con
gadtC [Name
n]
            [ BangQ -> TypeQ -> StrictTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
                [t|HWitness $(pure t) $nodeVar|]
            ] [t|$(pure c) $nodeVar|]
        nodeVar :: TypeQ
nodeVar = String -> Name
mkName String
"node" Name -> (Name -> TypeQ) -> TypeQ
forall a b. a -> (a -> b) -> b
& Name -> TypeQ
varT
        getWit :: Map Type Name -> Type -> Name
        getWit :: Map Type Name -> Type -> Name
getWit Map Type Name
m Type
h =
            Map Type Name
m Map Type Name
-> Getting (First Name) (Map Type Name) Name -> Maybe Name
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (Map Type Name)
-> Traversal' (Map Type Name) (IxValue (Map Type Name))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
Lens.ix Type
Index (Map Type Name)
h
            Maybe Name -> (Maybe Name -> Name) -> Name
forall a b. a -> (a -> b) -> b
& Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (String -> Name
forall a. HasCallStack => String -> a
error (String
"Cant find witness for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
h String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map Type Name -> String
forall a. Show a => a -> String
show Map Type Name
m))

mkNiceTypeName :: Type -> String
mkNiceTypeName :: Type -> String
mkNiceTypeName =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> (Type -> [String]) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [String]
makeNiceType
    where
        makeNiceType :: Type -> [String]
makeNiceType (ConT Name
x) =
            case Name -> String
niceName Name
x of
            n :: String
n@(Char
c:String
_) | Char -> Bool
Char.isAlpha Char
c -> [String
n]
            String
_ -> [] -- Skip operators
        makeNiceType (AppT Type
x Type
y) = Type -> [String]
makeNiceType Type
x [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Type -> [String]
makeNiceType Type
y
        makeNiceType (VarT Name
x) = [(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') (Name -> String
forall a. Show a => a -> String
show Name
x)]
        makeNiceType (SigT Type
x Type
_) = Type -> [String]
makeNiceType Type
x
        makeNiceType Type
x = String -> [String]
forall a. HasCallStack => String -> a
error (String
"TODO: Witness name generator is partial! Need to support " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
x)