{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE FlexibleContexts #-}

module Photoname.Date
  ( PhDate (..)
  , formatYear, formatDateHyphens, formatDate, formatDateTime
  , formatDateForExif
  , mkDateFormatter
  , parseExifDate
  , parseFilenameDate
  )
  where

import Data.Functor.Identity (Identity)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))
import System.FilePath (takeFileName)
import Text.Parsec (ParsecT)
import Text.ParserCombinators.Parsec (anyChar, char, count, digit,
  lookAhead, manyTill, parse, space, try)

import Photoname.Common (SrcPath (SrcPath), defaultDateTimeFormat)


data PhDate
  = ExifDate LocalTime
  | FilenameDate LocalTime
  | NoDateFound
  deriving (PhDate -> PhDate -> Bool
(PhDate -> PhDate -> Bool)
-> (PhDate -> PhDate -> Bool) -> Eq PhDate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PhDate -> PhDate -> Bool
== :: PhDate -> PhDate -> Bool
$c/= :: PhDate -> PhDate -> Bool
/= :: PhDate -> PhDate -> Bool
Eq, Int -> PhDate -> ShowS
[PhDate] -> ShowS
PhDate -> [Char]
(Int -> PhDate -> ShowS)
-> (PhDate -> [Char]) -> ([PhDate] -> ShowS) -> Show PhDate
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PhDate -> ShowS
showsPrec :: Int -> PhDate -> ShowS
$cshow :: PhDate -> [Char]
show :: PhDate -> [Char]
$cshowList :: [PhDate] -> ShowS
showList :: [PhDate] -> ShowS
Show)

instance Semigroup PhDate where
  <> :: PhDate -> PhDate -> PhDate
(<>) e :: PhDate
e@(ExifDate LocalTime
_)     PhDate
_              = PhDate
e
  (<>)   (FilenameDate LocalTime
_) e :: PhDate
e@(ExifDate LocalTime
_) = PhDate
e
  (<>) f :: PhDate
f@(FilenameDate LocalTime
_) PhDate
_              = PhDate
f
  (<>)    PhDate
NoDateFound     PhDate
x              = PhDate
x

instance Monoid PhDate where
  mempty :: PhDate
mempty = PhDate
NoDateFound


-- Parsec helper defs

colon :: ParsecT String u Identity Char
colon :: forall u. ParsecT [Char] u Identity Char
colon = Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'

digit2, digit4 :: ParsecT String u Identity [Char]
digit2 :: forall u. ParsecT [Char] u Identity [Char]
digit2 = Int
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
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 [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
digit4 :: forall u. ParsecT [Char] u Identity [Char]
digit4 = Int
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
4 ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit


{- Parse a string in the form "yyyy:mm:dd hh:mm:ss" into a 
   LocalTime datatype. Strings that fail to parse in this manner are
   returned as Nothing
-}
parseExifDate :: Maybe String -> PhDate
parseExifDate :: Maybe [Char] -> PhDate
parseExifDate Maybe [Char]
Nothing = PhDate
NoDateFound
parseExifDate (Just [Char]
s) =
   case Parsec [Char] () LocalTime
-> [Char] -> [Char] -> Either ParseError LocalTime
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () LocalTime
forall {u}. ParsecT [Char] u Identity LocalTime
dateParser [Char]
"" [Char]
s of
      Left ParseError
_  -> PhDate
NoDateFound
      Right LocalTime
x -> LocalTime -> PhDate
ExifDate LocalTime
x
   where
      dateParser :: ParsecT [Char] u Identity LocalTime
dateParser = do
         [Char]
year <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit4 ; ParsecT [Char] u Identity Char
forall u. ParsecT [Char] u Identity Char
colon ; [Char]
month <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2 ; ParsecT [Char] u Identity Char
forall u. ParsecT [Char] u Identity Char
colon ; [Char]
day <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
         ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
         [Char]
hour <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2 ; ParsecT [Char] u Identity Char
forall u. ParsecT [Char] u Identity Char
colon ; [Char]
minute <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
         ParsecT [Char] u Identity Char
forall u. ParsecT [Char] u Identity Char
colon ; [Char]
second <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
         LocalTime -> ParsecT [Char] u Identity LocalTime
forall a. a -> ParsecT [Char] u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> ParsecT [Char] u Identity LocalTime)
-> LocalTime -> ParsecT [Char] u Identity LocalTime
forall a b. (a -> b) -> a -> b
$
            Day -> TimeOfDay -> LocalTime
