-----------------------------------------------------------------------------
-- |
-- Module      :  Data.HodaTime.Pattern.Offset
-- Copyright   :  (C) 2017 Jason Johnson
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Jason Johnson <jason.johnson.081@gmail.com>
-- Stability   :  experimental
-- Portability :  POSIX, Windows
--
-- Patterns for an 'Data.HodaTime.Offset.Offset' from UTC, rendered as @(+\/-)HH:mm@; @pOffsetFull@ adds seconds,
-- @pOffsetZ@ writes @Z@ for UTC, and @pOffsetCompact@ omits the colon (@+0200@).
----------------------------------------------------------------------------
module Data.HodaTime.Pattern.Offset
(
  -- * Standard Patterns
   pOffset
  ,pOffsetZ
  ,pOffsetFull
  ,pOffsetCompact
)
where

import Data.HodaTime.Pattern.Internal (Pattern(..), p_sixty)
import Data.HodaTime.Offset.Internal (Offset(..), fromSeconds)
import Data.HodaTime.Constants (secondsPerHour, secondsPerMinute)
import Formatting (Format, later)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TLB
import Text.Parsec (Parsec, count, digit, (<|>), (<?>))
import qualified Text.Parsec as P (char, string)

-- o1 = fromHours 2
-- format pOffset o1        -- "+02:00"
-- parse pOffset "-05:30"   -- Just (Offset -19800)

type Parser a = Parsec String () a

-- DESIGN NOTE (why this module doesn't build offsets from composable per-field patterns like the others do):
--
-- The date and time pattern modules build a value field by field: each field is an independent lens 'set' and the
-- '<>' combinator composes those setters.  That works because those fields are independent and are backed by
-- read/write lenses.
--
-- An 'Offset' offers neither.  Its 'hours'/'minutes'/'seconds' are read-only accessors, not lenses — there is no
-- coherent 'set' for a single component of a signed quantity (see the note in Data.HodaTime.Offset) — so there is
-- nothing for the field-composition machinery to drive.  And the value is a single *signed* second count whose sign
-- belongs to the whole, not to any one component, so the components could not be set independently in any case.
--
-- So both directions treat the offset as a whole: format works from 'abs secs' and emits the sign as a separate
-- leading character; parse reads the sign and all components together and multiplies the combined magnitude by the
-- sign, building the 'Offset' through 'fromSeconds' (which also clamps to the +/-18h range).  The parsed value is
-- therefore fully determined by the text (it does not build on a default), which is why the parser's setter is
-- 'const <$> ...' — and these are exposed only as complete patterns, not composable sub-fields.

-- | The ISO-8601 offset pattern, sign followed by @HH:mm@ (e.g. @+02:00@, @-05:30@, @+00:00@ for UTC).
pOffset :: Pattern (Offset -> Offset) (Offset -> String) String
pOffset :: Pattern (Offset -> Offset) (Offset -> String) String
pOffset = Parser (Offset -> Offset) String
-> Format String (Offset -> String)
-> Pattern (Offset -> Offset) (Offset -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Offset -> Offset -> Offset
forall a b. a -> b -> a
const (Offset -> Offset -> Offset)
-> ParsecT String () Identity Offset
-> Parser (Offset -> Offset) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bool -> ParsecT String () Identity Offset
offsetParser String
":" Bool
False Parser (Offset -> Offset) String
-> String -> Parser (Offset -> Offset) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"offset: (+/-)HH:mm") (String -> Bool -> Format String (Offset -> String)
offsetFormat String
":" Bool
False)

-- | Like 'pOffset' but including seconds, sign followed by @HH:mm:ss@ (e.g. @-05:30:15@).
pOffsetFull :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetFull :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetFull = Parser (Offset -> Offset) String
-> Format String (Offset -> String)
-> Pattern (Offset -> Offset) (Offset -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Offset -> Offset -> Offset
forall a b. a -> b -> a
const (Offset -> Offset -> Offset)
-> ParsecT String () Identity Offset
-> Parser (Offset -> Offset) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bool -> ParsecT String () Identity Offset
offsetParser String
":" Bool
True Parser (Offset -> Offset) String
-> String -> Parser (Offset -> Offset) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"offset: (+/-)HH:mm:ss") (String -> Bool -> Format String (Offset -> String)
offsetFormat String
":" Bool
True)

-- | Like 'pOffset' but renders UTC (a zero offset) as @Z@ rather than @+00:00@, per ISO-8601 (and parses @Z@ back).
pOffsetZ :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetZ :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetZ = Parser (Offset -> Offset) String
-> Format String (Offset -> String)
-> Pattern (Offset -> Offset) (Offset -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Offset -> Offset -> Offset
forall a b. a -> b -> a
const (Offset -> Offset -> Offset)
-> ParsecT String () Identity Offset
-> Parser (Offset -> Offset) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Offset
parZ Parser (Offset -> Offset) String
-> String -> Parser (Offset -> Offset) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"offset: Z or (+/-)HH:mm") Format String (Offset -> String)
forall {r}. Format r (Offset -> r)
fmtZ
  where
    parZ :: ParsecT String () Identity Offset
parZ = (Int -> Offset
forall a. Integral a => a -> Offset
fromSeconds (Int
0 :: Int) Offset
-> ParsecT String () Identity Char
-> ParsecT String () Identity Offset
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'Z') ParsecT String () Identity Offset
-> ParsecT String () Identity Offset
-> ParsecT String () Identity Offset
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> Bool -> ParsecT String () Identity Offset
offsetParser String
":" Bool
False
    fmtZ :: Format r (Offset -> r)
fmtZ = (Offset -> Builder) -> Format r (Offset -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (\Offset
o -> Text -> Builder
TLB.fromText (Text -> Builder) -> (String -> Text) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ if Offset -> Int
offsetSeconds Offset
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"Z" else String -> Bool -> Offset -> String
renderOffset String
":" Bool
False Offset
o)

-- | The @strftime@ @%z@ offset: sign followed by @HHmm@ with no separator (e.g. @+0200@, @-0530@, @+0000@ for UTC).
pOffsetCompact :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetCompact :: Pattern (Offset -> Offset) (Offset -> String) String
pOffsetCompact = Parser (Offset -> Offset) String
-> Format String (Offset -> String)
-> Pattern (Offset -> Offset) (Offset -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Offset -> Offset -> Offset
forall a b. a -> b -> a
const (Offset -> Offset -> Offset)
-> ParsecT String () Identity Offset
-> Parser (Offset -> Offset) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bool -> ParsecT String () Identity Offset
offsetParser String
"" Bool
False Parser (Offset -> Offset) String
-> String -> Parser (Offset -> Offset) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"offset: (+/-)HHmm") (String -> Bool -> Format String (Offset -> String)
offsetFormat String
"" Bool
False)

-- helpers

offsetParser :: String -> Bool -> Parser Offset
offsetParser :: String -> Bool -> ParsecT String () Identity Offset
offsetParser String
sep Bool
withSecs = do
  Int
sign <- ((-Int
1) Int
-> ParsecT String () Identity Char
-> ParsecT String () Identity Int
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-') ParsecT String () Identity Int
-> ParsecT String () Identity Int -> ParsecT String () Identity Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Int
1 Int
-> ParsecT String () Identity Char
-> ParsecT String () Identity Int
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'+')
  Int
h <- ParsecT String () Identity Int
twoDigit
  String
_ <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
sep
  Int
m <- ParsecT String () Identity Int
forall n. (Num n, Read n) => Parser n String
p_sixty
  Int
s <- if Bool
withSecs then String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
sep ParsecT String () Identity String
-> ParsecT String () Identity Int -> ParsecT String () Identity Int
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Int
forall n. (Num n, Read n) => Parser n String
p_sixty else Int -> ParsecT String () Identity Int
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  Offset -> ParsecT String () Identity Offset
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Offset -> ParsecT String () Identity Offset)
-> (Int -> Offset) -> Int -> ParsecT String () Identity Offset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Offset
forall a. Integral a => a -> Offset
fromSeconds (Int -> ParsecT String () Identity Offset)
-> Int -> ParsecT String () Identity Offset
forall a b. (a -> b) -> a -> b
$ Int
sign Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
secondsPerHour Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
secondsPerMinute Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s)
  where
    twoDigit :: ParsecT String () Identity Int
