{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module FieldParser where

import Control.Category qualified as Cat
import Control.Monad ((<=<))
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.Types qualified as Json
import Data.Attoparsec.ByteString qualified as AttoBytes
import Data.Attoparsec.Text qualified as Atto
import Data.CaseInsensitive qualified as CaseInsensitive
import Data.Error.Tree
import Data.Fixed qualified as Fixed
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Scientific (Scientific)
import Data.Scientific qualified as Scientific
import Data.Semigroup.Foldable (Foldable1 (toNonEmpty))
import Data.Semigroupoid qualified as Semigroupoid
import Data.Text qualified as Text
import Data.Time qualified as Time
import Data.Time.Format.ISO8601 qualified as Time.Format.ISO
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import PossehlAnalyticsPrelude
import Text.ParserCombinators.ReadPrec qualified as Read
import Prelude hiding (or)

-- | Parser for a field. TODO: define what a field is
--
-- If you want to build more complex parsers, use the 'attoparsecText' and 'attoparsecBytes' functions
-- to build a parser from a bytestring.
--
-- If you want to nest parsers, e.g. first want to decode to Text via utf-8 and then parse the Text,
-- use the 'Semigroupoid'/'Category' instances to chain parsers.
--
-- As a general rule, when you create an error message, try to include the value
-- (or a shortened version of the value) that was not accepted.
-- Otherwise the error will be hard to debug.

-- TODO: Can we add some examples to each parser?
newtype FieldParser' err from to = FieldParser (from -> Either err to)
  deriving stock (forall a b. a -> FieldParser' err from b -> FieldParser' err from a
forall a b.
(a -> b) -> FieldParser' err from a -> FieldParser' err from b
forall err from a b.
a -> FieldParser' err from b -> FieldParser' err from a
forall err from a b.
(a -> b) -> FieldParser' err from a -> FieldParser' err from b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FieldParser' err from b -> FieldParser' err from a
$c<$ :: forall err from a b.
a -> FieldParser' err from b -> FieldParser' err from a
fmap :: forall a b.
(a -> b) -> FieldParser' err from a -> FieldParser' err from b
$cfmap :: forall err from a b.
(a -> b) -> FieldParser' err from a -> FieldParser' err from b
Functor)

-- | An alias for 'FieldParser'' for the common case where @err@ = 'Error'.
type FieldParser from to = FieldParser' Error from to

-- | If the right parser fails, return its error, otherwise run the left parser.
instance Semigroupoid (FieldParser' err) where
  o :: FieldParser' err middle to -> FieldParser' err from middle -> FieldParser' err from to
  o :: forall j k1 i.
FieldParser' err j k1
-> FieldParser' err i j -> FieldParser' err i k1
o (FieldParser middle -> Either err to
f) (FieldParser from -> Either err middle
g) = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser (middle -> Either err to
f forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< from -> Either err middle
g)

-- | `id` is the parser that always succeeds.
instance Cat.Category (FieldParser' err) where
  id :: FieldParser' err a a
  id :: forall a. FieldParser' err a a
id = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
  . :: forall b c a.
FieldParser' err b c
-> FieldParser' err a b -> FieldParser' err a c
(.) = forall {k} (c :: k -> k -> Type) (j :: k) (k1 :: k) (i :: k).
Semigroupoid c =>
c j k1 -> c i j -> c i k1
Semigroupoid.o

-- | You can map over both sides of a parser to change the types in a
instance Profunctor (FieldParser' err) where
  dimap :: (from' -> from) -> (to -> to') -> FieldParser' err from to -> FieldParser' err from' to'
  dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> FieldParser' err b c -> FieldParser' err a d
dimap from' -> from
pre to -> to'
post (FieldParser from -> Either err to
parser) = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap to -> to'
post forall b c a. (b -> c) -> (a -> b) -> a -> c
. from -> Either err to
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. from' -> from
pre)

-- | Execute the field parser.
runFieldParser :: FieldParser' err from to -> from -> Either err to
runFieldParser :: forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser (FieldParser from -> Either err to
fn) = from -> Either err to
fn

-- | Change the type of the `err` in a field Parser.`
mapError :: (err1 -> err2) -> FieldParser' err1 from to -> FieldParser' err2 from to
mapError :: forall err1 err2 from to.
(err1 -> err2)
-> FieldParser' err1 from to -> FieldParser' err2 from to
mapError err1 -> err2
f (FieldParser from -> Either err1 to
original) = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \from
from -> from -> Either err1 to
original from
from forall a b. a -> (a -> b) -> b
& forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first err1 -> err2
f

-- | Turn a @FieldParser Value@ directly into a valid 'parseJSON` implementation.
--
-- If you want to parse any objects or lists, it’s better to use 'Json.toAesonParser' with 'jsonParser' instead, but for simple json scalars this one is better.
toParseJSON ::
  FieldParser Json.Value a ->
  Json.Value ->
  Json.Parser a
toParseJSON :: forall a. FieldParser Value a -> Value -> Parser a
toParseJSON FieldParser Value a
parser =
  forall err a. (err -> Text) -> Parse err a -> Value -> Parser a
Json.toAesonParser
    Error -> Text
prettyError
    (forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
jsonParser FieldParser Value a
parser)

-- | Turn a @FieldParser' ErrorTree Value@ directly into a valid 'parseJSON` implementation.
--
-- If you want to parse any objects or lists, it’s better to use 'Json.toAesonParser' with 'jsonParser' instead, but for simple json scalars this one is better.
toParseJSONErrorTree ::
  FieldParser' ErrorTree Json.Value a ->
  Json.Value ->
  Json.Parser a
toParseJSONErrorTree :: forall a. FieldParser' ErrorTree Value a -> Value -> Parser a
toParseJSONErrorTree FieldParser' ErrorTree Value a
parser =
  forall err a. (err -> Text) -> Parse err a -> Value -> Parser a
Json.toAesonParser
    ErrorTree -> Text
prettyErrorTree
    (forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
jsonParser FieldParser' ErrorTree Value a
parser)

toReadPrec ::
  -- | ReadPrec to base this parser on (e.g. use @readPrec \@Text@@ to parse the same as Text)
  Read.ReadPrec from ->
  FieldParser from to ->
  Read.ReadPrec to
toReadPrec :: forall from to. ReadPrec from -> FieldParser from to -> ReadPrec to
toReadPrec ReadPrec from
innerReadPrec FieldParser from to
parser = do
  from
from :: from <- ReadPrec from
innerReadPrec
  case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to
parser from
from of
    Left Error
err -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (Error
err forall a b. a -> (a -> b) -> b
& Error -> Text
prettyError forall a b. a -> (a -> b) -> b
& Text -> String
textToString)
    Right to
a -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure to
a

-- | Turn a @FieldParser Value@ into an 'Json.ParseT` which parses this value.
jsonParser :: Monad m => FieldParser' err Json.Value to -> Json.ParseT err m to
jsonParser :: forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
jsonParser FieldParser' err Value to
parser =
  ( forall (m :: Type -> Type) err.
(Functor m, Monad m) =>
ParseT err m Value
Json.asValue
      forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( \Value
from ->
              forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser' err Value to
parser Value
from forall a b. a -> (a -> b) -> b
& \case
                Right to
a -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure to
a
                Left err
err -> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
err -> ParseT err m a
Json.throwCustomError err
err
          )
  )

-- TODO: provide nice shortened values in the error messages for these json parsers.

-- | parse a json boolean from a 'Json.Value'
jsonBool :: FieldParser Json.Value Bool
jsonBool :: FieldParser Value Bool
jsonBool = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \case
  Json.Bool Bool
b -> forall a b. b -> Either a b
Right Bool
b
  Value
_ -> forall a b. a -> Either a b
Left Error
"Not a json boolean"

-- | parse a json `null` from a 'Json.Value'
jsonNull :: FieldParser Json.Value ()
jsonNull :: FieldParser Value ()
jsonNull = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \case
  Value
Json.Null -> forall a b. b -> Either a b
Right ()
  Value
_ -> forall a b. a -> Either a b
Left Error
"Not a json `null`"

-- | parse a json number from a 'Json.Value'
jsonNumber :: FieldParser Json.Value Scientific
jsonNumber :: FieldParser Value Scientific
jsonNumber = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \case
  Json.Number Scientific
s -> forall a b. b -> Either a b
Right Scientific
s
  Value
_ -> forall a b. a -> Either a b
Left Error
"Not a json number"

-- | parse a json string from a 'Json.Value'
jsonString :: FieldParser Json.Value Text
jsonString :: FieldParser Value Text
jsonString = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \case
  Json.String Text
s -> forall a b. b -> Either a b
Right Text
s
  Value
_ -> forall a b. a -> Either a b
Left Error
"Not a json string"

-- * Field parsers

-- | Parse field as 'Text'
utf8 :: FieldParser ByteString Text
utf8 :: FieldParser ByteString Text
utf8 = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \ByteString
bytes -> case ByteString -> Either Error Text
bytesToTextUtf8 ByteString
bytes of
  Left Error
_err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error
"Not a valid UTF-8 string"
  Right Text
a -> forall a b. b -> Either a b
Right Text
a

-- | Assert that the string is not empty
notEmptyStringP :: FieldParser Text Text
notEmptyStringP :: FieldParser Text Text
notEmptyStringP = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \case
  Text
"" -> forall a b. a -> Either a b
Left [fmt|String cannot be empty|]
  Text
t -> forall a b. b -> Either a b
Right Text
t

-- | A decimal number with an optional `+` or `-` sign character.
signedDecimal :: FieldParser Text Integer
signedDecimal :: FieldParser Text Integer
signedDecimal =
  forall a. (Text -> Error) -> Parser a -> FieldParser Text a
attoparsecText
    (\Text
t -> [fmt|Not a signed decimal number: "{t}"|])
    -- the decimal is okay, since Integer has no maximum length
    -- we don’t have to care about memory, since the input text would already not fit into memory
    (forall a. Num a => Parser a -> Parser a
Atto.signed (forall a. Integral a => Parser a
Atto.decimal @Integer))

-- | A decimal natural number; does not allow for a @+@-sign.
decimalNatural :: FieldParser Text Natural
decimalNatural :: FieldParser Text Natural
decimalNatural =
  forall a. (Text -> Error) -> Parser a -> FieldParser Text a
attoparsecText
    (\Text
t -> [fmt|Not a natural number: "{t}"|])
    -- the decimal is okay, since Natural has no maximum length
    -- we don’t have to care about memory, since the input text would already not fit into memory
    (forall a. Integral a => Parser a
Atto.decimal @Integer)
    forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
Cat.>>> forall i. Integral i => FieldParser i Natural
integralToNatural @Integer

-- | A signed, decimal, natural number.
--
-- e.g. @12345@, @0@, or @+12@, but not @-12@.
signedDecimalNatural :: FieldParser Text Natural
signedDecimalNatural :: FieldParser Text Natural
signedDecimalNatural =
  forall a. (Text -> Error) -> Parser a -> FieldParser Text a
attoparsecText
    (\Text
t -> [fmt|Not a signed natural number: "{t}"|])
    -- the decimal is okay, since Natural has no maximum length
    -- we don’t have to care about memory, since the input text would already not fit into memory
    (forall a. Num a => Parser a -> Parser a
Atto.signed (forall a. Integral a => Parser a
Atto.decimal @Integer))
    forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
Cat.>>> forall i. Integral i => FieldParser i Natural
integralToNatural @Integer

-- | Parse any integral into a natural number, fails if the integral is negative.
integralToNatural :: Integral i => FieldParser i Natural
integralToNatural :: forall i. Integral i => FieldParser i Natural
integralToNatural =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser (\i
i -> i
i forall a b. a -> (a -> b) -> b
& forall a. Integral a => a -> Maybe Natural
intToNatural forall a b. a -> (a -> b) -> b
& forall err a. err -> Maybe a -> Either err a
annotate [fmt|Number must be 0 or positive, but was negative: {toInteger i}|])

-- | Parse any integral to an 'Integer'. This can never fail, but is here to mirror 'integralToNatural'.
integralToInteger :: Integral i => FieldParser' err i Integer
integralToInteger :: forall i err. Integral i => FieldParser' err i Integer
integralToInteger = forall (p :: Type -> Type -> Type) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Integer) forall {k} (cat :: k -> k -> Type) (a :: k).
Category cat =>
cat a a
Cat.id

-- | An arbitrary-precision number in scientific notation.
scientific :: FieldParser Text Scientific
scientific :: FieldParser Text Scientific
scientific = forall a. (Text -> Error) -> Parser a -> FieldParser Text a
attoparsecText (\Text
t -> [fmt|Not a scientific number: "{t}"|]) Parser Scientific
Atto.scientific

-- | Parse a scientific into a bounded integral type.
--
-- Scientific can be *very* big, (think @1e10000@) so this function makes sure we
-- * don’t wrap around the bound
-- * don’t fill up all our memory by e.g. parsing into @Integer@ or @Natural@.
--
-- So if you want to go to @Natural@, you have to first set an intermediate type with a bound you want to accept
-- (e.g. 64 bits via @Int@) and then go from that to the unbounded type (e.g. via 'integralToNatural').
--
-- @err@ is added as context around the bounded error.
boundedScientificIntegral :: forall i. (Integral i, Bounded i) => Error -> FieldParser Scientific i
boundedScientificIntegral :: forall i.
(Integral i, Bounded i) =>
Error -> FieldParser Scientific i
boundedScientificIntegral Error
err = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Scientific
s -> case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger Scientific
s of
  Maybe i
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (Error
err forall a b. a -> (a -> b) -> b
& Text -> Error -> Error
errorContext [fmt|Must be between {iMinBound} and {iMaxBound}|])
  Just i
i -> forall a b. b -> Either a b
Right i
i
  where
    iMinBound :: Integer
iMinBound = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound :: i)
    iMaxBound :: Integer
iMaxBound = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: i)

