{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | @since 0.1
module Kairos.Types.Date.Internal
  ( -- * Type
    Date (.., MkDate, MkDateString),

    -- * Construction
    parseDateString,

    -- * Elimination
    unDateString,
    unDate,
    year,
    month,
    day,
  )
where

import Control.DeepSeq (NFData)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word16, Word8)
import GHC.Generics (Generic)
import GHC.Records (HasField (getField))
import Optics.Core (A_Getter, LabelOptic (labelOptic), to)
import Text.Read qualified as TR

-- | Represents a date string in the format @YYYY-MM-DD@.
--
-- @since 0.1
data Date = UnsafeDate Word16 Word8 Word8
  deriving stock
    ( -- | @since 0.1
      Date -> Date -> Bool
(Date -> Date -> Bool) -> (Date -> Date -> Bool) -> Eq Date
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Date -> Date -> Bool
== :: Date -> Date -> Bool
$c/= :: Date -> Date -> Bool
/= :: Date -> Date -> Bool
Eq,
      -- | @since 0.1
      (forall x. Date -> Rep Date x)
-> (forall x. Rep Date x -> Date) -> Generic Date
forall x. Rep Date x -> Date
forall x. Date -> Rep Date x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Date -> Rep Date x
from :: forall x. Date -> Rep Date x
$cto :: forall x. Rep Date x -> Date
to :: forall x. Rep Date x -> Date
Generic,
      -- | @since 0.1
      Int -> Date -> ShowS
[Date] -> ShowS
Date -> String
(Int -> Date -> ShowS)
-> (Date -> String) -> ([Date] -> ShowS) -> Show Date
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Date -> ShowS
showsPrec :: Int -> Date -> ShowS
$cshow :: Date -> String
show :: Date -> String
$cshowList :: [Date] -> ShowS
showList :: [Date] -> ShowS
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      Date -> ()
(Date -> ()) -> NFData Date
forall a. (a -> ()) -> NFData a
$crnf :: Date -> ()
rnf :: Date -> ()
NFData
    )

