{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Web.Forma
(
field,
field',
value,
subParser,
withCheck,
runForm,
runFormPure,
unFieldName,
showFieldName,
FormParser,
FormResult (..),
FieldName,
InSet,
)
where
import Control.Applicative
import Control.Monad.Except
import Data.Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
import qualified Data.Aeson.Types as A
import Data.Functor.Identity (Identity (..))
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits
data FormResult (names :: [Symbol]) e a
=
ParsingFailed (Maybe (FieldName names)) Text
|
ValidationFailed (Map (FieldName names) e)
|
Succeeded a
deriving (FormResult names e a -> FormResult names e a -> Bool
(FormResult names e a -> FormResult names e a -> Bool)
-> (FormResult names e a -> FormResult names e a -> Bool)
-> Eq (FormResult names e a)
forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormResult names e a -> FormResult names e a -> Bool
$c/= :: forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
== :: FormResult names e a -> FormResult names e a -> Bool
$c== :: forall (names :: [Symbol]) e a.
(Eq e, Eq a) =>
FormResult names e a -> FormResult names e a -> Bool
Eq, Int -> FormResult names e a -> ShowS
[FormResult names e a] -> ShowS
FormResult names e a -> String
(Int -> FormResult names e a -> ShowS)
-> (FormResult names e a -> String)
-> ([FormResult names e a] -> ShowS)
-> Show (FormResult names e a)
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
Int -> FormResult names e a -> ShowS
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
[FormResult names e a] -> ShowS
forall (names :: [Symbol]) e a.
(Show e, Show a) =>
FormResult names e a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormResult names e a] -> ShowS
$cshowList :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
[FormResult names e a] -> ShowS
show :: FormResult names e a -> String
$cshow :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
FormResult names e a -> String
showsPrec :: Int -> FormResult names e a -> ShowS
$cshowsPrec :: forall (names :: [Symbol]) e a.
(Show e, Show a) =>
Int -> FormResult names e a -> ShowS
Show, a -> FormResult names e b -> FormResult names e a
(a -> b) -> FormResult names e a -> FormResult names e b
(forall a b.
(a -> b) -> FormResult names e a -> FormResult names e b)
-> (forall a b. a -> FormResult names e b -> FormResult names e a)
-> Functor (FormResult names e)
forall (names :: [Symbol]) e a b.
a -> FormResult names e b -> FormResult names e a
forall (names :: [Symbol]) e a b.
(a -> b) -> FormResult names e a -> FormResult names e b
forall a b. a -> FormResult names e b -> FormResult names e a
forall a b.
(a -> b) -> FormResult names e a -> FormResult names e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FormResult names e b -> FormResult names e a
$c<$ :: forall (names :: [Symbol]) e a b.
a -> FormResult names e b -> FormResult names e a
fmap :: (a -> b) -> FormResult names e a -> FormResult names e b
$cfmap :: forall (names :: [Symbol]) e a b.
(a -> b) -> FormResult names e a -> FormResult names e b
Functor)
instance (ToJSON e, ToJSON a) => ToJSON (FormResult names e a) where
toJSON :: FormResult names e a -> Value
toJSON = \case
ParsingFailed Maybe (FieldName names)
path Text
msg ->
Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f ((Maybe (FieldName names), Text)
-> Maybe (Maybe (FieldName names), Text)
forall a. a -> Maybe a
Just (Maybe (FieldName names)
path, Text
msg)) Maybe (Map (FieldName names) e)
forall a. Maybe a
Nothing Maybe a
forall a. Maybe a
Nothing
ValidationFailed Map (FieldName names) e
verr ->
Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
forall a. Maybe a
Nothing (Map (FieldName names) e -> Maybe (Map (FieldName names) e)
forall a. a -> Maybe a
Just Map (FieldName names) e
verr) Maybe a
forall a. Maybe a
Nothing
Succeeded a
x ->
Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
forall a. Maybe a
Nothing Maybe (Map (FieldName names) e)
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
where
f ::
Maybe (Maybe (FieldName names), Text) ->
Maybe (Map (FieldName names) e) ->
Maybe a ->
Value
f :: Maybe (Maybe (FieldName names), Text)
-> Maybe (Map (FieldName names) e) -> Maybe a -> Value
f Maybe (Maybe (FieldName names), Text)
perr Maybe (Map (FieldName names) e)
verr Maybe a
result =
[Pair] -> Value
object
[ Key
"parse_error"
Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= case Maybe (Maybe (FieldName names), Text)
perr of
Maybe (Maybe (FieldName names), Text)
Nothing -> Value
Null
Just (Maybe (FieldName names)
path, Text
msg) ->
[Pair] -> Value
object
[ Key
"field" Key -> Maybe (FieldName names) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (FieldName names)
path,
Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg
],
Key
"field_errors"
Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= let g :: (FieldName names, v) -> kv
g (FieldName names
fieldName, v
err) =
Text -> Key
Aeson.Key.fromText (FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName FieldName names
fieldName) Key -> v -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
err
in Value
-> (Map (FieldName names) e -> Value)
-> Maybe (Map (FieldName names) e)
-> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Object -> Value
Object Object
forall v. KeyMap v
Aeson.KeyMap.empty)
([Pair] -> Value
object ([Pair] -> Value)
-> (Map (FieldName names) e -> [Pair])
-> Map (FieldName names) e
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName names, e) -> Pair) -> [(FieldName names, e)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName names, e) -> Pair
forall kv v (names :: [Symbol]).
(KeyValue kv, ToJSON v) =>
(FieldName names, v) -> kv
g ([(FieldName names, e)] -> [Pair])
-> (Map (FieldName names) e -> [(FieldName names, e)])
-> Map (FieldName names) e
-> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (FieldName names) e -> [(FieldName names, e)]
forall k a. Map k a -> [(k, a)]
M.toAscList)
Maybe (Map (FieldName names) e)
verr,
Key
"result" Key -> Maybe a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe a
result
]
instance Applicative (FormResult names e) where
pure :: a -> FormResult names e a
pure = a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded
(ParsingFailed Maybe (FieldName names)
l Text
msg) <*> :: FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b
<*> FormResult names e a
_ = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
(ValidationFailed Map (FieldName names) e
_) <*> (ParsingFailed Maybe (FieldName names)
l Text
msg) = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
(ValidationFailed Map (FieldName names) e
e0) <*> (ValidationFailed Map (FieldName names) e
e1) = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed (Map (FieldName names) e
e0 Map (FieldName names) e
-> Map (FieldName names) e -> Map (FieldName names) e
forall a. Semigroup a => a -> a -> a
<> Map (FieldName names) e
e1)
(ValidationFailed Map (FieldName names) e
e) <*> Succeeded a
_ = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e
Succeeded a -> b
_ <*> (ParsingFailed Maybe (FieldName names)
l Text
msg) = Maybe (FieldName names) -> Text -> FormResult names e b
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
l Text
msg
Succeeded a -> b
_ <*> (ValidationFailed Map (FieldName names) e
e) = Map (FieldName names) e -> FormResult names e b
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e
Succeeded a -> b
f <*> Succeeded a
x = b -> FormResult names e b
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded (a -> b
f a
x)
newtype FormParser (names :: [Symbol]) e m a = FormParser
{ FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
unFormParser ::
Value ->
Maybe (FieldName names) ->
m (FormResult names e a)
}
instance Functor m => Functor (FormParser names e m) where
fmap :: (a -> b) -> FormParser names e m a -> FormParser names e m b
fmap a -> b
f (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) = (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
(FormResult names e a -> FormResult names e b)
-> m (FormResult names e a) -> m (FormResult names e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> FormResult names e a -> FormResult names e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path)
instance Applicative m => Applicative (FormParser names e m) where
pure :: a -> FormParser names e m a
pure a
x = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
_ Maybe (FieldName names)
_ ->
FormResult names e a -> m (FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
x)
(FormParser Value -> Maybe (FieldName names) -> m (FormResult names e (a -> b))
f) <*> :: FormParser names e m (a -> b)
-> FormParser names e m a -> FormParser names e m b
<*> (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) = (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e b))
-> FormParser names e m b
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
(FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b)
-> m (FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) m (FormResult names e (a -> b)
-> FormResult names e a -> FormResult names e b)
-> m (FormResult names e (a -> b))
-> m (FormResult names e a -> FormResult names e b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e (a -> b))
f Value
v Maybe (FieldName names)
path m (FormResult names e a -> FormResult names e b)
-> m (FormResult names e a) -> m (FormResult names e b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path
instance Applicative m => Alternative (FormParser names e m) where
empty :: FormParser names e m a
empty = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
_ Maybe (FieldName names)
_ ->
FormResult names e a -> m (FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
forall a. Maybe a
Nothing Text
"empty")
(FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
x) <|> :: FormParser names e m a
-> FormParser names e m a -> FormParser names e m a
<|> (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
y) = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
let g :: FormResult names e a
-> FormResult names e a -> FormResult names e a
g FormResult names e a
x' FormResult names e a
y' =
case FormResult names e a
x' of
ParsingFailed Maybe (FieldName names)
_ Text
_ -> FormResult names e a
y'
ValidationFailed Map (FieldName names) e
_ -> FormResult names e a
x'
Succeeded a
_ -> FormResult names e a
x'
in (FormResult names e a
-> FormResult names e a -> FormResult names e a)
-> m (FormResult names e a
-> FormResult names e a -> FormResult names e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FormResult names e a
-> FormResult names e a -> FormResult names e a
forall (names :: [Symbol]) e a.
FormResult names e a
-> FormResult names e a -> FormResult names e a
g m (FormResult names e a
-> FormResult names e a -> FormResult names e a)
-> m (FormResult names e a)
-> m (FormResult names e a -> FormResult names e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
x Value
v Maybe (FieldName names)
path m (FormResult names e a -> FormResult names e a)
-> m (FormResult names e a) -> m (FormResult names e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe (FieldName names) -> m (FormResult names e a)
y Value
v Maybe (FieldName names)
path
newtype FieldName (names :: [Symbol])
= FieldName (NonEmpty Text)
deriving (FieldName names -> FieldName names -> Bool
(FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> Eq (FieldName names)
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldName names -> FieldName names -> Bool
$c/= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
== :: FieldName names -> FieldName names -> Bool
$c== :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
Eq, Eq (FieldName names)
Eq (FieldName names)
-> (FieldName names -> FieldName names -> Ordering)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> Bool)
-> (FieldName names -> FieldName names -> FieldName names)
-> (FieldName names -> FieldName names -> FieldName names)
-> Ord (FieldName names)
FieldName names -> FieldName names -> Bool
FieldName names -> FieldName names -> Ordering
FieldName names -> FieldName names -> FieldName names
forall (names :: [Symbol]). Eq (FieldName names)
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
forall (names :: [Symbol]).
FieldName names -> FieldName names -> Ordering
forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FieldName names -> FieldName names -> FieldName names
$cmin :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
max :: FieldName names -> FieldName names -> FieldName names
$cmax :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> FieldName names
>= :: FieldName names -> FieldName names -> Bool
$c>= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
> :: FieldName names -> FieldName names -> Bool
$c> :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
<= :: FieldName names -> FieldName names -> Bool
$c<= :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
< :: FieldName names -> FieldName names -> Bool
$c< :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Bool
compare :: FieldName names -> FieldName names -> Ordering
$ccompare :: forall (names :: [Symbol]).
FieldName names -> FieldName names -> Ordering
$cp1Ord :: forall (names :: [Symbol]). Eq (FieldName names)
Ord, Int -> FieldName names -> ShowS
[FieldName names] -> ShowS
FieldName names -> String
(Int -> FieldName names -> ShowS)
-> (FieldName names -> String)
-> ([FieldName names] -> ShowS)
-> Show (FieldName names)
forall (names :: [Symbol]). Int -> FieldName names -> ShowS
forall (names :: [Symbol]). [FieldName names] -> ShowS
forall (names :: [Symbol]). FieldName names -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldName names] -> ShowS
$cshowList :: forall (names :: [Symbol]). [FieldName names] -> ShowS
show :: FieldName names -> String
$cshow :: forall (names :: [Symbol]). FieldName names -> String
showsPrec :: Int -> FieldName names -> ShowS
$cshowsPrec :: forall (names :: [Symbol]). Int -> FieldName names -> ShowS
Show)
instance
(KnownSymbol name, InSet name names) =>
IsLabel (name :: Symbol) (FieldName names)
where
fromLabel :: FieldName names
fromLabel =
(NonEmpty Text -> FieldName names
forall (names :: [Symbol]). NonEmpty Text -> FieldName names
FieldName (NonEmpty Text -> FieldName names)
-> (Proxy name -> NonEmpty Text) -> Proxy name -> FieldName names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NonEmpty Text
forall a. a -> NonEmpty a
nes (Text -> NonEmpty Text)
-> (Proxy name -> Text) -> Proxy name -> NonEmpty Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Proxy name -> String) -> Proxy name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal) (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)
where
nes :: a -> NonEmpty a
nes a
x = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []
instance Semigroup (FieldName names) where
FieldName NonEmpty Text
x <> :: FieldName names -> FieldName names -> FieldName names
<> FieldName NonEmpty Text
y = NonEmpty Text -> FieldName names
forall (names :: [Symbol]). NonEmpty Text -> FieldName names
FieldName (NonEmpty Text
x NonEmpty Text -> NonEmpty Text -> NonEmpty Text
forall a. Semigroup a => a -> a -> a
<> NonEmpty Text
y)
instance ToJSON (FieldName names) where
toJSON :: FieldName names -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value)
-> (FieldName names -> Text) -> FieldName names -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName
unFieldName :: FieldName names -> NonEmpty Text
unFieldName :: FieldName names -> NonEmpty Text
unFieldName (FieldName NonEmpty Text
path) = NonEmpty Text
path
showFieldName :: FieldName names -> Text
showFieldName :: FieldName names -> Text
showFieldName = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text)
-> (FieldName names -> [Text]) -> FieldName names -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Text -> [Text])
-> (FieldName names -> NonEmpty Text) -> FieldName names -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName names -> NonEmpty Text
forall (names :: [Symbol]). FieldName names -> NonEmpty Text
unFieldName
type family InSet (n :: Symbol) (ns :: [Symbol]) :: Constraint where
InSet n '[] =
TypeError
( 'Text "The name " ':<>: 'ShowType n ':<>: 'Text " is not in the given set."
':$$: 'Text "Either it's a typo or you need to add it to the set first."
)
InSet n (n : ns) = ()
InSet n (m : ns) = InSet n ns
field ::
forall (names :: [Symbol]) e m a s.
(Monad m, FromJSON s) =>
FieldName names ->
(s -> ExceptT e m a) ->
FormParser names e m a
field :: FieldName names -> (s -> ExceptT e m a) -> FormParser names e m a
field FieldName names
fieldName s -> ExceptT e m a
check = FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a s.
Monad m =>
FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
withCheck FieldName names
fieldName s -> ExceptT e m a
check (FieldName names -> FormParser names e m s
forall (names :: [Symbol]) e (m :: * -> *) a.
(Monad m, FromJSON a) =>
FieldName names -> FormParser names e m a
field' FieldName names
fieldName)
field' ::
forall (names :: [Symbol]) e m a.
(Monad m, FromJSON a) =>
FieldName names ->
FormParser names e m a
field' :: FieldName names -> FormParser names e m a
field' FieldName names
fieldName = FieldName names -> FormParser names e m a -> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
Monad m =>
FieldName names -> FormParser names e m a -> FormParser names e m a
subParser FieldName names
fieldName FormParser names e m a
forall (m :: * -> *) a (names :: [Symbol]) e.
(Monad m, FromJSON a) =>
FormParser names e m a
value
value :: (Monad m, FromJSON a) => FormParser names e m a
value :: FormParser names e m a
value = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path ->
case (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v of
Left String
msg ->
FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult names e a -> m (FormResult names e a))
-> FormResult names e a -> m (FormResult names e a)
forall a b. (a -> b) -> a -> b
$
Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path (String -> Text
fixupAesonError String
msg)
Right a
x -> FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
x)
subParser ::
forall (names :: [Symbol]) e m a.
Monad m =>
FieldName names ->
FormParser names e m a ->
FormParser names e m a
subParser :: FieldName names -> FormParser names e m a -> FormParser names e m a
subParser FieldName names
fieldName FormParser names e m a
p = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path -> do
let f :: Value -> Parser Value
f =
String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
String
"form field"
(Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Text -> Key
Aeson.Key.fromText (FieldName names -> Text
forall (names :: [Symbol]). FieldName names -> Text
showFieldName FieldName names
fieldName))
path' :: Maybe (FieldName names)
path' = Maybe (FieldName names)
path Maybe (FieldName names)
-> Maybe (FieldName names) -> Maybe (FieldName names)
forall a. Semigroup a => a -> a -> a
<> FieldName names -> Maybe (FieldName names)
forall a. a -> Maybe a
Just FieldName names
fieldName
case (Value -> Parser Value) -> Value -> Either String Value
forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither Value -> Parser Value
f Value
v of
Left String
msg -> do
let msg' :: Text
msg' = String -> Text
fixupAesonError String
msg
FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path' Text
msg')
Right Value
v' ->
FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
forall (names :: [Symbol]) e (m :: * -> *) a.
FormParser names e m a
-> Value -> Maybe (FieldName names) -> m (FormResult names e a)
unFormParser FormParser names e m a
p Value
v' Maybe (FieldName names)
path'
withCheck ::
forall (names :: [Symbol]) e m a s.
Monad m =>
FieldName names ->
(s -> ExceptT e m a) ->
FormParser names e m s ->
FormParser names e m a
withCheck :: FieldName names
-> (s -> ExceptT e m a)
-> FormParser names e m s
-> FormParser names e m a
withCheck FieldName names
fieldName s -> ExceptT e m a
check (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e s)
f) = (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall (names :: [Symbol]) e (m :: * -> *) a.
(Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
FormParser ((Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a)
-> (Value -> Maybe (FieldName names) -> m (FormResult names e a))
-> FormParser names e m a
forall a b. (a -> b) -> a -> b
$ \Value
v Maybe (FieldName names)
path -> do
FormResult names e s
r <- Value -> Maybe (FieldName names) -> m (FormResult names e s)
f Value
v Maybe (FieldName names)
path
case FormResult names e s
r of
Succeeded s
x -> do
Either e a
res <- ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (s -> ExceptT e m a
check s
x)
FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormResult names e a -> m (FormResult names e a))
-> FormResult names e a -> m (FormResult names e a)
forall a b. (a -> b) -> a -> b
$ case Either e a
res of
Left e
verr -> do
let path' :: Maybe (FieldName names)
path' = Maybe (FieldName names)
path Maybe (FieldName names)
-> Maybe (FieldName names) -> Maybe (FieldName names)
forall a. Semigroup a => a -> a -> a
<> FieldName names -> Maybe (FieldName names)
forall a. a -> Maybe a
Just FieldName names
fieldName
Map (FieldName names) e -> FormResult names e a
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed (FieldName names -> e -> Map (FieldName names) e
forall k a. k -> a -> Map k a
M.singleton (FieldName names -> Maybe (FieldName names) -> FieldName names
forall a. a -> Maybe a -> a
fromMaybe FieldName names
fieldName Maybe (FieldName names)
path') e
verr)
Right a
y ->
a -> FormResult names e a
forall (names :: [Symbol]) e a. a -> FormResult names e a
Succeeded a
y
ValidationFailed Map (FieldName names) e
e ->
FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (FieldName names) e -> FormResult names e a
forall (names :: [Symbol]) e a.
Map (FieldName names) e -> FormResult names e a
ValidationFailed Map (FieldName names) e
e)
ParsingFailed Maybe (FieldName names)
path' Text
msg ->
FormResult names e a -> m (FormResult names e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FieldName names) -> Text -> FormResult names e a
forall (names :: [Symbol]) e a.
Maybe (FieldName names) -> Text -> FormResult names e a
ParsingFailed Maybe (FieldName names)
path' Text
msg)
runForm ::
Monad m =>
FormParser names e m a ->
Value ->
m (FormResult names e a)
runForm :: FormParser names e m a -> Value -> m (FormResult names e a)
runForm (FormParser Value -> Maybe (FieldName names) -> m (FormResult names e a)
p) Value
v = Value -> Maybe (FieldName names) -> m (FormResult names e a)
p Value
v Maybe (FieldName names)
forall a. Maybe a
Nothing
runFormPure ::
FormParser names e Identity a ->
Value ->
FormResult names e a
runFormPure :: FormParser names e Identity a -> Value -> FormResult names e a
runFormPure FormParser names e Identity a
p Value
v = Identity (FormResult names e a) -> FormResult names e a
forall a. Identity a -> a
runIdentity (FormParser names e Identity a
-> Value -> Identity (FormResult names e a)
forall (m :: * -> *) (names :: [Symbol]) e a.
Monad m =>
FormParser names e m a -> Value -> m (FormResult names e a)
runForm FormParser names e Identity a
p Value
v)
fixupAesonError :: String -> Text
fixupAesonError :: String -> Text
fixupAesonError String
msg = String -> Text
T.pack (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
msg))