Prelude.hs

{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module LoggingTest.Prelude
  ( Alphabet(..)
  , LoggerString(..)
  , MessageString(..)
  , hTryGetLine
  , parent
  , runLog
  ) where


import           Control.Monad
import           Data.List           (dropWhileEnd, intersperse)
import           Data.String
import           Data.Time.LocalTime
import           System.IO
import           Test.QuickCheck

import qualified Logging
import           Logging.Prelude
import           Logging.Types


data Alphabet = Alphabet { getAlphabet :: Char } deriving Show

instance Arbitrary Alphabet where
  arbitrary = Alphabet <$> elements ['a'..'z']


instance Arbitrary Level where
  arbitrary = (Level . getNonNegative) <$> arbitrary


newtype LoggerString = LoggerString { getLoggerString :: Logger }

instance Arbitrary LoggerString where
  arbitrary = do
    ls <- listOf (elements ['A'..'Z'])
    return $ LoggerString $ intersperse '.' $ ls


newtype MessageString = MessageString { getMessageString :: String
                                      } deriving Show

instance Arbitrary MessageString where
  arbitrary = do
    ms <- forM [1..99] $ \_ -> arbitraryUnicodeChar `suchThat` (/= '\n')
    return $ MessageString ms


instance Arbitrary LogRecord where
  arbitrary = do
    logger <- getLoggerString <$> arbitrary
    level <- arbitrary
    message <- getMessageString <$> arbitrary
    pathname <- arbitrary
    filename <- arbitrary
    pkgname <- arbitrary
    modulename <- arbitrary
    lineno <- arbitrary
    let asctime = read "1970-01-01 00:00:00"
        utctime = zonedTimeToUTC asctime
        difftime = zonedTimeToPOSIXSeconds asctime
        created = timestamp difftime
        msecs   = milliseconds difftime
    return $ LogRecord{..}


hTryGetLine :: Handle -> IO String
hTryGetLine hdl = do
  ready <- hReady hdl
  if ready then hGetLine hdl else return ""


parent :: Logger -> Logger
parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')


runLog :: Manager -> IO a -> IO a
runLog = Logging.run