{-# LANGUAGE CPP, PatternGuards, Rank2Types #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-- 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 Data.Char (GeneralCategory (..), generalCategory)

import Data.Functor.Foldable

#if !MIN_VERSION_template_haskell(2,21,0) && !MIN_VERSION_th_abstraction(0,6,0)
type TyVarBndrVis = TyVarBndrUnit
#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 a b. (a -> b) -> Q a -> Q b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 a b. Q a -> (a -> Q b) -> Q b
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
    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
        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 a. String -> Q a
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 a. String -> Q a
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
    { _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 = 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 = 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 = 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
-> [TyVarBndrVis]
-> [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 -> TyVarBndrVis) -> Cxt -> [TyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TyVarBndrVis
toTyVarBndr Cxt
instTys) [ConstructorInfo]
cons
  where
    checkAllowed :: Q ()
checkAllowed =
      case DatatypeVariant
variant of
        DatatypeVariant
Datatype        -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        DatatypeVariant
Newtype         -> () -> Q ()
forall a. a -> Q a
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 a. String -> Q a
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 a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeBaseFunctor: Data families are currently not supported."

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

makePrimForDI' :: BaseRules
               -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance
               -> Bool -> Name
               -> [TyVarBndrVis]
               -> [ConstructorInfo] -> DecsQ
makePrimForDI' :: BaseRules
-> Maybe (Name -> [Dec] -> Dec)
-> Bool
-> Name
-> [TyVarBndrVis]
-> [ConstructorInfo]
-> DecsQ
makePrimForDI' BaseRules
rules Maybe (Name -> [Dec] -> Dec)
mkInstance' Bool
isNewtype Name
tyName [TyVarBndrVis]
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 ([TyVarBndrVis] -> [Name]
forall flag. [TyVarBndr_ flag] -> [Name]
typeVars [TyVarBndrVis]
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 :: [TyVarBndrVis]
varsF = [TyVarBndrVis]
vars [TyVarBndrVis] -> [TyVarBndrVis] -> [TyVarBndrVis]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndrVis
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)
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
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 a. a -> Q a
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
            [Con
conF] | Bool
isNewtype ->
                Cxt
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
tyNameF [TyVarBndrVis]
varsF Maybe Type
forall a. Maybe a
Nothing Con
conF [DerivClause]
deriveds
            [Con]
_ ->
                Cxt
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tyNameF [TyVarBndrVis]
varsF Maybe Type
forall a. Maybe a
Nothing [Con]
consF [DerivClause]
deriveds
          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 ]]
#else
              [ ConT functorTypeName
              , ConT foldableTypeName
              , ConT traversableTypeName ]
#endif

    -- type instance Base
    Dec
baseDec <- Name -> Maybe [Q TyVarBndrVis] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
baseTypeName Maybe [Q TyVarBndrVis]
forall a. Maybe a
Nothing
                                [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 -> 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 ->
                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)

    -- 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 a. a -> Q a
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 a. [a] -> 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")
    [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Name -> Name
nFrom Name
n) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fs)]                            -- patterns
                 (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Name
nTo Name
n) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 = 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 = 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 a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorVariant
NormalConstructor
    conVariantTraversal Name -> f Name
_ ConstructorVariant
InfixConstructor       = ConstructorVariant -> f ConstructorVariant
forall a. a -> f a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 = 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
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 (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
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 (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
. (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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType (ConT Name
n)   = Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType Type
t          = String -> Q Name
forall a. String -> Q a
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 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
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
    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)
    -- Rest are unchanged
    go Type
x = Type
x

toCon :: ConstructorInfo -> Con
toCon :: ConstructorInfo -> Con
toCon (ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName       = Name
name
                       , constructorVars :: ConstructorInfo -> [TyVarBndrVis]
constructorVars       = [TyVarBndrVis]
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 ([TyVarBndrVis] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrVis]
vars Bool -> Bool -> Bool
&& Cxt -> Bool
forall a. [a] -> 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
    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

-------------------------------------------------------------------------------
-- 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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
",;()[]{}`"

-------------------------------------------------------------------------------
-- TH-quoted names
-------------------------------------------------------------------------------
-- Note that this module only TemplateHaskellQuotes, not TemplateHaskell,
-- which makes lens able to be used in stage1 cross-compilers.

baseTypeName :: Name
baseTypeName :: Name
baseTypeName = ''Base

recursiveTypeName :: Name
recursiveTypeName :: Name
recursiveTypeName = ''Recursive

corecursiveTypeName :: Name
corecursiveTypeName :: Name
corecursiveTypeName = ''Corecursive

projectValName :: Name
projectValName :: Name
projectValName = 'project

embedValName :: Name
embedValName :: Name
embedValName = 'embed

functorTypeName :: Name
functorTypeName :: Name
functorTypeName = ''Functor

foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = ''Foldable

traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = ''Traversable