{-# LINE 1 "src/Data/HodaTime/Locale/Posix.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-- | POSIX implementation of the locale reader, shared by the Linux and macOS platform shims.  It reads the locale
--   database through the C library's per-locale query functions (@newlocale@ \/ @nl_langinfo_l@ \/ @freelocale@),
--   which are thread-safe and never mutate the global @setlocale@ state.
module Data.HodaTime.Locale.Posix
(
  loadCurrentLocale
 ,loadLocaleByName
)
where

import Data.HodaTime.Locale.Internal (Locale(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.C.Types (CInt(..))
import Foreign.C.String (CString, withCString)
import Control.Exception (bracket)
import Control.Monad (when)
import System.Environment (lookupEnv)
import Data.Maybe (catMaybes)
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE


{-# LINE 29 "src/Data/HodaTime/Locale/Posix.hsc" #-}


-- macOS declares the per-locale query functions (newlocale / freelocale / nl_langinfo_l) in <xlocale.h> rather than
-- in <locale.h> / <langinfo.h>.

{-# LINE 36 "src/Data/HodaTime/Locale/Posix.hsc" #-}

-- | An opaque POSIX @locale_t@ handle.
type CLocale = Ptr ()

foreign import ccall unsafe "newlocale"
  c_newlocale :: CInt -> CString -> CLocale -> IO CLocale

foreign import ccall unsafe "freelocale"
  c_freelocale :: CLocale -> IO ()

foreign import ccall unsafe "nl_langinfo_l"
  c_nl_langinfo_l :: CInt -> CLocale -> IO CString

lcAllMask :: CInt
lcAllMask :: CInt
lcAllMask = CInt
8127
{-# LINE 51 "src/Data/HodaTime/Locale/Posix.hsc" #-}

monthItems :: [CInt]
monthItems :: [CInt]
monthItems =
  [ CInt
131098,  CInt
131099,  CInt
131100,  CInt
131101
{-# LINE 55 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131102,  CInt
131103,  CInt
131104,  CInt
131105
{-# LINE 56 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131106,  CInt
131107, CInt
131108, CInt
131109 ]
{-# LINE 57 "src/Data/HodaTime/Locale/Posix.hsc" #-}

abMonthItems :: [CInt]
abMonthItems :: [CInt]
abMonthItems =
  [ CInt
131086,  CInt
131087,  CInt
131088,  CInt
131089
{-# LINE 61 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131090,  CInt
131091,  CInt
131092,  CInt
131093
{-# LINE 62 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131094,  CInt
131095, CInt
131096, CInt
131097 ]
{-# LINE 63 "src/Data/HodaTime/Locale/Posix.hsc" #-}

dayItems :: [CInt]
dayItems :: [CInt]
dayItems =
  [ CInt
131079, CInt
131080, CInt
131081, CInt
131082
{-# LINE 67 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131083, CInt
131084, CInt
131085 ]
{-# LINE 68 "src/Data/HodaTime/Locale/Posix.hsc" #-}

abDayItems :: [CInt]
abDayItems :: [CInt]
abDayItems =
  [ CInt
131072, CInt
131073, CInt
131074, CInt
131075
{-# LINE 72 "src/Data/HodaTime/Locale/Posix.hsc" #-}
  , 131076, CInt
131077, CInt
131078 ]
{-# LINE 73 "src/Data/HodaTime/Locale/Posix.hsc" #-}

itemAM, itemPM, itemDFmt, itemTFmt, itemDTFmt :: CInt
itemAM :: CInt
itemAM    = CInt
131110
{-# LINE 76 "src/Data/HodaTime/Locale/Posix.hsc" #-}
itemPM    = 131111
itemDFmt :: CInt
{-# LINE 77 "src/Data/HodaTime/Locale/Posix.hsc" #-}
itemDFmt  = 131113
itemTFmt :: CInt
{-# LINE 78 "src/Data/HodaTime/Locale/Posix.hsc" #-}
itemTFmt  = 131114
{-# LINE 79 "src/Data/HodaTime/Locale/Posix.hsc" #-}
itemDTFmt = 131112
{-# LINE 80 "src/Data/HodaTime/Locale/Posix.hsc" #-}

-- | Query one @nl_item@ from a locale and decode it as UTF-8 (leniently).  The result is copied into a Haskell 'String'
--   immediately, so it remains valid after the locale is freed.
peekItem :: CLocale -> CInt -> IO String
peekItem :: CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
item = do
  CString
cs <- CInt -> CLocale -> IO CString
c_nl_langinfo_l CInt
item CLocale
loc
  if CString
cs CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
    then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    else Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO ByteString
B.packCString CString
cs

buildLocale :: String -> CLocale -> IO Locale
buildLocale :: String -> CLocale -> IO Locale
buildLocale String
lid CLocale
loc = do
  [String]
mons  <- (CInt -> IO String) -> [CInt] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CLocale -> CInt -> IO String
peekItem CLocale
loc) [CInt]
monthItems
  [String]
amons <- (CInt -> IO String) -> [CInt] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CLocale -> CInt -> IO String
peekItem CLocale
loc) [CInt]
abMonthItems
  [String]
days  <- (CInt -> IO String) -> [CInt] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CLocale -> CInt -> IO String
peekItem CLocale
loc) [CInt]
dayItems
  [String]
adays <- (CInt -> IO String) -> [CInt] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CLocale -> CInt -> IO String
peekItem CLocale
loc) [CInt]
abDayItems
  String
am    <- CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
itemAM
  String
pm    <- CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
itemPM
  String
df    <- CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
itemDFmt
  String
tf    <- CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
itemTFmt
  String
dtf   <- CLocale -> CInt -> IO String
peekItem CLocale
loc CInt
itemDTFmt
  Locale -> IO Locale
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Locale
    { localeId :: String
localeId          = String
lid
    , monthNames :: [String]
monthNames        = [String]
mons
    , monthNamesShort :: [String]
monthNamesShort   = [String]
amons
    , dayNames :: [String]
dayNames          = [String]
days
    , dayNamesShort :: [String]
dayNamesShort     = [String]
adays
    , amName :: String
amName            = String
am
    , pmName :: String
pmName            = String
pm
    , rawDateFormat :: String
rawDateFormat     = String
df
    , rawTimeFormat :: String
rawTimeFormat     = String
tf
    , rawDateTimeFormat :: String
rawDateTimeFormat = String
dtf
    }

-- | Create a fresh @locale_t@ for the given name, run the action, and always free the handle.  Returns 'Nothing' when
--   the name does not resolve to an installed locale.
withNewLocale :: String -> (CLocale -> IO a) -> IO (Maybe a)
withNewLocale :: forall a. String -> (CLocale -> IO a) -> IO (Maybe a)
withNewLocale String
name CLocale -> IO a
act =
  String -> (CString -> IO (Maybe a)) -> IO (Maybe a)
forall a. String -> (CString -> IO a) -> IO a
withCString String
name ((CString -> IO (Maybe a)) -> IO (Maybe a))
-> (CString -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \CString
cname ->
    IO CLocale
-> (CLocale -> IO ()) -> (CLocale -> IO (Maybe a)) -> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CInt -> CString -> CLocale -> IO CLocale
c_newlocale CInt
lcAllMask CString
cname CLocale
forall a. Ptr a
nullPtr) CLocale -> IO ()
freeIfNonNull ((CLocale -> IO (Maybe a)) -> IO (Maybe a))
-> (CLocale -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \CLocale
loc ->
      if CLocale
loc CLocale -> CLocale -> Bool
forall a. Eq a => a -> a -> Bool
== CLocale
forall a. Ptr a
nullPtr then Maybe a -> IO (Maybe a)
forall a. a -> IO 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
<$> CLocale -> IO a
act CLocale
loc
  where
    freeIfNonNull :: CLocale -> IO ()
freeIfNonNull CLocale
l = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CLocale
l CLocale -> CLocale -> Bool
forall a. Eq a => a -> a -> Bool
/= CLocale
forall a. Ptr a
nullPtr) (CLocale -> IO ()
c_freelocale CLocale
l)

-- | Read a specific locale by name (e.g. @\"de_DE.UTF-8\"@).  'Nothing' if it is not installed on the machine.
loadLocaleByName :: String -> IO (Maybe Locale)
loadLocaleByName :: String -> IO (Maybe Locale)
loadLocaleByName String
name = String -> (CLocale -> IO Locale) -> IO (Maybe Locale)
forall a. String -> (CLocale -> IO a) -> IO (Maybe a)
withNewLocale String
name (String -> CLocale -> IO Locale
buildLocale String
name)

-- | Read the process's current locale, as selected by the environment (@LC_ALL@ \/ @LC_TIME@ \/ @LANG@), falling back
--   to the POSIX @C@ locale.
loadCurrentLocale :: IO Locale
loadCurrentLocale :: IO Locale
loadCurrentLocale = do
  String
lid <- IO String
currentLocaleId
  Maybe Locale
m <- String -> (CLocale -> IO Locale) -> IO (Maybe Locale)
forall a. String -> (CLocale -> IO a) -> IO (Maybe a)
withNewLocale String
"" (String -> CLocale -> IO Locale
buildLocale String
lid)
  case Maybe Locale
m of
    Just Locale
l  -> Locale -> IO Locale
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Locale
l
    Maybe Locale
Nothing -> String -> IO (Maybe Locale)
loadLocaleByName String
"C" IO (Maybe Locale) -> (Maybe Locale -> IO Locale) -> IO Locale
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Locale -> (Locale -> IO Locale) -> Maybe Locale -> IO Locale
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IOError -> IO Locale
forall a. IOError -> IO a
ioError (String -> IOError
userError String
"loadCurrentLocale: could not load the POSIX C locale")) Locale -> IO Locale
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | The identifier of the current locale, taken from the first of @LC_ALL@, @LC_TIME@ or @LANG@ that is set to a
--   non-empty value, defaulting to @\"C\"@.
currentLocaleId :: IO String
currentLocaleId :: IO String
currentLocaleId = do
  [Maybe String]
vals <- (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe String)
lookupEnv [String
"LC_ALL", String
"LC_TIME", String
"LANG"]
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
vals) of
    (String
x:[String]
_) -> String
x
    []    -> String
"C"