-- | Parse a scientific into a bounded floating point type.
--
-- Scientific can be *very* big, (think @1e10000@) so this function makes sure we
-- * don’t wrap around the bound
-- * don’t fill up all our memory
-- * Fit into the available floating point representation space
boundedScientificRealFloat :: RealFloat d => FieldParser Scientific d
boundedScientificRealFloat :: forall d. RealFloat d => FieldParser Scientific d
boundedScientificRealFloat = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Scientific
s ->
  forall a. RealFloat a => Scientific -> Either a a
Scientific.toBoundedRealFloat Scientific
s
    forall a b. a -> (a -> b) -> b
& forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
      ( \d
zeroOrInf ->
          ( if
                | d
0 forall a. Eq a => a -> a -> Bool
== d
zeroOrInf -> [fmt|Number {show s} is too small to fit into floating point.|]
                | forall a. RealFloat a => a -> Bool
isInfinite d
zeroOrInf -> [fmt|Number {show s} is too big to fit into floating point.|]
                | Bool
otherwise -> [fmt|Number {show s} did not fit into floating point, but we don’t know why (BUG).|]
          )
      )

-- | Parse an integer into a bounded integral type.
--
-- @err@ is added as context around the bounded error.
bounded :: forall i. (Integral i, Bounded i) => Text -> FieldParser Integer i
bounded :: forall i. (Integral i, Bounded i) => Text -> FieldParser Integer i
bounded Text
err = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Integer
num -> case Integer
num forall a b. a -> (a -> b) -> b
& Integer -> Maybe i
fromIntegerBounded of
  Maybe i
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (Text -> Error -> Error
errorContext Text
err [fmt|Must be between {iMinBound} and {iMaxBound}, but was: {num & toInteger}|])
  Just i
