module Control.Monad.Imperative.FunctionFactory
( liftOp
) where
import Control.Monad.Imperative.Internals
import Language.Haskell.TH
import Data.Functor
liftOp :: Name -> Q Exp
liftOp nm = do
let getTy (VarI _ ty _ _) = ty
getTy (ClassOpI _ ty _ _) = ty
getTy (DataConI _ ty _ _) = ty
getTy r = error $ "liftOp only supports lifting variable names. Tried to show" ++show r
ty <- getTy <$> reify nm
(pats,pats') <- unzip <$> (sequence $ tyToPats ty)
lamE (map return pats) $ appE [| C |] $ doE $
(nn2st <$> zip (ps2ns pats) (ps2ns pats'))
++
[noBindS $ appE [| return . Lit |] $ return $ foldl AppE (VarE nm) $ map p2e pats']
tyToPats :: Type -> [Q (Pat, Pat)]
tyToPats (ForallT _ _ t) = tyToPats t
tyToPats (AppT (AppT ArrowT a) r) = typat:tyToPats r
where typat = do
t <- t2p a
return $ case t of
(TupP s, TupP s') -> (TupP $ reverse s, TupP $ reverse s')
_ -> t
isTuple (AppT v _) = isTuple v
isTuple (TupleT _) = True
isTuple _ = False
t2p (ForallT _ _ t) = t2p t
t2p (TupleT _) = return (TupP [], TupP [])
t2p (AppT v a) | isTuple v = do
(TupP t, TupP t') <- t2p v
(p,p') <- t2p a
return (TupP $ p:t, TupP $ p':t')
t2p _ = do
a <- newName "a"
b <- newName "b"
return $ (VarP a, VarP b)
tyToPats _ = []
p2e :: Pat -> Exp
p2e (TupP l) = TupE $ map p2e l
p2e (VarP n) = VarE n
p2e l = error $ "Bug: shouldn't encounter non tuples or variables here. p2e: " ++ show l
ps2ns :: [Pat] -> [Name]
ps2ns = concatMap p2ns
where p2ns (TupP l) = ps2ns l
p2ns (VarP n) = [n]
p2ns l = error $ "Bug: shouldn't encounter non tuples or variables here. ps2ns: " ++ show l
nn2st :: (Name,Name) -> StmtQ
nn2st (n,n') = bindS (varP n') [| val $(varE n) |]