LocalTime
               (Year -> Int -> Int -> Day
fromGregorian ([Char] -> Year
forall a. Read a => [Char] -> a
read [Char]
year) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
month) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
day))
               (Int -> Int -> Pico -> TimeOfDay
TimeOfDay ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
hour) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
minute)
                  (Year -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Char] -> Year
forall a. Read a => [Char] -> a
read [Char]
second :: Integer)))


{- Parse a string in one of the the forms below into a LocalTime datatype.

    /some/path/ANYTHINGyyyy-mm-dd-hhmmss.jpg
    /some/path/ANYTHINGyyyy-mm-dd-hh-mm-ss-ttt.jpg
    ANYTHINGyyyy-mm-dd-hhmmss.jpg
    ANYTHINGyyyy-mm-dd-hh-mm-ss-ttt.jpg
    yyyymmdd-hhmmss.jpg
    yyyymmdd-hhmmss_xyz.jpg
    PXL_yyyymmdd_hhmmssttt.jpg
    PXL_yyyymmdd_hhmmssttt_xyz.jpg
-}
parseFilenameDate :: SrcPath -> PhDate
parseFilenameDate :: SrcPath -> PhDate
parseFilenameDate (SrcPath [Char]
srcPath) =
  case Parsec [Char] () LocalTime
-> [Char] -> [Char] -> Either ParseError LocalTime
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () LocalTime
forall {u}. ParsecT [Char] u Identity LocalTime
dateParser [Char]
"" (ShowS
takeFileName [Char]
srcPath) of
    Left ParseError
_  -> PhDate
NoDateFound
    Right LocalTime
x -> LocalTime -> PhDate
FilenameDate LocalTime
x
  where
    dateParser :: ParsecT [Char] u Identity LocalTime
dateParser = do
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit4)
      [Char]
year <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit4
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2)
      [Char]
month <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2)
      [Char]
day <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2)
      [Char]
hour <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2)
      [Char]
minute <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
      ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2)
      [Char]
second <- ParsecT [Char] u Identity [Char]
forall u. ParsecT [Char] u Identity [Char]
digit2
      LocalTime -> ParsecT [Char] u Identity LocalTime
forall a. a -> ParsecT [Char] u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> ParsecT [Char] u Identity LocalTime)
-> LocalTime -> ParsecT [Char] u Identity LocalTime
forall a b. (a -> b) -> a -> b
$
         Day -> TimeOfDay -> LocalTime
LocalTime
            (Year -> Int -> Int -> Day
fromGregorian ([Char] -> Year
forall a. Read a => [Char] -> a
read [Char]
year) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
month) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
day))
            (Int -> Int -> Pico -> TimeOfDay
TimeOfDay ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
hour) ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
minute)
               (Year -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Char] -> Year
forall a. Read a => [Char] -> a
read [Char]
second :: Integer)))


{- Format a LocalTime into a "yyyy" string
-}
formatYear :: LocalTime -> String
formatYear :: LocalTime -> [Char]
formatYear = TimeLocale -> [Char] -> LocalTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y"


{- Format a LocalTime into a "yyyy-mm-dd" string
-}
formatDateHyphens :: LocalTime -> String
formatDateHyphens :: LocalTime -> [Char]
formatDateHyphens = TimeLocale -> [Char] -> LocalTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%d"


{- Format a LocalTime into a "yyyymmdd" string
-}
formatDate :: LocalTime -> String
formatDate :: LocalTime -> [Char]
formatDate = TimeLocale -> [Char] -> LocalTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y%m%d"


{- Format a LocalTime into a "yyyymmdd-HHMMSS" string
-}
formatDateTime :: LocalTime -> String
formatDateTime :: LocalTime -> [Char]
formatDateTime = [Char] -> LocalTime -> [Char]
mkDateFormatter [Char]
defaultDateTimeFormat


{- Format a LocalTime into a "yyyy:mm:dd HH:MM:SS" string
-}
formatDateForExif :: LocalTime -> String
formatDateForExif :: LocalTime -> [Char]
formatDateForExif = TimeLocale -> [Char] -> LocalTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y:%m:%d %H:%M:%S"


mkDateFormatter :: String -> LocalTime -> String
mkDateFormatter :: [Char] -> LocalTime -> [Char]
mkDateFormatter = TimeLocale -> [Char] -> LocalTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale