{-# LANGUAGE CPP #-}
#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 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
import Language.Haskell.TH.Syntax
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_lens (version)
#endif

-- | Apply arguments to a type constructor
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT

-- | Apply arguments to a function
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
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 (Int -> TypeQ
tupleT ([TypeQ] -> Int
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 = [ExpQ] -> ExpQ
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 = [PatQ] -> PatQ
tupP [PatQ]
xs

-- | Apply arguments to a type constructor.
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> [Type] -> Type
conAppsT Name
conName = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
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 = [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ String -> Q Name
newName (String
baseString -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
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 :: Type -> (Type, [Type])
unfoldType = [Type] -> Type -> (Type, [Type])
go []
  where
    go :: [Type] -> Type -> (Type, [Type])
    go :: [Type] -> Type -> (Type, [Type])
go [Type]
acc (ForallT [TyVarBndr]
_ [Type]
_ Type
ty) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
    go [Type]
acc (AppT Type
ty1 Type
ty2)   = [Type] -> Type -> (Type, [Type])
go (Type
ty2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
acc) Type
ty1
    go [Type]
acc (SigT Type
ty Type
_)      = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#if MIN_VERSION_template_haskell(2,11,0)
    go [Type]
acc (ParensT Type
ty)     = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#endif
#if MIN_VERSION_template_haskell(2,15,0)
    go [Type]
acc (AppKindT Type
ty Type
_)  = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#endif
    go [Type]
acc Type
ty               = (Type
ty, [Type]
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 -> Type
datatypeTypeKinded DatatypeInfo
di
  = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
di))
  ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type]
dropSigsIfNonDataFam
  ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
D.datatypeInstTypes DatatypeInfo
di
  where
    {-
    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 :: [Type] -> [Type]
    dropSigsIfNonDataFam :: [Type] -> [Type]
dropSigsIfNonDataFam
      | DatatypeVariant -> Bool
isDataFamily (DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
di) = [Type] -> [Type]
forall a. a -> a
id
      | Bool
otherwise                           = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
dropSig

    dropSig :: Type -> Type
    dropSig :: Type -> Type
dropSig (SigT Type
t Type
k) | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
D.freeVariables Type
k) = Type
t
    dropSig Type
t                                     = Type
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 :: [Type] -> Type -> Type
quantifyType = Set Name -> [Type] -> Type -> Type
quantifyType' Set Name
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 -> [Type] -> Type -> Type
quantifyType' Set Name
exclude [Type]
c Type
t = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
forall flag. [TyVarBndr]
vs [Type]
c Type
t
  where
  vs :: [TyVarBndr]
vs = (TyVarBndr -> Bool) -> [TyVarBndr] -> [TyVarBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr
tvb -> TyVarBndr -> Name
forall flag. TyVarBndr -> Name
D.tvName TyVarBndr
tvb Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
exclude)
     ([TyVarBndr] -> [TyVarBndr]) -> [TyVarBndr] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ Specificity -> [TyVarBndr] -> [TyVarBndr]
forall newFlag oldFlag. newFlag -> [TyVarBndr] -> [TyVarBndr]
D.changeTVFlags Specificity
D.SpecifiedSpec
     ([TyVarBndr] -> [TyVarBndr]) -> [TyVarBndr] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr]
D.freeVariablesWellScoped (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:(Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Type]
predTypes [Type]
c) -- stable order

  predTypes :: Pred -> [Type]
#if MIN_VERSION_template_haskell(2,10,0)
  predTypes :: Type -> [Type]
predTypes Type
p = [Type
p]
#else
  predTypes (ClassP _ ts)  = ts
  predTypes (EqualP t1 t2) = [t1, t2]
#endif

-- | Convert a 'TyVarBndr' into its corresponding 'Type'.
tvbToType :: D.TyVarBndr_ flag -> Type
tvbToType :: TyVarBndr -> Type
tvbToType = (Name -> Type) -> (Name -> Type -> Type) -> TyVarBndr -> Type
forall r flag. (Name -> r) -> (Name -> Type -> r) -> TyVarBndr -> r
D.elimTV Name -> Type
VarT (Type -> Type -> Type
SigT (Type -> Type -> Type) -> (Name -> Type) -> Name -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT)

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type
t
unSigT Type
t          = Type
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

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

lensPackageKey         :: String
#ifdef CURRENT_PACKAGE_KEY
lensPackageKey :: String
lensPackageKey          = CURRENT_PACKAGE_KEY
#else
lensPackageKey          = "lens-" ++ showVersion version
#endif

mkLensName_tc          :: String -> String -> Name
mkLensName_tc :: String -> String -> Name
mkLensName_tc           = String -> String -> String -> Name
mkNameG_tc String
lensPackageKey

mkLensName_v           :: String -> String -> Name
mkLensName_v :: String -> String -> Name
mkLensName_v            = String -> String -> String -> Name
mkNameG_v String
lensPackageKey

traversalTypeName      :: Name
traversalTypeName :: Name
traversalTypeName       = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Traversal"

traversal'TypeName     :: Name
traversal'TypeName :: Name
traversal'TypeName      = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Traversal'"

lensTypeName           :: Name
lensTypeName :: Name
lensTypeName            = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Lens"

lens'TypeName          :: Name
lens'TypeName :: Name
lens'TypeName           = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Lens'"

isoTypeName            :: Name
isoTypeName :: Name
isoTypeName             = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Iso"

iso'TypeName           :: Name
iso'TypeName :: Name
iso'TypeName            = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Iso'"

getterTypeName         :: Name
getterTypeName :: Name
getterTypeName          = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Getter"

foldTypeName           :: Name
foldTypeName :: Name
foldTypeName            = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Fold"

prismTypeName          :: Name
prismTypeName :: Name
prismTypeName           = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Prism"

prism'TypeName         :: Name
prism'TypeName :: Name
prism'TypeName          = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Prism'"

reviewTypeName          :: Name
reviewTypeName :: Name
reviewTypeName           = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Review"

wrappedTypeName         :: Name
wrappedTypeName :: Name
wrappedTypeName          = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Wrapped"

unwrappedTypeName       :: Name
unwrappedTypeName :: Name
unwrappedTypeName        = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Unwrapped"

rewrappedTypeName       :: Name
rewrappedTypeName :: Name
rewrappedTypeName        = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Rewrapped"

_wrapped'ValName        :: Name
_wrapped'ValName :: Name
_wrapped'ValName         = String -> String -> Name
mkLensName_v String
"Control.Lens.Wrapped" String
"_Wrapped'"

isoValName              :: Name
isoValName :: Name
isoValName               = String -> String -> Name
mkLensName_v String
"Control.Lens.Iso" String
"iso"

prismValName            :: Name
prismValName :: Name
prismValName             = String -> String -> Name
mkLensName_v String
"Control.Lens.Prism" String
"prism"

untoValName             :: Name
untoValName :: Name
untoValName              = String -> String -> Name
mkLensName_v String
"Control.Lens.Review" String
"unto"

phantomValName          :: Name
phantomValName :: Name
phantomValName           = String -> String -> Name
mkLensName_v String
"Control.Lens.Internal.TH" String
"phantom2"

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

composeValName          :: Name
composeValName :: Name
composeValName           = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"."

idValName               :: Name
idValName :: Name
idValName                = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"id"

fmapValName             :: Name
fmapValName :: Name
fmapValName              = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"fmap"

#if MIN_VERSION_base(4,8,0)
pureValName             :: Name
pureValName :: Name
pureValName              = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"pure"

apValName               :: Name
apValName :: Name
apValName                = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"<*>"
#else
pureValName             :: Name
pureValName              = mkNameG_v "base" "Control.Applicative" "pure"

apValName               :: Name
apValName                = mkNameG_v "base" "Control.Applicative" "<*>"
#endif

rightDataName           :: Name
rightDataName :: Name
rightDataName            = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Either" String
"Right"

leftDataName            :: Name
leftDataName :: Name
leftDataName             = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Either" String
"Left"


------------------------------------------------------------------------
-- Support for generating inline pragmas
------------------------------------------------------------------------

inlinePragma :: Name -> [DecQ]
inlinePragma :: Name -> [DecQ]
inlinePragma Name
methodName = [Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases]