{-# LANGUAGE CPP #-}
#if MIN_VERSION_GLASGOW_HASKELL(9, 0, 0, 0)
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
#endif
module Yaya.Retrofit
( module Yaya.Fold,
PatternFunctorRules
( PatternFunctorRules,
patternCon,
patternField,
patternType
),
defaultRules,
extractPatternFunctor,
)
where
import safe "base" Control.Applicative (Applicative (pure))
import safe "base" Control.Category (Category (id, (.)))
import safe "base" Control.Monad ((<=<))
import safe "base" Control.Monad.Fail (MonadFail (fail))
import safe "base" Data.Bifunctor (Bifunctor (bimap))
import safe "base" Data.Bool (Bool, otherwise, (&&))
import safe "base" Data.Either (Either (Left), either)
import safe "base" Data.Eq (Eq ((==)))
import safe "base" Data.Foldable (Foldable (foldl, length, null))
import safe "base" Data.Function (const, flip, ($))
import safe "base" Data.Functor (Functor (fmap), (<$>))
import safe "base" Data.Functor.Identity (Identity (Identity, runIdentity))
import safe "base" Data.List (all, zip, zip3)
import safe "base" Data.List.NonEmpty (NonEmpty)
import safe "base" Data.Maybe (Maybe (Just, Nothing), maybe)
import safe "base" Data.Semigroup (Semigroup ((<>)))
import safe "base" Data.String (String)
import safe "base" Data.Traversable (Traversable (traverse))
import safe "base" Text.Read.Lex (isSymbolChar)
import safe "base" Text.Show (Show (show))
import safe "either" Data.Either.Validation
( Validation (Failure, Success),
validationToEither,
)
import safe qualified "template-haskell" Language.Haskell.TH as TH
import safe qualified "template-haskell" Language.Haskell.TH.Syntax as TH.Syn
import safe qualified "th-abstraction" Language.Haskell.TH.Datatype as TH.Abs
import safe "this" Yaya.Fold
( Corecursive (ana),
Projectable (project),
Recursive (cata),
Steppable (embed),
recursiveCompare,
recursiveCompare',
recursiveEq,
recursiveEq',
recursiveShowsPrec,
recursiveShowsPrec',
steppableReadPrec,
steppableReadPrec',
)
#if MIN_VERSION_template_haskell(2, 21, 0)
type TyVarBndrUnit = TH.TyVarBndrUnit
type TyVarBndrVis = TH.TyVarBndrVis
#elif MIN_VERSION_template_haskell(2, 17, 0)
type TyVarBndrUnit = TH.TyVarBndrUnit
type TyVarBndrVis = TH.TyVarBndr ()
#else
type TyVarBndrUnit = TH.TyVarBndr
type TyVarBndrVis = TH.TyVarBndr
#endif
conP' :: TH.Name -> [TH.Pat] -> TH.Pat
#if MIN_VERSION_template_haskell(2, 18, 0)
conP' :: Name -> [Pat] -> Pat
conP' Name
n = Name -> [Type] -> [Pat] -> Pat
TH.ConP Name
n []
#else
conP' = TH.ConP
#endif
extractPatternFunctor :: PatternFunctorRules -> TH.Name -> TH.Q [TH.Dec]
PatternFunctorRules
rules =
(UnsupportedDatatype -> Q [Dec])
-> (Q [Dec] -> Q [Dec])
-> Either UnsupportedDatatype (Q [Dec])
-> Q [Dec]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec])
-> (UnsupportedDatatype -> String)
-> UnsupportedDatatype
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnsupportedDatatype -> String
displayUnsupportedDatatype) Q [Dec] -> Q [Dec]
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either UnsupportedDatatype (Q [Dec]) -> Q [Dec])
-> (DatatypeInfo -> Either UnsupportedDatatype (Q [Dec]))
-> DatatypeInfo
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PatternFunctorRules
-> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])
makePrimForDI PatternFunctorRules
rules
(DatatypeInfo -> Q [Dec])
-> (Name -> Q DatatypeInfo) -> Name -> Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
TH.Abs.reifyDatatype
data PatternFunctorRules = PatternFunctorRules
{ PatternFunctorRules -> Name -> Name
patternType :: TH.Name -> TH.Name,
PatternFunctorRules -> Name -> Name
patternCon :: TH.Name -> TH.Name,
PatternFunctorRules -> Name -> Name
patternField :: TH.Name -> TH.Name
}
defaultRules :: PatternFunctorRules
defaultRules :: PatternFunctorRules
defaultRules =
PatternFunctorRules
{ patternType :: Name -> Name
patternType = Name -> Name
toFName,
patternCon :: Name -> Name
patternCon = Name -> Name
toFName,
patternField :: Name -> Name
patternField = Name -> Name
toFName
}
toFName :: TH.Name -> TH.Name
toFName :: Name -> Name
toFName = String -> Name
TH.mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> String
TH.nameBase
where
f :: String -> String
f String
name
| String -> Bool
isInfixName String
name = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"$"
| Bool
otherwise = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"F"
isInfixName :: String -> Bool
isInfixName :: String -> Bool
isInfixName = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSymbolChar
data UnsupportedDatatype
= UnsupportedInstTypes (NonEmpty TH.Type)
| UnsupportedVariant TH.Abs.DatatypeVariant
| UnsupportedGADT [TyVarBndrUnit] TH.Cxt
| NonBinaryInfixConstructor [(TH.Bang, TH.Type)]
deriving stock (Int -> UnsupportedDatatype -> String -> String
[UnsupportedDatatype] -> String -> String
UnsupportedDatatype -> String
(Int -> UnsupportedDatatype -> String -> String)
-> (UnsupportedDatatype -> String)
-> ([UnsupportedDatatype] -> String -> String)
-> Show UnsupportedDatatype
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnsupportedDatatype -> String -> String
showsPrec :: Int -> UnsupportedDatatype -> String -> String
$cshow :: UnsupportedDatatype -> String
show :: UnsupportedDatatype -> String
$cshowList :: [UnsupportedDatatype] -> String -> String
showList :: [UnsupportedDatatype] -> String -> String
Show)
displayUnsupportedDatatype :: UnsupportedDatatype -> String
displayUnsupportedDatatype :: UnsupportedDatatype -> String
displayUnsupportedDatatype =
(String
"extractPatternFunctor: " <>) (String -> String)
-> (UnsupportedDatatype -> String) -> UnsupportedDatatype -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. \case
UnsupportedInstTypes NonEmpty Type
tys ->
String
"Couldn't process the following types " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Type -> String
forall a. Show a => a -> String
show NonEmpty Type
tys
UnsupportedVariant DatatypeVariant
_variant -> String
"Data families are currently not supported."
UnsupportedGADT [TyVarBndrUnit]
_vars [Type]
_context -> String
"GADTs are not currently supported."
NonBinaryInfixConstructor [(Bang, Type)]
bts ->
String
"internal error: wrong number of BangTypes for InfixConstructor; expected 2, but got "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(Bang, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bang, Type)]
bts)
makePrimForDI ::
PatternFunctorRules ->
TH.Abs.DatatypeInfo ->
Either UnsupportedDatatype (TH.Q [TH.Dec])
makePrimForDI :: PatternFunctorRules
-> DatatypeInfo -> Either UnsupportedDatatype (Q [Dec])
makePrimForDI
PatternFunctorRules
rules
( TH.Abs.DatatypeInfo
{ datatypeName :: DatatypeInfo -> Name
TH.Abs.datatypeName = Name
tyName,
datatypeInstTypes :: DatatypeInfo -> [Type]
TH.Abs.datatypeInstTypes = [Type]
instTys,
datatypeCons :: DatatypeInfo -> [ConstructorInfo]
TH.Abs.datatypeCons = [ConstructorInfo]
cons,
datatypeVariant :: DatatypeInfo -> DatatypeVariant
TH.Abs.datatypeVariant = DatatypeVariant
variant
}
) =
Either UnsupportedDatatype (Q [Dec])
-> (SafeDatatypeVariant -> Either UnsupportedDatatype (Q [Dec]))
-> Maybe SafeDatatypeVariant
-> Either UnsupportedDatatype (Q [Dec])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec])
forall a b. a -> Either a b
Left (UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec]))
-> UnsupportedDatatype -> Either UnsupportedDatatype (Q [Dec])
forall a b. (a -> b) -> a -> b
$ DatatypeVariant -> UnsupportedDatatype
UnsupportedVariant DatatypeVariant
variant)
( \SafeDatatypeVariant
safeVariant ->
(NonEmpty Type -> UnsupportedDatatype)
-> ([TyVarBndrUnit] -> Q [Dec])
-> Either (NonEmpty Type) [TyVarBndrUnit]
-> Either UnsupportedDatatype (Q [Dec])
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
NonEmpty Type -> UnsupportedDatatype
UnsupportedInstTypes
(([TyVarBndrUnit] -> [ConstructorInfo] -> Q [Dec])
-> [ConstructorInfo] -> [TyVarBndrUnit] -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PatternFunctorRules
-> SafeDatatypeVariant
-> Name
-> [TyVarBndrUnit]
-> [ConstructorInfo]
-> Q [Dec]
makePrimForDI' PatternFunctorRules
rules SafeDatatypeVariant
safeVariant Name
tyName) [ConstructorInfo]
cons)
(Either (NonEmpty Type) [TyVarBndrUnit]
-> Either UnsupportedDatatype (Q [Dec]))
-> (Validation (NonEmpty Type) [TyVarBndrUnit]
-> Either (NonEmpty Type) [TyVarBndrUnit])
-> Validation (NonEmpty Type) [TyVarBndrUnit]
-> Either UnsupportedDatatype (Q [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Validation (NonEmpty Type) [TyVarBndrUnit]
-> Either (NonEmpty Type) [TyVarBndrUnit]
forall e a. Validation e a -> Either e a
validationToEither
(Validation (NonEmpty Type) [TyVarBndrUnit]
-> Either UnsupportedDatatype (Q [Dec]))
-> Validation (NonEmpty Type) [TyVarBndrUnit]
-> Either UnsupportedDatatype (Q [Dec])
forall a b. (a -> b) -> a -> b
$ (Type -> Validation (NonEmpty Type) TyVarBndrUnit)
-> [Type] -> Validation (NonEmpty Type) [TyVarBndrUnit]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
(\Type
ty -> Validation (NonEmpty Type) TyVarBndrUnit
-> (TyVarBndrUnit -> Validation (NonEmpty Type) TyVarBndrUnit)
-> Maybe TyVarBndrUnit
-> Validation (NonEmpty Type) TyVarBndrUnit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NonEmpty Type -> Validation (NonEmpty Type) TyVarBndrUnit
forall e a. e -> Validation e a
Failure (NonEmpty Type -> Validation (NonEmpty Type) TyVarBndrUnit)
-> NonEmpty Type -> Validation (NonEmpty Type) TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Type -> NonEmpty Type
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) TyVarBndrUnit -> Validation (NonEmpty Type) TyVarBndrUnit
forall e a. a -> Validation e a
Success (Maybe TyVarBndrUnit -> Validation (NonEmpty Type) TyVarBndrUnit)
-> Maybe TyVarBndrUnit -> Validation (NonEmpty Type) TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Type -> Maybe TyVarBndrUnit
toTyVarBndr Type
ty)
[Type]
instTys
)
(Maybe SafeDatatypeVariant -> Either UnsupportedDatatype (Q [Dec]))
-> Maybe SafeDatatypeVariant
-> Either UnsupportedDatatype (Q [Dec])
forall a b. (a -> b) -> a -> b
$ DatatypeVariant -> Maybe SafeDatatypeVariant
excludeDataFamInstance DatatypeVariant
variant
where
toTyVarBndr :: TH.Type -> Maybe TyVarBndrVis
toTyVarBndr :: Type -> Maybe TyVarBndrUnit
toTyVarBndr (TH.VarT Name
n) = TyVarBndrUnit -> Maybe TyVarBndrUnit
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndrUnit -> Maybe TyVarBndrUnit)
-> TyVarBndrUnit -> Maybe TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Name -> TyVarBndrUnit
TH.plainTV Name
n
toTyVarBndr (TH.SigT (TH.VarT Name
n) Type
k) = TyVarBndrUnit -> Maybe TyVarBndrUnit
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndrUnit -> Maybe TyVarBndrUnit)
-> TyVarBndrUnit -> Maybe TyVarBndrUnit
forall a b. (a -> b) -> a -> b
$ Name -> Type -> TyVarBndrUnit
TH.kindedTV Name
n Type
k
toTyVarBndr Type
_ = Maybe TyVarBndrUnit
forall a. Maybe a
Nothing
deriveds :: [TH.DerivClause]
deriveds :: [DerivClause]
deriveds =
DerivClause -> [DerivClause]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivClause -> [DerivClause]) -> DerivClause -> [DerivClause]
forall a b. (a -> b) -> a -> b
$
Maybe DerivStrategy -> [Type] -> DerivClause
TH.DerivClause
(DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivStrategy
TH.StockStrategy)
[ Name -> Type
TH.ConT Name
functorTypeName,
Name -> Type
TH.ConT Name
foldableTypeName,
Name -> Type
TH.ConT Name
traversableTypeName
]
#if MIN_VERSION_th_abstraction(0, 5, 0)
data SafeDatatypeVariant = Datatype | Newtype | TypeDataV
#else
data SafeDatatypeVariant = Datatype | Newtype
#endif
excludeDataFamInstance :: TH.Abs.DatatypeVariant -> Maybe SafeDatatypeVariant
#if MIN_VERSION_th_abstraction(0, 5, 0)
excludeDataFamInstance :: DatatypeVariant -> Maybe SafeDatatypeVariant
excludeDataFamInstance = \case
DatatypeVariant
TH.Abs.DataInstance -> Maybe SafeDatatypeVariant
forall a. Maybe a
Nothing
DatatypeVariant
TH.Abs.NewtypeInstance -> Maybe SafeDatatypeVariant
forall a. Maybe a
Nothing
DatatypeVariant
TH.Abs.Datatype -> SafeDatatypeVariant -> Maybe SafeDatatypeVariant
forall a. a -> Maybe a
Just SafeDatatypeVariant
Datatype
DatatypeVariant
TH.Abs.Newtype -> SafeDatatypeVariant -> Maybe SafeDatatypeVariant
forall a. a -> Maybe a
Just SafeDatatypeVariant
Newtype
DatatypeVariant
TH.Abs.TypeData -> SafeDatatypeVariant -> Maybe SafeDatatypeVariant
forall a. a -> Maybe a
Just SafeDatatypeVariant
TypeDataV
#else
excludeDataFamInstance = \case
TH.Abs.DataInstance -> Nothing
TH.Abs.NewtypeInstance -> Nothing
TH.Abs.Datatype -> Just Datatype
TH.Abs.Newtype -> Just Newtype
#endif
makeDataDefinition ::
SafeDatatypeVariant -> TH.Name -> [TyVarBndrVis] -> [TH.Con] -> TH.Dec
#if MIN_VERSION_template_haskell(2, 20, 0) && MIN_VERSION_th_abstraction(0, 5, 0)
makeDataDefinition :: SafeDatatypeVariant -> Name -> [TyVarBndrUnit] -> [Con] -> Dec
makeDataDefinition SafeDatatypeVariant
safeVariant Name
tyName [TyVarBndrUnit]
vars [Con]
cons =
case (SafeDatatypeVariant
safeVariant, [Con]
cons) of
(SafeDatatypeVariant
Newtype, [Con
con]) -> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
TH.NewtypeD [] Name
tyName [TyVarBndrUnit]
vars Maybe Type
forall a. Maybe a
Nothing Con
con [DerivClause]
deriveds
(SafeDatatypeVariant
TypeDataV, [Con]
_) -> Name -> [TyVarBndrUnit] -> Maybe Type -> [Con] -> Dec
TH.TypeDataD Name
tyName [TyVarBndrUnit]
vars Maybe Type
forall a. Maybe a
Nothing [Con]
cons
(SafeDatatypeVariant
_, [Con]
_) -> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
tyName [TyVarBndrUnit]
vars Maybe Type
forall a. Maybe a
Nothing [Con]
cons [DerivClause]
deriveds
#else
makeDataDefinition safeVariant tyName vars cons =
case (safeVariant, cons) of
(Newtype, [con]) -> TH.NewtypeD [] tyName vars Nothing con deriveds
(_, _) -> TH.DataD [] tyName vars Nothing cons deriveds
#endif
makePrimForDI' ::
PatternFunctorRules ->
SafeDatatypeVariant ->
TH.Name ->
[TyVarBndrVis] ->
[TH.Abs.ConstructorInfo] ->
TH.Q [TH.Dec]
makePrimForDI' :: PatternFunctorRules
-> SafeDatatypeVariant
-> Name
-> [TyVarBndrUnit]
-> [ConstructorInfo]
-> Q [Dec]
makePrimForDI' PatternFunctorRules
rules SafeDatatypeVariant
safeVariant Name
tyName [TyVarBndrUnit]
vars [ConstructorInfo]
cons = do
let vars' :: [Type]
vars' = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
TH.VarT ([TyVarBndrUnit] -> [Name]
typeVars [TyVarBndrUnit]
vars)
let tyNameF :: Name
tyNameF = PatternFunctorRules -> Name -> Name
patternType PatternFunctorRules
rules Name
tyName
let s :: Type
s = Name -> [Type] -> Type
conAppsT Name
tyName [Type]
vars'
Name
rName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"r"
let r :: Type
r = Name -> Type
TH.VarT Name
rName
let varsF :: [TyVarBndrUnit]
varsF = [TyVarBndrUnit]
vars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. Semigroup a => a -> a -> a
<> [Name -> TyVarBndrUnit
TH.plainTV Name
rName]
[ConstructorInfo]
cons' <- (ConstructorInfo -> Q ConstructorInfo)
-> [ConstructorInfo] -> Q [ConstructorInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Type -> Q Type) -> ConstructorInfo -> Q ConstructorInfo
Traversal' ConstructorInfo Type
conTypeTraversal Type -> Q Type
TH.Abs.resolveTypeSynonyms) [ConstructorInfo]
cons
[Con]
consF <-
(UnsupportedDatatype -> Q [Con])
-> ([Con] -> Q [Con])
-> Either UnsupportedDatatype [Con]
-> Q [Con]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q [Con]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Con])
-> (UnsupportedDatatype -> String)
-> UnsupportedDatatype
-> Q [Con]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnsupportedDatatype -> String
displayUnsupportedDatatype) [Con] -> Q [Con]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnsupportedDatatype [Con] -> Q [Con])
-> Either UnsupportedDatatype [Con] -> Q [Con]
forall a b. (a -> b) -> a -> b
$
(ConstructorInfo -> Either UnsupportedDatatype Con)
-> [ConstructorInfo] -> Either UnsupportedDatatype [Con]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
( ConstructorInfo -> Either UnsupportedDatatype Con
toCon
(ConstructorInfo -> Either UnsupportedDatatype Con)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> Either UnsupportedDatatype Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap (PatternFunctorRules -> Name -> Name
patternCon PatternFunctorRules
rules)
(ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap (PatternFunctorRules -> Name -> Name
patternField PatternFunctorRules
rules)
(ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap (Type -> Type -> Type -> Type
substType Type
s Type
r)
)
[ConstructorInfo]
cons'
(SafeDatatypeVariant -> Name -> [TyVarBndrUnit] -> [Con] -> Dec
makeDataDefinition SafeDatatypeVariant
safeVariant Name
tyNameF [TyVarBndrUnit]
varsF [Con]
consF :)
([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [d|
instance Projectable (->) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT Name
tyNameF [Type]
vars') where
project = $([Match] -> Exp
TH.LamCaseE ([Match] -> Exp) -> Q [Match] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Match]
mkMorphism Name -> Name
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (PatternFunctorRules -> Name -> Name
patternCon PatternFunctorRules
rules) [ConstructorInfo]
cons')
instance Steppable (->) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT Name
tyNameF [Type]
vars') where
embed = $([Match] -> Exp
TH.LamCaseE ([Match] -> Exp) -> Q [Match] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Match]
mkMorphism (PatternFunctorRules -> Name -> Name
patternCon PatternFunctorRules
rules) Name -> Name
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id [ConstructorInfo]
cons')
instance Recursive (->) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT Name
tyNameF [Type]
vars') where
cata φ = φ . fmap (cata φ) . project
instance Corecursive (->) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s) $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT Name
tyNameF [Type]
vars') where
ana ψ = embed . fmap (ana ψ) . ψ
|]
mkMorphism ::
(TH.Name -> TH.Name) ->
(TH.Name -> TH.Name) ->
[TH.Abs.ConstructorInfo] ->
TH.Q [TH.Match]
mkMorphism :: (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Match]
mkMorphism Name -> Name
nFrom Name -> Name
nTo =
(ConstructorInfo -> Q Match) -> [ConstructorInfo] -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
( \ConstructorInfo
ci -> do
let n :: Name
n = ConstructorInfo -> Name
TH.Abs.constructorName ConstructorInfo
ci
[Name]
fs <- (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"x") ([Type] -> Q [Name]) -> [Type] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
TH.Abs.constructorFields ConstructorInfo
ci
Match -> Q Match
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$
Pat -> Body -> [Dec] -> Match
TH.Match
(Name -> [Pat] -> Pat
conP' (Name -> Name
nFrom Name
n) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
TH.VarP [Name]
fs))
( Exp -> Body
TH.NormalB (Exp -> Body) -> ([Exp] -> Exp) -> [Exp] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name
nTo Name
n) ([Exp] -> Body) -> [Exp] -> Body
forall a b. (a -> b) -> a -> b
$
(Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
TH.VarE [Name]
fs
)
[]
)
conNameTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Name
conNameTraversal :: Traversal' ConstructorInfo Name
conNameTraversal = (ConstructorInfo -> Name)
-> (ConstructorInfo -> Name -> ConstructorInfo)
-> Lens' ConstructorInfo Name
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> Name
TH.Abs.constructorName (\ConstructorInfo
s Name
v -> ConstructorInfo
s {TH.Abs.constructorName = v})
conFieldNameTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Name
conFieldNameTraversal :: Traversal' ConstructorInfo Name
conFieldNameTraversal =
(ConstructorInfo -> ConstructorVariant)
-> (ConstructorInfo -> ConstructorVariant -> ConstructorInfo)
-> Lens' ConstructorInfo ConstructorVariant
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> ConstructorVariant
TH.Abs.constructorVariant (\ConstructorInfo
s ConstructorVariant
v -> ConstructorInfo
s {TH.Abs.constructorVariant = v})
((ConstructorVariant -> f ConstructorVariant)
-> ConstructorInfo -> f ConstructorInfo)
-> ((Name -> f Name) -> ConstructorVariant -> f ConstructorVariant)
-> (Name -> f Name)
-> ConstructorInfo
-> f ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> f Name) -> ConstructorVariant -> f ConstructorVariant
Traversal' ConstructorVariant Name
conVariantTraversal
where
conVariantTraversal :: Traversal' TH.Abs.ConstructorVariant TH.Name
conVariantTraversal :: Traversal' ConstructorVariant Name
conVariantTraversal Name -> f Name
_ ConstructorVariant
TH.Abs.NormalConstructor =
ConstructorVariant -> f ConstructorVariant
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
TH.Abs.NormalConstructor
conVariantTraversal Name -> f Name
_ ConstructorVariant
TH.Abs.InfixConstructor = ConstructorVariant -> f ConstructorVariant
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
TH.Abs.InfixConstructor
conVariantTraversal Name -> f Name
f (TH.Abs.RecordConstructor [Name]
fs) =
[Name] -> ConstructorVariant
TH.Abs.RecordConstructor ([Name] -> ConstructorVariant) -> f [Name] -> f ConstructorVariant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> f Name) -> [Name] -> f [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Name -> f Name
f [Name]
fs
conTypeTraversal :: Traversal' TH.Abs.ConstructorInfo TH.Type
conTypeTraversal :: Traversal' ConstructorInfo Type
conTypeTraversal =
(ConstructorInfo -> [Type])
-> (ConstructorInfo -> [Type] -> ConstructorInfo)
-> Lens' ConstructorInfo [Type]
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> [Type]
TH.Abs.constructorFields (\ConstructorInfo
s [Type]
v -> ConstructorInfo
s {TH.Abs.constructorFields = v})
(([Type] -> f [Type]) -> ConstructorInfo -> f ConstructorInfo)
-> ((Type -> f Type) -> [Type] -> f [Type])
-> (Type -> f Type)
-> ConstructorInfo
-> f ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Type -> f Type) -> [Type] -> f [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
conNameMap ::
(TH.Name -> TH.Name) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo
conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap = Traversal' ConstructorInfo Name
-> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
Traversal' ConstructorInfo Name
conNameTraversal
conFieldNameMap ::
(TH.Name -> TH.Name) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo
conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap = Traversal' ConstructorInfo Name
-> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
Traversal' ConstructorInfo Name
conFieldNameTraversal
conTypeMap ::
(TH.Type -> TH.Type) -> TH.Abs.ConstructorInfo -> TH.Abs.ConstructorInfo
conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap = Traversal' ConstructorInfo Type
-> (Type -> Type) -> ConstructorInfo -> ConstructorInfo
forall s a. Traversal' s a -> (a -> a) -> s -> s
over (Type -> f Type) -> ConstructorInfo -> f ConstructorInfo
Traversal' ConstructorInfo Type
conTypeTraversal
type Lens' s a = forall f. (Functor f) => (a -> f a) -> s -> f s
type Traversal' s a = forall f. (Applicative f) => (a -> f a) -> s -> f s
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens :: forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens s -> a
sa s -> a -> s
sas a -> f a
afa s
s = s -> a -> s
sas s
s (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
afa (s -> a
sa s
s)
{-# INLINE lens #-}
over :: Traversal' s a -> (a -> a) -> s -> s
over :: forall s a. Traversal' s a -> (a -> a) -> s -> s
over Traversal' s a
l a -> a
f = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> Identity a) -> s -> Identity s
Traversal' s a
l (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a
f)
{-# INLINE over #-}
typeVars :: [TyVarBndrVis] -> [TH.Name]
typeVars :: [TyVarBndrUnit] -> [Name]
typeVars = (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
TH.Abs.tvName
conAppsT :: TH.Name -> [TH.Type] -> TH.Type
conAppsT :: Name -> [Type] -> Type
conAppsT Name
conName = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
conName)
substType ::
TH.Type ->
TH.Type ->
TH.Type ->
TH.Type
substType :: Type -> Type -> Type -> Type
substType Type
a Type
b = Type -> Type
go
where
go :: Type -> Type
go Type
x | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
a = Type
b
go (TH.VarT Name
n) = Name -> Type
TH.VarT Name
n
go (TH.AppT Type
l Type
r) = Type -> Type -> Type
TH.AppT (Type -> Type
go Type
l) (Type -> Type
go Type
r)
go (TH.ForallT [TyVarBndr Specificity]
xs [Type]
ctx Type
t) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
xs [Type]
ctx (Type -> Type
go Type
t)
go (TH.SigT Type
t Type
k) = Type -> Type -> Type
TH.SigT (Type -> Type
go Type
t) Type
k
go (TH.InfixT Type
l Name
n Type
r) = Type -> Name -> Type -> Type
TH.InfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
go (TH.UInfixT Type
l Name
n Type
r) = Type -> Name -> Type -> Type
TH.UInfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
go (TH.ParensT Type
t) = Type -> Type
TH.ParensT (Type -> Type
go Type
t)
go Type
x = Type
x
toCon :: TH.Abs.ConstructorInfo -> Either UnsupportedDatatype TH.Con
toCon :: ConstructorInfo -> Either UnsupportedDatatype Con
toCon
( TH.Abs.ConstructorInfo
{ constructorName :: ConstructorInfo -> Name
TH.Abs.constructorName = Name
name,
constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
TH.Abs.constructorVars = [TyVarBndrUnit]
vars,
constructorContext :: ConstructorInfo -> [Type]
TH.Abs.constructorContext = [Type]
ctxt,
constructorFields :: ConstructorInfo -> [Type]
TH.Abs.constructorFields = [Type]
ftys,
constructorStrictness :: ConstructorInfo -> [FieldStrictness]
TH.Abs.constructorStrictness = [FieldStrictness]
fstricts,
constructorVariant :: ConstructorInfo -> ConstructorVariant
TH.Abs.constructorVariant = ConstructorVariant
variant
}
) =
if [TyVarBndrUnit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
vars Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt
then
let bangs :: [Bang]
bangs = (FieldStrictness -> Bang) -> [FieldStrictness] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldStrictness -> Bang
toBang [FieldStrictness]
fstricts
in case ConstructorVariant
variant of
ConstructorVariant
TH.Abs.NormalConstructor ->
Con -> Either UnsupportedDatatype Con
forall a. a -> Either UnsupportedDatatype a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Either UnsupportedDatatype Con)
-> ([(Bang, Type)] -> Con)
-> [(Bang, Type)]
-> Either UnsupportedDatatype Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> [(Bang, Type)] -> Con
TH.NormalC Name
name ([(Bang, Type)] -> Either UnsupportedDatatype Con)
-> [(Bang, Type)] -> Either UnsupportedDatatype Con
forall a b. (a -> b) -> a -> b
$ [Bang] -> [Type] -> [(Bang, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bang]
bangs [Type]
ftys
TH.Abs.RecordConstructor [Name]
fnames ->
Con -> Either UnsupportedDatatype Con
forall a. a -> Either UnsupportedDatatype a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Either UnsupportedDatatype Con)
-> ([(Name, Bang, Type)] -> Con)
-> [(Name, Bang, Type)]
-> Either UnsupportedDatatype Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> [(Name, Bang, Type)] -> Con
TH.RecC Name
name ([(Name, Bang, Type)] -> Either UnsupportedDatatype Con)
-> [(Name, Bang, Type)] -> Either UnsupportedDatatype Con
forall a b. (a -> b) -> a -> b
$ [Name] -> [Bang] -> [Type] -> [(Name, Bang, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fnames [Bang]
bangs [Type]
ftys
ConstructorVariant
TH.Abs.InfixConstructor -> case [Bang] -> [Type] -> [(Bang, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bang]
bangs [Type]
ftys of
[(Bang, Type)
bt1, (Bang, Type)
bt2] -> Con -> Either UnsupportedDatatype Con
forall a. a -> Either UnsupportedDatatype a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Either UnsupportedDatatype Con)
-> Con -> Either UnsupportedDatatype Con
forall a b. (a -> b) -> a -> b
$ (Bang, Type) -> Name -> (Bang, Type) -> Con
TH.InfixC (Bang, Type)
bt1 Name
name (Bang, Type)
bt2
[(Bang, Type)]
bts -> UnsupportedDatatype -> Either UnsupportedDatatype Con
forall a b. a -> Either a b
Left (UnsupportedDatatype -> Either UnsupportedDatatype Con)
-> UnsupportedDatatype -> Either UnsupportedDatatype Con
forall a b. (a -> b) -> a -> b
$ [(Bang, Type)] -> UnsupportedDatatype
NonBinaryInfixConstructor [(Bang, Type)]
bts
else UnsupportedDatatype -> Either UnsupportedDatatype Con
forall a b. a -> Either a b
Left (UnsupportedDatatype -> Either UnsupportedDatatype Con)
-> UnsupportedDatatype -> Either UnsupportedDatatype Con
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> [Type] -> UnsupportedDatatype
UnsupportedGADT [TyVarBndrUnit]
vars [Type]
ctxt
where
toBang :: FieldStrictness -> Bang
toBang (TH.Abs.FieldStrictness Unpackedness
upkd Strictness
strct) =
SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang
(Unpackedness -> SourceUnpackedness
toSourceUnpackedness Unpackedness
upkd)
(Strictness -> SourceStrictness
toSourceStrictness Strictness
strct)
where
toSourceUnpackedness :: TH.Abs.Unpackedness -> TH.SourceUnpackedness
toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
toSourceUnpackedness = \case
Unpackedness
TH.Abs.UnspecifiedUnpackedness -> SourceUnpackedness
TH.NoSourceUnpackedness
Unpackedness
TH.Abs.NoUnpack -> SourceUnpackedness
TH.SourceNoUnpack
Unpackedness
TH.Abs.Unpack -> SourceUnpackedness
TH.SourceUnpack
toSourceStrictness :: TH.Abs.Strictness -> TH.SourceStrictness
toSourceStrictness :: Strictness -> SourceStrictness
toSourceStrictness = \case
Strictness
TH.Abs.UnspecifiedStrictness -> SourceStrictness
TH.NoSourceStrictness
Strictness
TH.Abs.Lazy -> SourceStrictness
TH.SourceLazy
Strictness
TH.Abs.Strict -> SourceStrictness
TH.SourceStrict
functorTypeName :: TH.Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
TH.Syn.mkNameG_tc String
"base" String
"GHC.Base" String
"Functor"
foldableTypeName :: TH.Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
TH.Syn.mkNameG_tc String
"base" String
"Data.Foldable" String
"Foldable"
traversableTypeName :: TH.Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
TH.Syn.mkNameG_tc String
"base" String
"Data.Traversable" String
"Traversable"