-- | @since 0.1
pattern MkDateString :: Text -> Date
pattern $mMkDateString :: forall {r}. Date -> (Text -> r) -> ((# #) -> r) -> r
MkDateString t <- (unDateString -> t)

{-# COMPLETE MkDateString #-}

-- | @since 0.1
pattern MkDate :: Word16 -> Word8 -> Word8 -> Date
pattern $mMkDate :: forall {r}.
Date -> (Word16 -> Word8 -> Word8 -> r) -> ((# #) -> r) -> r
MkDate y m d <- UnsafeDate y m d

{-# COMPLETE MkDate #-}

-- | @since 0.1
instance HasField "unDateString" Date Text where
  getField :: Date -> Text
getField = Date -> Text
unDateString
  {-# INLINE getField #-}

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ Text, b ~ Text) =>
  LabelOptic "unDateString" k Date Date a b
  where
  labelOptic :: Optic k NoIx Date Date a b
labelOptic = (Date -> a) -> Getter Date a
forall s a. (s -> a) -> Getter s a
to Date -> a
Date -> Text
unDateString
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance HasField "unDate" Date (Word16, Word8, Word8) where
  getField :: Date -> (Word16, Word8, Word8)
getField = Date -> (Word16, Word8, Word8)
unDate
  {-# INLINE getField #-}

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ (Word16, Word8, Word8), b ~ (Word16, Word8, Word8)) =>
  LabelOptic "unDate" k Date Date a b
  where
  labelOptic :: Optic k NoIx Date Date a b
labelOptic = (Date -> a) -> Getter Date a
forall s a. (s -> a) -> Getter s a
to Date -> a
Date -> (Word16, Word8, Word8)
unDate
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance HasField "year" Date Word16 where
  getField :: Date -> Word16
getField = Date -> Word16
year
  {-# INLINE getField #-}

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ Word16, b ~ Word16) =>
  LabelOptic "year" k Date Date a b
  where
  labelOptic :: Optic k NoIx Date Date a b
labelOptic = (Date -> a) -> Getter Date a
forall s a. (s -> a) -> Getter s a
to Date -> a
Date -> Word16
year
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance HasField "month" Date Word8 where
  getField :: Date -> Word8
getField = Date -> Word8
month
  {-# INLINE getField #-}

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ Word8, b ~ Word8) =>
  LabelOptic "month" k Date Date a b
  where
  labelOptic :: Optic k NoIx Date Date a b
labelOptic = (Date -> a) -> Getter Date a
forall s a. (s -> a) -> Getter s a
to Date -> a
Date -> Word8
month
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance HasField "day" Date Word8 where
  getField :: Date -> Word8
getField = Date -> Word8
day
  {-# INLINE getField #-}

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ Word8, b ~ Word8) =>
  LabelOptic "day" k Date Date a b
  where
  labelOptic :: Optic k NoIx Date Date a b
labelOptic = (Date -> a) -> Getter Date a
forall s a. (s -> a) -> Getter s a
to Date -> a
Date -> Word8
day
  {-# INLINE labelOptic #-}

-- | @since 0.1
unDateString :: Date -> Text
unDateString :: Date -> Text
unDateString (UnsafeDate Word16
y Word8
m Word8
d) =
  [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Word16 -> Text
forall a. Show a => a -> Text
showt Word16
y,
      Text
"-",
      Text -> Text
pad2 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> Text
forall a. Show a => a -> Text
showt Word8
m,
      Text
"-",
      Text -> Text
pad2 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> Text
forall a. Show a => a -> Text
showt Word8
d
    ]
  where
    showt :: (Show a) => a -> Text
    showt :: forall a. Show a => a -> Text
showt = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
    pad2 :: Text -> Text
pad2 Text
x
      | Text -> Int
T.length Text
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Char -> Text -> Text
T.cons Char
'0' Text
x
      | Bool
otherwise = Text
x

-- | @since 0.1
unDate :: Date -> (Word16, Word8, Word8)
unDate :: Date -> (Word16, Word8, Word8)
unDate (UnsafeDate Word16
y Word8
m Word8
d) = (Word16
y, Word8
m, Word8
d)

-- | Parses a date string in @YYYY-MM-DD@ form.
--
-- @since 0.1
parseDateString :: (MonadFail f) => Text -> f Date
parseDateString :: forall (f :: * -> *). MonadFail f => Text -> f Date
parseDateString Text
txt = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
txt of
  [Text
y, Text
m, Text
d] | Text -> Bool
nonEmpty Text
y Bool -> Bool -> Bool
&& Text -> Bool
nonEmpty Text
m Bool -> Bool -> Bool
&& Text -> Bool
nonEmpty Text
d ->
    case (Text -> Maybe Word16
parseYear Text
y, Text -> Maybe Word8
parseMonth Text
m, Text -> Maybe Word8
parseDay Text
d) of
      (Just Word16
y', Just Word8
m', Just Word8
d') -> Date -> f Date
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Date -> f Date) -> Date -> f Date
forall a b. (a -> b) -> a -> b
$ Word16 -> Word8 -> Word8 -> Date
UnsafeDate Word16
y' Word8
m' Word8
d'
      (Maybe Word16
Nothing, Maybe Word8
_, Maybe Word8
_) ->
        String -> f Date
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Date) -> String -> f Date
forall a b. (a -> b) -> a -> b
$
          String
"Year should be an integer between 1900 and 3000, received " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
squote Text
y
      (Maybe Word16
_, Maybe Word8
Nothing, Maybe Word8
_) ->
        String -> f Date
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Date) -> String -> f Date
forall a b. (a -> b) -> a -> b
$
          String
"Month should be an integer between 1 and 12, received " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
squote Text
m
      (Maybe Word16
_, Maybe Word8
_, Maybe Word8
Nothing) ->
        String -> f Date
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Date) -> String -> f Date
forall a b. (a -> b) -> a -> b
$
          String
"Day should be an integer between 1 and 31, received " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
squote Text
d
  [Text]
_ ->
    String -> f Date
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Date) -> String -> f Date
forall a b. (a -> b) -> a -> b
$ String
"Date has the form YYYY-MM-DD, received " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
squote Text
txt

-- | @since 0.1
year :: Date -> Word16
year :: Date -> Word16
year (UnsafeDate Word16
y Word8
_ Word8
_) = Word16
y

-- | @since 0.1
month :: Date -> Word8
month :: Date -> Word8
month (UnsafeDate Word16
_ Word8
m Word8
_) = Word8
m

-- | @since 0.1
day :: Date -> Word8
day :: Date -> Word8
day (UnsafeDate Word16
_ Word8
_ Word8
d) = Word8
d

parseYear :: Text -> Maybe Word16
parseYear :: Text -> Maybe Word16
parseYear = forall a. (Ord a, Read a) => Int -> a -> a -> Text -> Maybe a
readDecimal @Word16 Int
4 Word16
1900 Word16
3000

parseMonth :: Text -> Maybe Word8
parseMonth :: Text -> Maybe Word8
parseMonth = forall a. (Ord a, Read a) => Int -> a -> a -> Text -> Maybe a
readDecimal @Word8 Int
2 Word8
1 Word8
12

parseDay :: Text -> Maybe Word8
parseDay :: Text -> Maybe Word8
parseDay = forall a. (Ord a, Read a) => Int -> a -> a -> Text -> Maybe a
readDecimal @Word8 Int
2 Word8
1 Word8
31

readDecimal :: (Ord a, Read a) => Int -> a -> a -> Text -> Maybe a
readDecimal :: forall a. (Ord a, Read a) => Int -> a -> a -> Text -> Maybe a
readDecimal Int
len a
l a
u Text
t = do
  Text
tLen <- if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing
  a
n <- String -> Maybe a
forall a. Read a => String -> Maybe a
TR.readMaybe (Text -> String
T.unpack Text
tLen)
  if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
l Bool -> Bool -> Bool
&& a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
u
    then a -> Maybe a
forall a. a -> Maybe a
Just a
n
    else Maybe a
forall a. Maybe a
Nothing

nonEmpty :: Text -> Bool
nonEmpty :: Text -> Bool
nonEmpty = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

squote :: Text -> String
squote :: Text -> String
squote Text
t = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"