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

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