-----------------------------------------------------------------------------
-- |
-- Module      :  Data.HodaTime.Pattern.Duration
-- 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 a 'Data.HodaTime.Duration.Duration', rendered as @[-]D:HH:mm:ss@; @pDurationNano@ additionally carries
-- the fractional second down to the nanosecond.
----------------------------------------------------------------------------
module Data.HodaTime.Pattern.Duration
(
  -- * Standard Patterns
   pDuration
  ,pDurationNano
)
where

import Data.HodaTime.Pattern.Internal (Pattern(..), p_sixty)
import Data.HodaTime.Duration.Internal (Duration(..))
import qualified Data.HodaTime.Duration as Dur (fromSeconds, fromNanoseconds, add)
import Data.HodaTime.Instant.Internal (Instant(..))
import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond)
import Formatting (Format, later)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TLB
import Text.Parsec (Parsec, many1, count, digit, option, (<?>))
import qualified Text.Parsec as P (char)

-- d1 = fromStandardDays 1 `Dur.add` fromSeconds 30
-- format pDuration d1        -- "1:00:00:30"
-- parse pDuration "-0:00:00:30"

type Parser a = Parsec String () a

-- DESIGN NOTE: like 'Data.HodaTime.Offset.Offset', a 'Duration' is a /signed/ quantity whose sign belongs to the
-- whole value, not to any one component — and it is stored floor-style (a signed day count plus /non-negative/
-- normalized sub-day seconds and nanoseconds, so e.g. -30s is stored as -1 day + 86370s).  So we do not decompose it
-- with independent field lenses; instead both directions treat it as a whole: the signed total is computed once (in
-- 'Integer', to interpret the floor representation correctly and to avoid overflow), then formatting emits the sign
-- followed by the magnitude, and parsing reads the sign and all components and rebuilds via 'Dur.fromSeconds' /
-- 'Dur.fromNanoseconds' (which re-normalize).  Hence the parser's setter is 'const': the text fully determines the
-- value.

-- | The duration pattern @[-]D:HH:mm:ss@ (days, hours, minutes, seconds; a leading @-@ only for negative durations),
--   e.g. @1:00:00:30@ or @-0:00:00:30@.
pDuration :: Pattern (Duration -> Duration) (Duration -> String) String
pDuration :: Pattern (Duration -> Duration) (Duration -> String) String
pDuration = Parser (Duration -> Duration) String
-> Format String (Duration -> String)
-> Pattern (Duration -> Duration) (Duration -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Duration -> Duration -> Duration
forall a b. a -> b -> a
const (Duration -> Duration -> Duration)
-> ParsecT String () Identity Duration
-> Parser (Duration -> Duration) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ParsecT String () Identity Duration
durationParser Bool
False Parser (Duration -> Duration) String
-> String -> Parser (Duration -> Duration) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"duration: [-]D:HH:mm:ss") (Bool -> Format String (Duration -> String)
durationFormat Bool
False)