i -> forall a b. b -> Either a b
Right i
i
  where
    -- from Scientific.toBoundedInteger
    fromIntegerBounded :: Integer -> Maybe i
    fromIntegerBounded :: Integer -> Maybe i
fromIntegerBounded Integer
i
      | Integer
i forall a. Ord a => a -> a -> Bool
< Integer
iMinBound Bool -> Bool -> Bool
|| Integer
i forall a. Ord a => a -> a -> Bool
> Integer
iMaxBound = forall a. Maybe a
Nothing
      | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
i
    iMinBound :: Integer
iMinBound = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound :: i)
    iMaxBound :: Integer
iMaxBound = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: i)

-- | ex: @2021-02-23@
hyphenatedDay :: FieldParser Text Time.Day
hyphenatedDay :: FieldParser Text Day
hyphenatedDay =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Maybe Day
parseDay Text
t of
      Maybe Day
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [fmt|Not a valid date of format yyyy-mm-dd: "{t}"|]
      Just Day
day -> forall a b. b -> Either a b
Right Day
day
  where
    parseDay :: Text -> Maybe Time.Day
    parseDay :: Text -> Maybe Day
parseDay Text
t =
      Text
t
        forall a b. a -> (a -> b) -> b
& Text -> String
textToString
        forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) t.
