{-# OPTIONS -fno-warn-orphans #-}

module Test.Format.Format (
    testFormat,
) where

import Data.Char
import Data.Fixed as F
import Data.Time
import Data.Time.Clock.POSIX
import Foreign
import Foreign.C
import System.IO.Unsafe
import System.Random
import Test.QuickCheck hiding (Result)
import Test.QuickCheck.Property
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Test.TestUtil

{-
    size_t format_time (
    char *s, size_t maxsize,
    const char *format,
    int isdst,int gmtoff,time_t t);
-}
foreign import ccall unsafe "FormatStuff.h format_time"
    format_time ::
        CString ->
        CSize ->
        CString ->
        CInt ->
        CInt ->
        CString ->
        CTime ->
        IO CSize

withBuffer :: Int -> (CString -> IO CSize) -> IO String
withBuffer n f =
    withArray
        (replicate n 0)
        ( \buffer -> do
            len <- f buffer
            peekCStringLen (buffer, fromIntegral len)
        )

unixFormatTime :: String -> TimeZone -> UTCTime -> String
unixFormatTime fmt zone time =
    unsafePerformIO $
        withCString
            fmt
            ( \pfmt ->
                withCString
                    (timeZoneName zone)
                    ( \pzonename ->
                        withBuffer
                            100
                            ( \buffer ->
                                format_time
                                    buffer
                                    100
                                    pfmt
                                    ( if timeZoneSummerOnly zone
                                        then 1
                                        else 0
                                    )
                                    (fromIntegral (timeZoneMinutes zone * 60))
                                    pzonename
                                    (fromInteger (floor (utcTimeToPOSIXSeconds time)))
                            )
                    )
            )

locale :: TimeLocale
locale = defaultTimeLocale{dateTimeFmt = "%a %b %e %H:%M:%S %Y"}

instance Random (F.Fixed res) where
    randomR (MkFixed lo, MkFixed hi) oldgen = let
        (v, newgen) = randomR (lo, hi) oldgen
        in (MkFixed v, newgen)
    random oldgen = let
        (v, newgen) = random oldgen
        in (MkFixed v, newgen)

instance Arbitrary TimeZone where
    arbitrary = do
        mins <- choose (-2000, 2000)
        dst <- arbitrary
        hasName <- arbitrary
        let
            name =
                if hasName
                    then "ZONE"
                    else ""
        return $ TimeZone mins dst name

instance Arbitrary TimeOfDay where
    arbitrary = do
        h <- choose (0, 23)
        m <- choose (0, 59)
        s <- choose (0, 59.999999999999) -- don't allow leap-seconds
        return $ TimeOfDay h m s

-- | The size of 'CTime' is platform-dependent.
secondsFitInCTime :: Integer -> Bool
secondsFitInCTime sec = let
    CTime ct = fromInteger sec
    sec' = toInteger ct
    in sec == sec'

instance Arbitrary UTCTime where
    arbitrary = do
        day <- choose (-25000, 75000)
        time <- arbitrary
        let
            -- verify that the created time can fit in the local CTime
            localT = LocalTime (ModifiedJulianDay day) time
            utcT = localTimeToUTC utc localT
            secondsInteger = floor (utcTimeToPOSIXSeconds utcT)
        if secondsFitInCTime (secondsInteger + 2 * 86400) && secondsFitInCTime (secondsInteger - 2 * 86400) -- two days slop each way
            then return utcT
            else arbitrary

padN :: Int -> Char -> String -> String
padN n _ s
    | n <= (length s) = s
padN n c s = (replicate (n - length s) c) ++ s

unixWorkarounds :: String -> String -> String
unixWorkarounds "%_Y" s = padN 4 ' ' s
unixWorkarounds "%0Y" s = padN 4 '0' s
unixWorkarounds "%_C" s = padN 2 ' ' s
unixWorkarounds "%0C" s = padN 2 '0' s
unixWorkarounds "%_G" s = padN 4 ' ' s
unixWorkarounds "%0G" s = padN 4 '0' s
unixWorkarounds "%_f" s = padN 2 ' ' s
unixWorkarounds "%0f" s = padN 2 '0' s
unixWorkarounds fmt s
    | elem 'z' fmt = dropWhile isPadChar s
  where
    isPadChar ' ' = True
    isPadChar '0' = True
    isPadChar _ = False
unixWorkarounds _ s = s

compareFormat :: (String -> String) -> String -> TimeZone -> UTCTime -> Result
compareFormat _modUnix fmt zone _time
    | last fmt == 'Z' && timeZoneName zone == "" = rejected
compareFormat modUnix fmt zone time = let
    ctime = utcToZonedTime zone time
    haskellText = formatTime locale fmt ctime
    unixText = unixFormatTime fmt zone time
    expectedText = unixWorkarounds fmt (modUnix unixText)
    in assertEqualQC (show time ++ " with " ++ show zone) expectedText haskellText

-- as found in http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html
-- plus FgGklz
-- f not supported
-- P not always supported
-- s time-zone dependent
chars :: [Char]
chars = "aAbBcCdDeFgGhHIjklmMnprRStTuUVwWxXyYzZ%"

-- as found in "man strftime" on a glibc system. '#' is different, though
modifiers :: [String]
modifiers = ["", "_", "-", "0", "^"]

widths :: [String]
widths = ["", "1", "2", "9", "12"]

formats :: [String]
formats =
    ["%G-W%V-%u", "%U-%w", "%W-%u"]
        ++ ( do
                char <- chars
                width <- widths
                modifier <- modifiers
                return $ "%" ++ modifier ++ width ++ [char]
           )

hashformats :: [String]
hashformats = do
    char <- chars
    return $ "%#" ++ [char]

testCompareFormat :: [TestTree]
testCompareFormat =
    tgroup formats $ \fmt -> do
        time <- arbitrary
        zone <- arbitrary
        return $ compareFormat id fmt zone time

testCompareHashFormat :: [TestTree]
testCompareHashFormat =
    tgroup hashformats $ \fmt -> do
        time <- arbitrary
        zone <- arbitrary
        return $ compareFormat (fmap toLower) fmt zone time

formatUnitTest :: String -> Pico -> String -> TestTree
formatUnitTest fmt sec expected =
    nameTest (show fmt) $ let
        tod = TimeOfDay 0 0 (1 + sec)
        found = formatTime locale fmt tod
        in assertEqual "" expected found

testQs :: [TestTree]
testQs =
    [ formatUnitTest "%q" 0 "000000000000"
    , formatUnitTest "%q" 0.37 "370000000000"
    , formatUnitTest "%0q" 0 "000000000000"
    , formatUnitTest "%0q" 0.37 "370000000000"
    , formatUnitTest "%_q" 0 "            "
    , formatUnitTest "%_q" 0.37 "37          "
    , formatUnitTest "%-q" 0 ""
    , formatUnitTest "%-q" 0.37 "37"
    , formatUnitTest "%1q" 0 "0"
    , formatUnitTest "%1q" 0.37 "3"
    , formatUnitTest "%01q" 0 "0"
    , formatUnitTest "%01q" 0.37 "3"
    , formatUnitTest "%_1q" 0 " "
    , formatUnitTest "%_1q" 0.37 "3"
    , formatUnitTest "%-1q" 0 " "
    , formatUnitTest "%-1q" 0.37 "3"
    , formatUnitTest "%5q" 0 "00000"
    , formatUnitTest "%5q" 0.37 "37000"
    , formatUnitTest "%05q" 0 "00000"
    , formatUnitTest "%05q" 0.37 "37000"
    , formatUnitTest "%_5q" 0 "     "
    , formatUnitTest "%_5q" 0.37 "37   "
    , formatUnitTest "%-5q" 0 "     "
    , formatUnitTest "%-5q" 0.37 "37   "
    , formatUnitTest "%Q" 0 ""
    , formatUnitTest "%Q" 0.37 ".37"
    , formatUnitTest "%0Q" 0 ".000000000000"
    , formatUnitTest "%0Q" 0.37 ".370000000000"
    , formatUnitTest "%_Q" 0 ".            "
    , formatUnitTest "%_Q" 0.37 ".37          "
    , formatUnitTest "%-Q" 0 ""
    , formatUnitTest "%-Q" 0.37 ".37"
    , formatUnitTest "%1Q" 0 ".0"
    , formatUnitTest "%1Q" 0.37 ".3"
    , formatUnitTest "%01Q" 0 ".0"
    , formatUnitTest "%01Q" 0.37 ".3"
    , formatUnitTest "%_1Q" 0 ". "
    , formatUnitTest "%_1Q" 0.37 ".3"
    , formatUnitTest "%-1Q" 0 ". "
    , formatUnitTest "%-1Q" 0.37 ".3"
    , formatUnitTest "%5Q" 0 ".00000"
    , formatUnitTest "%5Q" 0.37 ".37000"
    , formatUnitTest "%05Q" 0 ".00000"
    , formatUnitTest "%05Q" 0.37 ".37000"
    , formatUnitTest "%_5Q" 0 ".     "
    , formatUnitTest "%_5Q" 0.37 ".37   "
    , formatUnitTest "%-5Q" 0 ".     "
    , formatUnitTest "%-5Q" 0.37 ".37   "
    ]

strftimeHasGNUExts :: Bool
strftimeHasGNUExts = unixFormatTime "%_6Y" utc (UTCTime (fromGregorian 1980 1 1) 0) == "  1980"

testFormat :: [TestTree]
testFormat =
    if strftimeHasGNUExts
        then pure $ localOption (QuickCheckTests 10000) $ testGroup "testFormat" $ testCompareFormat ++ testCompareHashFormat ++ testQs
        else []
