ImplicitParams emulating `static`

main.hs

{-# LANGUAGE ImplicitParams, TemplateHaskell, NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -ddump-splices #-}
import Data.IORef
import Control.Monad
import StaticVars

mainLoop = do
  let v = $(static [| 2 :: Int |])
  print =<< readIORef v
  modifyIORef v (+1)
  v <- readIORef v
  when (v < 10) mainLoop

main = do
  x <- newIORef (2 :: Int)
  $(declareStaticsFor "mainLoop")

main_output.hs

[2 of 2] Compiling Main             ( main.hs, interpreted )
main.hs:8:12-34: Splicing expression
    static [| 2 :: Int |]
  ======>
    (?v1 `asTypeOf` (undefined :: a_a4o9 -> IORef a_a4o9) (2 :: Int))
main.hs:16:4-33: Splicing expression
    declareStaticsFor "mainLoop"
  ======>
    do p_a4og <- newIORef (2 :: Int)
       let ?v1 = p_a4og in mainLoop
Ok, two modules loaded.
ghci> main
2
3
4
5
6
7
8
9

StaticVars.hs

{-# LANGUAGE TemplateHaskell #-}
module StaticVars where

import Language.Haskell.TH
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class

staticVarsPrefix = "v"

{-# NOINLINE varInits #-}
varInits :: IORef [ExpQ]
varInits = unsafePerformIO $ newIORef []

static :: ExpQ -> ExpQ
static v0 = do
  n <- liftIO $ do
    modifyIORef varInits (v0:)
    length <$> readIORef varInits
  [| $(implicitParamVarE (staticVarsPrefix ++ show n))
        `asTypeOf` (undefined :: a -> IORef a) $v0 |]

-- | $(declareStaticsFor "mainLoop") has whatever type mainLoop does
declareStaticsFor :: String -> ExpQ
declareStaticsFor mainLoop = do
  vs <- liftIO $ readIORef varInits
  liftIO $ writeIORef varInits [] -- lsp ends up with v17 otherwise
  
  -- p1 <- newIORef v1
  (doBody,ps) <- unzip <$> sequence [ do
        p <- newName "p"
        return (bindS (varP p) [| newIORef $v |], p)
                        | v <- vs ]
  -- let ?v1 = p1 in mainLoop
  let letES = [ noBindS $
             letE [ implicitParamBindD (staticVarsPrefix ++ show i) (varE p)
                        | (p, i) <- ps `zip` [1 .. ] ]
                  $ varE (mkName mainLoop) ]
  doE $ doBody ++ letES