-- | Like 'pDuration' but with a nanosecond fraction, @[-]D:HH:mm:ss.fffffffff@.
pDurationNano :: Pattern (Duration -> Duration) (Duration -> String) String
pDurationNano :: Pattern (Duration -> Duration) (Duration -> String) String
pDurationNano = Parser (Duration -> Duration) String
-> Format String (Duration -> String)
-> Pattern (Duration -> Duration) (Duration -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern (Duration -> Duration -> Duration
forall a b. a -> b -> a
const (Duration -> Duration -> Duration)
-> ParsecT String () Identity Duration
-> Parser (Duration -> Duration) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ParsecT String () Identity Duration
durationParser Bool
True Parser (Duration -> Duration) String
-> String -> Parser (Duration -> Duration) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"duration: [-]D:HH:mm:ss.fffffffff") (Bool -> Format String (Duration -> String)
durationFormat Bool
True)

-- helpers

-- | Decompose into @(isNegative, days, hours, minutes, seconds, nanoseconds)@ as non-negative magnitudes.
durComponents :: Duration -> (Bool, Integer, Integer, Integer, Integer, Integer)
durComponents :: Duration -> (Bool, Integer, Integer, Integer, Integer, Integer)
durComponents (Duration (Instant Int32
days Word32
secs Word32
nsecs)) = (Integer
total Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0, Integer
d, Integer
h, Integer
m, Integer
s, Integer
ns)
  where
    nsPerSec :: Integer
nsPerSec = Integer
forall a. Num a => a
nsecsPerSecond :: Integer
    nsPerDay :: Integer
nsPerDay = (Integer
forall a. Num a => a
secondsPerDay :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
nsPerSec
    total :: Integer
total = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
days Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
nsPerDay Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
secs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
nsPerSec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nsecs
    a :: Integer
a = Integer -> Integer
forall a. Num a => a -> a
abs Integer
total
    (Integer
totalSec, Integer
ns) = Integer
a Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
nsPerSec
    (Integer
totalMin, Integer
s)  = Integer
totalSec Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
60
    (Integer
totalHr, Integer
m)   = Integer
totalMin Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
60
    (Integer
d, Integer
h)         = Integer
totalHr Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
24

durationFormat :: Bool -> Format String (Duration -> String)
durationFormat :: Bool -> Format String (Duration -> String)
durationFormat Bool
withFrac = (Duration -> Builder) -> Format String (Duration -> String)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (Duration -> Text) -> Duration -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Duration -> String) -> Duration -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duration -> String
render)
  where
    render :: Duration -> String
render Duration
dur = String
sign String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
pad2 Integer
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
pad2 Integer
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
pad2 Integer
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fracPart
      where
        (Bool
neg, Integer
d, Integer
h, Integer
m, Integer
s, Integer
ns) = Duration -> (Bool, Integer, Integer, Integer, Integer, Integer)
durComponents Duration
dur
        sign :: String
sign = if Bool
neg then String
"-" else String
""
        fracPart :: String
fracPart = if Bool
withFrac then String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Integer -> String
forall {p}. Show p => Int -> p -> String
padN Int
9 Integer
ns else String
""
    pad2 :: Integer -> String
pad2 = Int -> Integer -> String
forall {p}. Show p => Int -> p -> String
padN Int
2
    padN :: Int -> p -> String
padN Int
n p
x = let str :: String
str = p -> String
forall a. Show a => a -> String
show p
x in Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

durationParser :: Bool -> Parser Duration
durationParser :: Bool -> ParsecT String () Identity Duration
durationParser Bool
withFrac = do
  Bool
neg <- Bool
-> ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Bool
False (Bool
True Bool
-> ParsecT String () Identity Char
-> ParsecT String () Identity Bool
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
d <- String -> Int
readInt (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  Char
_ <- 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
forall {u}. ParsecT String u Identity Int
twoDigit
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
':'
  Int
m <- ParsecT String () Identity Int
forall n. (Num n, Read n) => Parser n String
p_sixty
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
':'
  Int
s <- ParsecT String () Identity Int
forall n. (Num n, Read n) => Parser n String
p_sixty
  Int
ns <- if Bool
withFrac then 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 Char
-> 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
*> (String -> Int
readInt (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
9 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) else Int -> ParsecT String () Identity Int
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  let sign :: Int
sign = if Bool
neg then -Int
1 else Int
1
      totalSec :: Int
totalSec = Int
sign Int -> Int -> Int
forall a. Num a => a -> a -> a
* (((Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s)
      signedNs :: Int
signedNs = Int
sign Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ns
  Duration -> ParsecT String () Identity Duration
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> ParsecT String () Identity Duration)
-> Duration -> ParsecT String () Identity Duration
forall a b. (a -> b) -> a -> b
$ Int -> Duration
Dur.fromSeconds Int
totalSec Duration -> Duration -> Duration
`Dur.add` Int -> Duration
Dur.fromNanoseconds Int
signedNs
  where
    twoDigit :: ParsecT String u Identity Int
twoDigit = String -> Int
readInt (String -> Int)
-> ParsecT String u Identity String
-> ParsecT String u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT String u Identity Char
-> ParsecT String u 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 u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
    readInt :: String -> Int
readInt = String -> Int
forall a. Read a => String -> a
read :: String -> Int