gistfile1.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

module Slogger where

import           Control.Applicative
import           Control.Concurrent.Async
import           Control.Monad.Logger
import           Control.Monad.State
import           Data.Binary (Binary, encode, decode)
import qualified Data.Binary.Typed.Internal as BT
import qualified Data.ByteString.Lazy as LB
import           Data.Conduit
import           Data.Conduit.Binary (sourceHandle, sinkHandle)
import qualified Data.Conduit.List as CL
import           Data.Conduit.Serialization.Binary (conduitDecode, conduitEncode)
import           Data.IORef
import           Data.Maybe
import           Data.Monoid
import           Data.String
import qualified Data.Text as T
import           Data.Text.Encoding (encodeUtf8)
import           Data.Typeable
import           GHC.Generics
import           GHC.IO.Handle
import qualified Language.Haskell.TH.Syntax as TH
import           Prelude hiding (log)
import           Safe (headMay)
import           System.IO
import           System.Log.FastLogger (ToLogStr(..))
import           System.Process

type LogId = Int

newtype SloggerT m a = SloggerT (StateT SloggerState m a)
    deriving (Functor, Applicative, Monad, MonadFix, MonadPlus, Alternative, MonadTrans, MonadIO, MonadLogger)

data SloggerState = SloggerState
    { nextIdRef :: IORef LogId
    , idParents :: [LogId]
    }

evalSloggerT :: MonadIO m => SloggerT m a -> m a
evalSloggerT (SloggerT m) = do
    nextIdRef <- liftIO $ newIORef 0
    let idParents = []
    evalStateT m SloggerState {..}

getSloggerState :: Monad m => SloggerT m SloggerState
getSloggerState = SloggerT get

getFreshId :: MonadIO m => SloggerT m LogId
getFreshId = do
    ss <- getSloggerState
    liftIO $ atomicModifyIORef (nextIdRef ss) (\i -> (i + 1, i))

-- Log functions

logTH :: LogLevel -> TH.Q TH.Exp
logTH level =
    [|\x -> log $(TH.qLocation >>= liftLoc) (T.pack "") $(TH.lift level) (x :: T.Text)|]

logDebug, logInfo, logWarn, logError :: TH.Q TH.Exp
logDebug = logTH LevelDebug
logInfo = logTH LevelInfo
logWarn = logTH LevelWarn
logError = logTH LevelError

log :: (MonadLogger m, MonadIO m, ToLogStr msg) => Loc -> LogSource -> LogLevel -> msg -> SloggerT m ()
log loc source level msg = do
    i <- getFreshId
    ss <- getSloggerState
    logInternal loc source level msg "slog" (LogInfo i (headMay (idParents ss)) 0)

logStart :: (MonadLogger m, ToLogStr msg) => Loc -> LogSource -> LogLevel -> msg -> SloggerT m LogId
logStart loc source level msg = undefined

logEnd :: (MonadLogger m, ToLogStr msg) => Loc -> LogSource -> LogLevel -> msg -> LogId -> SloggerT m ()
logEnd loc source level msg = undefined

--TODO: exception handling
logNest :: (MonadLogger m, ToLogStr msg) => Loc -> LogSource -> LogLevel -> msg -> SloggerT m a -> SloggerT m a
logNest loc source level msg f = do
    lid <- logStart loc source level msg
    x <- f
    logEnd loc source level msg lid
    return x

data LogInfo = LogInfo
    { logId :: LogId
    , logParentId :: Maybe LogId
    , dataOffset :: Integer
    }

logInternal :: (MonadLogger m, ToLogStr msg) => Loc -> LogSource -> LogLevel -> msg -> String -> LogInfo -> m ()
logInternal loc source level msg typ info = do
    let msg' = toLogStr msg <>
               " [" <>
               fromString typ <>
               "=" <>
               fromString (show (logId info, fromMaybe 0 (logParentId info), dataOffset info)) <>
               "]"
    monadLoggerLog loc source level msg'

-- Binary bits

-- TODO: memoize type serialization?  Serialize to a separate file?

appendTypedData :: (Typeable a, Binary a) => FilePath -> a -> IO Integer
appendTypedData fp x = withBinaryFile fp AppendMode (\h -> appendTypedData' h x)

readTypedData :: (Typeable a, Binary a) => FilePath -> Integer -> IO a
readTypedData fp pos = withBinaryFile fp ReadMode (\h -> readTypedData' h pos)

appendTypedData' :: forall a. (Typeable a, Binary a) => Handle -> a -> IO Integer
appendTypedData' h x = do
    let ty = BT.stripTypeRep (typeOf x)
    appendData h (RawData ty (encode x))

readTypedData' :: forall a. (Typeable a, Binary a) => Handle -> Integer -> IO a
readTypedData' h pos = do
    RawData ty bs <- readData h pos
    let expected = BT.stripTypeRep (typeOf (undefined :: a))
    if ty /= expected
        then fail $ "Type mismatch in decodeData (got " ++ show ty ++ ", but expected " ++ show expected ++ ")"
        else return $ decode bs

data RawData = RawData BT.TypeRep LB.ByteString
    deriving (Generic)

instance Binary RawData where

appendData :: Binary a => Handle -> a -> IO Integer
appendData h raw = do
    pos <- hFileSize h
    yield raw $= conduitEncode $$ sinkHandle h
    return pos

--TODO: handle EOF case

readData :: Binary a => Handle -> Integer -> IO a
readData h pos = do
    hSeek h AbsoluteSeek pos
    mdecoded <- sourceHandle h $= conduitDecode $$ CL.head
    maybe (fail "Failed to decode data.") return mdecoded

--TODO: avoid overhead of decoding twice, by computing the offset of
--the data which comes after the type.

ghciStr :: FilePath -> Integer -> IO String
ghciStr fp pos = do
    RawData ty _ <- withBinaryFile fp ReadMode (\h -> readData h pos)
    return $ "readTypedData \"" ++ fp ++ "\" " ++ show pos ++ " :: IO (" ++ show (BT.unStripTypeRep ty) ++ ")"

runGhciWithData :: FilePath -> Integer -> IO ()
runGhciWithData fp pos = do
    cmd <- ghciStr fp pos
    (hin, hout, herr, ph) <- runInteractiveProcess "ghci" ["Slogger.hs"] Nothing Nothing
    (sourceHandle hout $$ sinkHandle stdout) `concurrently`
        (sourceHandle herr $$ sinkHandle stderr) `concurrently` do
            yield (encodeUtf8 (T.pack ("x <- " ++ cmd ++ "\n"))) $$ sinkHandle hin
            (sourceHandle stdin $$ sinkHandle hin)
    return ()