{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif

#include "lens-common.h"

-----------------------------------------------------------------------------

-- |

-- Module      :  Control.Lens.Internal.TH

-- Copyright   :  (C) 2013-2016 Edward Kmett and Eric Mertens

-- License     :  BSD-style (see the file LICENSE)

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  experimental

-- Portability :  non-portable

--

----------------------------------------------------------------------------

module Control.Lens.Internal.TH where

import Control.Lens.Iso
import Control.Lens.Prism
import Control.Lens.Review
import Control.Lens.Type
import Control.Lens.Wrapped
import Data.Functor.Contravariant
import qualified Data.Set as Set
import Data.Set (Set)
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D

-- | Apply arguments to a type constructor

appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT

-- | Apply arguments to a function

appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE

-- | Construct a tuple type given a list of types.

toTupleT :: [TypeQ] -> TypeQ
toTupleT :: [TypeQ] -> TypeQ
toTupleT [TypeQ
x] = TypeQ
x
toTupleT [TypeQ]
xs = TypeQ -> [TypeQ] -> TypeQ
appsT (forall (m :: * -> *). Quote m => Int -> m Kind
tupleT (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeQ]
xs)) [TypeQ]
xs

-- | Construct a tuple value given a list of expressions.

toTupleE :: [ExpQ] -> ExpQ
toTupleE :: [ExpQ] -> ExpQ
toTupleE [ExpQ
x] = ExpQ
x
toTupleE [ExpQ]
xs = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ExpQ]
xs

-- | Construct a tuple pattern given a list of patterns.

toTupleP :: [PatQ] -> PatQ
toTupleP :: [PatQ] -> PatQ
toTupleP [PatQ
x] = PatQ
x
toTupleP [PatQ]
xs = forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [PatQ]
xs

-- | Apply arguments to a type constructor.

conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> [Kind] -> Kind
conAppsT Name
conName = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
conName)

-- | Generate many new names from a given base name.

newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name]
newNames :: String -> Int -> Q [Name]
newNames String
base Int
n = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ forall (m :: * -> *). Quote m => String -> m Name
newName (String
baseforall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
1..Int
n] ]

-- | Decompose an applied type into its individual components. For example, this:

--

-- @

-- Either Int Char

-- @

--

-- would be unfolded to this:

--

-- @

-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char])

-- @

--

-- This function ignores explicit parentheses and visible kind applications.

unfoldType :: Type -> (Type, [Type])
unfoldType :: Kind -> (Kind, [Kind])
unfoldType = [Kind] -> Kind -> (Kind, [Kind])
go []
  where
    go :: [Type] -> Type -> (Type, [Type])
    go :: [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc (ForallT [TyVarBndr Specificity]
_ [Kind]
_ Kind
ty) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
    go [Kind]
acc (AppT Kind
ty1 Kind
ty2)   = [Kind] -> Kind -> (Kind, [Kind])
go (Kind
ty2forall a. a -> [a] -> [a]
:[Kind]
acc) Kind
ty1
    go [Kind]
acc (SigT Kind
ty Kind
_)      = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
    go [Kind]
acc (ParensT Kind
ty)     = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#if MIN_VERSION_template_haskell(2,15,0)
    go [Kind]
acc (AppKindT Kind
ty Kind
_)  = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#endif
    go [Kind]
acc Kind
ty               = (Kind
ty, [Kind]
acc)

-- Construct a 'Type' using the datatype's type constructor and type

-- parameters. Unlike 'D.datatypeType', kind signatures are preserved to

-- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more

-- details on this.)

datatypeTypeKinded :: D.DatatypeInfo -> Type
datatypeTypeKinded :: DatatypeInfo -> Kind
datatypeTypeKinded DatatypeInfo
di
  = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
di))
  forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Kind] -> [Kind]
dropSigsIfNonDataFam DatatypeInfo
di
  forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Kind]
D.datatypeInstTypes DatatypeInfo
di

-- | In an effort to prevent users from having to enable KindSignatures every

-- time that they use lens' TH functionality, we strip off reified kind

-- annotations from when:

--

-- 1. The kind of a type does not contain any kind variables. If it *does*

--    contain kind variables, we want to preserve them so that we can generate

--    type signatures that preserve the dependency order of kind and type

--    variables. (The data types in test/T917.hs contain examples where this

--    is important.) This will require enabling `PolyKinds`, but since

--    `PolyKinds` implies `KindSignatures`, we can at least accomplish two

--    things at once.

-- 2. The data type is not an instance of a data family. We make an exception

--    for data family instances, since the presence or absence of a kind

--    annotation can be the difference between typechecking or not.

--    (See T917DataFam in tests/T917.hs for an example.) Moreover, the

--    `TypeFamilies` extension implies `KindSignatures`.

dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type]
dropSigsIfNonDataFam :: DatatypeInfo -> [Kind] -> [Kind]
dropSigsIfNonDataFam DatatypeInfo
di
  | DatatypeVariant -> Bool
isDataFamily (DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
di) = forall a. a -> a
id
  | Bool
otherwise                           = forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
dropSig
  where
    dropSig :: Type -> Type
    dropSig :: Kind -> Kind
dropSig (SigT Kind
t Kind
k) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. TypeSubstitution a => a -> [Name]
D.freeVariables Kind
k) = Kind
t
    dropSig Kind
t                                     = Kind
t

-- | Template Haskell wants type variables declared in a forall, so