twoDigit = String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
2 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit :: Parser Int

offsetFormat :: String -> Bool -> Format String (Offset -> String)
offsetFormat :: String -> Bool -> Format String (Offset -> String)
offsetFormat String
sep Bool
withSecs = (Offset -> Builder) -> Format String (Offset -> String)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (Offset -> Text) -> Offset -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Offset -> String) -> Offset -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool -> Offset -> String
renderOffset String
sep Bool
withSecs)

renderOffset :: String -> Bool -> Offset -> String
renderOffset :: String -> Bool -> Offset -> String
renderOffset String
sep Bool
withSecs (Offset Int
secs) = Char
sign Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall {p}. Show p => p -> String
pad2 Int
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {p}. Show p => p -> String
pad2 Int
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
secPart
  where
    sign :: Char
sign = if Int
secs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Char
'-' else Char
'+'
    a :: Int
a = Int -> Int
forall a. Num a => a -> a
abs Int
secs
    h :: Int
h = Int
a Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
forall a. Num a => a
secondsPerHour
    m :: Int
m = (Int
a Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
forall a. Num a => a
secondsPerHour) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
forall a. Num a => a
secondsPerMinute
    s :: Int
s = Int
a Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
forall a. Num a => a
secondsPerMinute
    secPart :: String
secPart = if Bool
withSecs then String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {p}. Show p => p -> String
pad2 Int
s else String
""
    pad2 :: p -> String
pad2 p
x = let str :: String
str = p -> String
forall {p}. Show p => p -> String
show p
x in if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
str else String
str