quasiquote for defunctionalization

MkF.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
module MkF (MkF(..), mkF, mkFInstances) where
import Control.Applicative
import Data.HList.CommonMain
import Language.Haskell.TH.Quote
import Language.Haskell.TH
import Language.Haskell.Meta.Syntax.Translate (toType,toExp)
import qualified Language.Haskell.Exts as E
import Data.List
import System.Process
import System.IO.Unsafe
import Data.IORef
import Control.Monad
import GHC.TypeLits


mkF :: QuasiQuoter
mkF = QuasiQuoter { quoteExp = quoteExp1 }

data MkF (x :: Symbol) = MkF

mkMkFT :: String -> TypeQ
mkMkFT body = [t| MkF $(litT (strTyLit body)) |]


quoteExp1 :: String -> ExpQ
quoteExp1 body = do
    let uniqName = "eihee2Oo"
    ty <- runIO $ readProcess "ghc" ["-e", "let "++uniqName++" x = ("++body++") x", "-e", ":t "++uniqName] ""
    runIO $ print ty
    ty <- either fail return $ do
      tyBody <- maybe (Left $ "ghc produced unexpected output"++ty)
            Right
           $ stripPrefix (uniqName++" :: ") ty
      parseType tyBody

    writeInstD body ty
    [| MkF :: $(mkMkFT body) |]
    

{-# NOINLINE mkFApplyABInstances #-}
mkFApplyABInstances :: IORef DecsQ
mkFApplyABInstances = unsafePerformIO $ newIORef (return [])

mkFInstances :: DecsQ
mkFInstances = do
  r <- runIO $ readIORef mkFApplyABInstances
  runIO $ writeIORef mkFApplyABInstances (return []) 
  r

writeInstD :: String -> Type -> Q ()
writeInstD body ty = do
  e <- either (\ msg -> fail $ "cannot parse: " ++ body ++ " message: " ++ msg)
          return $ parseExp body

  dec <- case ty of
    ForallT tvb cxt ty -> do
      x <- varT <$> newName "x"
      y <- varT <$> newName "y"
      defXY <- [t| $x -> $y |] `equalP` return ty
      instanceD (return (defXY : cxt)) [t| ApplyAB $(mkMkFT body) $x $y |]
          [funD 'applyAB [clause [wildP] (normalB (return e)) []] ]

  runIO $ modifyIORef mkFApplyABInstances ((dec :) <$>)

  return ()


-- * parse 
parseType str = fmap toType $ toEither $ E.parseTypeWithMode allExtensionsMode str
parseExp str = fmap toExp $ toEither $ E.parseExpWithMode allExtensionsMode str

toEither (E.ParseOk x) = Right x
toEither err = Left (show err)


allExtensionsMode :: E.ParseMode
allExtensionsMode =
    E.defaultParseMode{
        E.fixities = Nothing, -- these get filled in later
        E.extensions = map E.EnableExtension [
          E.ImplicitParams,
          E.BangPatterns,
          E.NamedFieldPuns,
          E.PatternGuards,
          E.TypeFamilies,
          E.UnicodeSyntax,
          E.TypeOperators,
          E.FlexibleContexts,
          E.FlexibleInstances,
          E.RecordWildCards,
          E.LambdaCase,
          E.ViewPatterns,
          E.TupleSections,
          E.NPlusKPatterns,
          E.DataKinds,
          E.PolyKinds,
          E.ScopedTypeVariables,
          E.MultiWayIf ]}

test.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
import MkF
import Data.HList.CommonMain

test = hEnd $ hBuild (1 :: Int) (5 :: Integer) (1 :: Double)
main = print $ hMap [mkF| \y -> if y < 3 then y+3 else 0 |] test
{- |

>>> main
H[4, 0, 4.0]

-}

mkFInstances

{- TH generates:

test.hs:12:21-59: Splicing expression
    " \\y -> if y < 3 then y+3 else 0 "
  ======>
      MkF :: MkF " \\y -> if y < 3 then y+3 else 0 "
test.hs:1:1: Splicing declarations
    mkFInstances
  ======>
    test.hs:14:1-12
    instance ((x -> y) ~ (a -> a), Ord a, Num a) =>
             ApplyAB (MkF " \\y -> if y < 3 then y+3 else 0 ") x y where
      applyAB _ = \ y -> if y < 3 then y + 3 else 0
-}