FunctionFactory.hs

{-# LANGUAGE
 TemplateHaskell
 #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Imperative.FunctionFactory
-- Maintainer  :  Matthew Mirman <mmirman@andrew.cmu.edu>
-- Stability   :  experimental
-- Portability :  TemplateHaskell
-- A module which defines a function 'liftOp' which coverts pure functions 
-- into reference taking functions.
-----------------------------------------------------------------------------

module Control.Monad.Imperative.FunctionFactory
       ( liftOp
       ) where

import Control.Monad.Imperative.Internals
import Language.Haskell.TH
import Data.Functor

-- | @'liftOp' nm@ is a function factory producer which uses template 
-- to infer the type of its argument and output an impure function factory.
-- 
-- The argument @nm@ must be a quoted name with type already known.
-- 
-- Examples:
-- > liftSomeFoo (v :: a -> ((a,b),b) -> c) = $(liftOp 'v)
-- >
-- > plus = $(liftOp '(+))
-- > 
-- > letBound = let f a = a * 5 in $(liftOp 'f)
-- > 
-- > argument n = $(liftOp 'mod) 4 n
-- 
-- If the function factories produce will be used in the same file that produced them
-- the output type needs to be known before 'liftOp' is called, 
-- such as in the definition of 'liftOp2'.
-- 
-- Currently 'liftOp' does not support unboxed tuples.
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) |]