(MonadFail m, ISO8601 t) =>
String -> m t
Time.Format.ISO.iso8601ParseM @Maybe @Time.Day

-- | @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
utcTime :: FieldParser Text Time.UTCTime
utcTime :: FieldParser Text UTCTime
utcTime =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Maybe UTCTime
parseTime Text
t of
      Maybe UTCTime
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [fmt|Not a valid date of format `yyyy-mm-ddThh:mm:ss[.sss]Z` (ISO 8601:2004(E) sec. 4.3.2 extended format): "{t}"|]
      Just UTCTime
day -> forall a b. b -> Either a b
Right UTCTime
day
  where
    parseTime :: Text -> Maybe Time.UTCTime
    parseTime :: Text -> Maybe UTCTime
parseTime Text
t =
      Text
t
        forall a b. a -> (a -> b) -> b
& Text -> String
textToString
        forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) t.
(MonadFail m, ISO8601 t) =>
String -> m t
Time.Format.ISO.iso8601ParseM @Maybe @Time.UTCTime

-- | Example of how to create a more “complicated” parser that checks whether a value
-- is between two other values.
clamped ::
  (Ord a, Show a) =>
  -- | lower boundary (inclusive)
  a ->
  -- | upper boundary (exclusive)
  a ->
  FieldParser a a
