{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module T17839 where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Data.Map as Map
import Control.Monad.State
import Control.Monad.Writer
import Language.Haskell.TH
import qualified Control.Monad.Writer as W
import Data.Functor.Identity


type LetT m a = WriterT [Locus] m a

type MCode m a = m (TExp a)

type LetCode m a = LetT m (TExp a)

data Locus = Locus

instance (Monoid w, Quote m) => Quote (WriterT w m) where
  newName x = W.lift (newName x)

instance (Monoid w, Quote m) => Quote (StateT w m) where
  newName x = W.lift (newName x)


locus :: (Locus -> LetCode m a) -> MCode m a
locus = undefined

newTypedName :: Quote m => m (TExp a)
newTypedName = do
  n <- newName "n"
  return (TExp (VarE n))


gen :: Quote m => Locus -> (MCode Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b)
gen l f = do
  n <- newTypedName
  examineCode [|| \a -> $$(liftCode $ f (Identity n) (examineCode [|| a ||])) ||]


mrfix :: forall a b m r . (Monad m, Ord a, Quote m)
      => (forall m . (a -> MCode m (b -> r)) -> (a -> MCode m b -> MCode m r))
      -> (a -> MCode m (b -> r))
mrfix f x =
  flip evalStateT Map.empty $
    locus $ \locus -> do
      m <- get
      let loop :: a -> LetT (StateT (Map.Map a (Identity (TExp (b -> r)))) m) (TExp (b -> r))
          loop n =
            case Map.lookup n m of
              Just (Identity v) -> return v
              Nothing -> do
                gen locus (\g y -> do
                  modify (Map.insert n g)
                  f loop n y)
      loop x


