----------------------------------------------------------------------------
-- |
-- Module      :  Data.Emacs.Module.SymbolName.TH
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE MagicHash       #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Emacs.Module.SymbolName.TH
  ( cacheSym
  ) where

import Data.IORef
import Data.Maybe
import Language.Haskell.TH
import System.IO.Unsafe

import Data.Emacs.Module.Raw.Env.Internal (Env)
import Data.Emacs.Module.Raw.Value
import Data.Emacs.Module.SymbolName.Internal qualified as Sym

cacheSym :: String -> Maybe String -> Q [Dec]
cacheSym :: String -> Maybe String -> Q [Dec]
cacheSym String
sym Maybe String
bindingName = do
  Name
ref      <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"ref_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
binding)
  Dec
noinline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
ref Inline
NoInline RuleMatch
FunLike Phases
AllPhases
  Dec
refSig   <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
ref [t| IORef (Env -> IO (RawValue 'Pinned)) |]
  Dec
refDecl  <- Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
ref) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| unsafePerformIO (Sym.mkSymbolNameCache $Q Exp
sym') |]) []
  Dec
symSig   <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName String
binding) [t| Sym.SymbolName |]
  Dec
symDecl  <- Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
binding)) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e| Sym.CachedSymbol $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
ref) $Q Exp
sym' |]) []
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
noinline, Dec
refSig, Dec
refDecl, Dec
symSig, Dec
symDecl]
  where
    sym' :: ExpQ
    sym' :: Q Exp
sym' = [e| Sym.mkSymbolNameString $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
sym)) |]
    binding :: String
binding = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
sym Maybe String
bindingName