clamped :: forall a. (Ord a, Show a) => a -> a -> FieldParser a a
clamped a
lower a
upperExcl = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \a
a ->
  if a
a forall a. Ord a => a -> a -> Bool
>= a
lower Bool -> Bool -> Bool
&& a
a forall a. Ord a => a -> a -> Bool
< a
upperExcl
    then forall a b. b -> Either a b
Right a
a
    else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [fmt|Value not between {lower & show} (inclusive) and {upperExcl & show} (exclusive), was: {show a}|]

-- | @oneOf prettyFrom oneOfMap@
--
-- Takes a @oneOf@, which is a list of possibilities that this parser accepts.
-- The comparison is done with '(==)', and then the according 'to' value is returned.
--
-- In case of an error @prettyFrom@ is used to pretty-print the available choices and actual input.
--
-- If you want to match on an 'Enum'-like type,
-- you should probably use 'invertPretty' or 'invertPrettyCaseInsensitive' instead,
-- which allows for exhaustiveness checks.
oneOf :: Ord from => (from -> Text) -> [(from, to)] -> FieldParser from to
oneOf :: forall from to.
Ord from =>
(from -> Text) -> [(from, to)] -> FieldParser from to
oneOf from -> Text
errDisplay [(from, to)]
m =
  -- This doesn’t strictly need an 'Ord' instance, it can also use `findMaybe` with `==` instead of going through a map.
  forall from to.
Ord from =>
(from -> Text) -> Map from to -> FieldParser from to
oneOfMap from -> Text
errDisplay (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(from, to)]
m)

-- | 'oneOf', but takes a map directly.
--
-- | @oneOfMap prettyFrom oneOfMap@
--
-- Takes a @oneOfMap@, which is a map of possibilities that this parser accepts.
--
-- In case of an error @prettyFrom@ is used to pretty-print the available choices and actual input.
oneOfMap :: (Ord from) => (from -> Text) -> Map from to -> FieldParser from to
oneOfMap :: forall from to.
Ord from =>
(from -> Text) -> Map from to -> FieldParser from to
oneOfMap from -> Text
errDisplay Map from to
m = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \from
from ->
  Map from to
m
    forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup from
from
    forall a b. a -> (a -> b) -> b
& \case
      Maybe to
Nothing -> do
        let prettyFrom :: from -> Text
prettyFrom from
f = [fmt|"{f & errDisplay}"|]
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [fmt|Not one of: {m & Map.keys <&> prettyFrom & Text.intercalate ", "}, was {from & prettyFrom}|]
      Just to
to -> forall a b. b -> Either a b
Right to
to

-- | Parse into an enum from a textual description of the fields.
--
-- The given function is inverted with 'inverseMap' and then used as the parsing function.
textEnum :: (Bounded to, Enum to) => (to -> Text) -> FieldParser Text to
textEnum :: forall to.
(Bounded to, Enum to) =>
(to -> Text) -> FieldParser Text to
textEnum to -> Text
displayEnum = forall from to.
Ord from =>
(from -> Text) -> Map from to -> FieldParser from to
oneOfMap forall a. a -> a
id (forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
inverseMap to -> Text
displayEnum)

-- | Try to run the first parser, or if it fails run the second one; return an Either.
either :: FieldParser from to1 -> FieldParser from to2 -> FieldParser' ErrorTree from (Either to1 to2)
either :: forall from to1 to2.
FieldParser from to1
-> FieldParser from to2
-> FieldParser' ErrorTree from (Either to1 to2)
either FieldParser from to1
first' FieldParser from to2
second' =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \from
from -> case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to1
first' from
from of
    Left Error
err -> case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to2
second' from
from of
      Left Error
err2 ->
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error -> NonEmpty Error -> ErrorTree
errorTree Error
"Neither the left nor the right parser succeeded" forall a b. (a -> b) -> a -> b
$ Error
err forall a. a -> [a] -> NonEmpty a
:| [Error
err2]
      Right to2
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right to2
a
    Right to1
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left to1
a

-- | Try to run the first parser, or if it fails run the next one; They have to return the same value.
or :: NonEmpty (FieldParser from to) -> FieldParser' ErrorTree from to
or :: forall from to.
NonEmpty (FieldParser from to) -> FieldParser' ErrorTree from to
or NonEmpty (FieldParser from to)
parsers =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \from
from ->
    NonEmpty (FieldParser from to)
parsers
      forall a b. a -> (a -> b) -> b
