{-# LANGUAGE CPP #-}
#if MIN_VERSION_GLASGOW_HASKELL(9, 0, 0, 0)
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
#endif

-- | This module re-exports a subset of `Yaya.Fold`, intended for when you want
--   to define recursion scheme instances for your existing recursive types.
--
--   This is /not/ the recommended way to use Yaya, but it solves some real
--   problems:
-- 1. you have existing directly-recursive types and you want to start taking
--    advantage of recursion schemes without having to rewrite your existing
--    code, or
-- 2. a directly-recursive type has been imposed on you by some other library
--    and you want to take advantage of recursion schemes.
--
--   The distinction between these two cases is whether you have control of the
--   @data@ declaration. In the first case, you probably do. In that case, you
--   should only generate the /safe/ instances, and ensure that all the
--   recursive type references are /strict/ (if you want a `Recursive`
--   instance). If you don't have control, then you /may/ need to generate all
--   instances.
--
--   Another difference when you have control is that it means you may migrate
--   away from direct recursion entirely, at which point this import should
--   disappear.
module Yaya.Retrofit
  ( module Yaya.Fold,
    PatternFunctorRules
      ( PatternFunctorRules,
        patternCon,
        patternField,
        patternType
      ),
    defaultRules,
    extractPatternFunctor,
  )
where

-- NB: This module does not use the strict library, because its use of `Either`,
--    `Maybe`, etc. is tied to template-haskell and does not involve recursion
--     schemes.
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

-- | Extract a pattern functor and relevant instances from a simply recursive type.
--
-- /e.g./
--
-- @
-- data Expr a
--     = Lit a
--     | Add (Expr a) (Expr a)
--     | Expr a :* [Expr a]
--   deriving stock (Show)
--
-- `extractPatternFunctor` `defaultRules` ''Expr
-- @
--
-- will create
--
-- @
-- data ExprF a x
--     = LitF a
--     | AddF x x
--     | x :*$ [x]
--   deriving stock ('Functor', 'Foldable', 'Traversable')
--
-- instance `Projectable` (->) (Expr a) (ExprF a) where
--   `project` (Lit x)   = LitF x
--   `project` (Add x y) = AddF x y
--   `project` (x :* y)  = x :*$ y
--
-- instance `Steppable` (->) (Expr a) (ExprF a) where
--   `embed` (LitF x)   = Lit x
--   `embed` (AddF x y) = Add x y
--   `embed` (x :*$ y)  = x :* y
--
-- instance `Recursive` (->) (Expr a) (ExprF a) where
--   `cata` φ = φ . `fmap` (`cata` φ) . `project`
--
-- instance `Corecursive` (->) (Expr a) (ExprF a) where
--   `ana` ψ = `embed` . `fmap` (`ana` ψ) . ψ
-- @
--
-- /Notes:/
--
-- - `extractPatternFunctor` works properly only with ADTs.
--   Existentials and GADTs aren't supported,
--   as we don't try to do better than
--   <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>.
-- - we always generate both `Recursive` and `Corecursive` instances, but one of these is always unsafe.
--   In future, we should check the strictness of the recursive parameter and generate only the appropriate one (unless overridden by a rule).
extractPatternFunctor :: PatternFunctorRules -> TH.Name -> TH.Q [TH.Dec]
extractPatternFunctor :: PatternFunctorRules -> Name -> Q [Dec]
extractPatternFunctor 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

-- | Rules of renaming data names
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
  }

-- | Default 'PatternFunctorRules': append @F@ or @$@ to data type, constructors and field names.
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
      ]

-- | A restricted version of `TH.Abs.DatatypeVariant` that excludes data family
--   declarations.
#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
  -- variable parameters
  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)
  -- Name of base functor
  let tyNameF :: Name
tyNameF = PatternFunctorRules -> Name -> Name
patternType PatternFunctorRules
rules Name
tyName
  -- Recursive type
  let s :: Type
s = Name -> [Type] -> Type
conAppsT Name
tyName [Type]
vars'
  -- Additional argument
  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

  -- Vars
  let varsF :: [TyVarBndrUnit]
varsF = [TyVarBndrUnit]
vars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. Semigroup a => a -> a -> a
<> [Name -> TyVarBndrUnit
TH.plainTV Name
rName]

  -- ekmett/recursion-schemes#33
  [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 ψ) . ψ
      |]

-- | makes clauses to rename constructors
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)) -- pattern
            ( 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 -- body
            )
            [] -- where dec
    )

-------------------------------------------------------------------------------
-- Traversals
-------------------------------------------------------------------------------

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

-------------------------------------------------------------------------------
-- Lenses
-------------------------------------------------------------------------------

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 #-}

-------------------------------------------------------------------------------
-- Type mangling
-------------------------------------------------------------------------------

-- | Extract type variables
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

-- | Apply arguments to a type constructor.
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)

-- | Provides substitution for types
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)
    -- This may fail with kind error
    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)
    -- Rest are unchanged
    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

-------------------------------------------------------------------------------
-- Manually quoted names
-------------------------------------------------------------------------------
-- By manually generating these names we avoid needing to use the
-- TemplateHaskell language extension when compiling this library.
-- This allows the library to be used in stage1 cross-compilers.

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"