{-# 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
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
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)))
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)))
formatYear :: LocalTime -> String
formatYear :: LocalTime -> String
formatYear = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y"
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"
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"
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"
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"