-- we find all free type variables in a given type and declare them.

quantifyType :: Cxt -> Type -> Type
quantifyType :: [Kind] -> Kind -> Kind
quantifyType = Set Name -> [Kind] -> Kind -> Kind
quantifyType' forall a. Set a
Set.empty

-- | This function works like 'quantifyType' except that it takes

-- a list of variables to exclude from quantification.

quantifyType' :: Set Name -> Cxt -> Type -> Type
quantifyType' :: Set Name -> [Kind] -> Kind -> Kind
quantifyType' Set Name
exclude [Kind]
c Kind
t = [TyVarBndr Specificity] -> [Kind] -> Kind -> Kind
ForallT [TyVarBndr Specificity]
vs [Kind]
c Kind
t
  where
  vs :: [TyVarBndr Specificity]
vs = forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr Specificity
tvb -> forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr Specificity
tvb forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
exclude)
     forall a b. (a -> b) -> a -> b
$ forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags Specificity
D.SpecifiedSpec
     forall a b. (a -> b) -> a -> b
$ [Kind] -> [TyVarBndrUnit]
D.freeVariablesWellScoped (Kind
tforall a. a -> [a] -> [a]
:[Kind]
c) -- stable order


-- | Convert a 'TyVarBndr' into its corresponding 'Type'.

tvbToType :: D.TyVarBndr_ flag -> Type
tvbToType :: forall flag. TyVarBndr_ flag -> Kind
tvbToType = forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
D.elimTV Name -> Kind
VarT (Kind -> Kind -> Kind
SigT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Kind
VarT)

-- | Peel off a kind signature from a Type (if it has one).

unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT Kind
t Kind
_) = Kind
t
unSigT Kind
t          = Kind
t

isDataFamily :: D.DatatypeVariant -> Bool
isDataFamily :: DatatypeVariant -> Bool
isDataFamily DatatypeVariant
D.Datatype        = Bool
False
isDataFamily DatatypeVariant
D.Newtype         = Bool
False
isDataFamily DatatypeVariant
D.DataInstance    = Bool
True
isDataFamily DatatypeVariant
D.NewtypeInstance = Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
isDataFamily DatatypeVariant
D.TypeData        = Bool
False
#endif

------------------------------------------------------------------------

-- TH-quoted names

------------------------------------------------------------------------

-- Note that this module only TemplateHaskellQuotes, not TemplateHaskell,

-- which makes lens able to be used in stage1 cross-compilers.


traversalTypeName      :: Name
traversalTypeName :: Name
traversalTypeName       = ''Traversal

traversal'TypeName     :: Name
traversal'TypeName :: Name
traversal'TypeName      = ''Traversal'

lensTypeName           :: Name
lensTypeName :: Name
lensTypeName            = ''Lens

lens'TypeName          :: Name
lens'TypeName :: Name
lens'TypeName           = ''Lens'

isoTypeName            :: Name
isoTypeName :: Name
isoTypeName             = ''Iso

iso'TypeName           :: Name
iso'TypeName :: Name
iso'TypeName            = ''Iso'

getterTypeName         :: Name
getterTypeName :: Name
getterTypeName          = ''Getter

foldTypeName           :: Name
foldTypeName :: Name
foldTypeName            = ''Fold

prismTypeName          :: Name
prismTypeName :: Name
prismTypeName           = ''Prism

prism'TypeName         :: Name
prism'TypeName :: Name
prism'TypeName          = ''Prism'

reviewTypeName          :: Name
reviewTypeName :: Name
reviewTypeName           = ''Review

wrappedTypeName         :: Name
wrappedTypeName :: Name
wrappedTypeName          = ''Wrapped

unwrappedTypeName       :: Name
unwrappedTypeName :: Name
unwrappedTypeName        = ''Unwrapped

rewrappedTypeName       :: Name
rewrappedTypeName :: Name
rewrappedTypeName        = ''Rewrapped

_wrapped'ValName        :: Name
_wrapped'ValName :: Name
_wrapped'ValName         = '_Wrapped'

isoValName              :: Name
isoValName :: Name
isoValName               = 'iso

prismValName            :: Name
prismValName :: Name
prismValName             = 'prism

untoValName             :: Name
untoValName :: Name
untoValName              = 'unto

phantomValName          :: Name
phantomValName :: Name
phantomValName           = 'phantom2

phantom2 :: (Functor f, Contravariant f) => f a -> f b
phantom2 :: forall (f :: * -> *) a b.
(Functor f, Contravariant f) =>
f a -> f b
phantom2 = forall (f :: * -> *) a b.
(Functor f, Contravariant f) =>
f a -> f b
phantom
{-# INLINE phantom2 #-}

composeValName          :: Name
composeValName :: Name
composeValName           = '(.)

idValName               :: Name
idValName :: Name
idValName                = 'id

fmapValName             :: Name
fmapValName :: Name
fmapValName              = 'fmap

pureValName             :: Name
pureValName :: Name
pureValName              = 'pure

apValName               :: Name
apValName :: Name
apValName                = '(<*>)

rightDataName           :: Name
rightDataName :: Name
rightDataName            = 'Right

leftDataName            :: Name
leftDataName :: Name
leftDataName             = 'Left


------------------------------------------------------------------------

-- Support for generating inline pragmas

------------------------------------------------------------------------


inlinePragma :: Name -> [DecQ]
inlinePragma :: Name -> [DecQ]
inlinePragma Name
methodName = [forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases]