-- | Template Haskell support
{-# LANGUAGE TemplateHaskell, CPP #-}
module Control.Distributed.Process.Internal.Closure.TH
  ( -- * User-level API
    remotable
  , remotableDecl
  , mkStatic
  , functionSDict
  , functionTDict
  , mkClosure
  , mkStaticClosure
  ) where

import Prelude hiding (succ, any)
import Language.Haskell.TH
  ( -- Q monad and operations
    Q
  , reify
  , Loc(loc_module)
  , location
    -- Names
  , Name
  , mkName
  , nameBase
    -- Algebraic data types
  , Dec(SigD)
  , Exp
  , Type(AppT, ForallT, VarT, ArrowT)
  , Info(VarI)
#if MIN_VERSION_template_haskell(2,17,0)
  , Specificity
#endif
  , TyVarBndr(PlainTV, KindedTV)
  , Pred
#if MIN_VERSION_template_haskell(2,10,0)
  , conT
  , appT
#else
  , classP
#endif
  , varT
    -- Lifted constructors
    -- .. Literals
  , stringL
    -- .. Patterns
  , normalB
  , clause
    -- .. Expressions
  , varE
  , litE
   -- .. Top-level declarations
  , funD
  , sigD
  )
import Data.Maybe (catMaybes)
import Data.Binary (encode)
import Data.Generics (everywhereM, mkM, gmapM)
import Data.Rank1Dynamic (toDynamic)
import Data.Rank1Typeable
  ( Zero
  , Succ
  , TypVar
  )
import Control.Distributed.Static
  ( RemoteTable
  , registerStatic
  , Static
  , staticLabel
  , closure
  , staticCompose
  , staticClosure
  )
import Control.Distributed.Process.Internal.Types (Process)
import Control.Distributed.Process.Serializable
  ( SerializableDict(SerializableDict)
  )
import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

--------------------------------------------------------------------------------
-- User-level API                                                             --
--------------------------------------------------------------------------------

-- | Create the closure, decoder, and metadata definitions for the given list
-- of functions
remotable :: [Name] -> Q [Dec]
remotable :: [Name] -> Q [Dec]
remotable [Name]
ns = do
    [(Name, Type)]
types <- (Name -> Q (Name, Type)) -> [Name] -> Q [(Name, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> Q (Name, Type)
getType [Name]
ns
    ([[Dec]]
closures, [[Q Exp]]
inserts) <- [([Dec], [Q Exp])] -> ([[Dec]], [[Q Exp]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Dec], [Q Exp])] -> ([[Dec]], [[Q Exp]]))
-> Q [([Dec], [Q Exp])] -> Q ([[Dec]], [[Q Exp]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Type) -> Q ([Dec], [Q Exp]))
-> [(Name, Type)] -> Q [([Dec], [Q Exp])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, Type) -> Q ([Dec], [Q Exp])
generateDefs [(Name, Type)]
types
    [Dec]
rtable <- Name -> [Q Exp] -> Q [Dec]
createMetaData (String -> Name
mkName String
"__remoteTable") ([[Q Exp]] -> [Q Exp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Q Exp]]
inserts)
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
closures [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
rtable

-- | Like 'remotable', but parameterized by the declaration of a function
-- instead of the function name. So where for 'remotable' you'd do
--
-- > f :: T1 -> T2
-- > f = ...
-- >
-- > remotable ['f]
--
-- with 'remotableDecl' you would instead do
--
-- > remotableDecl [
-- >    [d| f :: T1 -> T2 ;
-- >        f = ...
-- >      |]
-- >  ]
--
-- 'remotableDecl' creates the function specified as well as the various
-- dictionaries and static versions that 'remotable' also creates.
-- 'remotableDecl' is sometimes necessary when you want to refer to, say,
-- @$(mkClosure 'f)@ within the definition of @f@ itself.
--
-- NOTE: 'remotableDecl' creates @__remoteTableDecl@ instead of @__remoteTable@
-- so that you can use both 'remotable' and 'remotableDecl' within the same
-- module.
remotableDecl :: [Q [Dec]] -> Q [Dec]
remotableDecl :: [Q [Dec]] -> Q [Dec]
remotableDecl [Q [Dec]]
qDecs = do
    [Dec]
decs <- [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Dec]]
qDecs
    let types :: [(Name, Type)]
types = [Maybe (Name, Type)] -> [(Name, Type)]
forall a. [Maybe a] -> [a]
catMaybes ((Dec -> Maybe (Name, Type)) -> [Dec] -> [Maybe (Name, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Maybe (Name, Type)
typeOf [Dec]
decs)
    ([[Dec]]
closures, [[Q Exp]]
inserts) <- [([Dec], [Q Exp])] -> ([[Dec]], [[Q Exp]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Dec], [Q Exp])] -> ([[Dec]], [[Q Exp]]))
-> Q [([Dec], [Q Exp])] -> Q ([[Dec]], [[Q Exp]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Type) -> Q ([Dec], [Q Exp]))
-> [(Name, Type)] -> Q [([Dec], [Q Exp])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, Type) -> Q ([Dec], [Q Exp])
generateDefs [(Name, Type)]
types
    [Dec]
rtable <- Name -> [Q Exp] -> Q [Dec]
createMetaData (String -> Name
mkName String
"__remoteTableDecl") ([[Q Exp]] -> [Q Exp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Q Exp]]
inserts)
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
closures [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
rtable
  where
    typeOf :: Dec -> Maybe (Name, Type)
    typeOf :: Dec -> Maybe (Name, Type)
typeOf (SigD Name
name Type
typ) = (Name, Type) -> Maybe (Name, Type)
forall a. a -> Maybe a
Just (Name
name, Type
typ)
    typeOf Dec
_               = Maybe (Name, Type)
forall a. Maybe a
Nothing

-- | Construct a static value.
--
-- If @f : forall a1 .. an. T@
-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
-- Be sure to pass 'f' to 'remotable'.
mkStatic :: Name -> Q Exp
mkStatic :: Name -> Q Exp
mkStatic = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (Name -> Name) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
staticName

-- | If @f : T1 -> T2@ is a monomorphic function
-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
--
-- Be sure to pass 'f' to 'remotable'.
functionSDict :: Name -> Q Exp
functionSDict :: Name -> Q Exp
functionSDict = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (Name -> Name) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
sdictName

-- | If @f : T1 -> Process T2@ is a monomorphic function
-- then @$(functionTDict 'f) :: Static (SerializableDict T2)@.
--
-- Be sure to pass 'f' to 'remotable'.
functionTDict :: Name -> Q Exp
functionTDict :: Name -> Q Exp
functionTDict = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (Name -> Name) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
tdictName

-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
--
-- TODO: The current version of mkClosure is too polymorphic
-- (@forall a. Binary a => a -> Closure T2).
mkClosure :: Name -> Q Exp
mkClosure :: Name -> Q Exp
mkClosure Name
n =
  [|   closure ($(Name -> Q Exp
mkStatic Name
n) `staticCompose` staticDecode $(Name -> Q Exp
functionSDict Name
n))
     . encode
  |]

-- | Make a 'Closure' from a static function.  This is useful for
-- making a closure for a top-level @Process ()@ function, because
-- using 'mkClosure' would require adding a dummy @()@ argument.
--
mkStaticClosure :: Name -> Q Exp
mkStaticClosure :: Name -> Q Exp
mkStaticClosure Name
n = [| staticClosure $( Name -> Q Exp
mkStatic Name
n ) |]

--------------------------------------------------------------------------------
-- Internal (Template Haskell)                                                --
--------------------------------------------------------------------------------

-- | Generate the code to add the metadata to the CH runtime
createMetaData :: Name -> [Q Exp] -> Q [Dec]
createMetaData :: Name -> [Q Exp] -> Q [Dec]
createMetaData Name
name [Q Exp]
is =
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name [t| RemoteTable -> RemoteTable |]
           , Name -> Q Exp -> Q Dec
sfnD Name
name ([Q Exp] -> Q Exp
compose [Q Exp]
is)
           ]

generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp])
generateDefs :: (Name, Type) -> Q ([Dec], [Q Exp])
generateDefs (Name
origName, Type
fullType) = do
    Type
proc <- [t| Process |]
    let ([TyVarBndr Specificity]
typVars, Type
typ') = case Type
fullType of ForallT [TyVarBndr Specificity]
vars [] Type
mono -> ([TyVarBndr Specificity]
vars, Type
mono)
                                           Type
_                    -> ([], Type
fullType)

    -- The main "static" entry
    ([Dec]
static, [Q Exp]
register) <- [TyVarBndr Specificity] -> Type -> Q ([Dec], [Q Exp])
makeStatic [TyVarBndr Specificity]
typVars Type
typ'

    -- If n :: T1 -> T2, static serializable dictionary for T1
    -- TODO: we should check if arg is an instance of Serializable, but we cannot
    -- http://hackage.haskell.org/trac/ghc/ticket/7066
    ([Dec]
sdict, [Q Exp]
registerSDict) <- case ([TyVarBndr Specificity]
typVars, Type
typ') of
      ([], Type
ArrowT `AppT` Type
arg `AppT` Type
_res) ->
        Name -> Type -> Q ([Dec], [Q Exp])
makeDict (Name -> Name
sdictName Name
origName) Type
arg
      ([TyVarBndr Specificity], Type)
_ ->
        ([Dec], [Q Exp]) -> Q ([Dec], [Q Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])

    -- If n :: T1 -> Process T2, static serializable dictionary for T2
    -- TODO: check if T2 is serializable (same as above)
    ([Dec]
tdict, [Q Exp]
registerTDict) <- case ([TyVarBndr Specificity]
typVars, Type
typ') of
      ([], Type
ArrowT `AppT` Type
_arg `AppT` (Type
proc' `AppT` Type
res)) | Type
proc' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
proc ->
        Name -> Type -> Q ([Dec], [Q Exp])
makeDict (Name -> Name
tdictName Name
origName) Type
res
      ([TyVarBndr Specificity], Type)
_ ->
        ([Dec], [Q Exp]) -> Q ([Dec], [Q Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])

    ([Dec], [Q Exp]) -> Q ([Dec], [Q Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
static, [Dec]
sdict, [Dec]
tdict]
           , [[Q Exp]] -> [Q Exp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Q Exp]
register, [Q Exp]
registerSDict, [Q Exp]
registerTDict]
           )
  where
#if MIN_VERSION_template_haskell(2,17,0)
    makeStatic :: [TyVarBndr Specificity] -> Type -> Q ([Dec], [Q Exp])
#else
    makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
#endif
    makeStatic :: [TyVarBndr Specificity] -> Type -> Q ([Dec], [Q Exp])
makeStatic [TyVarBndr Specificity]
typVars Type
typ = do
      [Dec]
static <- Name -> [TyVarBndr Specificity] -> Type -> Q [Dec]
generateStatic Name
origName [TyVarBndr Specificity]
typVars Type
typ
      let dyn :: Q Exp
dyn = case [TyVarBndr Specificity]
typVars of
                  [] -> [| toDynamic $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
origName) |]
                  [TyVarBndr Specificity]
_  -> [| toDynamic ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
origName) :: $([TyVarBndr Specificity] -> Type -> Q Type
monomorphize [TyVarBndr Specificity]
typVars Type
typ)) |]
      ([Dec], [Q Exp]) -> Q ([Dec], [Q Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Dec]
static
             , [ [| registerStatic $(Name -> Q Exp
showFQN Name
origName) $Q Exp
dyn |] ]
             )

    makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
    makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
makeDict Name
dictName Type
typ = do
      [Dec]
sdict <- Name -> Type -> Q [Dec]
generateDict Name
dictName Type
typ
      let dyn :: Q Exp
dyn = [| toDynamic (SerializableDict :: SerializableDict $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ)) |]
      ([Dec], [Q Exp]) -> Q ([Dec], [Q Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Dec]
sdict
             , [ [| registerStatic $(Name -> Q Exp
showFQN Name
dictName) $Q Exp
dyn |] ]
             )

-- | Turn a polymorphic type into a monomorphic type using ANY and co
#if MIN_VERSION_template_haskell(2,17,0)
monomorphize :: [TyVarBndr Specificity] -> Type -> Q Type
#else
monomorphize :: [TyVarBndr] -> Type -> Q Type
#endif

monomorphize :: [TyVarBndr Specificity] -> Type -> Q Type
monomorphize [TyVarBndr Specificity]
tvs =
    let subst :: [(Name, Q Type)]
subst = [Name] -> [Q Type] -> [(Name, Q Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr Specificity -> Name)
-> [TyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Name
tyVarBndrName [TyVarBndr Specificity]
tvs) [Q Type]
anys
    in GenericM Q -> GenericM Q
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((Type -> Q Type) -> a -> Q a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM ([(Name, Q Type)] -> Type -> Q Type
applySubst [(Name, Q Type)]
subst))
  where
    anys :: [Q Type]
    anys :: [Q Type]
anys = (Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Q Type -> Q Type
typVar ((Q Type -> Q Type) -> Q Type -> [Q Type]
forall a. (a -> a) -> a -> [a]
iterate Q Type -> Q Type
succ Q Type
zero)

    typVar :: Q Type -> Q Type
    typVar :: Q Type -> Q Type
typVar Q Type
t = [t| TypVar $Q Type
t |]

    zero :: Q Type
    zero :: Q Type
zero = [t| Zero |]

    succ :: Q Type -> Q Type
    succ :: Q Type -> Q Type
succ Q Type
t = [t| Succ $Q Type
t |]

    applySubst :: [(Name, Q Type)] -> Type -> Q Type
    applySubst :: [(Name, Q Type)] -> Type -> Q Type
applySubst [(Name, Q Type)]
s (VarT Name
n) =
      case Name -> [(Name, Q Type)] -> Maybe (Q Type)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Q Type)]
s of
        Maybe (Q Type)
Nothing -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT Name
n)
        Just Q Type
t  -> Q Type
t
    applySubst [(Name, Q Type)]
s Type
t = GenericM Q -> Type -> Q Type
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Type -> m Type
gmapM ((Type -> Q Type) -> d -> Q d
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM ([(Name, Q Type)] -> Type -> Q Type
applySubst [(Name, Q Type)]
s)) Type
t

-- | Generate a static value
#if MIN_VERSION_template_haskell(2,17,0)
generateStatic :: Name -> [TyVarBndr Specificity] -> Type -> Q [Dec]
#else
generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
#endif
generateStatic :: Name -> [TyVarBndr Specificity] -> Type -> Q [Dec]
generateStatic Name
n [TyVarBndr Specificity]
xs Type
typ = do
    Type
staticTyp <- [t| Static |]
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (Name -> Name
staticName Name
n) (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ do
          [Type]
txs <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Type] -> Q [Type]) -> [Q Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (TyVarBndr Specificity -> Q Type)
-> [TyVarBndr Specificity] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Q Type
typeable [TyVarBndr Specificity]
xs
          Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
xs
                  [Type]
txs
                  (Type
staticTyp Type -> Type -> Type
`AppT` Type
typ))
      , Name -> Q Exp -> Q Dec
sfnD (Name -> Name
staticName Name
n) [| staticLabel $(Name -> Q Exp
showFQN Name
n) |]
      ]
  where
#if MIN_VERSION_template_haskell(2,17,0)
    typeable :: TyVarBndr Specificity -> Q Pred
#else
    typeable :: TyVarBndr -> Q Pred
#endif
    typeable :: TyVarBndr Specificity -> Q Type
typeable TyVarBndr Specificity
tv =
#if MIN_VERSION_template_haskell(2,10,0)
      Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Typeable") Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (TyVarBndr Specificity -> Name
tyVarBndrName TyVarBndr Specificity
tv)
#else
      classP (mkName "Typeable") [varT (tyVarBndrName tv)]
#endif

-- | Generate a serialization dictionary with name 'n' for type 'typ'
generateDict :: Name -> Type -> Q [Dec]
generateDict :: Name -> Type -> Q [Dec]
generateDict Name
n Type
typ = do
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ [t| Static (SerializableDict $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ)) |]
      , Name -> Q Exp -> Q Dec
sfnD Name
n [| staticLabel $(Name -> Q Exp
showFQN Name
n) |]
      ]

staticName :: Name -> Name
staticName :: Name -> Name
staticName Name
n = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__static"

sdictName :: Name -> Name
sdictName :: Name -> Name
sdictName Name
n = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__sdict"

tdictName :: Name -> Name
tdictName :: Name -> Name
tdictName Name
n = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__tdict"

--------------------------------------------------------------------------------
-- Generic Template Haskell auxiliary functions                               --
--------------------------------------------------------------------------------

-- | Compose a set of expressions
compose :: [Q Exp] -> Q Exp
compose :: [Q Exp] -> Q Exp
compose []     = [| id |]
compose [Q Exp
e]    = Q Exp
e
compose (Q Exp
e:[Q Exp]
es) = [| $Q Exp
e . $([Q Exp] -> Q Exp
compose [Q Exp]
es) |]

-- | Literal string as an expression
stringE :: String -> Q Exp
stringE :: String -> Q Exp
stringE = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL

-- | Look up the "original name" (module:name) and type of a top-level function
getType :: Name -> Q (Name, Type)
getType :: Name -> Q (Name, Type)
getType Name
name = do
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
    VarI Name
origName Type
typ Maybe Dec
_   -> (Name, Type) -> Q (Name, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
origName, Type
typ)
#else
    VarI origName typ _ _ -> return (origName, typ)
#endif
    Info
_                     -> String -> Q (Name, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, Type)) -> String -> Q (Name, Type)
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"

-- | Variation on 'funD' which takes a single expression to define the function
sfnD :: Name -> Q Exp -> Q Dec
sfnD :: Name -> Q Exp -> Q Dec
sfnD Name
n Q Exp
e = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
e) []]

-- | The name of a type variable binding occurrence
#if MIN_VERSION_template_haskell(2,17,0)
tyVarBndrName :: TyVarBndr Specificity -> Name
tyVarBndrName :: TyVarBndr Specificity -> Name
tyVarBndrName (PlainTV Name
n Specificity
_)    = Name
n
tyVarBndrName (KindedTV Name
n Specificity
_ Type
_) = Name
n
#else
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV n)    = n
tyVarBndrName (KindedTV n _) = n
#endif


-- | Fully qualified name; that is, the name and the _current_ module
--
-- We ignore the module part of the Name argument (which may or may not exist)
-- because we construct various names (`staticName`, `sdictName`, `tdictName`)
-- and those names certainly won't have Module components.
showFQN :: Name -> Q Exp
showFQN :: Name -> Q Exp
showFQN Name
n = do
  Loc
loc <- Q Loc
location
  String -> Q Exp
stringE (Loc -> String
loc_module Loc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n)