{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE TemplateHaskell, CPP, PatternSynonyms, LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable, PatternSynonyms #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
{-|
Mostly some utils for dealing with TH in a version-agnostic way.
-}
module Text.Gigaparsec.Internal.TH.VersionAgnostic (
  -- * `TH.Type` Smart Constructors
  mkVarT,
  mkConT,
  mkPromotedT,
  mkSigT,
  mkAppT,
  mkForallT,
  -- *** Version ≥ 2.11
  mkInfixT,
  mkUInfixT,
  mkParensT,
  -- *** Version ≥ 2.15
  mkAppKindT,
  mkImplicitParamT,
  -- *** Version ≥ 2.16
  mkForallVisT,
  -- *** Version ≥ 2.19
  mkPromotedInfixT,
  mkPromotedUInfixT,
  -- * TyVarBndr
  -- ** Constructors and Recursors
  TyVarBndr,
  mkPlainTV,
  mkKindedTV,
  recTyVarBndr,
  -- ** Base Functor
  TyVarBndrF,
  pattern PlainTVF,
  pattern KindedTVF,
  recTyVarBndrF,
  projectBnd,
  embedBnd,
  -- * `TH.Type` Base Functor
  TypeF,
  -- ** View Patterns
  pattern ForallTF,
  pattern ForallVisTF, 
  pattern AppTF, 
  pattern AppKindTF, 
  pattern SigTF, 
  pattern InfixTF, 
  pattern UInfixTF, 
  pattern PromotedInfixTF, 
  pattern PromotedUInfixTF, 
  pattern ImplicitParamTF,
  pattern AtomicF, 
  pattern ParensTF,
  pattern VarTF,
  -- ** Recursion and Corecursion
  projectType,
  embedType,
  cataType,
  zygoType,
  -- * Template Haskell select re-exports
  module TH,
  module TH.Lib,
  TH.pprint,
#if !(MIN_VERSION_template_haskell(2,17,0))
  Quote(..),
  DocLoc(..),
  pattern MulArrowT,
  getDoc,
  putDoc,
#endif
  ) where

#if (MIN_VERSION_template_haskell(2,17,0))
import Language.Haskell.TH.Syntax hiding (TyVarBndr(..), Specificity)
import Language.Haskell.TH qualified as TH hiding (TyVarBndr(..), Specificity)
import Language.Haskell.TH.Syntax qualified as TH hiding (TyVarBndr(..), Specificity)
import Language.Haskell.TH.Syntax qualified as THAll
import Language.Haskell.TH.Lib as TH.Lib
#else
import Data.IORef (atomicModifyIORef')
import Language.Haskell.TH.Syntax hiding (TyVarBndr(..), Specificity, newName)
import Language.Haskell.TH qualified as TH hiding (TyVarBndr(..), Specificity)
import Language.Haskell.TH.Syntax qualified as TH hiding (TyVarBndr(..), Specificity)
import Language.Haskell.TH.Syntax qualified as THAll
import Language.Haskell.TH.Lib as TH.Lib
#endif


import Control.Applicative (liftA2)

import GHC.Generics (Generic)
import Data.Kind (Constraint)
import Data.Bitraversable (bisequence)


---------------------------------------------------------------------------------------------------
-- TyVarBndr Base Functor

-- use this defn so that TypeF doesn't need to have two recursion params
type TyVarBndrF :: * -> * -> *
type TyVarBndrF flag k = Either (Name, flag) (Name, flag, k)


{-# COMPLETE PlainTVF, KindedTVF #-}


pattern PlainTVF :: Name -> flag -> TyVarBndrF flag k
pattern KindedTVF :: Name -> flag -> k -> TyVarBndrF flag k
pattern $mPlainTVF :: forall {r} {flag} {k}.
TyVarBndrF flag k -> (Name -> flag -> r) -> ((# #) -> r) -> r
$bPlainTVF :: forall flag k. Name -> flag -> TyVarBndrF flag k
PlainTVF n f = Left (n, f)
pattern $mKindedTVF :: forall {r} {flag} {k}.
TyVarBndrF flag k -> (Name -> flag -> k -> r) -> ((# #) -> r) -> r
$bKindedTVF :: forall flag k. Name -> flag -> k -> TyVarBndrF flag k
KindedTVF n f knd = Right (n, f, knd)


recTyVarBndrF 
  :: (Name -> flag -> a) -- The `PlainTV` case
  -> (Name -> flag -> k -> a) -- The `KindedTV` case
  -> TyVarBndrF flag k
  -> a
recTyVarBndrF :: forall flag a k.
(Name -> flag -> a)
-> (Name -> flag -> k -> a) -> TyVarBndrF flag k -> a
recTyVarBndrF Name -> flag -> a
f Name -> flag -> k -> a
_ (PlainTVF Name
nm ~flag
flag) = Name -> flag -> a
f Name
nm flag
flag
recTyVarBndrF Name -> flag -> a
_ Name -> flag -> k -> a
g (KindedTVF Name
nm ~flag
flag k
k) = Name -> flag -> k -> a
g Name
nm flag
flag k
k

{-| Unrolls one step of recursion on `TyVarBndr`.

Projects a `TyVarBndr` onto its base functor.
-}
projectBnd :: TyVarBndr flag -> TyVarBndrF flag Type
projectBnd :: forall flag. TyVarBndr flag -> TyVarBndrF flag Type
projectBnd = (Name -> flag -> TyVarBndrF flag Type)
-> (Name -> flag -> Type -> TyVarBndrF flag Type)
-> TyVarBndr flag
-> TyVarBndrF flag Type
forall flag a.
(Name -> flag -> a)
-> (Name -> flag -> Type -> a) -> TyVarBndr flag -> a
recTyVarBndr Name -> flag -> TyVarBndrF flag Type
forall flag k. Name -> flag -> TyVarBndrF flag k
PlainTVF Name -> flag -> Type -> TyVarBndrF flag Type
forall flag k. Name -> flag -> k -> TyVarBndrF flag k
KindedTVF

{-| Rolls up one step of recursion into a `TyVarBndr`.

Embeds a `TyVarBndrF` onto the standard representation `TyVarBndr`.
-}
embedBnd :: TyVarBndrF flag Type -> TyVarBndr flag
embedBnd :: forall flag. TyVarBndrF flag Type -> TyVarBndr flag
embedBnd = (Name -> flag -> TyVarBndr flag)
-> (Name -> flag -> Type -> TyVarBndr flag)
-> TyVarBndrF flag Type
-> TyVarBndr flag
forall flag a k.
(Name -> flag -> a)
-> (Name -> flag -> k -> a) -> TyVarBndrF flag k -> a
recTyVarBndrF Name -> flag -> TyVarBndr flag
forall flag. Name -> flag -> TyVarBndr flag
mkPlainTV Name -> flag -> Type -> TyVarBndr flag
forall flag. Name -> flag -> Type -> TyVarBndr flag
mkKindedTV

---------------------------------------------------------------------------------------------------
-- Type Base Functor

{-|
Base functor for `Type`.

Use a hand-rolled base functor, as we then only need to handle the TH version inconsistencies
in the `embed` and `project` functions.
-}
type TypeF :: * -> *
data TypeF k = 
    ForallTF_ [TyVarBndrF Specificity k] [k] k
  | ForallVisTF_ [TyVarBndrF () k] k
  | AppTF_ k k
  | AppKindTF_ k k
  | SigTF_ k k
  | InfixTF_ k Name k
  | UInfixTF_ k Name k
  | PromotedInfixTF_ k Name k
  | PromotedUInfixTF_ k Name k
  | ImplicitParamTF_ String k
  | AtomicF_ Type
  | ParensTF_ k
  deriving stock ((forall a b. (a -> b) -> TypeF a -> TypeF b)
-> (forall a b. a -> TypeF b -> TypeF a) -> Functor TypeF
forall a b. a -> TypeF b -> TypeF a
forall a b. (a -> b) -> TypeF a -> TypeF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TypeF a -> TypeF b
fmap :: forall a b. (a -> b) -> TypeF a -> TypeF b
$c<$ :: forall a b. a -> TypeF b -> TypeF a
<$ :: forall a b. a -> TypeF b -> TypeF a
Functor, (forall m. Monoid m => TypeF m -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeF a -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeF a -> m)
-> (forall a b. (a -> b -> b) -> b -> TypeF a -> b)
-> (forall a b. (a -> b -> b) -> b -> TypeF a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeF a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeF a -> b)
-> (forall a. (a -> a -> a) -> TypeF a -> a)
-> (forall a. (a -> a -> a) -> TypeF a -> a)
-> (forall a. TypeF a -> [a])
-> (forall a. TypeF a -> Bool)
-> (forall a. TypeF a -> Int)
-> (forall a. Eq a => a -> TypeF a -> Bool)
-> (forall a. Ord a => TypeF a -> a)
-> (forall a. Ord a => TypeF a -> a)
-> (forall a. Num a => TypeF a -> a)
-> (forall a. Num a => TypeF a -> a)
-> Foldable TypeF
forall a. Eq a => a -> TypeF a -> Bool
forall a. Num a => TypeF a -> a
forall a. Ord a => TypeF a -> a
forall m. Monoid m => TypeF m -> m
forall a. TypeF a -> Bool
forall a. TypeF a -> Int
forall a. TypeF a -> [a]
forall a. (a -> a -> a) -> TypeF a -> a
forall m a. Monoid m => (a -> m) -> TypeF a -> m
forall b a. (b -> a -> b) -> b -> TypeF a -> b
forall a b. (a -> b -> b) -> b -> TypeF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TypeF m -> m
fold :: forall m. Monoid m => TypeF m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeF a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TypeF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TypeF a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TypeF a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeF a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TypeF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TypeF a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TypeF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TypeF a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TypeF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TypeF a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TypeF a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TypeF a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeF a -> a
foldl1 :: forall a. (a -> a -> a) -> TypeF a -> a
$ctoList :: forall a. TypeF a -> [a]
toList :: forall a. TypeF a -> [a]
$cnull :: forall a. TypeF a -> Bool
null :: forall a. TypeF a -> Bool
$clength :: forall a. TypeF a -> Int
length :: forall a. TypeF a -> Int
$celem :: forall a. Eq a => a -> TypeF a -> Bool
elem :: forall a. Eq a => a -> TypeF a -> Bool
$cmaximum :: forall a. Ord a => TypeF a -> a
maximum :: forall a. Ord a => TypeF a -> a
$cminimum :: forall a. Ord a => TypeF a -> a
minimum :: forall a. Ord a => TypeF a -> a
$csum :: forall a. Num a => TypeF a -> a
sum :: forall a. Num a => TypeF a -> a
$cproduct :: forall a. Num a => TypeF a -> a
product :: forall a. Num a => TypeF a -> a
Foldable, Functor TypeF
Foldable TypeF
(Functor TypeF, Foldable TypeF) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> TypeF a -> f (TypeF b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    TypeF (f a) -> f (TypeF a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> TypeF a -> m (TypeF b))
-> (forall (m :: * -> *) a. Monad m => TypeF (m a) -> m (TypeF a))
-> Traversable TypeF
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => TypeF (m a) -> m (TypeF a)
forall (f :: * -> *) a. Applicative f => TypeF (f a) -> f (TypeF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TypeF a -> m (TypeF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TypeF a -> f (TypeF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TypeF a -> f (TypeF b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TypeF a -> f (TypeF b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => TypeF (f a) -> f (TypeF a)
sequenceA :: forall (f :: * -> *) a. Applicative f => TypeF (f a) -> f (TypeF a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TypeF a -> m (TypeF b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TypeF a -> m (TypeF b)
$csequence :: forall (m :: * -> *) a. Monad m => TypeF (m a) -> m (TypeF a)
sequence :: forall (m :: * -> *) a. Monad m => TypeF (m a) -> m (TypeF a)
Traversable, (forall x. TypeF k -> Rep (TypeF k) x)
-> (forall x. Rep (TypeF k) x -> TypeF k) -> Generic (TypeF k)
forall x. Rep (TypeF k) x -> TypeF k
forall x. TypeF k -> Rep (TypeF k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k x. Rep (TypeF k) x -> TypeF k
forall k x. TypeF k -> Rep (TypeF k) x
$cfrom :: forall k x. TypeF k -> Rep (TypeF k) x
from :: forall x. TypeF k -> Rep (TypeF k) x
$cto :: forall k x. Rep (TypeF k) x -> TypeF k
to :: forall x. Rep (TypeF k) x -> TypeF k
Generic)

{-# COMPLETE ForallTF,ForallVisTF, AppTF, AppKindTF, SigTF, InfixTF, UInfixTF, 
  PromotedInfixTF, PromotedUInfixTF, ImplicitParamTF, AtomicF, ParensTF #-}

pattern ForallTF :: [TyVarBndrF Specificity k] -> [k] -> k -> TypeF k
pattern $mForallTF :: forall {r} {k}.
TypeF k
-> ([TyVarBndrF Specificity k] -> [k] -> k -> r)
-> ((# #) -> r)
-> r
ForallTF bnds ctx t <- ForallTF_ bnds ctx t
pattern ForallVisTF :: [TyVarBndrF () k] -> k -> TypeF k
pattern $mForallVisTF :: forall {r} {k}.
TypeF k -> ([TyVarBndrF () k] -> k -> r) -> ((# #) -> r) -> r
ForallVisTF bnds t <- ForallVisTF_ bnds t 
pattern AppTF :: k -> k -> TypeF k
pattern $mAppTF :: forall {r} {k}. TypeF k -> (k -> k -> r) -> ((# #) -> r) -> r
AppTF a b <- AppTF_ a b
pattern AppKindTF :: k -> k -> TypeF k
pattern $mAppKindTF :: forall {r} {k}. TypeF k -> (k -> k -> r) -> ((# #) -> r) -> r
AppKindTF a k <- AppKindTF_ a k
pattern SigTF :: k -> k -> TypeF k
pattern $mSigTF :: forall {r} {k}. TypeF k -> (k -> k -> r) -> ((# #) -> r) -> r
SigTF a k <- SigTF_ a k
pattern InfixTF :: k -> Name -> k -> TypeF k
pattern $mInfixTF :: forall {r} {k}.
TypeF k -> (k -> Name -> k -> r) -> ((# #) -> r) -> r
InfixTF  a n b      <- InfixTF_ a n b
pattern UInfixTF :: k -> Name -> k -> TypeF k
pattern $mUInfixTF :: forall {r} {k}.
TypeF k -> (k -> Name -> k -> r) -> ((# #) -> r) -> r
UInfixTF a n b      <- UInfixTF_ a n b
pattern PromotedInfixTF :: k -> Name -> k -> TypeF k
pattern $mPromotedInfixTF :: forall {r} {k}.
TypeF k -> (k -> Name -> k -> r) -> ((# #) -> r) -> r
PromotedInfixTF a n b <- PromotedInfixTF_ a n b 
pattern PromotedUInfixTF :: k -> Name -> k -> TypeF k
pattern $mPromotedUInfixTF :: forall {r} {k}.
TypeF k -> (k -> Name -> k -> r) -> ((# #) -> r) -> r
PromotedUInfixTF a n b <- PromotedUInfixTF_ a n b 
pattern ImplicitParamTF :: String -> k -> TypeF k
pattern $mImplicitParamTF :: forall {r} {k}. TypeF k -> (String -> k -> r) -> ((# #) -> r) -> r
ImplicitParamTF x a <- ImplicitParamTF_ x a
pattern AtomicF :: Type -> TypeF k
pattern $mAtomicF :: forall {r} {k}. TypeF k -> (Type -> r) -> ((# #) -> r) -> r
AtomicF  a <- AtomicF_ a
pattern ParensTF :: k -> TypeF k
pattern $mParensTF :: forall {r} {k}. TypeF k -> (k -> r) -> ((# #) -> r) -> r
ParensTF a <- ParensTF_ a

pattern VarTF :: Name -> TypeF k
pattern $mVarTF :: forall {r} {k}. TypeF k -> (Name -> r) -> ((# #) -> r) -> r
$bVarTF :: forall k. Name -> TypeF k
VarTF nm = AtomicF_ (VarT nm)

-------------------------------------------------------------------------------
-- Recursion Schemes Stuff
{-
To avoid adding a dependency on `recursion-schemes`, we re-implement some of
the core features from this library.
The originals can be found at:
https://hackage.haskell.org/package/recursion-schemes
-}

type Base :: * -> * -> *
type family Base t :: * -> *

type Recursive :: * -> Constraint
class Functor (Base t) => Recursive t where
  project :: t -> Base t t
  cata :: (Base t a -> a) -> t -> a
  cata Base t a -> a
f = t -> a
c 
    where 
    c :: t -> a
c = Base t a -> a
f (Base t a -> a) -> (t -> Base t a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> Base t t -> Base t a
forall a b. (a -> b) -> Base t a -> Base t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> a
c (Base t t -> Base t a) -> (t -> Base t t) -> t -> Base t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project

type Corecursive :: * -> Constraint
class Functor (Base t) => Corecursive t where
  embed :: Base t t -> t

zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo :: forall t b a.
Recursive t =>
(Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo Base t b -> b
f Base t (b, a) -> a
g = (b, a) -> a
forall a b. (a, b) -> b
snd ((b, a) -> a) -> (t -> (b, a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (b, a) -> (b, a)) -> t -> (b, a)
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base t a -> a) -> t -> a
cata ((Base t (b, a) -> b, Base t (b, a) -> a) -> Base t (b, a) -> (b, a)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence (Base t b -> b
f (Base t b -> b)
-> (Base t (b, a) -> Base t b) -> Base t (b, a) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, a) -> b) -> Base t (b, a) -> Base t b
forall a b. (a -> b) -> Base t a -> Base t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst, Base t (b, a) -> a
g))

-------------------------------------------------------------------------------
-- Base Functor Recursive/Corecursive instances

-- | Newtype for `TH.Type`, so we can make an instance of Recursive and Corecursive.
type THType :: *
newtype THType = THType {THType -> Type
getTHType :: TH.Type}

type instance Base THType = TypeF

projectType :: Type -> TypeF Type
projectType :: Type -> TypeF Type
projectType = (THType -> Type) -> TypeF THType -> TypeF Type
forall a b. (a -> b) -> TypeF a -> TypeF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap THType -> Type
getTHType (TypeF THType -> TypeF Type)
-> (Type -> TypeF THType) -> Type -> TypeF Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THType -> Base THType THType
THType -> TypeF THType
forall t. Recursive t => t -> Base t t
project (THType -> TypeF THType)
-> (Type -> THType) -> Type -> TypeF THType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> THType
THType

embedType :: TypeF Type -> Type
embedType :: TypeF Type -> Type
embedType = THType -> Type
getTHType (THType -> Type) -> (TypeF Type -> THType) -> TypeF Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base THType THType -> THType
TypeF THType -> THType
forall t. Corecursive t => Base t t -> t
embed (TypeF THType -> THType)
-> (TypeF Type -> TypeF THType) -> TypeF Type -> THType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> THType) -> TypeF Type -> TypeF THType
forall a b. (a -> b) -> TypeF a -> TypeF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> THType
THType

cataType :: (TypeF a -> a) -> Type -> a
cataType :: forall a. (TypeF a -> a) -> Type -> a
cataType TypeF a -> a
alg = (Base THType a -> a) -> THType -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base THType a -> a) -> THType -> a
cata Base THType a -> a
TypeF a -> a
alg (THType -> a) -> (Type -> THType) -> Type -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> THType
THType

zygoType :: (TypeF b -> b) -> (TypeF (b, a) -> a) -> Type -> a
zygoType :: forall b a. (TypeF b -> b) -> (TypeF (b, a) -> a) -> Type -> a
zygoType TypeF b -> b
α TypeF (b, a) -> a
β = (Base THType b -> b) -> (Base THType (b, a) -> a) -> THType -> a
forall t b a.
Recursive t =>
(Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo Base THType b -> b
TypeF b -> b
α Base THType (b, a) -> a
TypeF (b, a) -> a
β (THType -> a) -> (Type -> THType) -> Type -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> THType
THType


instance Recursive THType where
  project :: THType -> Base THType THType
  project :: THType -> Base THType THType
project = (Type -> THType) -> TypeF Type -> TypeF THType
forall a b. (a -> b) -> TypeF a -> TypeF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> THType
THType (TypeF Type -> TypeF THType)
-> (THType -> TypeF Type) -> THType -> TypeF THType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Base THType Type
Type -> TypeF Type
go (Type -> TypeF Type) -> (THType -> Type) -> THType -> TypeF Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THType -> Type
getTHType
    where
    go :: Type -> Base THType Type
    go :: Type -> Base THType Type
go Type
t = case Type
t of
      ForallT [TyVarBndr Specificity]
bnds Cxt
ctx Type
a -> 
        [TyVarBndrF Specificity Type] -> Cxt -> Type -> TypeF Type
forall k. [TyVarBndrF Specificity k] -> [k] -> k -> TypeF k
ForallTF_ ((TyVarBndr Specificity -> TyVarBndrF Specificity Type)
-> [TyVarBndr Specificity] -> [TyVarBndrF Specificity Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> TyVarBndrF Specificity Type
forall flag. TyVarBndr flag -> TyVarBndrF flag Type
projectBnd [TyVarBndr Specificity]
bnds) Cxt
ctx Type
a
      AppT Type
a Type
b -> Type -> Type -> TypeF Type
forall k. k -> k -> TypeF k
AppTF_ Type
a Type
b
      SigT Type
a Type
k -> Type -> Type -> TypeF Type
forall k. k -> k -> TypeF k
SigTF_ Type
a Type
k
#if MIN_VERSION_template_haskell(2,11,0)
      InfixT Type
a Name
n Type
b -> Type -> Name -> Type -> TypeF Type
forall k. k -> Name -> k -> TypeF k
InfixTF_ Type
a Name
n Type
b
      UInfixT Type
a Name
n Type
b -> Type -> Name -> Type -> TypeF Type
forall k. k -> Name -> k -> TypeF k
UInfixTF_ Type
a Name
n Type
b
      ParensT Type
k -> Type -> TypeF Type
forall k. k -> TypeF k
ParensTF_ Type
k
#endif
#if MIN_VERSION_template_haskell(2,15,0)
      AppKindT Type
a Type
k -> Type -> Type -> TypeF Type
forall k. k -> k -> TypeF k
AppKindTF_ Type
a Type
k
      ImplicitParamT String
x Type
a -> String -> Type -> TypeF Type
forall k. String -> k -> TypeF k
ImplicitParamTF_ String
x Type
a
#endif
#if MIN_VERSION_template_haskell(2,16,0)
      ForallVisT [TyVarBndr ()]
bnds Type
a ->
        [TyVarBndrF () Type] -> Type -> TypeF Type
forall k. [TyVarBndrF () k] -> k -> TypeF k
ForallVisTF_ ((TyVarBndr () -> TyVarBndrF () Type)
-> [TyVarBndr ()] -> [TyVarBndrF () Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> TyVarBndrF () Type
forall flag. TyVarBndr flag -> TyVarBndrF flag Type
projectBnd [TyVarBndr ()]
bnds) Type
a
#endif
#if MIN_VERSION_template_haskell(2,19,0)
      PromotedInfixT Type
a Name
n Type
b -> Type -> Name -> Type -> TypeF Type
forall k. k -> Name -> k -> TypeF k
PromotedInfixTF_ Type
a Name
n Type
b
      PromotedUInfixT Type
a Name
n Type
b -> Type -> Name -> Type -> TypeF Type
forall k. k -> Name -> k -> TypeF k
PromotedUInfixTF_ Type
a Name
n Type
b
#endif
      Type
a -> Type -> TypeF Type
forall k. Type -> TypeF k
AtomicF_ Type
a
    
instance Corecursive THType where
  embed :: Base THType THType -> THType
  embed :: Base THType THType -> THType
embed = Type -> THType
THType (Type -> THType)
-> (TypeF THType -> Type) -> TypeF THType -> THType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeF Type -> Type
go (TypeF Type -> Type)
-> (TypeF THType -> TypeF Type) -> TypeF THType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (THType -> Type) -> TypeF THType -> TypeF Type
forall a b. (a -> b) -> TypeF a -> TypeF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap THType -> Type
getTHType 
    where
    go :: TypeF Type -> Type
    go :: TypeF Type -> Type
go TypeF Type
t = case TypeF Type
t of
      ForallTF [TyVarBndrF Specificity Type]
bnds Cxt
ctx Type
a -> 
        [TyVarBndr Specificity] -> Cxt -> Type -> Type
mkForallT ((TyVarBndrF Specificity Type -> TyVarBndr Specificity)
-> [TyVarBndrF Specificity Type] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrF Specificity Type -> TyVarBndr Specificity
forall flag. TyVarBndrF flag Type -> TyVarBndr flag
embedBnd [TyVarBndrF Specificity Type]
bnds) Cxt
ctx Type
a
      ForallVisTF [TyVarBndrF () Type]
bnds Type
a ->
        [TyVarBndr ()] -> Type -> Type
mkForallVisT ((TyVarBndrF () Type -> TyVarBndr ())
-> [TyVarBndrF () Type] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrF () Type -> TyVarBndr ()
forall flag. TyVarBndrF flag Type -> TyVarBndr flag
embedBnd [TyVarBndrF () Type]
bnds) Type
a
      AppTF Type
a Type
b -> Type -> Type -> Type
mkAppT Type
a Type
b
      AppKindTF Type
a Type
k -> Type -> Type -> Type
mkAppKindT Type
a Type
k
      SigTF Type
a Type
k -> Type -> Type -> Type
mkSigT Type
a Type
k
      InfixTF Type
a Name
n Type
b -> Type -> Name -> Type -> Type
mkInfixT Type
a Name
n Type
b
      UInfixTF Type
a Name
n Type
b -> Type -> Name -> Type -> Type
mkUInfixT Type
a Name
n Type
b
      PromotedInfixTF Type
a Name
n Type
b -> Type -> Name -> Type -> Type
mkPromotedInfixT Type
a Name
n Type
b
      PromotedUInfixTF Type
a Name
n Type
b -> Type -> Name -> Type -> Type
mkPromotedUInfixT Type
a Name
n Type
b
      ImplicitParamTF String
x Type
a -> String -> Type -> Type
mkImplicitParamT String
x Type
a
      ParensTF Type
k -> Type -> Type
mkParensT Type
k
      AtomicF Type
a -> Type
a


---------------------------------------------------------------------------------------------------
-- Smart Types and Constructors for version agnosticism

{-| A type variable binder.

__Do not__ pattern match on this, instead use `recTyVarBndr`, which safely handles pattern matching in different
versions of template haskell.

/Note:/ In TemplateHaskell < 2.17, the flag parameter is ignored.
-}
#if MIN_VERSION_template_haskell(2,17,0)
type TyVarBndr :: * -> *
type TyVarBndr flag = THAll.TyVarBndr flag
#else
type TyVarBndr flag = THAll.TyVarBndr 
#endif

{-| The specificity of a binding; whether it is inferred or given by a user.

__Note:__ In TemplateHaskell < 2.17, this is unit.
-}
type Specificity :: *
#if MIN_VERSION_template_haskell(2,17,0)
type Specificity = THAll.Specificity
#else
type Specificity = ()
#endif

{-| Version-safe way to pattern match on `TyVarBndr`.

First case is for `TH.PlainTV`, the second for `TH.KindedTV`.
-}
recTyVarBndr 
  :: (Name -> flag -> a) -- The `PlainTV` case
  -> (Name -> flag -> Kind -> a) -- The `KindedTV` case
  -> TyVarBndr flag 
  -> a
#if MIN_VERSION_template_haskell(2,17,0)
recTyVarBndr :: forall flag a.
(Name -> flag -> a)
-> (Name -> flag -> Type -> a) -> TyVarBndr flag -> a
recTyVarBndr Name -> flag -> a
f Name -> flag -> Type -> a
_ (THAll.PlainTV Name
nm flag
flag) = Name -> flag -> a
f Name
nm flag
flag
recTyVarBndr Name -> flag -> a
_ Name -> flag -> Type -> a
g (THAll.KindedTV Name
nm flag
flag Type
k) = Name -> flag -> Type -> a
g Name
nm flag
flag Type
k
#else
  -- TODO: this is quite naughty
recTyVarBndr f _ (THAll.PlainTV nm) = f nm undefined
recTyVarBndr _ g (THAll.KindedTV nm k) = g nm undefined k
#endif

{-| Version-safe `TH.PlainTV` constructor for `TyVarBndr`.

In Template Haskell < 2.17, @flag@ can be assumed to be @()@.
-}
mkPlainTV :: Name -> flag -> TyVarBndr flag

{-| Version-safe `TH.KindedTV` constructor for `TyVarBndr`.

In Template Haskell < 2.17, @flag@ can be assumed to be @()@.
-}
mkKindedTV :: Name -> flag -> Type -> TyVarBndr flag
#if MIN_VERSION_template_haskell(2,17,0)
mkPlainTV :: forall flag. Name -> flag -> TyVarBndr flag
mkPlainTV  = Name -> flag -> TyVarBndr flag
forall flag. Name -> flag -> TyVarBndr flag
THAll.PlainTV
mkKindedTV :: forall flag. Name -> flag -> Type -> TyVarBndr flag
mkKindedTV = Name -> flag -> Type -> TyVarBndr flag
forall flag. Name -> flag -> Type -> TyVarBndr flag
THAll.KindedTV
#else
mkPlainTV  n ~_ = THAll.PlainTV n
mkKindedTV n ~_ = THAll.KindedTV n
#endif

mkVarT :: Name -> Type
mkVarT :: Name -> Type
mkVarT = Name -> Type
VarT

mkConT :: Name -> Type
mkConT :: Name -> Type
mkConT = Name -> Type
ConT

mkPromotedT :: Name -> Type
mkPromotedT :: Name -> Type
mkPromotedT = Name -> Type
PromotedT

-- | Smart constructor for `ForallT`. Version-safe.
mkForallT :: [TyVarBndr Specificity] -> Cxt -> Type -> Type
mkForallT :: [TyVarBndr Specificity] -> Cxt -> Type -> Type
mkForallT = [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT
-- | Smart constructor for `SigT`. Version-safe.
mkAppT :: Type -> Type -> Type
mkAppT :: Type -> Type -> Type
mkAppT = Type -> Type -> Type
AppT
-- | Smart constructor for `SigT`. Version-safe.
mkSigT :: Type -> Kind -> Type
mkSigT :: Type -> Type -> Type
mkSigT = Type -> Type -> Type
SigT

{-| Smart constructor for `InfixT`.

Equal to `undefined` for template haskell versions < 2.11, so ensure any code that
uses this will need only be run in versions ≥ 2.11 .
-}
mkInfixT :: Type -> Name -> Type -> Type
{-| Smart constructor for `UInfixT`.

Equal to `undefined` for template haskell versions < 2.11, so ensure any code that
uses this will need only be run in versions ≥ 2.11 .
-}
mkUInfixT :: Type -> Name -> Type -> Type

{-| Smart constructor for `ParensT`.

Equal to `undefined` for template haskell versions < 2.11, so ensure any code that
uses this will need only be run in versions ≥ 2.11 .
-}
mkParensT :: Type -> Type
#if MIN_VERSION_template_haskell(2,11,0)
mkParensT :: Type -> Type
mkParensT = Type -> Type
ParensT
mkUInfixT :: Type -> Name -> Type -> Type
mkUInfixT = Type -> Name -> Type -> Type
UInfixT
mkInfixT :: Type -> Name -> Type -> Type
mkInfixT = Type -> Name -> Type -> Type
InfixT
#else
mkUInfixT = undefined
mkParensT = undefined
mkInfixT = undefined
#endif

{-| Smart constructor for `AppKindT`.

Equal to `undefined` for template haskell versions < 2.15, so ensure any code that
uses this will need only be run in versions ≥ 2.15 .
-}
mkAppKindT :: Type -> Type -> Type

{-| Smart constructor for `ImplicitParamT`.

Equal to `undefined` for template haskell versions < 2.15, so ensure any code that
uses this will need only be run in versions ≥ 2.15 .
-}
mkImplicitParamT :: String -> Type -> Type
#if MIN_VERSION_template_haskell(2,15,0)
mkAppKindT :: Type -> Type -> Type
mkAppKindT = Type -> Type -> Type
AppKindT
mkImplicitParamT :: String -> Type -> Type
mkImplicitParamT = String -> Type -> Type
ImplicitParamT
#else
mkAppKindT = undefined
mkImplicitParamT = undefined
#endif

{-| Smart constructor for `ForallVisT`.

Equal to `undefined` for template haskell versions < 2.16, so ensure any code that
uses this will need only be run in versions ≥ 2.16 .
-}
mkForallVisT :: [TyVarBndr ()] -> Type -> Type
#if MIN_VERSION_template_haskell(2,16,0)
mkForallVisT :: [TyVarBndr ()] -> Type -> Type
mkForallVisT [TyVarBndr ()]
bnds Type
tp = [TyVarBndr ()] -> Type -> Type
ForallVisT [TyVarBndr ()]
bnds Type
tp
#else
mkForallVisT bnds tp = undefined
#endif

{-| Smart constructor for `PromotedInfixT`.

Equal to `undefined` for template haskell versions < 2.19, so ensure any code that
uses this will need only be run in versions ≥ 2.19 .
-}
mkPromotedInfixT :: Type -> Name -> Type -> Type

{-| Smart constructor for `PromotedUInfixT`.

Equal to `undefined` for template haskell versions < 2.19, so ensure any code that
uses this will need only be run in versions ≥ 2.19 .
-}
mkPromotedUInfixT :: Type -> Name -> Type -> Type
#if MIN_VERSION_template_haskell(2,19,0)
mkPromotedInfixT :: Type -> Name -> Type -> Type
mkPromotedInfixT = Type -> Name -> Type -> Type
PromotedInfixT
mkPromotedUInfixT :: Type -> Name -> Type -> Type
mkPromotedUInfixT = Type -> Name -> Type -> Type
PromotedUInfixT
#else
mkPromotedInfixT = undefined
mkPromotedUInfixT = undefined
#endif


#if !(MIN_VERSION_template_haskell(2,17,0))

{-
All of this is ported from:
https://hackage.haskell.org/package/template-haskell-2.22.0.0/docs/src/Language.Haskell.TH.Syntax.html

-}

class Monad m => Quote m where
  newName :: String -> m Name

instance Quote IO where
  newName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
                 ; pure (mkNameU s n) }
instance Quote Q where
  newName = qNewName

instance (Semigroup a) => Semigroup (Q a) where
  (<>) = liftA2 (<>)
instance (Monoid a) => Monoid (Q a) where
  mempty = pure mempty


#endif


#if !(MIN_VERSION_template_haskell(2,17,0))

data DocLoc = DeclDoc Name

getDoc :: DocLoc -> Q (Maybe String)
getDoc _ = pure Nothing

putDoc :: DocLoc -> String -> Q ()
putDoc _ _ = pure ()

-- Is this awful?
pattern MulArrowT = ArrowT


#endif