{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use camelCase" #-}

module Data.HodaTime.Pattern.Internal
(
   Pattern(..)
  ,DefaultForParse(..)
  ,parse
  ,parse'
  ,parse''
  ,format
  ,(<>)         -- TODO: Remove
  ,(<%)
  ,string
  ,char
  ,pat_lens
  ,pat_lens'
  ,digitsToInt
  ,p_sixty
  ,f_shown
  ,f_shown_two
  ,ParseFailedException(..)
)
where

import Control.Monad.Catch (MonadThrow, throwM)
import qualified  Data.Text as T
import qualified  Data.Text.Lazy.Builder as TLB
import Text.Parsec hiding (many, optional, (<|>), parse, string, char)
import qualified Text.Parsec as P (string, char)
import Formatting (Format, later, formatToString, left, (%.), (%), now)
import Data.String (fromString)
import Data.HodaTime.Internal.Lens (view, set, Lens)
import Data.HodaTime.Pattern.ApplyParse (DefaultForParse(..), ApplyParse(..))
import Control.Exception (Exception)
import Data.Typeable (Typeable)

-- Exceptions

-- | Parse failed on the given string
newtype ParseFailedException = ParseFailedException String
  deriving (Typeable, Int -> ParseFailedException -> ShowS
[ParseFailedException] -> ShowS
ParseFailedException -> String
(Int -> ParseFailedException -> ShowS)
-> (ParseFailedException -> String)
-> ([ParseFailedException] -> ShowS)
-> Show ParseFailedException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseFailedException -> ShowS
showsPrec :: Int -> ParseFailedException -> ShowS
$cshow :: ParseFailedException -> String
show :: ParseFailedException -> String
$cshowList :: [ParseFailedException] -> ShowS
showList :: [ParseFailedException] -> ShowS
Show)

instance Exception ParseFailedException

type Parser a r = Parsec r () a

-- | Pattern for the data type which is used by the 'parse', 'format' and 'parse\'' functions
data Pattern a b r = Pattern
  {
     forall a b r. Pattern a b r -> Parser a r
_patParse :: Parser a r
    ,forall a b r. Pattern a b r -> Format r b
_patFormat :: Format r b
  }

-- | Merge a pattern that operates on a data type with a static pattern
(<%) :: Pattern a b r -> Pattern c r r -> Pattern a b r
(Pattern Parser a r
parse1 Format r b
format1) <% :: forall a b r c. Pattern a b r -> Pattern c r r -> Pattern a b r
<% (Pattern Parser c r
parse2 Format r r
format2) = Parser a r -> Format r b -> Pattern a b r
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser a r
par Format r b
fmt
  where
    par :: Parser a r
par = Parser a r
parse1 Parser a r -> Parser c r -> Parser a r
forall a b.
ParsecT r () Identity a
-> ParsecT r () Identity b -> ParsecT r () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser c r
parse2
    fmt :: Format r b
fmt = Format r b
format1 Format r b -> Format r r -> Format r b
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format r r
format2

{-
-- | Merge a static pattern with one that operates on a data type

-- NOTE: The following doesn't work, I believe because of how much we're fixing the types removes the ability to apply (%) in either direction.
-- NOTE: But in fact, (<%) above is sufficient, the library can work fine without offering the other option

(%>) :: Pattern c r r -> Pattern a b r -> Pattern a b r
(Pattern parse1 format1) %> (Pattern parse2 format2) = Pattern par fmt
  where
    par = parse1 *> parse2
    fmt = format1 % format2
-}

instance Semigroup (Pattern (a -> a) (b -> r) r) where
  (Pattern Parser (a -> a) r
parse1 Format r (b -> r)
format1) <> :: Pattern (a -> a) (b -> r) r
-> Pattern (a -> a) (b -> r) r -> Pattern (a -> a) (b -> r) r
<> (Pattern Parser (a -> a) r
parse2 Format r (b -> r)
format2) = Parser (a -> a) r
-> Format r (b -> r) -> Pattern (a -> a) (b -> r) r
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser (a -> a) r
par Format r (b -> r)
fmt
    where
      par :: Parser (a -> a) r
par = (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((a -> a) -> (a -> a) -> a -> a)
-> Parser (a -> a) r -> ParsecT r () Identity ((a -> a) -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (a -> a) r
parse1 ParsecT r () Identity ((a -> a) -> a -> a)
-> Parser (a -> a) r -> Parser (a -> a) r
forall a b.
ParsecT r () Identity (a -> b)
-> ParsecT r () Identity a -> ParsecT r () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (a -> a) r
parse2
      fmt :: Format r (b -> r)
fmt = Format r (b -> r)
format1 Format r (b -> r) -> Format r (b -> r) -> Format r (b -> r)
forall a. Monoid a => a -> a -> a
`mappend` Format r (b -> r)
format2

-- | Parse a 'String' given by 'Pattern' for the data type 'a'.  Will call 'throwM' on failure.
-- NOTE: A default 'a' will be used to determine what happens for fields which do not appear in
--       the parse
parse :: (MonadThrow m, DefaultForParse a) => Pattern (a -> a) b String -> SourceName -> m a
parse :: forall (m :: * -> *) a b.
(MonadThrow m, DefaultForParse a) =>
Pattern (a -> a) b String -> String -> m a
parse Pattern (a -> a) b String
pat String
s = Pattern (a -> a) b String -> String -> a -> m a
forall (m :: * -> *) a b.
MonadThrow m =>
Pattern (a -> a) b String -> String -> a -> m a
parse' Pattern (a -> a) b String
pat String
s a
forall d. DefaultForParse d => d
getDefault

-- | Like 'parse' above but lets the user provide an 'a' as the default to use
parse' :: MonadThrow m => Pattern (a -> a) b String -> SourceName -> a -> m a
parse' :: forall (m :: * -> *) a b.
MonadThrow m =>
Pattern (a -> a) b String -> String -> a -> m a
parse' (Pattern Parser (a -> a) String
p Format String b
_) String
s a
def =
  case Parser (a -> a) String
-> () -> String -> String -> Either ParseError (a -> a)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parser (a -> a) String
p () String
s String
s of
    Left ParseError
err -> ParseFailedException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ParseFailedException -> m a)
-> (String -> ParseFailedException) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseFailedException
ParseFailedException (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right a -> a
r -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (a -> a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
r (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a
def

parse'' :: (MonadThrow m, ApplyParse a b) => Pattern (a -> a) (b -> String) String -> SourceName -> m b
parse'' :: forall (m :: * -> *) a b.
(MonadThrow m, ApplyParse a b) =>
Pattern (a -> a) (b -> String) String -> String -> m b
parse'' (Pattern Parser (a -> a) String
p Format String (b -> String)
_) String
s =
  case Parser (a -> a) String
-> () -> String -> String -> Either ParseError (a -> a)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parser (a -> a) String
p () String
s String
s of
    Left ParseError
err -> ParseFailedException -> m b
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ParseFailedException -> m b)
-> (String -> ParseFailedException) -> String -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseFailedException
ParseFailedException (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right a -> a
r -> (a -> a) -> m b
forall a b (m :: * -> *).
(ApplyParse a b, MonadThrow m) =>
(a -> a) -> m b
forall (m :: * -> *). MonadThrow m => (a -> a) -> m b
applyParse a -> a
r

-- | Use the given 'Pattern' to format the data type 'a' into a 'String'
format :: Pattern a r String -> r
format :: forall a r. Pattern a r String -> r
format (Pattern Parser a String
_ Format String r
fmt) = Format String r -> r
forall a. Format String a -> a
formatToString Format String r
fmt

pat_lens :: Lens s s a a
              -> Parser a String
              -> ((s -> a) -> Format String (s -> String))
              -> String
              -> Pattern (s -> s) (s -> String) String
pat_lens :: forall s a.
Lens s s a a
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_lens Lens s s a a
l Parser a String
p (s -> a) -> Format String (s -> String)
f String
err = Parser (s -> s) String
-> Format String (s -> String)
-> Pattern (s -> s) (s -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser (s -> s) String
par Format String (s -> String)
fmt
  where
    fmt :: Format String (s -> String)
fmt = (s -> a) -> Format String (s -> String)
f ((s -> a) -> Format String (s -> String))
-> (s -> a) -> Format String (s -> String)
forall a b. (a -> b) -> a -> b
$ Lens s s a a -> s -> a
forall s t a b. Lens s t a b -> s -> a
view (a -> f a) -> s -> f s
Lens s s a a
l
    par :: Parser (s -> s) String
par = Lens s s a a -> a -> s -> s
forall s t a b. Lens s t a b -> b -> s -> t
set (a -> f a) -> s -> f s
Lens s s a a
l (a -> s -> s) -> Parser a String -> Parser (s -> s) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a String
p Parser (s -> s) String -> String -> Parser (s -> s) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
err

pat_lens' :: Lens s s a a
              -> Lens s' s' a' a'
              -> Parser a String
              -> ((s' -> a') -> Format String (s' -> String))
              -> String
              -> Pattern (s -> s) (s' -> String) String
pat_lens' :: forall s a s' a'.
Lens s s a a
-> Lens s' s' a' a'
-> Parser a String
-> ((s' -> a') -> Format String (s' -> String))
-> String
-> Pattern (s -> s) (s' -> String) String
pat_lens' Lens s s a a
lp Lens s' s' a' a'
lf Parser a String
p (s' -> a') -> Format String (s' -> String)
f String
err = Parser (s -> s) String
-> Format String (s' -> String)
-> Pattern (s -> s) (s' -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser (s -> s) String
par Format String (s' -> String)
fmt
  where
    fmt :: Format String (s' -> String)
fmt = (s' -> a') -> Format String (s' -> String)
f ((s' -> a') -> Format String (s' -> String))
-> (s' -> a') -> Format String (s' -> String)
forall a b. (a -> b) -> a -> b
$ Lens s' s' a' a' -> s' -> a'
forall s t a b. Lens s t a b -> s -> a
view (a' -> f a') -> s' -> f s'
Lens s' s' a' a'
lf
    par :: Parser (s -> s) String
par = Lens s s a a -> a -> s -> s
forall s t a b. Lens s t a b -> b -> s -> t
set (a -> f a) -> s -> f s
Lens s s a a
lp (a -> s -> s) -> Parser a String -> Parser (s -> s) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a String
p Parser (s -> s) String -> String -> Parser (s -> s) String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
err

digitsToInt :: (Num n, Read n) => Char -> Char -> n
digitsToInt :: forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt Char
a Char
b = String -> n
forall a. Read a => String -> a
read [Char
a, Char
b]

p_sixty :: (Num n, Read n) => Parser n String
p_sixty :: forall n. (Num n, Read n) => Parser n String
p_sixty = Char -> Char -> n
forall n. (Num n, Read n) => Char -> Char -> n
digitsToInt (Char -> Char -> n)
-> ParsecT String () Identity Char
-> ParsecT String () Identity (Char -> n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'0'..Char
'5'] ParsecT String () Identity (Char -> n)
-> ParsecT String () Identity Char -> ParsecT String () Identity n
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

f_shown :: Show b => (a -> b) -> Format r (a -> r)
f_shown :: forall b a r. Show b => (a -> b) -> Format r (a -> r)
f_shown a -> b
x = (a -> Builder) -> Format r (a -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (a -> Text) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show (b -> String) -> (a -> b) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
x)

f_shown_two :: Show b => (a -> b) -> Format r (a -> r)
f_shown_two :: forall b a r. Show b => (a -> b) -> Format r (a -> r)
f_shown_two a -> b
x = Int -> Char -> Format r (Builder -> r)
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
2 Char
'0' Format r (Builder -> r) -> Format r (a -> r) -> Format r (a -> r)
forall r r' a.
Format r (Builder -> r') -> Format r' a -> Format r a
%. (a -> b) -> Format r (a -> r)
forall b a r. Show b => (a -> b) -> Format r (a -> r)
f_shown a -> b
x

string :: String -> Pattern String String String
string :: String -> Pattern String String String
string String
s = Parser String String
-> Format String String -> Pattern String String String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser String String
forall {u}. ParsecT String u Identity String
p_str Format String String
forall {r}. Format r r
f_str
  where
    p_str :: ParsecT String u Identity String
p_str = String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
s
    f_str :: Format r r
f_str = Builder -> Format r r
forall r. Builder -> Format r r
now (String -> Builder
forall a. IsString a => String -> a
fromString String
s)

char :: Char -> Pattern Char String String
char :: Char -> Pattern Char String String
char Char
c = ParsecT String () Identity Char
-> Format String String -> Pattern Char String String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern ParsecT String () Identity Char
forall {u}. ParsecT String u Identity Char
p_char Format String String
forall {r}. Format r r
f_char
  where
    p_char :: ParsecT String u Identity Char
p_char = Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
c
    f_char :: Format r r
f_char = Builder -> Format r r
forall r. Builder -> Format r r
now (Char -> Builder
TLB.singleton Char
c)