& forall (t :: Type -> Type) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty
      forall a b. a -> (a -> b) -> b
& forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
        ( \FieldParser from to
p ->
            forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to
p from
from
              -- we want to shortcut on the first successful parser, using Left
              forall a b. a -> (a -> b) -> b
& forall a b. Either a b -> Either b a
flipEither
        )
      forall a b. a -> (a -> b) -> b
& \case
        Left to
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ to
a
        Right NonEmpty Error
errs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error -> NonEmpty Error -> ErrorTree
errorTree Error
"Neither of these parsers succeeded" NonEmpty Error
errs
  where
    flipEither :: Either a b -> Either b a
    flipEither :: forall a b. Either a b -> Either b a
flipEither (Left a
err) = forall a b. b -> Either a b
Right a
err
    flipEither (Right b
a) = forall a b. a -> Either a b
Left b
a

-- | Parse into Nothing if the Monoid (e.g. Text, Map etc.) was empty
emptyOr :: forall s a. (Eq s, Show s, Monoid s) => FieldParser s a -> FieldParser' Error s (Maybe a)
emptyOr :: forall s a.
(Eq s, Show s, Monoid s) =>
FieldParser s a -> FieldParser' Error s (Maybe a)
emptyOr FieldParser s a
inner =
  forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \s
from ->
    if s
from forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
      then forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
      else case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser s a
inner s
from of
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Error -> Error
errorContext [fmt|Value was neither empty ("{mempty @s & show}") nor|] Error
err
        Right a
a -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just a
a)

-- | Given a pretty printing function, it will create a parser
-- that uses the inverse function to parse the field.
--
-- The pretty printing function must create a different output for different inputs!
-- Otherwise which value is returned is undefined.
invertPretty :: (Bounded to, Enum to) => (to -> Text) -> FieldParser Text to
invertPretty :: forall to.
(Bounded to, Enum to) =>
(to -> Text) -> FieldParser Text to
invertPretty to -> Text
prettyFn = forall from to.
Ord from =>
(from -> Text) -> Map from to -> FieldParser from to
oneOfMap forall a. a -> a
id (forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
inverseMap to -> Text
prettyFn)

-- | Given a pretty printing function, it will create a parser
-- that uses the inverse function to parse the field.
-- The parsed text is compared case-insensitively.
--
-- The pretty printing function must create a different output for different inputs!
-- This also means two outputs should not match if compared case-insensitively.
-- Otherwise which value is returned is undefined.
invertPrettyCaseInsensitive :: (Bounded to, Enum to) => (to -> Text) -> FieldParser Text to
invertPrettyCaseInsensitive :: forall to.
(Bounded to, Enum to) =>
(to -> Text) -> FieldParser Text to
invertPrettyCaseInsensitive to -> Text
prettyFn =
  forall from to.
Ord from =>
(from -> Text) -> Map from to -> FieldParser from to
oneOfMap
    forall s. CI s -> s
CaseInsensitive.original
    (forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
inverseMap (\to
t -> to -> Text
prettyFn to
t forall a b. a -> (a -> b) -> b
& forall s. FoldCase s => s -> CI s
CaseInsensitive.mk))
    forall a b. a -> (a -> b) -> b
& forall (p :: Type -> Type -> Type) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall s. FoldCase s => s -> CI s
CaseInsensitive.mk

-- | 'oneOf' but only one value possible
exactly :: Eq from => (from -> Text) -> from -> FieldParser from from
exactly :: forall from.
Eq from =>
(from -> Text) -> from -> FieldParser from from
exactly from -> Text
errDisplay from
from = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \from
from' ->
  if from
from forall a. Eq a => a -> a -> Bool
== from
from'
    then forall a b. b -> Either a b
