Compiler.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}
module Compiler where

import Language.Haskell.TH

type QTExp a = Q (TExp a)

fix :: (a -> a) -> a
fix f = let x = f x in x

while ::
  forall m . Monoid m =>
  QTExp (IO m -> IO m) -> QTExp (IO m)
while b = [|| fix (\r -> whenM @(IO m) ($$b r)) ||]

whenM :: Monoid m => m ->  m
whenM _ = mempty

execOp :: forall m . Monoid m => QTExp (IO m)
execOp = while [|| \r -> $$(while @m [|| id ||]) >> r ||]

runQuery :: QTExp (IO ())
runQuery = execOp

Test.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices #-}
module Test where

import qualified Compiler as C

main :: IO ()
main = do
  $$(C.runQuery)