Applicatives for Profiling, Profit, and Fun

applicative-profiling.hs

import Control.Applicative((<*>), Applicative, pure)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.RWS.Strict (RWST, runRWST, tell)
import Control.Monad.State (get, modify)
import Data.List.NonEmpty (NonEmpty((:|)), (<|), nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import System.Clock (Clock (Monotonic), getTime, nsec)

data Profiler m a = Profiler { item :: m a
                             , profilerPre  :: m ()
                             , profilerPost :: m ()
                             }

instance Functor m => Functor (Profiler m) where
  fmap f pa@(Profiler ma _ _) = pa { item = fmap f ma }

noop :: (Applicative m) => m ()
noop = pure ()

instance (Applicative m, MonadIO m) => Applicative (Profiler m) where
  pure a = Profiler (pure a) noop noop
  (Profiler mf' pre' post') <*> (Profiler ma' _ _) = Profiler (interleave ma' pre' mf' post') noop noop where
    interleave ma pre mf post = do
      _ <- pre
      result <- mf <*> ma
      _ <- post
      pure result

type FuncState = NonEmpty Int
type TracingProfiler a = Profiler (RWST () [String] FuncState IO) a

-- prints system clock to StdOut before and after computation.
timedP :: String -> (a -> b) -> TracingProfiler (a -> b)
timedP name f = Profiler (pure f) pre post where
  pre = do
    timeSpec <- liftIO $ getTime Monotonic
    times <- get
    let space = replicate (NE.length times) '\t'
    modify (nsec timeSpec <|)
    tell [space ++ "Beginning computation for: " ++ name ++ " @ " ++ (show . nsec $ timeSpec)]
  post = do
    timeSpec <- liftIO $ getTime Monotonic
    times <- get
    let remaining = NE.tail times
    let space = replicate (length remaining) '\t'
    modify (\t -> fromMaybe t (nonEmpty remaining))
    tell [ space ++ "Ending computation for: " ++ name ++ " @ " ++ (show . nsec $ timeSpec)
         , space ++ "== LENGTH: " ++ show (nsec timeSpec - NE.head times)
         ]

runRWSTProfiler :: (Applicative m, MonadIO m)
                => r
                -> s
                -> Profiler (RWST r w s m) a
                -> m (a, s, w)
runRWSTProfiler ir is profile = (runRWST $ item profile) ir is

myComputation :: TracingProfiler String
myComputation = (timedP "1st reverse" reverse)
              <*> ((timedP "2nd reverse" reverse)
              <*> (timedP "(++)" (++) <*> pure "cool " <*> pure "aaron "))

main :: IO ()
main = do
  (a,_,w) <- runRWSTProfiler () (0 :| []) myComputation
  mapM_ putStrLn w
  putStrLn a


-- ☭ ./profiler 
--	Beginning computation for: 1st reverse @ 907710097
--		Beginning computation for: 2nd reverse @ 907716099
--			Beginning computation for: (++) @ 907718702
--			Ending computation for: (++) @ 907721713
--			== LENGTH: 3011
--		Ending computation for: 2nd reverse @ 907725795
--		== LENGTH: 9696
--	Ending computation for: 1st reverse @ 907726781
--	== LENGTH: 16684
-- cool aaron 

My first, more simpler attempt:

import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Applicative((<*>), (<$>), Applicative, pure)

data Profiler m a = Profiler { item :: m a }

instance Functor m => Functor (Profiler m) where
  fmap f (Profiler fa) = Profiler $ fmap f fa


instance (Applicative m, MonadIO m) => Applicative (Profiler m) where
  pure a = Profiler $ pure a
  (Profiler mf) <*> (Profiler ma) = Profiler $ do
    liftIO $ putStrLn "start"
    result <- mf <*> ma
    liftIO $ putStrLn "done"
    return result

myComputation :: Profiler IO String
myComputation = (++) <$> pure "cool " <*> pure "aaron "

main :: IO ()
main = do
  name <- item myComputation
  putStrLn name

My second attempt:

{-# LANGUAGE Rank2Types #-}

import Control.Applicative((<*>), Applicative, pure)
import Control.Monad.IO.Class (MonadIO)
import System.Clock (Clock (Monotonic), getTime, nsec, sec)

data Profiler m a = Profiler { item :: m a
                             , profilerPre  :: forall b. b -> m ()
                             , profilerPost :: forall b. b -> m ()
                             }

instance Functor m => Functor (Profiler m) where
  fmap f pa@(Profiler ma _ _) = pa { item = fmap f ma }

noop :: (Applicative m) => forall b. b -> m ()
noop = const (pure ())

instance (Applicative m, MonadIO m) => Applicative (Profiler m) where
  pure a = Profiler (pure a) noop noop
  (Profiler mf' pre' post') <*> (Profiler ma' _ _) = Profiler (interleave ma' pre' mf' post') noop noop where
    interleave ma pre mf post = do
      _ <- ma >>= pre
      result <- mf <*> ma
      _ <-post result
      pure result

-- prints system clock to StdOut before and after computation.
timedP :: (a -> b) -> Profiler IO (a -> b)
timedP f = Profiler (pure f) pre post where
  pre _ = do
    timeSpec <- getTime Monotonic
    putStrLn $ "Pre-Seconds: " ++ (show . sec $ timeSpec) ++ "\nPre-Nanos: " ++ (show . nsec $ timeSpec)
  post _ = do
    timeSpec <- getTime Monotonic
    putStrLn $ "Post-Seconds: " ++ (show . sec $ timeSpec) ++ "\nPost-nanos: " ++ (show . nsec $ timeSpec)

myComputation :: Profiler IO String
myComputation = timedP (++) <*> pure "cool " <*> pure "aaron "

main :: IO ()
main = do
  i <- item myComputation
  putStrLn i