Right from
from'
    else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [fmt|Field has to be exactly {errDisplay from}, was: {errDisplay from'}|]

-- | Takes a parser and lifts it to parse every element in a list.
multiple ::
  -- \| @toLevelError@: A descriptive message about the context of how these multiple elements should be parsed
  --
  -- e.g. @"Must be a |-separated list of <foo> (e.g. <foo>|<foo>), but some elements could not be parsed"@.
  -- It is used as the root of the 'ErrorTree'.
  Text ->
  -- | For each sub-parser that failed, @displayValOnErr@ is prefixed to its error.
  -- It receives the index (starting from 1) of the element that failed,
  -- so you can display it in the element’s error message.
  -- You can decide yourself whether you want to print the full value, part of the value, or only the index.
  (Natural -> from -> Text) ->
  -- | Parser for each element
  FieldParser from to ->
  FieldParser' ErrorTree [from] [to]
multiple :: forall from to.
Text
-> (Natural -> from -> Text)
-> FieldParser from to
-> FieldParser' ErrorTree [from] [to]
multiple Text
topLevelErr Natural -> from -> Text
displayValOnErr FieldParser from to
inner = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \[from]
ta ->
  [from]
ta forall a b. a -> (a -> b) -> b
& forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList forall a b. a -> (a -> b) -> b
& forall {b}. [b] -> [(Natural, b)]
indexed forall a b. a -> (a -> b) -> b
& forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Natural, from) -> Validation (NonEmpty Error) to
run forall a b. a -> (a -> b) -> b
& \case
    Success [to]
b -> forall a b. b -> Either a b
Right [to]
b
    Failure NonEmpty Error
errs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error -> NonEmpty Error -> ErrorTree
errorTree (Text -> Error
newError Text
topLevelErr) NonEmpty Error
errs
  where
    indexed :: [b] -> [(Natural, b)]
indexed = forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
1 :: Natural ..]
    run :: (Natural, from) -> Validation (NonEmpty Error) to
run (Natural
index, from
a) = case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to
inner from
a of
      -- TODO: It would probably be nice to display the actual value that could not be parsed here!
      Left Error
err -> forall e a. e -> Validation e a
Failure (forall a. a -> NonEmpty a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Error -> Error
errorContext (Natural -> from -> Text
displayValOnErr Natural
index from
a) Error
err)
      Right to
res -> forall e a. a -> Validation e a
Success to
res

nonEmpty :: err -> FieldParser' err [from] (NonEmpty from)
nonEmpty :: forall err from. err -> FieldParser' err [from] (NonEmpty from)
nonEmpty err
msg = forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \[from]
from -> do
  case [from]
from forall a b. a -> (a -> b) -> b
& forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty of
    Maybe (NonEmpty from)
Nothing -> forall a b. a -> Either a b
Left err
msg
    Just NonEmpty from
ne -> forall a b. b -> Either a b
Right NonEmpty from
ne

-- | Wrap a FieldParser with some descriptions for generating better error messages.
data FieldParserDesc' err from to = FieldParserDesc
  { -- | Symbolic description of a parser, e.g. “hh:mm” for a timestamp
    forall err from to. FieldParserDesc' err from to -> Text
symbolicDesc :: Text,
    -- | Actual parser
    forall err from to.
FieldParserDesc' err from to -> FieldParser' err from to
fieldParser :: FieldParser' err from to
  }

type FieldParserDesc from to = FieldParserDesc' Error from to

-- | Splits the input string into multiple elements based on the given separator string.
--
-- Each element is then passed to the provided @innerParser@.
--
-- This returns a descriptive tree of errors containing the errors of each sub-parser that failed.
separatedBy ::
  -- | Separator
  Text ->
  -- | For each sub-parser that failed, @displayValOnErr@ is prefixed to its error.
  -- It receives the index (starting from 1) of the element that failed,
  -- so you can display it in the element’s error message.
  -- You can decide yourself whether you want to print the full value, part of the value, or only the index.
  (Natural -> Text -> Text) ->
  FieldParserDesc Text to ->
  FieldParser' ErrorTree Text [to]
separatedBy :: forall to.
Text
-> (Natural -> Text -> Text)
-> FieldParserDesc Text to
-> FieldParser' ErrorTree Text [to]
separatedBy Text
separator Natural -> Text -> Text
displayValOnErr FieldParserDesc Text to
innerParser =
  ( forall {k} (cat :: k -> k -> Type) (a :: k).
Category cat =>
cat a a
Cat.id
      forall a b. a -> (a -> b) -> b
& forall (p :: Type -> Type -> Type) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (Text -> Text -> [Text]
Text.splitOn Text
separator)
      forall a b. a -> (a -> b) -> b
& forall (p :: Type -> Type -> Type) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
        ( \case
            -- splitOn for "" results in [""] but we want to accept a empty list
            [Text
""] -> []
            [Text]
xs -> [Text]
xs
        )
      forall a b. a -> (a -> b) -> b
& forall err1 err2 from to.
(err1 -> err2)
-> FieldParser' err1 from to -> FieldParser' err2 from to
mapError Error -> ErrorTree
singleError
  )
    forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
Cat.>>> ( forall from to.
Text
-> (Natural -> from -> Text)
-> FieldParser from to
-> FieldParser' ErrorTree [from] [to]
multiple
                ( let d :: Text
d = FieldParserDesc Text to
innerParser.symbolicDesc
                   in [fmt|Must be a {separator}-separated list of {d} (e.g. "{d}{separator}{d}"), but some elements could not be parsed|]
                )
                Natural -> Text -> Text
displayValOnErr
                FieldParserDesc Text to
innerParser.fieldParser
            )

