{- |
   Module      :  System.Win32.Utils
   Copyright   :  2009 Balazs Komuves, 2013 shelarcy
   License     :  BSD-style

   Maintainer  :  shelarcy@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (Win32 API)

   Utilities for calling Win32 API
-}
module System.Win32.Utils
  ( try, tryWithoutNull, trySized, try'
  -- * Maybe values

  , maybePtr, ptrToMaybe, maybeNum, numToMaybe
  , peekMaybe, withMaybe
  -- * Format picture translation

  , fromDateFormatPicture
  , fromTimeFormatPicture
  ) where

import Control.Monad               ( unless )
import Foreign.C.Types             ( CInt )
import Foreign.Marshal.Array       ( allocaArray, peekArray )
import Foreign.Marshal.Utils       ( with )
import Foreign.Ptr                 ( Ptr, nullPtr )
import Foreign.Storable            ( Storable(..) )
import Text.ParserCombinators.ReadP ( ReadP, (<++), between, char, count
                                    , readP_to_S, satisfy )


import System.Win32.String         ( LPTSTR, peekTString, peekTStringLen
                                   , withTStringBufferLen )
import System.Win32.Types          ( BOOL, UINT, eRROR_INSUFFICIENT_BUFFER
                                   , failIfZero, failWith, getLastError
                                   , maybeNum, maybePtr, numToMaybe
                                   , ptrToMaybe )
import qualified System.Win32.Types ( try )
import System.Win32.Word           ( DWORD, PDWORD )

-- | Support for API calls that are passed a fixed-size buffer and tell

-- you via the return value if the buffer was too small.  In that

-- case, we extend the buffer size and try again.

try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
try = String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
System.Win32.Types.try
{-# INLINE try #-}

tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
tryWithoutNull String
loc LPTSTR -> UINT -> IO UINT
f UINT
n = do
   Either UINT String
e <- Int
-> (LPTSTR -> IO (Either UINT String)) -> IO (Either UINT String)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (UINT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINT
n) ((LPTSTR -> IO (Either UINT String)) -> IO (Either UINT String))
-> (LPTSTR -> IO (Either UINT String)) -> IO (Either UINT String)
forall a b. (a -> b) -> a -> b
$ \LPTSTR
lptstr -> do
          UINT
r <- String -> IO UINT -> IO UINT
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
loc (IO UINT -> IO UINT) -> IO UINT -> IO UINT
forall a b. (a -> b) -> a -> b
$ LPTSTR -> UINT -> IO UINT
f LPTSTR
lptstr UINT
n
          if UINT
r UINT -> UINT -> Bool
forall a. Ord a => a -> a -> Bool
> UINT
n then Either UINT String -> IO (Either UINT String)
forall (m :: * -> *) a. Monad m => a -> m a
return (UINT -> Either UINT String
forall a b. a -> Either a b
Left UINT
r) else do
            String
str <- LPTSTR -> IO String
peekTString LPTSTR
lptstr
            Either UINT String -> IO (Either UINT String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either UINT String
forall a b. b -> Either a b
Right String
str)
   case Either UINT String
e of
        Left UINT
r'   -> String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
tryWithoutNull String
loc LPTSTR -> UINT -> IO UINT
f UINT
r'
        Right String
str -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

try' :: Storable a => String -> (Ptr a -> PDWORD -> IO BOOL) -> DWORD -> IO [a]
try' :: forall a.
Storable a =>
String -> (Ptr a -> PDWORD -> IO Bool) -> UINT -> IO [a]
try' String
loc Ptr a -> PDWORD -> IO Bool
f UINT
n =
   UINT -> (PDWORD -> IO [a]) -> IO [a]
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with UINT
n ((PDWORD -> IO [a]) -> IO [a]) -> (PDWORD -> IO [a]) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \PDWORD
n' -> do
   Either UINT [a]
e <- Int -> (Ptr a -> IO (Either UINT [a])) -> IO (Either UINT [a])
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (UINT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINT
n) ((Ptr a -> IO (Either UINT [a])) -> IO (Either UINT [a]))
-> (Ptr a -> IO (Either UINT [a])) -> IO (Either UINT [a])
forall a b. (a -> b) -> a -> b
$ \Ptr a
lptstr -> do
          Bool
flg <- Ptr a -> PDWORD -> IO Bool
f Ptr a
lptstr PDWORD
n'
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
flg (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            UINT
err_code <- IO UINT
getLastError
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UINT
err_code UINT -> UINT -> Bool
forall a. Eq a => a -> a -> Bool
== UINT
eRROR_INSUFFICIENT_BUFFER)
              (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> UINT -> IO ()
forall a. String -> UINT -> IO a
failWith String
loc UINT
err_code
          UINT
r   <- PDWORD -> IO UINT
forall a. Storable a => Ptr a -> IO a
peek PDWORD
n'
          if UINT
r UINT -> UINT -> Bool
forall a. Ord a => a -> a -> Bool
> UINT
n then Either UINT [a] -> IO (Either UINT [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (UINT -> Either UINT [a]
forall a b. a -> Either a b
Left UINT
r) else do
            [a]
str <- Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (UINT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINT
r) Ptr a
lptstr
            Either UINT [a] -> IO (Either UINT [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Either UINT [a]
forall a b. b -> Either a b
Right [a]
str)
   case Either UINT [a]
e of
        Left UINT
r'   -> String -> (Ptr a -> PDWORD -> IO Bool) -> UINT -> IO [a]
forall a.
Storable a =>
String -> (Ptr a -> PDWORD -> IO Bool) -> UINT -> IO [a]
try' String
loc Ptr a -> PDWORD -> IO Bool
f UINT
r'
        Right [a]
str -> [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
str

-- | Support for API calls that return the required size, in characters

-- including a null character, of the buffer when passed a buffer size of zero.

trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO String
trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO String
trySized String
wh LPTSTR -> CInt -> IO CInt
f = do
    CInt
c_len <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
wh (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ LPTSTR -> CInt -> IO CInt
f LPTSTR
forall a. Ptr a
nullPtr CInt
0
    let len :: Int
len = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
c_len
    Int -> ((LPTSTR, Int) -> IO String) -> IO String
forall a. Int -> ((LPTSTR, Int) -> IO a) -> IO a
withTStringBufferLen Int
len (((LPTSTR, Int) -> IO String) -> IO String)
-> ((LPTSTR, Int) -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \(LPTSTR
buf', Int
len') -> do
        let c_len' :: CInt
c_len' = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len'
        CInt
c_len'' <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
wh (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ LPTSTR -> CInt -> IO CInt
f LPTSTR
buf' CInt
c_len'
        let len'' :: Int
len'' = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
c_len''
        (LPTSTR, Int) -> IO String
peekTStringLen (LPTSTR
buf', Int
len'' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) -- Drop final null character


-- | See also: 'Foreign.Marshal.Utils.maybePeek' function.

peekMaybe :: Storable a => Ptr a -> IO (Maybe a)
peekMaybe :: forall a. Storable a => Ptr a -> IO (Maybe a)
peekMaybe Ptr a
p =
  if Ptr a
p Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
    then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
p

-- | See also: 'Foreign.Marshal.Utils.maybeWith' function.

withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
withMaybe :: forall a b. Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
withMaybe Maybe a
Nothing  Ptr a -> IO b
action = Ptr a -> IO b
action Ptr a
forall a. Ptr a
nullPtr
withMaybe (Just a
x) Ptr a -> IO b
action = a -> (Ptr a -> IO b) -> IO b
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with a
x Ptr a -> IO b
action

-- | Type representing components of a Windows API day, month, year and era

-- format picture.

data DateFormatPicture
  = Day
  | Day0 -- Padded with zeros

  | DayShort
  | DayLong
  | Month
  | Month0 -- Padded with zeros

  | MonthShort
  | MonthLong
  | YearVeryShort -- Year represented only by the last digit

  | YearShort
  | Year
  | Era
  | DateOther String
  deriving (DateFormatPicture -> DateFormatPicture -> Bool
(DateFormatPicture -> DateFormatPicture -> Bool)
-> (DateFormatPicture -> DateFormatPicture -> Bool)
-> Eq DateFormatPicture
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DateFormatPicture -> DateFormatPicture -> Bool
$c/= :: DateFormatPicture -> DateFormatPicture -> Bool
== :: DateFormatPicture -> DateFormatPicture -> Bool
$c== :: DateFormatPicture -> DateFormatPicture -> Bool
Eq, Int -> DateFormatPicture -> ShowS
[DateFormatPicture] -> ShowS
DateFormatPicture -> String
(Int -> DateFormatPicture -> ShowS)
-> (DateFormatPicture -> String)
-> ([DateFormatPicture] -> ShowS)
-> Show DateFormatPicture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DateFormatPicture] -> ShowS
$cshowList :: [DateFormatPicture] -> ShowS
show :: DateFormatPicture -> String
$cshow :: DateFormatPicture -> String
showsPrec :: Int -> DateFormatPicture -> ShowS
$cshowsPrec :: Int -> DateFormatPicture -> ShowS
Show)

fromDFP :: DateFormatPicture -> String
fromDFP :: DateFormatPicture -> String
fromDFP DateFormatPicture
Day = String
"%-e" -- No padding

fromDFP DateFormatPicture
Day0 = String
"%d" -- Padded with zeros

fromDFP DateFormatPicture
DayShort = String
"%a" -- eg Tue

fromDFP DateFormatPicture
DayLong = String
"%A" -- eg Tuesday

fromDFP DateFormatPicture
Month = String
"%-m" -- No padding

fromDFP DateFormatPicture
Month0 = String
"%m" -- Padded with zeros

fromDFP DateFormatPicture
MonthShort = String
"%b" -- eg Jan

fromDFP DateFormatPicture
MonthLong = String
"%B" -- eg January

fromDFP DateFormatPicture
YearVeryShort = String
"%-y" -- No direct equivalent of a one digit year, so

                              -- do not distinguish from a short year without

                              -- padding

fromDFP DateFormatPicture
YearShort = String
"%y"
fromDFP DateFormatPicture
Year = String
"%Y"
fromDFP DateFormatPicture
Era = String
"" -- No equivalent

fromDFP (DateOther String
cs) = ShowS
escape String
cs

escape :: String -> String
escape :: ShowS
escape [] = []
escape (Char
c:String
cs) = Char -> String
escape' Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escape String
cs
 where
  escape' :: Char -> String
escape' Char
'%' = String
"%%"
  escape' Char
'\t' = String
"%t"
  escape' Char
'\n' = String
"%n"
  escape' Char
c' = [Char
c']

d :: ReadP Char
d :: ReadP Char
d = Char -> ReadP Char
char Char
'd'

day :: ReadP DateFormatPicture
day :: ReadP DateFormatPicture
day = do
  Char
_ <- ReadP Char
d
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Day

day0 :: ReadP DateFormatPicture
day0 :: ReadP DateFormatPicture
day0 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
d
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Day0

dayShort :: ReadP DateFormatPicture
dayShort :: ReadP DateFormatPicture
dayShort = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
3 ReadP Char
d
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
DayShort

dayLong :: ReadP DateFormatPicture
dayLong :: ReadP DateFormatPicture
dayLong = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
4 ReadP Char
d
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
DayLong

days :: ReadP DateFormatPicture
days :: ReadP DateFormatPicture
days = ReadP DateFormatPicture
dayLong ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
dayShort ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
day0 ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
day

bigM :: ReadP Char
bigM :: ReadP Char
bigM = Char -> ReadP Char
char Char
'M'

month :: ReadP DateFormatPicture
month :: ReadP DateFormatPicture
month = do
  Char
_ <- ReadP Char
bigM
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Month

month0 :: ReadP DateFormatPicture
month0 :: ReadP DateFormatPicture
month0 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
bigM
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Month0

monthShort :: ReadP DateFormatPicture
monthShort :: ReadP DateFormatPicture
monthShort = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
3 ReadP Char
bigM
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
MonthShort

monthLong :: ReadP DateFormatPicture
monthLong :: ReadP DateFormatPicture
monthLong = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
4 ReadP Char
bigM
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
MonthLong

months :: ReadP DateFormatPicture
months :: ReadP DateFormatPicture
months = ReadP DateFormatPicture
monthLong ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
monthShort ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
month0 ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
month

y :: ReadP Char
y :: ReadP Char
y = Char -> ReadP Char
char Char
'y'

yearVeryShort :: ReadP DateFormatPicture
yearVeryShort :: ReadP DateFormatPicture
yearVeryShort = do
  Char
_ <- ReadP Char
y
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
YearVeryShort

yearShort :: ReadP DateFormatPicture
yearShort :: ReadP DateFormatPicture
yearShort = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
y
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
YearShort

year :: ReadP DateFormatPicture
year :: ReadP DateFormatPicture
year = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
5 ReadP Char
y ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
4 ReadP Char
y
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Year

years :: ReadP DateFormatPicture
years :: ReadP DateFormatPicture
years = ReadP DateFormatPicture
year ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
yearShort ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
yearVeryShort

g :: ReadP Char
g :: ReadP Char
g = Char -> ReadP Char
char Char
'g'

era :: ReadP DateFormatPicture
era :: ReadP DateFormatPicture
era = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
g ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
1 ReadP Char
g
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return DateFormatPicture
Era

quote :: ReadP Char
quote :: ReadP Char
quote = Char -> ReadP Char
char Char
'\''

notQuote :: ReadP Char
notQuote :: ReadP Char
notQuote = (Char -> Bool) -> ReadP Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'')

escQuote :: ReadP Char
escQuote :: ReadP Char
escQuote = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
quote
  Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\''

quotedChars :: ReadP String
quotedChars :: ReadP String
quotedChars = ReadP Char -> ReadP Char -> ReadP String -> ReadP String
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between ReadP Char
quote ReadP Char
quote (ReadP String -> ReadP String) -> ReadP String -> ReadP String
forall a b. (a -> b) -> a -> b
$ ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
greedy (ReadP Char
escQuote ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP Char
notQuote)

-- | Although not documented at

-- https://docs.microsoft.com/en-us/windows/win32/intl/day--month--year--and-era-format-pictures

-- the format pictures used by Windows do not require all such characters to be

-- enclosed in single quotation marks.

nonDateSpecial :: ReadP Char
nonDateSpecial :: ReadP Char
nonDateSpecial = (Char -> Bool) -> ReadP Char
satisfy (\Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'd', Char
'M', Char
'y', Char
'g', Char
'\''])

nonDateSpecials :: ReadP String
nonDateSpecials :: ReadP String
nonDateSpecials = ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
greedy1 ReadP Char
nonDateSpecial

dateOther :: ReadP DateFormatPicture
dateOther :: ReadP DateFormatPicture
dateOther = do
  [String]
chars <- ReadP String -> ReadP [String]
forall a. ReadP a -> ReadP [a]
greedy1 (ReadP String
nonDateSpecials ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP String
quotedChars)
  DateFormatPicture -> ReadP DateFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return (DateFormatPicture -> ReadP DateFormatPicture)
-> DateFormatPicture -> ReadP DateFormatPicture
forall a b. (a -> b) -> a -> b
$ String -> DateFormatPicture
DateOther (String -> DateFormatPicture) -> String -> DateFormatPicture
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chars

datePicture :: ReadP [DateFormatPicture]
datePicture :: ReadP [DateFormatPicture]
datePicture = ReadP DateFormatPicture -> ReadP [DateFormatPicture]
forall a. ReadP a -> ReadP [a]
greedy (ReadP DateFormatPicture
days ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
months ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
years ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
era ReadP DateFormatPicture
-> ReadP DateFormatPicture -> ReadP DateFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP DateFormatPicture
dateOther)

-- | Type representing components of a Windows API hours, minute, and second

-- format picture.

data TimeFormatPicture
  = Hours12
  | Hours012 -- Padded with zeros

  | Hours24
  | Hours024 -- Padded with zeros

  | Minutes
  | Minutes0 -- Padded with zeros

  | Seconds
  | Seconds0 -- Padded with zeros

  | TimeMarkerShort -- One-character time marker string, eg "A" and "P"

  | TimeMarker -- Multi-character time marker string, eg "AM" and "PM"

  | TimeOther String
  deriving (TimeFormatPicture -> TimeFormatPicture -> Bool
(TimeFormatPicture -> TimeFormatPicture -> Bool)
-> (TimeFormatPicture -> TimeFormatPicture -> Bool)
-> Eq TimeFormatPicture
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeFormatPicture -> TimeFormatPicture -> Bool
$c/= :: TimeFormatPicture -> TimeFormatPicture -> Bool
== :: TimeFormatPicture -> TimeFormatPicture -> Bool
$c== :: TimeFormatPicture -> TimeFormatPicture -> Bool
Eq, Int -> TimeFormatPicture -> ShowS
[TimeFormatPicture] -> ShowS
TimeFormatPicture -> String
(Int -> TimeFormatPicture -> ShowS)
-> (TimeFormatPicture -> String)
-> ([TimeFormatPicture] -> ShowS)
-> Show TimeFormatPicture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeFormatPicture] -> ShowS
$cshowList :: [TimeFormatPicture] -> ShowS
show :: TimeFormatPicture -> String
$cshow :: TimeFormatPicture -> String
showsPrec :: Int -> TimeFormatPicture -> ShowS
$cshowsPrec :: Int -> TimeFormatPicture -> ShowS
Show)

fromTFP :: TimeFormatPicture -> String
fromTFP :: TimeFormatPicture -> String
fromTFP TimeFormatPicture
Hours12 = String
"%-l" -- No padding

fromTFP TimeFormatPicture
Hours012 = String
"%I" -- Padded with zeros

fromTFP TimeFormatPicture
Hours24 = String
"%-k" -- No padding

fromTFP TimeFormatPicture
Hours024 = String
"%H" -- Padded with zeros

fromTFP TimeFormatPicture
Minutes = String
"%-M" -- No padding

fromTFP TimeFormatPicture
Minutes0 = String
"%M" -- Padded with zeros

fromTFP TimeFormatPicture
Seconds = String
"%-S" -- No padding

fromTFP TimeFormatPicture
Seconds0 = String
"%S" -- Padded with zeros

fromTFP TimeFormatPicture
TimeMarkerShort = String
"%p" -- No direct equivalent, so do not distinguish

                               -- from TimeMarker

fromTFP TimeFormatPicture
TimeMarker = String
"%p"
fromTFP (TimeOther String
cs) = ShowS
escape String
cs

h :: ReadP Char
h :: ReadP Char
h = Char -> ReadP Char
char Char
'h'

hours12 :: ReadP TimeFormatPicture
hours12 :: ReadP TimeFormatPicture
hours12 = do
  Char
_ <- ReadP Char
h
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Hours12

hours012 :: ReadP TimeFormatPicture
hours012 :: ReadP TimeFormatPicture
hours012 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
h
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Hours012

bigH :: ReadP Char
bigH :: ReadP Char
bigH = Char -> ReadP Char
char Char
'H'

hours24 :: ReadP TimeFormatPicture
hours24 :: ReadP TimeFormatPicture
hours24 = do
  Char
_ <- ReadP Char
bigH
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Hours24

hours024 :: ReadP TimeFormatPicture
hours024 :: ReadP TimeFormatPicture
hours024 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
bigH
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Hours024

hours :: ReadP TimeFormatPicture
hours :: ReadP TimeFormatPicture
hours = ReadP TimeFormatPicture
hours012 ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
hours12 ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
hours024 ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
hours24

m :: ReadP Char
m :: ReadP Char
m = Char -> ReadP Char
char Char
'm'

minute :: ReadP TimeFormatPicture
minute :: ReadP TimeFormatPicture
minute = do
  Char
_ <- ReadP Char
m
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Minutes

minute0 :: ReadP TimeFormatPicture
minute0 :: ReadP TimeFormatPicture
minute0 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
m
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Minutes0

minutes :: ReadP TimeFormatPicture
minutes :: ReadP TimeFormatPicture
minutes = ReadP TimeFormatPicture
minute0 ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
minute

s :: ReadP Char
s :: ReadP Char
s = Char -> ReadP Char
char Char
's'

second :: ReadP TimeFormatPicture
second :: ReadP TimeFormatPicture
second = do
  Char
_ <- ReadP Char
s
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Seconds

second0 :: ReadP TimeFormatPicture
second0 :: ReadP TimeFormatPicture
second0 = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
s
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
Seconds0

seconds :: ReadP TimeFormatPicture
seconds :: ReadP TimeFormatPicture
seconds = ReadP TimeFormatPicture
second0 ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
second

t :: ReadP Char
t :: ReadP Char
t = Char -> ReadP Char
char Char
't'

timeMarkerShort :: ReadP TimeFormatPicture
timeMarkerShort :: ReadP TimeFormatPicture
timeMarkerShort = do
  Char
_ <- ReadP Char
t
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
TimeMarkerShort

timeMarker :: ReadP TimeFormatPicture
timeMarker :: ReadP TimeFormatPicture
timeMarker = do
  String
_ <- Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count Int
2 ReadP Char
t
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return TimeFormatPicture
TimeMarker

timeMarkers :: ReadP TimeFormatPicture
timeMarkers :: ReadP TimeFormatPicture
timeMarkers = ReadP TimeFormatPicture
timeMarker ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
timeMarkerShort

-- | Although not documented at

-- https://docs.microsoft.com/en-us/windows/win32/intl/hour--minute--and-second-format-pictures

-- the format pictures used by Windows do not require all such characters to be

-- enclosed in single quotation marks.

nonTimeSpecial :: ReadP Char
nonTimeSpecial :: ReadP Char
nonTimeSpecial = (Char -> Bool) -> ReadP Char
satisfy (\Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'h', Char
'H', Char
'm', Char
's', Char
't', Char
'\''])

nonTimeSpecials :: ReadP String
nonTimeSpecials :: ReadP String
nonTimeSpecials = ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
greedy1 ReadP Char
nonTimeSpecial

timeOther :: ReadP TimeFormatPicture
timeOther :: ReadP TimeFormatPicture
timeOther = do
  [String]
chars <- ReadP String -> ReadP [String]
forall a. ReadP a -> ReadP [a]
greedy1 (ReadP String
nonTimeSpecials ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP String
quotedChars)
  TimeFormatPicture -> ReadP TimeFormatPicture
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeFormatPicture -> ReadP TimeFormatPicture)
-> TimeFormatPicture -> ReadP TimeFormatPicture
forall a b. (a -> b) -> a -> b
$ String -> TimeFormatPicture
TimeOther (String -> TimeFormatPicture) -> String -> TimeFormatPicture
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chars

timePicture :: ReadP [TimeFormatPicture]
timePicture :: ReadP [TimeFormatPicture]
timePicture = ReadP TimeFormatPicture -> ReadP [TimeFormatPicture]
forall a. ReadP a -> ReadP [a]
greedy (ReadP TimeFormatPicture
hours ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
minutes ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
seconds ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TimeFormatPicture
timeMarkers ReadP TimeFormatPicture
-> ReadP TimeFormatPicture -> ReadP TimeFormatPicture
forall a. ReadP a -> ReadP a -> ReadP a
<++
                     ReadP TimeFormatPicture
timeOther)

greedy :: ReadP a -> ReadP [a]
greedy :: forall a. ReadP a -> ReadP [a]
greedy ReadP a
p = ReadP a -> ReadP [a]
forall a. ReadP a -> ReadP [a]
greedy1 ReadP a
p ReadP [a] -> ReadP [a] -> ReadP [a]
forall a. ReadP a -> ReadP a -> ReadP a
<++ [a] -> ReadP [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []

greedy1 :: ReadP a -> ReadP [a]
greedy1 :: forall a. ReadP a -> ReadP [a]
greedy1 ReadP a
p = do
  a
first <- ReadP a
p
  [a]
rest <- ReadP a -> ReadP [a]
forall a. ReadP a -> ReadP [a]
greedy ReadP a
p
  [a] -> ReadP [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
first a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest)

parseMaybe :: ReadP a -> String -> Maybe a
parseMaybe :: forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP a
parser String
input =
  case ReadP a -> ReadS a
forall a. ReadP a -> ReadS a
readP_to_S ReadP a
parser String
input of
    [] -> Maybe a
forall a. Maybe a
Nothing
    ((a
result, String
_):[(a, String)]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
result

-- | Translate from a Windows API day, month, year, and era format picture to

-- the closest corresponding format string used by

-- 'Data.Time.Format.formatTime'.

fromDateFormatPicture :: String -> Maybe String
fromDateFormatPicture :: String -> Maybe String
fromDateFormatPicture String
dfp =
  ([DateFormatPicture] -> String)
-> Maybe [DateFormatPicture] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DateFormatPicture -> String) -> [DateFormatPicture] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DateFormatPicture -> String
fromDFP) (Maybe [DateFormatPicture] -> Maybe String)
-> Maybe [DateFormatPicture] -> Maybe String
forall a b. (a -> b) -> a -> b
$ ReadP [DateFormatPicture] -> String -> Maybe [DateFormatPicture]
forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP [DateFormatPicture]
datePicture String
dfp

-- | Translate from a Windows API hours, minute, and second format picture to

-- the closest corresponding format string used by

-- 'Data.Time.Format.formatTime'.

fromTimeFormatPicture :: String -> Maybe String
fromTimeFormatPicture :: String -> Maybe String
fromTimeFormatPicture String
tfp =
  ([TimeFormatPicture] -> String)
-> Maybe [TimeFormatPicture] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TimeFormatPicture -> String) -> [TimeFormatPicture] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TimeFormatPicture -> String
fromTFP) (Maybe [TimeFormatPicture] -> Maybe String)
-> Maybe [TimeFormatPicture] -> Maybe String
forall a b. (a -> b) -> a -> b
$ ReadP [TimeFormatPicture] -> String -> Maybe [TimeFormatPicture]
forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP [TimeFormatPicture]
timePicture String
tfp