Template Haskell splices to generate operations for Free monads

TH.hs

{-# LANGUAGE TemplateHaskell #-}
                
module Control.Monad.Free.TH 
    ( makeFree
    , showType
    ) where

import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import Control.Applicative
import Data.Char (toLower)
import Language.Haskell.TH

trace :: Show a => a -> Q ()
trace a = reportWarning (show a)

showType :: Name -> Q [Dec]
showType name = do 
    a <- reify name 
    reportWarning $ show a
    return []
    
failMaybe :: Monad m => String -> m (Maybe a) -> m a
failMaybe error m = m >>= maybe (fail error) return

data Arg = Arg Type       -- ^ Capture an argument of the given type
         | Ret [Type]     -- ^ Return a tuple of the given type
         deriving (Show)

unSigT :: Type -> Type
unSigT = gmapT 
unSigT 
appArgs :: Type -> Maybe -> [Type]
appArgs (AppT (AppT ArrowT a) rest) = do
    rest' <- appArgs rest
    return $ Just $ a : rest'
appArgs (AppT 

arg :: Name -> Type -> Q Arg
arg next (ConT t)        = return $ Capture (ConT t)
arg next (AppT ListT t)  = return $ Capture (AppT ListT t)
arg next (AppT (AppT ArrowT _) (VarT t))
    | t == next          = do x <- newName "x"
                              let idE = LamE [VarP x] (VarE x)
                              return $ Literal idE (ConT t)
arg next (VarT t)
    | t == next          = return $ Literal (TupE []) (TupleT 0)
arg _ a                  = fail $ "arg: Unsupported field type: "++show a

operationName :: String -> String
operationName (c:rest) = toLower c : rest

-- | Lift a data constructor into a free monad
liftCon' :: Type -> Name -> Name -> [Type] -> Q [Dec]
liftCon' functor nextTyName conName fieldTys = do
    let liftedName = mkName (operationName (nameBase conName))
    m <- newName "m"
    monadFree <- failMaybe "MonadFree not in scope" $ lookupTypeName "MonadFree"
    liftF <- failMaybe "liftF not in scope" $ lookupValueName "liftF"
    tys <- mapM (arg nextTyName) fieldTys
    let returnTy = case tys
        liftedTy = foldr f (AppT (VarT m) (VarT nextTyName)) tys
          where
            f (Capture t') t = AppT (AppT ArrowT t') t
            f _            t = t
        pat = undefined
        body = undefined
    trace liftedTy
    return $ [ SigD liftedName (ForallT [PlainTV m] [ClassP monadFree [functor, VarT m]] liftedTy)
             --, FunD liftedName [Clause pat body []]
             ]

tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV name)    = name
tyVarBndrName (KindedTV name _) = name

liftCon :: Type -> Name -> Con -> Q [Dec]
liftCon functor nextTyName (NormalC conName fieldTys) =
    liftCon' functor nextTyName conName (map snd fieldTys)
liftCon functor nextTyName (RecC conName fieldTys) =
    liftCon' functor nextTyName conName (map (\(_,_,ty)->ty) fieldTys)
liftCon _ _ con = fail $ "liftCon: Don't know how to lift "++show con

liftDec :: Dec -> Q [Dec]
liftDec (DataD _ tyName tyVarBndrs cons _)
    | null tyVarBndrs    = fail $ "Type "++show tyName++" needs at least one free variable"
    | otherwise          = do
        let nextTyName = tyVarBndrName (last tyVarBndrs)
        concat <$> mapM (liftCon (ConT tyName) nextTyName) cons
liftDec dec = fail $ "liftDec: Don't know how to lift "++show dec

-- | @$(makeFree ''Type)@ provides free monadic actions for the
-- constructors of the given type
makeFree :: Name -> Q [Dec]
makeFree typCon = do
    typInfo <- reify typCon
    case typInfo of
      TyConI dec -> liftDec dec
      otherwise  -> fail "makeFree expects a type constructor"