-- | Ignore whitespace around a text.
--
-- Shows how to use the profunctor instance to do pure transformations (that cannot throw any errors).
--
-- Alternatively this could be implemented in the FieldParser pipeline like
-- @
-- ignore = FieldParser $ \t -> Right (Text.strip t)
-- @
ignoreSurroundingWhitespace :: FieldParser Text a -> FieldParser Text a
ignoreSurroundingWhitespace :: forall a. FieldParser Text a -> FieldParser Text a
ignoreSurroundingWhitespace = forall (p :: Type -> Type -> Type) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap Text -> Text
Text.strip

-- | Given an error message and an attoparsec parser,
-- “clamp” the parser that it expects to match until the end of the string,
-- then run the parser and put the given error message on error.
--
-- This function works on "Data.Attoparsec.Text" parsers.
attoparsecText ::
  -- | Error message to use if the parser fails (the attoparsec message is discarded)
  (Text -> Error) ->
  -- | Parser to use. Should not check for `endOfInput` itself.
  Atto.Parser a ->
  FieldParser Text a
attoparsecText :: forall a. (Text -> Error) -> Parser a -> FieldParser Text a
attoparsecText Text -> Error
err Parser a
parser =
  let parseAll :: Text -> Either String a
parseAll = forall a. Parser a -> Text -> Either String a
Atto.parseOnly (Parser a
parser forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Atto.endOfInput)
   in forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \Text
text -> case Text -> Either String a
parseAll Text
text of
        Left String
_attoErr -> forall a b. a -> Either a b
Left (Text -> Error
err Text
text)
        Right a
a -> forall a b. b -> Either a b
Right a
a

-- | Given an error message and an attoparsec parser,
-- “clamp” the parser that it expects to match until the end of the string,
-- then run the parser and put the given error message on error.
--
-- This function works on "Data.Attoparsec.ByteString" parsers.
attoparsecBytes ::
  -- | Error message to use if the parser fails (the attoparsec message is discarded)
  Error ->
  -- | Parser to use. Should not check for `endOfInput` itself.
  AttoBytes.Parser a ->
  FieldParser ByteString a
attoparsecBytes :: forall a. Error -> Parser a -> FieldParser ByteString a
attoparsecBytes Error
err Parser a
parser =
  let parseAll :: ByteString -> Either String a
parseAll = forall a. Parser a -> ByteString -> Either String a
AttoBytes.parseOnly (Parser a
parser forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
AttoBytes.endOfInput)
   in forall err from to.
(from -> Either err to) -> FieldParser' err from to
FieldParser forall a b. (a -> b) -> a -> b
$ \ByteString
bytes -> case ByteString -> Either String a
parseAll ByteString
bytes of
        Left String
_attoErr -> forall a b. a -> Either a b
Left Error
err
        Right a
a -> forall a b. b -> Either a b
Right a
a

-- | Parse a literal value at compile time. This is used with Template Haskell, like so:
--
-- > $$("2023-07-27" & literal hyphenatedDay) :: Time.Day
--
-- You need the double @$$@!
--
-- ATTN: This needs an instance of the 'TH.Lift' class for the output type.
-- Many library types don’t yet implement this class, so we have to provide the instances ourselves.
-- See NOTE: Lift for library types
literal :: forall from to. TH.Lift to => FieldParser from to -> from -> TH.Code TH.Q to
literal :: forall from to. Lift to => FieldParser from to -> from -> Code Q to
literal FieldParser from to
parser from
s = do
  case forall err from to.
FieldParser' err from to -> from -> Either err to
runFieldParser FieldParser from to
parser from
s of
    Right to
a -> [||a||]
    Left Error
err -> forall a (m :: Type -> Type). m (TExp a) -> Code m a
TH.liftCode (Error
err forall a b. a -> (a -> b) -> b
& Error -> Text
prettyError forall a b. a -> (a -> b) -> b
& Text -> String
textToString forall a b. a -> (a -> b) -> b
& forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail)

{-
NOTE: Lift for library types

Newer versions of Template Haskell provide a `Lift` class,
which lets us parse types from e.g. strings at compile time.

But many types do not implement the stock `Lift` instance yet
(it can be auto-derived by GHC if requested).
-}

deriving stock instance (TH.Lift Fixed.Pico)

deriving stock instance (TH.Lift Time.TimeOfDay)

deriving stock instance (TH.Lift Time.Day)