{-# LANGUAGE LambdaCase #-}
module Di.Backend
( mkDiStringStderr
, mkDiStringHandle
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Monoid (mconcat, mappend)
import Data.String (IsString(fromString))
import qualified Data.Time as Time
import Prelude hiding (log, filter)
import qualified System.IO as IO
import Data.Semigroup (Semigroup(..))
import Di.Core (Di, mkDi, contrapath)
newtype StringPath = UnsafeStringPath { unStringPath :: String }
deriving (Eq, Ord, Show)
instance IsString StringPath where
fromString = stringPathSingleton
{-# INLINE fromString #-}
stringPathSingleton :: String -> StringPath
stringPathSingleton = \s -> UnsafeStringPath (map f s)
where f :: Char -> Char
f = \case '/' -> '_'
' ' -> '_'
'\n' -> '_'
'\r' -> '_'
c -> c
instance Semigroup StringPath where
UnsafeStringPath "" <> b = b
a <> UnsafeStringPath "" = a
UnsafeStringPath a <> UnsafeStringPath b = UnsafeStringPath (a <> "/" <> b)
instance Monoid StringPath where
mempty = UnsafeStringPath ""
{-# INLINE mempty #-}
mappend = (<>)
{-# INLINE mappend #-}
mkDiStringHandle
:: (MonadIO m)
=> IO.Handle
-> m (Di String [String] String)
mkDiStringHandle h = liftIO $ do
IO.hSetBuffering h IO.LineBuffering
fmap (contrapath (mconcat . map stringPathSingleton)) $ do
mkDi $ \ts l p m -> do
IO.hPutStrLn h $ mconcat
[ l, " ", renderIso8601 ts
, if p == mempty then "" else (" " <> unStringPath p)
, ": ", noBreaks m ]
IO.hFlush h
where
noBreaks :: String -> String
noBreaks = concatMap $ \case
'\n' -> "\\n"
'\r' -> "\\r"
c -> [c]
mkDiStringStderr :: MonadIO m => m (Di String [String] String)
mkDiStringStderr = mkDiStringHandle IO.stderr
renderIso8601 :: Time.UTCTime -> String
renderIso8601 = Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S.%qZ"