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

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

import Control.Newtype.Generics ( op )
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 (..) )


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
/= :: PhDate -> PhDate -> Bool
$c/= :: PhDate -> PhDate -> Bool
== :: PhDate -> PhDate -> Bool
$c== :: PhDate -> PhDate -> Bool
Eq, Int -> PhDate -> ShowS
[PhDate] -> ShowS
PhDate -> String
(Int -> PhDate -> ShowS)
-> (PhDate -> String) -> ([PhDate] -> ShowS) -> Show PhDate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PhDate] -> ShowS
$cshowList :: [PhDate] -> ShowS
show :: PhDate -> String
$cshow :: PhDate -> String
showsPrec :: Int -> PhDate -> ShowS
$cshowsPrec :: Int -> 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 :: ParsecT String u Identity Char
colon = Char -> ParsecT String 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 :: ParsecT String u Identity String
digit2 = 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
digit4 :: ParsecT String u Identity String
digit4 = 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
4 ParsecT String 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 
   CalendarTime datatype. Strings that fail to parse in this manner are
   returned as Nothing
-}
parseExifDate :: Maybe String -> PhDate
parseExifDate :: Maybe String -> PhDate
parseExifDate Maybe String
Nothing = PhDate
NoDateFound
parseExifDate (Just String
s) =
   case Parsec String () LocalTime
-> String -> String -> Either ParseError LocalTime
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () LocalTime
forall u. ParsecT String u Identity LocalTime
dateParser String
"" String
s of
      Left ParseError
_  -> PhDate
NoDateFound
      Right LocalTime
x -> LocalTime -> PhDate
ExifDate LocalTime
x
   where
      dateParser :: ParsecT String u Identity LocalTime
dateParser = do
         String
year <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit4 ; ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
colon ; String
month <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2 ; ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
colon ; String
day <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
         ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
         String
hour <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2 ; ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
colon ; String
minute <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
         ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
colon ; String
second <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
         LocalTime -> ParsecT String u Identity LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> ParsecT String u Identity LocalTime)
-> LocalTime -> ParsecT String u Identity LocalTime
forall a b. (a -> b) -> a -> b
$
            Day -> TimeOfDay -> LocalTime
LocalTime
               (Integer -> Int -> Int -> Day
fromGregorian (String -> Integer
forall a. Read a => String -> a
read String
year) (String -> Int
forall a. Read a => String -> a
read String
month) (String -> Int
forall a. Read a => String -> a
read String
day))
               (Int -> Int -> Pico -> TimeOfDay
TimeOfDay (String -> Int
forall a. Read a => String -> a
read String
hour) (String -> Int
forall a. Read a => String -> a
read String
minute)
                  (Integer -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Integer
forall a. Read a => String -> a
read String
second :: Integer)))


{- Parse a string in one of the the forms below into a CalendarTime 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
srcPath =
  case Parsec String () LocalTime
-> String -> String -> Either ParseError LocalTime
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () LocalTime
forall u. ParsecT String u Identity LocalTime
dateParser String
"" (ShowS
takeFileName ShowS -> (SrcPath -> String) -> SrcPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SrcPath) -> SrcPath -> String
forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op String -> SrcPath
SrcPath (SrcPath -> String) -> SrcPath -> String
forall a b. (a -> b) -> a -> b
$ SrcPath
srcPath) of
    Left ParseError
_  -> PhDate
NoDateFound
    Right LocalTime
x -> LocalTime -> PhDate
FilenameDate LocalTime
x
  where
    dateParser :: ParsecT String u Identity LocalTime
dateParser = do
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit4)
      String
year <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit4
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2)
      String
month <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2)
      String
day <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2)
      String
hour <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2)
      String
minute <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
      ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
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 String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity String
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2)
      String
second <- ParsecT String u Identity String
forall u. ParsecT String u Identity String
digit2
      LocalTime -> ParsecT String u Identity LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> ParsecT String u Identity LocalTime)
-> LocalTime -> ParsecT String u Identity LocalTime
forall a b. (a -> b) -> a -> b
$
         Day -> TimeOfDay -> LocalTime
LocalTime
            (Integer -> Int -> Int -> Day
fromGregorian (String -> Integer
forall a. Read a => String -> a
read String
year) (String -> Int
forall a. Read a => String -> a
read String
month) (String -> Int
forall a. Read a => String -> a
read String
day))
            (Int -> Int -> Pico -> TimeOfDay
TimeOfDay (String -> Int
forall a. Read a => String -> a
read String
hour) (String -> Int
forall a. Read a => String -> a
read String
minute)
               (Integer -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Integer
forall a. Read a => String -> a
read String
second :: Integer)))


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


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


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


{- Format a Maybe CalendarTime into a "yyyymmdd-HHMMSS" string
-}
formatDateTime :: LocalTime -> String
formatDateTime :: LocalTime -> String
formatDateTime = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d-%H%M%S"


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