{-# LANGUAGE CPP, PatternGuards, Rank2Types #-}
-- This OPTIONS_GHC line is a workaround for
-- https://gitlab.haskell.org/ghc/ghc/-/issues/18320, a bug which only occurs
-- when running specific TemplateHaskell code while both profiling and
-- optimisations are enabled. The code in this file triggers the bug, so until
-- it is fixed, we work around the issue by disabling optimisations in this
-- file. The code in this file only runs at compile-time, the code _generated_
-- by makeBaseFunctor will still get optimized if the file which calls
-- makeBaseFunctor is optimized.
{-# OPTIONS_GHC -O0 #-}
module Data.Functor.Foldable.TH
  ( MakeBaseFunctor(..)
  , BaseRules
  , baseRules
  , baseRulesType
  , baseRulesCon
  , baseRulesField
  ) where

import Control.Applicative as A
import Control.Monad
import Data.Traversable as T
import Data.Functor.Identity
import Language.Haskell.TH
import Language.Haskell.TH.Datatype as TH.Abs
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Syntax (mkNameG_tc, mkNameG_v)
import Data.Char (GeneralCategory (..), generalCategory)
import Data.Orphans ()
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_recursion_schemes (version)
#endif

#ifdef __HADDOCK__
import Data.Functor.Foldable
#endif

-- $setup
-- >>> :set -XTemplateHaskell -XTypeFamilies -XDeriveTraversable -XScopedTypeVariables
-- >>> import Data.Functor.Foldable
-- >>> import Language.Haskell.TH (Q)
-- >>> let asQ :: Q a -> Q a; asQ = id

-- | Build base functor with a sensible default configuration.
--
-- /e.g./
--
-- @
-- data Expr a
--     = Lit a
--     | Add (Expr a) (Expr a)
--     | Expr a :* [Expr a]
--   deriving (Show)
--
-- 'makeBaseFunctor' ''Expr
-- @
--
-- will create
--
-- @
-- data ExprF a x
--     = LitF a
--     | AddF x x
--     | x :*$ [x]
--   deriving ('Functor', 'Foldable', 'Traversable')
--
-- type instance 'Base' (Expr a) = ExprF a
--
-- instance 'Recursive' (Expr a) where
--     'project' (Lit x)   = LitF x
--     'project' (Add x y) = AddF x y
--     'project' (x :* y)  = x :*$ y
--
-- instance 'Corecursive' (Expr a) where
--     'embed' (LitF x)   = Lit x
--     'embed' (AddF x y) = Add x y
--     'embed' (x :*$ y)  = x :* y
-- @
--
--
-- /Notes:/
--
-- 'makeBaseFunctor' 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>.
--
-- Allowing 'makeBaseFunctor' to take both 'Name's and 'Dec's as an argument is why it exists as a method in a type class.
-- For trickier data-types, like rose-tree (see also 'Cofree'):
--
-- @
-- data Rose f a = Rose a (f (Rose f a))
-- @
--
-- we can invoke 'makeBaseFunctor' with an instance declaration
-- to provide needed context for instances. (c.f. @StandaloneDeriving@)
--
-- @
-- 'makeBaseFunctor' [d| instance Functor f => Recursive (Rose f a) |]
-- @
--
-- will create
--
-- @
-- data RoseF f a r = RoseF a (f fr)
--   deriving ('Functor', 'Foldable', 'Traversable')
--
-- type instance 'Base' (Rose f a) = RoseF f a
--
-- instance Functor f => 'Recursive' (Rose f a) where
--   'project' (Rose x xs) = RoseF x xs
--
-- instance Functor f => 'Corecursive' (Rose f a) where
--   'embed' (RoseF x xs) = Rose x xs
-- @
--
-- Some doctests:
--
-- >>> data Expr a = Lit a | Add (Expr a) (Expr a) | Expr a :* [Expr a]; makeBaseFunctor ''Expr
--
-- >>> :t AddF
-- AddF :: r -> r -> ExprF a r
--
-- >>> data Rose f a = Rose a (f (Rose f a)); makeBaseFunctor $ asQ [d| instance Functor f => Recursive (Rose f a) |]
--
-- >>> :t RoseF
-- RoseF :: a -> f r -> RoseF f a r
--
-- >>> let rose = Rose 1 (Just (Rose 2 (Just (Rose 3 Nothing))))
-- >>> cata (\(RoseF x f) -> x + maybe 0 id f) rose
-- 6
--
class MakeBaseFunctor a where
    -- |
    -- @
    -- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'
    -- @
    makeBaseFunctor :: a -> DecsQ
    makeBaseFunctor = BaseRules -> a -> DecsQ
forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
makeBaseFunctorWith BaseRules
baseRules

    -- | Build base functor with a custom configuration.
    makeBaseFunctorWith :: BaseRules -> a -> DecsQ

instance MakeBaseFunctor a => MakeBaseFunctor [a] where
    makeBaseFunctorWith :: BaseRules -> [a] -> DecsQ
makeBaseFunctorWith BaseRules
rules [a]
a = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((a -> DecsQ) -> [a] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (BaseRules -> a -> DecsQ
forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
makeBaseFunctorWith BaseRules
rules) [a]
a)

instance MakeBaseFunctor a => MakeBaseFunctor (Q a) where
    makeBaseFunctorWith :: BaseRules -> Q a -> DecsQ
makeBaseFunctorWith BaseRules
rules Q a
a = BaseRules -> a -> DecsQ
forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
makeBaseFunctorWith BaseRules
rules (a -> DecsQ) -> Q a -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q a
a

instance MakeBaseFunctor Name where
    makeBaseFunctorWith :: BaseRules -> Name -> DecsQ
makeBaseFunctorWith BaseRules
rules Name
name = Name -> Q DatatypeInfo
reifyDatatype Name
name Q DatatypeInfo -> (DatatypeInfo -> DecsQ) -> DecsQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseRules -> Maybe (Name -> [Dec] -> Dec) -> DatatypeInfo -> DecsQ
makePrimForDI BaseRules
rules Maybe (Name -> [Dec] -> Dec)
forall a. Maybe a
Nothing

-- | Expects declarations of 'Recursive' or 'Corecursive' instances, e.g.
--
-- @
-- makeBaseFunctor [d| instance Functor f => Recursive (Rose f a) |]
-- @
--
-- This way we can provide a context for generated instances.
-- Note that this instance's 'makeBaseFunctor' still generates all of
-- 'Base' type instance, 'Recursive' and 'Corecursive' instances.
--
instance MakeBaseFunctor Dec where
#if MIN_VERSION_template_haskell(2,11,0)
    makeBaseFunctorWith :: BaseRules -> Dec -> DecsQ
makeBaseFunctorWith BaseRules
rules (InstanceD Maybe Overlap
overlaps Cxt
ctx Type
classHead []) = do
        let instanceFor :: Type -> [Dec] -> Dec
instanceFor = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
overlaps Cxt
ctx
#else
    makeBaseFunctorWith rules (InstanceD ctx classHead []) = do
        let instanceFor = InstanceD ctx
#endif
        case Type
classHead of
          ConT Name
u `AppT` Type
t | Name
u Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
recursiveTypeName Bool -> Bool -> Bool
|| Name
u Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
corecursiveTypeName -> do
              Name
name <- Type -> Q Name
headOfType Type
t
              DatatypeInfo
di <- Name -> Q DatatypeInfo
reifyDatatype Name
name
              BaseRules -> Maybe (Name -> [Dec] -> Dec) -> DatatypeInfo -> DecsQ
makePrimForDI BaseRules
rules ((Name -> [Dec] -> Dec) -> Maybe (Name -> [Dec] -> Dec)
forall a. a -> Maybe a
Just ((Name -> [Dec] -> Dec) -> Maybe (Name -> [Dec] -> Dec))
-> (Name -> [Dec] -> Dec) -> Maybe (Name -> [Dec] -> Dec)
forall a b. (a -> b) -> a -> b
$ \Name
n -> Type -> [Dec] -> Dec
instanceFor (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
t)) DatatypeInfo
di
          Type
_ -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"makeBaseFunctor: expected an instance head like `ctx => Recursive (T a b ...)`, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
classHead

    makeBaseFunctorWith BaseRules
_ Dec
_ = String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeBaseFunctor(With): expected an empty instance declaration"

-- | Rules of renaming data names
data BaseRules = BaseRules
    { BaseRules -> Name -> Name
_baseRulesType  :: Name -> Name
    , BaseRules -> Name -> Name
_baseRulesCon   :: Name -> Name
    , BaseRules -> Name -> Name
_baseRulesField :: Name -> Name
    }

-- | Default 'BaseRules': append @F@ or @$@ to data type, constructors and field names.
baseRules :: BaseRules
baseRules :: BaseRules
baseRules = BaseRules :: (Name -> Name) -> (Name -> Name) -> (Name -> Name) -> BaseRules
BaseRules
    { _baseRulesType :: Name -> Name
_baseRulesType  = Name -> Name
toFName
    , _baseRulesCon :: Name -> Name
_baseRulesCon   = Name -> Name
toFName
    , _baseRulesField :: Name -> Name
_baseRulesField = Name -> Name
toFName
    }

-- | How to name the base functor type.
--
-- Default is to append @F@ or @$@.
baseRulesType :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesType :: forall (f :: * -> *).
Functor f =>
((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesType (Name -> Name) -> f (Name -> Name)
f BaseRules
rules = (\Name -> Name
x -> BaseRules
rules { _baseRulesType :: Name -> Name
_baseRulesType = Name -> Name
x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> f (Name -> Name)
f (BaseRules -> Name -> Name
_baseRulesType BaseRules
rules)

-- | How to rename the base functor type constructors.
--
-- Default is to append @F@ or @$@.
baseRulesCon :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesCon :: forall (f :: * -> *).
Functor f =>
((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesCon (Name -> Name) -> f (Name -> Name)
f BaseRules
rules = (\Name -> Name
x -> BaseRules
rules { _baseRulesCon :: Name -> Name
_baseRulesCon = Name -> Name
x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> f (Name -> Name)
f (BaseRules -> Name -> Name
_baseRulesCon BaseRules
rules)

-- | How to rename the base functor type field names (in records).
--
-- Default is to append @F@ or @$@.
baseRulesField :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesField :: forall (f :: * -> *).
Functor f =>
((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
baseRulesField (Name -> Name) -> f (Name -> Name)
f BaseRules
rules = (\Name -> Name
x -> BaseRules
rules { _baseRulesField :: Name -> Name
_baseRulesField = Name -> Name
x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> f (Name -> Name)
f (BaseRules -> Name -> Name
_baseRulesField BaseRules
rules)

toFName :: Name -> Name
toFName :: Name -> Name
toFName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
  where
    f :: String -> String
f String
name | String -> Bool
isInfixName String
name = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$"
           | Bool
otherwise        = String
name String -> String -> String
forall 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

makePrimForDI :: BaseRules
              -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance
              -> DatatypeInfo
              -> DecsQ
makePrimForDI :: BaseRules -> Maybe (Name -> [Dec] -> Dec) -> DatatypeInfo -> DecsQ
makePrimForDI BaseRules
rules Maybe (Name -> [Dec] -> Dec)
mkInstance'
  (DatatypeInfo { datatypeName :: DatatypeInfo -> Name
datatypeName      = Name
tyName
                , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTys
                , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons      = [ConstructorInfo]
cons
                , datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant   = DatatypeVariant
variant }) = do
    Q ()
checkAllowed
    BaseRules
-> Maybe (Name -> [Dec] -> Dec)
-> Bool
-> Name
-> [TyVarBndrUnit]
-> [ConstructorInfo]
-> DecsQ
makePrimForDI' BaseRules
rules Maybe (Name -> [Dec] -> Dec)
mkInstance'
                   (DatatypeVariant
variant DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
Newtype) Name
tyName
                   ((Type -> TyVarBndrUnit) -> Cxt -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TyVarBndrUnit
toTyVarBndr Cxt
instTys) [ConstructorInfo]
cons
  where
    checkAllowed :: Q ()
checkAllowed =
      case DatatypeVariant
variant of
        DatatypeVariant
Datatype        -> () -> Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        DatatypeVariant
Newtype         -> () -> Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        DatatypeVariant
DataInstance    -> Q ()
forall {a}. Q a
dataFamilyError
        DatatypeVariant
NewtypeInstance -> Q ()
forall {a}. Q a
dataFamilyError
#if MIN_VERSION_th_abstraction(0,5,0)
        DatatypeVariant
TH.Abs.TypeData -> String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeBaseFunctor: `type data` declarations are not supported."
#endif

    dataFamilyError :: Q a
dataFamilyError = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeBaseFunctor: Data families are currently not supported."

    toTyVarBndr :: Type -> TyVarBndrUnit
    toTyVarBndr :: Type -> TyVarBndrUnit
toTyVarBndr (VarT Name
n)          = Name -> TyVarBndrUnit
plainTV Name
n
    toTyVarBndr (SigT (VarT Name
n) Type
k) = Name -> Type -> TyVarBndrUnit
kindedTV Name
n Type
k
    toTyVarBndr Type
_                 = String -> TyVarBndrUnit
forall a. HasCallStack => String -> a
error String
"toTyVarBndr"

makePrimForDI' :: BaseRules
               -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance
               -> Bool -> Name -> [TyVarBndrUnit]
               -> [ConstructorInfo] -> DecsQ
makePrimForDI' :: BaseRules
-> Maybe (Name -> [Dec] -> Dec)
-> Bool
-> Name
-> [TyVarBndrUnit]
-> [ConstructorInfo]
-> DecsQ
makePrimForDI' BaseRules
rules Maybe (Name -> [Dec] -> Dec)
mkInstance' Bool
isNewtype Name
tyName [TyVarBndrUnit]
vars [ConstructorInfo]
cons = do
    -- variable parameters
    let vars' :: Cxt
vars' = (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT ([TyVarBndrUnit] -> [Name]
forall flag. [TyVarBndr_ flag] -> [Name]
typeVars [TyVarBndrUnit]
vars)
    -- Name of base functor
    let tyNameF :: Name
tyNameF = BaseRules -> Name -> Name
_baseRulesType BaseRules
rules Name
tyName
    -- Recursive type
    let s :: Type
s = Name -> Cxt -> Type
conAppsT Name
tyName Cxt
vars'
    -- Additional argument
    Name
rName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
    let r :: Type
r = Name -> Type
VarT Name
rName
    -- Vars
    let varsF :: [TyVarBndrUnit]
varsF = [TyVarBndrUnit]
vars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndrUnit
plainTV Name
rName]

    -- #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)
traverse ((Type -> Q Type) -> ConstructorInfo -> Q ConstructorInfo
Traversal' ConstructorInfo Type
conTypeTraversal Type -> Q Type
resolveTypeSynonyms) [ConstructorInfo]
cons
    let consF :: [Con]
consF
          = ConstructorInfo -> Con
toCon
          (ConstructorInfo -> Con)
-> (ConstructorInfo -> ConstructorInfo) -> ConstructorInfo -> Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conNameMap (BaseRules -> Name -> Name
_baseRulesCon BaseRules
rules)
          (ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> ConstructorInfo -> ConstructorInfo
conFieldNameMap (BaseRules -> Name -> Name
_baseRulesField BaseRules
rules)
          (ConstructorInfo -> ConstructorInfo)
-> (ConstructorInfo -> ConstructorInfo)
-> ConstructorInfo
-> ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type) -> ConstructorInfo -> ConstructorInfo
conTypeMap (Type -> Type -> Type -> Type
substType Type
s Type
r)
          (ConstructorInfo -> Con) -> [ConstructorInfo] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo]
cons'

    -- Data definition
#if MIN_VERSION_template_haskell(2,12,0)
    Maybe DerivStrategy
derivStrat <- do
      Bool
e <- Extension -> Q Bool
isExtEnabled Extension
DerivingStrategies
      Maybe DerivStrategy -> Q (Maybe DerivStrategy)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> Q (Maybe DerivStrategy))
-> Maybe DerivStrategy -> Q (Maybe DerivStrategy)
forall a b. (a -> b) -> a -> b
$ if Bool
e then DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy else Maybe DerivStrategy
forall a. Maybe a
Nothing
#endif
    let dataDec :: Dec
dataDec = case [Con]
consF of
#if MIN_VERSION_template_haskell(2,11,0)
            [Con
conF] | Bool
isNewtype ->
                Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
tyNameF [TyVarBndrUnit]
varsF Maybe Type
forall a. Maybe a
Nothing Con
conF [DerivClause]
deriveds
            [Con]
_ ->
                Cxt
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tyNameF [TyVarBndrUnit]
varsF Maybe Type
forall a. Maybe a
Nothing [Con]
consF [DerivClause]
deriveds
#else
            [conF] | isNewtype ->
                NewtypeD [] tyNameF varsF conF deriveds
            _ ->
                DataD [] tyNameF varsF consF deriveds
#endif
          where
            deriveds :: [DerivClause]
deriveds =
#if MIN_VERSION_template_haskell(2,12,0)
              [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
derivStrat
                [ Name -> Type
ConT Name
functorTypeName
                , Name -> Type
ConT Name
foldableTypeName
                , Name -> Type
ConT Name
traversableTypeName ]]
#elif MIN_VERSION_template_haskell(2,11,0)
              [ ConT functorTypeName
              , ConT foldableTypeName
              , ConT traversableTypeName ]
#else
              [functorTypeName, foldableTypeName, traversableTypeName]
#endif

    -- type instance Base
    Dec
baseDec <- Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
baseTypeName Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing
                                [Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s] (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
conAppsT Name
tyNameF Cxt
vars')

    let mkInstance :: Name -> [Dec] -> Dec
        mkInstance :: Name -> [Dec] -> Dec
mkInstance = case Maybe (Name -> [Dec] -> Dec)
mkInstance' of
            Just Name -> [Dec] -> Dec
f  -> Name -> [Dec] -> Dec
f
            Maybe (Name -> [Dec] -> Dec)
Nothing -> \Name
n ->
#if MIN_VERSION_template_haskell(2,11,0)
                Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
s)
#else
                InstanceD [] (ConT n `AppT` s)
#endif

    -- instance Recursive
    Dec
projDec <- Name -> [Clause] -> Dec
FunD Name
projectValName ([Clause] -> Dec) -> Q [Clause] -> DecQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Clause]
mkMorphism Name -> Name
forall a. a -> a
id (BaseRules -> Name -> Name
_baseRulesCon BaseRules
rules) [ConstructorInfo]
cons'
    let recursiveDec :: Dec
recursiveDec = Name -> [Dec] -> Dec
mkInstance Name
recursiveTypeName [Dec
projDec]

    -- instance Corecursive
    Dec
embedDec <- Name -> [Clause] -> Dec
FunD Name
embedValName ([Clause] -> Dec) -> Q [Clause] -> DecQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Clause]
mkMorphism (BaseRules -> Name -> Name
_baseRulesCon BaseRules
rules) Name -> Name
forall a. a -> a
id [ConstructorInfo]
cons'
    let corecursiveDec :: Dec
corecursiveDec = Name -> [Dec] -> Dec
mkInstance Name
corecursiveTypeName [Dec
embedDec]

    -- Combine
    [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
A.pure [Dec
dataDec, Dec
baseDec, Dec
recursiveDec, Dec
corecursiveDec]

-- | makes clauses to rename constructors
mkMorphism
    :: (Name -> Name)
    -> (Name -> Name)
    -> [ConstructorInfo]
    -> Q [Clause]
mkMorphism :: (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Clause]
mkMorphism Name -> Name
nFrom Name -> Name
nTo [ConstructorInfo]
args = [ConstructorInfo] -> (ConstructorInfo -> Q Clause) -> Q [Clause]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ConstructorInfo]
args ((ConstructorInfo -> Q Clause) -> Q [Clause])
-> (ConstructorInfo -> Q Clause) -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ci -> do
    let n :: Name
n = ConstructorInfo -> Name
constructorName ConstructorInfo
ci
    [Name]
fs <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> Cxt
constructorFields ConstructorInfo
ci)) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
#if MIN_VERSION_template_haskell(2,18,0)
    pure $ Clause [ConP (nFrom n) [] (map VarP fs)]                   -- patterns
#else
    Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP (Name -> Name
nFrom Name
n) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fs)]                      -- patterns
#endif
                  (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name
nTo Name
n) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
fs)) -- body
                  [] -- where dec

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

conNameTraversal :: Traversal' ConstructorInfo 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
constructorName (\ConstructorInfo
s Name
v -> ConstructorInfo
s { constructorName :: Name
constructorName = Name
v })

conFieldNameTraversal :: Traversal' ConstructorInfo 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
constructorVariant (\ConstructorInfo
s ConstructorVariant
v -> ConstructorInfo
s { constructorVariant :: ConstructorVariant
constructorVariant = 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
. (Name -> f Name) -> ConstructorVariant -> f ConstructorVariant
Traversal' ConstructorVariant Name
conVariantTraversal
  where
    conVariantTraversal :: Traversal' ConstructorVariant Name
    conVariantTraversal :: Traversal' ConstructorVariant Name
conVariantTraversal Name -> f Name
_ ConstructorVariant
NormalConstructor      = ConstructorVariant -> f ConstructorVariant
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
NormalConstructor
    conVariantTraversal Name -> f Name
_ ConstructorVariant
InfixConstructor       = ConstructorVariant -> f ConstructorVariant
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
InfixConstructor
    conVariantTraversal Name -> f Name
f (RecordConstructor [Name]
fs) = [Name] -> ConstructorVariant
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)
traverse Name -> f Name
f [Name]
fs

conTypeTraversal :: Traversal' ConstructorInfo Type
conTypeTraversal :: Traversal' ConstructorInfo Type
conTypeTraversal = (ConstructorInfo -> Cxt)
-> (ConstructorInfo -> Cxt -> ConstructorInfo)
-> Lens' ConstructorInfo Cxt
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens ConstructorInfo -> Cxt
constructorFields (\ConstructorInfo
s Cxt
v -> ConstructorInfo
s { constructorFields :: Cxt
constructorFields = Cxt
v })
                 ((Cxt -> f Cxt) -> ConstructorInfo -> f ConstructorInfo)
-> ((Type -> f Type) -> Cxt -> f Cxt)
-> (Type -> f Type)
-> ConstructorInfo
-> f ConstructorInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> Cxt -> f Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

conNameMap :: (Name -> Name) -> ConstructorInfo -> 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 Traversal' ConstructorInfo Name
conNameTraversal

conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> 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 Traversal' ConstructorInfo Name
conFieldNameTraversal

conTypeMap :: (Type -> Type) -> ConstructorInfo -> 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 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
. (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
. a -> a
f)
{-# INLINE over #-}

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

headOfType :: Type -> Q Name
headOfType :: Type -> Q Name
headOfType (AppT Type
t Type
_) = Type -> Q Name
headOfType Type
t
headOfType (VarT Name
n)   = Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType (ConT Name
n)   = Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType Type
t          = String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"headOfType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t

-- | Extract type variables
typeVars :: [TyVarBndr_ flag] -> [Name]
typeVars :: forall flag. [TyVarBndr_ flag] -> [Name]
typeVars = (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName

-- | Apply arguments to a type constructor.
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> Cxt -> Type
conAppsT Name
conName = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
conName)

-- | Provides substitution for types
substType
    :: Type
    -> Type
    -> Type
    -> 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 (VarT Name
n)           = Name -> Type
VarT Name
n
    go (AppT Type
l Type
r)         = Type -> Type -> Type
AppT (Type -> Type
go Type
l) (Type -> Type
go Type
r)
    go (ForallT [TyVarBndr Specificity]
xs Cxt
ctx Type
t) = [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
xs Cxt
ctx (Type -> Type
go Type
t)
    -- This may fail with kind error
    go (SigT Type
t Type
k)         = Type -> Type -> Type
SigT (Type -> Type
go Type
t) Type
k
#if MIN_VERSION_template_haskell(2,11,0)
    go (InfixT Type
l Name
n Type
r)     = Type -> Name -> Type -> Type
InfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
    go (UInfixT Type
l Name
n Type
r)    = Type -> Name -> Type -> Type
UInfixT (Type -> Type
go Type
l) Name
n (Type -> Type
go Type
r)
    go (ParensT Type
t)        = Type -> Type
ParensT (Type -> Type
go Type
t)
#endif
    -- Rest are unchanged
    go Type
x = Type
x

toCon :: ConstructorInfo -> Con
toCon :: ConstructorInfo -> Con
toCon (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
name
                       , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars       = [TyVarBndrUnit]
vars
                       , constructorContext :: ConstructorInfo -> Cxt
constructorContext    = Cxt
ctxt
                       , constructorFields :: ConstructorInfo -> Cxt
constructorFields     = Cxt
ftys
                       , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
fstricts
                       , constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant    = ConstructorVariant
variant })
  | Bool -> Bool
not ([TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
vars Bool -> Bool -> Bool
&& Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
ctxt)
  = String -> Con
forall a. HasCallStack => String -> a
error String
"makeBaseFunctor: GADTs are not currently supported."
  | Bool
otherwise
  = let bangs :: [Bang]
bangs = (FieldStrictness -> Bang) -> [FieldStrictness] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map FieldStrictness -> Bang
toBang [FieldStrictness]
fstricts
     in case ConstructorVariant
variant of
          ConstructorVariant
NormalConstructor        -> Name -> [BangType] -> Con
NormalC Name
name ([BangType] -> Con) -> [BangType] -> Con
forall a b. (a -> b) -> a -> b
$ [Bang] -> Cxt -> [BangType]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bang]
bangs Cxt
ftys
          RecordConstructor [Name]
fnames -> Name -> [VarBangType] -> Con
RecC Name
name ([VarBangType] -> Con) -> [VarBangType] -> Con
forall a b. (a -> b) -> a -> b
$ [Name] -> [Bang] -> Cxt -> [VarBangType]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fnames [Bang]
bangs Cxt
ftys
          ConstructorVariant
InfixConstructor
            |  [Bang
bang1, Bang
bang2] <- [Bang]
bangs
            ,  [Type
fty1,  Type
fty2]  <- Cxt
ftys
            -> BangType -> Name -> BangType -> Con
InfixC (Bang
bang1, Type
fty1) Name
name (Bang
bang2, Type
fty2)

            |  Bool
otherwise
            -> String -> Con
forall a. HasCallStack => String -> a
error (String -> Con) -> String -> Con
forall a b. (a -> b) -> a -> b
$ String
"makeBaseFunctor: Encountered an InfixConstructor "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"without exactly two fields"
  where
#if MIN_VERSION_template_haskell(2,11,0)
    toBang :: FieldStrictness -> Bang
toBang (FieldStrictness Unpackedness
upkd Strictness
strct) = SourceUnpackedness -> SourceStrictness -> Bang
Bang (Unpackedness -> SourceUnpackedness
toSourceUnpackedness Unpackedness
upkd)
                                               (Strictness -> SourceStrictness
toSourceStrictness Strictness
strct)
      where
        toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
        toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
toSourceUnpackedness Unpackedness
UnspecifiedUnpackedness = SourceUnpackedness
NoSourceUnpackedness
        toSourceUnpackedness Unpackedness
NoUnpack                = SourceUnpackedness
SourceNoUnpack
        toSourceUnpackedness Unpackedness
Unpack                  = SourceUnpackedness
SourceUnpack

        toSourceStrictness :: Strictness -> SourceStrictness
        toSourceStrictness :: Strictness -> SourceStrictness
toSourceStrictness Strictness
UnspecifiedStrictness = SourceStrictness
NoSourceStrictness
        toSourceStrictness Strictness
Lazy                  = SourceStrictness
SourceLazy
        toSourceStrictness Strictness
TH.Abs.Strict         = SourceStrictness
SourceStrict
#else
    -- On old versions of Template Haskell, there isn't as rich of strictness
    -- information available, so the conversion is somewhat lossy. We try our
    -- best to recognize certain common combinations, and fall back to NotStrict
    -- in the event there's an exotic combination.
    toBang (FieldStrictness UnspecifiedUnpackedness Strict)                = IsStrict
    toBang (FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness) = NotStrict
    toBang (FieldStrictness Unpack Strict)                                 = Unpacked
    toBang FieldStrictness{}                                               = NotStrict
#endif

-------------------------------------------------------------------------------
-- Compat from base-4.9
-------------------------------------------------------------------------------

isSymbolChar :: Char -> Bool
isSymbolChar :: Char -> Bool
isSymbolChar Char
c = Bool -> Bool
not (Char -> Bool
isPuncChar Char
c) Bool -> Bool -> Bool
&& case Char -> GeneralCategory
generalCategory Char
c of
    GeneralCategory
MathSymbol              -> Bool
True
    GeneralCategory
CurrencySymbol          -> Bool
True
    GeneralCategory
ModifierSymbol          -> Bool
True
    GeneralCategory
OtherSymbol             -> Bool
True
    GeneralCategory
DashPunctuation         -> Bool
True
    GeneralCategory
OtherPunctuation        -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"'\""
    GeneralCategory
ConnectorPunctuation    -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_'
    GeneralCategory
_                       -> Bool
False

isPuncChar :: Char -> Bool
isPuncChar :: Char -> Bool
isPuncChar Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
",;()[]{}`"

-------------------------------------------------------------------------------
-- 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.

rsPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
rsPackageKey :: String
rsPackageKey = CURRENT_PACKAGE_KEY
#else
rsPackageKey = "recursion-schemes-" ++ showVersion version
#endif

mkRsName_tc :: String -> String -> Name
mkRsName_tc :: String -> String -> Name
mkRsName_tc = String -> String -> String -> Name
mkNameG_tc String
rsPackageKey

mkRsName_v :: String -> String -> Name
mkRsName_v :: String -> String -> Name
mkRsName_v = String -> String -> String -> Name
mkNameG_v String
rsPackageKey

baseTypeName :: Name
baseTypeName :: Name
baseTypeName = String -> String -> Name
mkRsName_tc String
"Data.Functor.Foldable" String
"Base"

recursiveTypeName :: Name
recursiveTypeName :: Name
recursiveTypeName = String -> String -> Name
mkRsName_tc String
"Data.Functor.Foldable" String
"Recursive"

corecursiveTypeName :: Name
corecursiveTypeName :: Name
corecursiveTypeName = String -> String -> Name
mkRsName_tc String
"Data.Functor.Foldable" String
"Corecursive"

projectValName :: Name
projectValName :: Name
projectValName = String -> String -> Name
mkRsName_v String
"Data.Functor.Foldable" String
"project"

embedValName :: Name
embedValName :: Name
embedValName = String -> String -> Name
mkRsName_v String
"Data.Functor.Foldable" String
"embed"

functorTypeName :: Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"GHC.Base" String
"Functor"

foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Foldable" String
"Foldable"

traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Traversable" String
"Traversable"