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

module Data.HodaTime.Pattern.Internal
(
   Pattern(..)
  ,DefaultForParse(..)
  ,Parser
  ,parse
  ,parse'
  ,parse''
  ,format
  ,(<%)
  ,dimapP
  ,pairP
  ,string
  ,char
  ,pat_field
  ,pat_lens_field
  ,digitsToInt
  ,p_sixty
  ,f_shown
  ,f_shown_two
  ,f_shown_pad
  ,f_shown_spad
  ,pDigits
  ,pDigitsSpace
  ,caseInsensitiveString
  ,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 Control.Applicative ((<|>))
import Data.Char (toLower, toUpper)
import Formatting (Format, later, formatToString, left, (%.), (%), now)
import Data.String (fromString)
import Data.HodaTime.Internal.Lens (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_field :: (s -> a)
              -> (a -> s -> s)
              -> Parser a String
              -> ((s -> a) -> Format String (s -> String))
              -> String
              -> Pattern (s -> s) (s -> String) String
pat_field :: forall s a.
(s -> a)
-> (a -> s -> s)
-> Parser a String
-> ((s -> a) -> Format String (s -> String))
-> String
-> Pattern (s -> s) (s -> String) String
pat_field s -> a
getter a -> s -> s
setter 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
getter
    par :: Parser (s -> s) String
par = a -> s -> s
setter (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_field :: Lens s s a a
              -> (s' -> a')
              -> Parser a String
              -> ((s' -> a') -> Format String (s' -> String))
              -> String
              -> Pattern (s -> s) (s' -> String) String
pat_lens_field :: forall s a s' a'.
Lens s s a a
-> (s' -> a')
-> Parser a String
-> ((s' -> a') -> Format String (s' -> String))
-> String
-> Pattern (s -> s) (s' -> String) String
pat_lens_field Lens s s a a
lens s' -> a'
getter 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'
getter
    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
lens (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

-- | Format a numeric field @n@ characters wide, zero-padded.  Width @1@ means no padding (every number is at least
--   one character, so @left 1 '0'@ never adds a zero).
f_shown_pad :: Show b => Int -> (a -> b) -> Format r (a -> r)
f_shown_pad :: forall b a r. Show b => Int -> (a -> b) -> Format r (a -> r)
f_shown_pad Int
n a -> b
x = Int -> Char -> Format r (Builder -> r)
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
n 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

-- | Format a numeric field @n@ characters wide, /space/-padded (the @strftime@ @%e@\/@%l@ convention), e.g. @" 3"@.
f_shown_spad :: Show b => Int -> (a -> b) -> Format r (a -> r)
f_shown_spad :: forall b a r. Show b => Int -> (a -> b) -> Format r (a -> r)
f_shown_spad Int
n a -> b
x = Int -> Char -> Format r (Builder -> r)
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
n Char
' ' 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

-- | Parse a numeric field.  Width @1@ is the /no-padding/ case: it reads 1 up to @maxW@ digits, so both @"3"@ and
--   @"31"@ are accepted.  Width @n >= 2@ reads exactly @n@ digits.  Either way the value is validated to lie within
--   @[lo, hi]@.
pDigits :: Int -> Int -> Int -> Int -> Parser Int String
pDigits :: Int -> Int -> Int -> Int -> Parser Int String
pDigits Int
w Int
maxW Int
lo Int
hi = do
  String
ds <- if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Int -> Parser String String
upTo Int
maxW else Int -> ParsecT String () Identity Char -> Parser String String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
w ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  let x :: Int
x = String -> Int
forall a. Read a => String -> a
read String
ds
  if Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hi then Int -> Parser Int String
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x else String -> Parser Int String
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail (String
"expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
lo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
hi)
  where
    upTo :: Int -> Parser [Char] String
    upTo :: Int -> Parser String String
upTo Int
k = (:) (Char -> ShowS)
-> ParsecT String () Identity Char
-> ParsecT String () Identity ShowS
forall (f :: * -> *) a b. Functor 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 ParsecT String () Identity ShowS
-> Parser String String -> Parser String String
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
<*> Int -> Parser String String
go (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    go :: Int -> Parser [Char] String
    go :: Int -> Parser String String
go Int
j = if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then String -> Parser String String
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [] else String -> Parser String String -> Parser String String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] ((:) (Char -> ShowS)
-> ParsecT String () Identity Char
-> ParsecT String () Identity ShowS
forall (f :: * -> *) a b. Functor 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 ParsecT String () Identity ShowS
-> Parser String String -> Parser String String
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
<*> Int -> Parser String String
go (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- | Parse a /space/-padded numeric field (the @strftime@ @%e@\/@%l@ convention): skip any leading spaces, then read 1
--   up to @maxW@ digits, validated to lie within @[lo, hi]@.  Accepts both the padded (@" 3"@) and bare (@"3"@) forms.
pDigitsSpace :: Int -> Int -> Int -> Parser Int String
pDigitsSpace :: Int -> Int -> Int -> Parser Int String
pDigitsSpace Int
maxW Int
lo Int
hi = ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
' ') ParsecT String () Identity ()
-> Parser Int String -> Parser Int String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Int -> Int -> Int -> Parser Int String
pDigits Int
1 Int
maxW Int
lo Int
hi

-- | Case-insensitive literal string parser, used by the name-based patterns (month\/weekday names, AM\/PM designators).
caseInsensitiveString :: String -> Parsec String () String
caseInsensitiveString :: String -> Parser String String
caseInsensitiveString = (Char -> ParsecT String () Identity Char)
-> String -> Parser String String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Char -> ParsecT String () Identity Char
caseInsensitiveChar
  where
    caseInsensitiveChar :: Char -> Parsec String () Char
    caseInsensitiveChar :: Char -> ParsecT String () Identity Char
caseInsensitiveChar Char
c = (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char (Char -> Char
toLower Char
c) ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char (Char -> Char
toUpper Char
c)) ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String () Identity Char
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

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)

-- | Adapt a pattern over @s@ into a pattern over @t@ given a conversion in each direction (an isomorphism as far as the
--   pattern is concerned).  The parse setter is lifted through the conversion, and the formatter first projects the
--   @t@ down to an @s@.  This lets a pattern written for one type drive another that is convertible to it — for
--   example an 'Data.HodaTime.Instant.Instant' formatted through its UTC 'CalendarDateTime' projection.
dimapP :: (t -> s) -> (s -> t) -> Pattern (s -> s) (s -> String) String -> Pattern (t -> t) (t -> String) String
dimapP :: forall t s.
(t -> s)
-> (s -> t)
-> Pattern (s -> s) (s -> String) String
-> Pattern (t -> t) (t -> String) String
dimapP t -> s
toS s -> t
fromS (Pattern Parser (s -> s) String
pS Format String (s -> String)
fmtS) = Parser (t -> t) String
-> Format String (t -> String)
-> Pattern (t -> t) (t -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser (t -> t) String
pT Format String (t -> String)
forall {r}. Format r (t -> r)
fmtT
  where
    pT :: Parser (t -> t) String
pT = (\s -> s
f -> s -> t
fromS (s -> t) -> (t -> s) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f (s -> s) -> (t -> s) -> t -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> s
toS) ((s -> s) -> t -> t)
-> Parser (s -> s) String -> Parser (t -> t) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (s -> s) String
pS
    fmtT :: Format r (t -> r)
fmtT = (t -> Builder) -> Format r (t -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (Text -> Builder
TLB.fromText (Text -> Builder) -> (t -> Text) -> t -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (t -> String) -> t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format String (s -> String) -> s -> String
forall a. Format String a -> a
formatToString Format String (s -> String)
fmtS (s -> String) -> (t -> s) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> s
toS)

-- | Combine two patterns over independent parts (@a@ and @b@) of a whole @w@: the formatter concatenates their output
--   (the @a@ part then the @b@ part) and the parser runs both in that order and rebuilds the whole with the supplied
--   function.  Because @a@ and @b@ together fully determine @w@, the parsed setter is a 'const' (it does not build on
--   a default), so this produces whole values — e.g. an 'Data.HodaTime.OffsetDateTime.OffsetDateTime' from a
--   date\/time pattern and an offset pattern — rather than composable sub-fields.
pairP :: (DefaultForParse a, DefaultForParse b)
      => (w -> a) -> (w -> b) -> (a -> b -> w)
      -> Pattern (a -> a) (a -> String) String
      -> Pattern (b -> b) (b -> String) String
      -> Pattern (w -> w) (w -> String) String
pairP :: forall a b w.
(DefaultForParse a, DefaultForParse b) =>
(w -> a)
-> (w -> b)
-> (a -> b -> w)
-> Pattern (a -> a) (a -> String) String
-> Pattern (b -> b) (b -> String) String
-> Pattern (w -> w) (w -> String) String
pairP w -> a
getA w -> b
getB a -> b -> w
build (Pattern Parser (a -> a) String
pa Format String (a -> String)
fa) (Pattern Parser (b -> b) String
pb Format String (b -> String)
fb) = Parser (w -> w) String
-> Format String (w -> String)
-> Pattern (w -> w) (w -> String) String
forall a b r. Parser a r -> Format r b -> Pattern a b r
Pattern Parser (w -> w) String
forall {b}. ParsecT String () Identity (b -> w)
par Format String (w -> String)
forall {r}. Format r (w -> r)
fmt
  where
    par :: ParsecT String () Identity (b -> w)
par = (\a -> a
sa b -> b
sb -> w -> b -> w
forall a b. a -> b -> a
const (a -> b -> w
build (a -> a
sa a
forall d. DefaultForParse d => d
getDefault) (b -> b
sb b
forall d. DefaultForParse d => d
getDefault))) ((a -> a) -> (b -> b) -> b -> w)
-> Parser (a -> a) String
-> ParsecT String () Identity ((b -> b) -> b -> w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (a -> a) String
pa ParsecT String () Identity ((b -> b) -> b -> w)
-> Parser (b -> b) String -> ParsecT String () Identity (b -> w)
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
<*> Parser (b -> b) String
pb
    fmt :: Format r (w -> r)
fmt = (w -> Builder) -> Format r (w -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (\w
w -> Text -> Builder
TLB.fromText (Text -> Builder) -> (String -> Text) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Format String (a -> String) -> a -> String
forall a. Format String a -> a
formatToString Format String (a -> String)
fa (w -> a
getA w
w) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Format String (b -> String) -> b -> String
forall a. Format String a -> a
formatToString Format String (b -> String)
fb (w -> b
getB w
w))