diff --git a/compose.yml b/compose.yml index 4906787..0a05210 100644 --- a/compose.yml +++ b/compose.yml @@ -1,6 +1,6 @@ services: dev: - image: ghcr.io/flipstone/haskell-tools:debian-unstable-ghc-9.4.5-2023-07-17-f86296e + image: ghcr.io/flipstone/haskell-tools:debian-unstable-ghc-9.4.5-2023-07-18-1d8bf61 environment: STACK_ROOT: /stack-root IN_DEV_CONTAINER: 'true' diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..e31b827 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,14 @@ +indentation: 2 +function-arrows: trailing +comma-style: leading # default +import-export-style: leading +indent-wheres: false # default +record-brace-space: true +newlines-between-decls: 1 # default +haddock-style: multi-line # default +haddock-style-module: # default +let-style: newline +in-style: left-align +unicode: never # default +respectful: true # default +single-constraint-parens: never diff --git a/src/Data/Validation.hs b/src/Data/Validation.hs index 3bc8fd4..32a4ea3 100644 --- a/src/Data/Validation.hs +++ b/src/Data/Validation.hs @@ -1,9 +1,9 @@ -module Data.Validation ( - module Data.Validation.Aeson, - module Data.Validation.Primitives, - module Data.Validation.Types, - module Data.Validation.XML, -) where +module Data.Validation + ( module Data.Validation.Aeson + , module Data.Validation.Primitives + , module Data.Validation.Types + , module Data.Validation.XML + ) where import Data.Validation.Aeson import Data.Validation.Primitives diff --git a/src/Data/Validation/Aeson.hs b/src/Data/Validation/Aeson.hs index 887c362..2b5dc2d 100644 --- a/src/Data/Validation/Aeson.hs +++ b/src/Data/Validation/Aeson.hs @@ -16,65 +16,65 @@ import Data.Validation.Types decodeValidJSON :: Validator Value a -> LazyBS.ByteString -> ValidationResult a decodeValidJSON validator input = - runIdentity (decodeValidJSONT (liftV validator) input) + runIdentity (decodeValidJSONT (liftV validator) input) decodeValidJSONStrict :: Validator Value a -> BS.ByteString -> ValidationResult a decodeValidJSONStrict validator input = - runIdentity (decodeValidJSONStrictT (liftV validator) input) + runIdentity (decodeValidJSONStrictT (liftV validator) input) decodeValidJSONT :: - (Applicative m) => - ValidatorT Value m a -> - LazyBS.ByteString -> - m (ValidationResult a) + Applicative m => + ValidatorT Value m a -> + LazyBS.ByteString -> + m (ValidationResult a) decodeValidJSONT validator input = - case eitherDecode input of - Left err -> pure $ Invalid (errMessage $ Text.pack err) - Right value -> runValidatorT validator (value :: Value) + case eitherDecode input of + Left err -> pure $ Invalid (errMessage $ Text.pack err) + Right value -> runValidatorT validator (value :: Value) decodeValidJSONStrictT :: - (Applicative m) => - ValidatorT Value m a -> - BS.ByteString -> - m (ValidationResult a) + Applicative m => + ValidatorT Value m a -> + BS.ByteString -> + m (ValidationResult a) decodeValidJSONStrictT validator input = - case eitherDecodeStrict input of - Left err -> pure $ Invalid (errMessage $ Text.pack err) - Right value -> runValidatorT validator (value :: Value) + case eitherDecodeStrict input of + Left err -> pure $ Invalid (errMessage $ Text.pack err) + Right value -> runValidatorT validator (value :: Value) instance Validatable Value where - inputText (String text) = Just text - inputText _ = Nothing + inputText (String text) = Just text + inputText _ = Nothing - inputNull Null = IsNull - inputNull _ = NotNull + inputNull Null = IsNull + inputNull _ = NotNull - inputBool (Bool True) = Just True - inputBool (Bool False) = Just False - inputBool _ = Nothing + inputBool (Bool True) = Just True + inputBool (Bool False) = Just False + inputBool _ = Nothing - arrayItems (Array items) = Just items - arrayItems _ = Nothing + arrayItems (Array items) = Just items + arrayItems _ = Nothing - scientificNumber (Number sci) = Just sci - scientificNumber _ = Nothing + scientificNumber (Number sci) = Just sci + scientificNumber _ = Nothing - lookupChild attrName (Object hmap) = - LookupResult $ - KeyMap.lookup (Key.fromText attrName) hmap - lookupChild _ _ = InvalidLookup + lookupChild attrName (Object hmap) = + LookupResult $ + KeyMap.lookup (Key.fromText attrName) hmap + lookupChild _ _ = InvalidLookup instance ToJSON Errors where - toJSON (Messages set) = - Array - . Vec.fromList - . map toJSON - . Set.toList - $ set - toJSON (Group attrs) = - Object - . KeyMap.fromList - . Map.toList - . Map.mapKeys Key.fromText - . Map.map toJSON - $ attrs + toJSON (Messages set) = + Array + . Vec.fromList + . map toJSON + . Set.toList + $ set + toJSON (Group attrs) = + Object + . KeyMap.fromList + . Map.toList + . Map.mapKeys Key.fromText + . Map.map toJSON + $ attrs diff --git a/src/Data/Validation/Primitives.hs b/src/Data/Validation/Primitives.hs index 8c90f02..d41c1b9 100644 --- a/src/Data/Validation/Primitives.hs +++ b/src/Data/Validation/Primitives.hs @@ -21,148 +21,150 @@ import Data.Validation.Types liftResult :: ValidationResult a -> Validator input a liftResult result = Validator (const result) -validRead :: (Validatable input) => String -> ReadS a -> Validator input a +validRead :: Validatable input => String -> ReadS a -> Validator input a validRead err reader = do - text <- string + text <- string - case reader (Text.unpack text) of - [(value, "")] -> pure value - _ -> fail err + case reader (Text.unpack text) of + [(value, "")] -> pure value + _ -> fail err -bool :: (Validatable input) => Validator input Bool +bool :: Validatable input => Validator input Bool bool = - Validator $ \input -> - case inputBool input of - Just True -> Valid True - Just False -> Valid False - _ -> Invalid (errMessage "must_be_bool") + Validator $ \input -> + case inputBool input of + Just True -> Valid True + Just False -> Valid False + _ -> Invalid (errMessage "must_be_bool") -string :: (Validatable input) => Validator input Text.Text +string :: Validatable input => Validator input Text.Text string = - Validator $ \input -> - case inputText input of - Just t -> Valid (Text.strip t) - _ -> Invalid (errMessage "must_be_string") + Validator $ \input -> + case inputText input of + Just t -> Valid (Text.strip t) + _ -> Invalid (errMessage "must_be_string") notBlank :: Validator input Text.Text -> Validator input Text.Text notBlank validator = - Validator $ \value -> - case run validator value of - Valid t | Text.all isSpace t -> Invalid (errMessage "must_not_be_blank") - result -> result + Validator $ \value -> + case run validator value of + Valid t | Text.all isSpace t -> Invalid (errMessage "must_not_be_blank") + result -> result atMost :: Int -> Validator input Text.Text -> Validator input Text.Text atMost len validator = - Validator $ \value -> - case run validator value of - Valid t | Text.length t > len -> Invalid (errMessage $ Text.pack ("max_length_" ++ show len)) - result -> result + Validator $ \value -> + case run validator value of + Valid t | Text.length t > len -> Invalid (errMessage $ Text.pack ("max_length_" ++ show len)) + result -> result atLeast :: Int -> Validator input Text.Text -> Validator input Text.Text atLeast len validator = - Validator $ \value -> - case run validator value of - Valid t | Text.length t < len -> Invalid (errMessage $ Text.pack ("min_length_" ++ show len)) - result -> result + Validator $ \value -> + case run validator value of + Valid t | Text.length t < len -> Invalid (errMessage $ Text.pack ("min_length_" ++ show len)) + result -> result exactly :: Int -> Validator input Text.Text -> Validator input Text.Text exactly len validator = - Validator $ \value -> - case run validator value of - Valid t | Text.length t /= len -> Invalid (errMessage $ Text.pack ("must_be_length_" ++ show len)) - result -> result + Validator $ \value -> + case run validator value of + Valid t | Text.length t /= len -> Invalid (errMessage $ Text.pack ("must_be_length_" ++ show len)) + result -> result -numeric :: (Validatable input) => Validator input Scientific +numeric :: Validatable input => Validator input Scientific numeric = Validator $ \input -> - case scientificNumber input of - Just n -> Valid n - _ -> Invalid (errMessage "must_be_numeric") + case scientificNumber input of + Just n -> Valid n + _ -> Invalid (errMessage "must_be_numeric") integer :: (Validatable input, Integral i, Bounded i) => Validator input i integer = do - number <- numeric - case toBoundedInteger number of - Just int -> return int - _ -> fail "must_be_integer" + number <- numeric + case toBoundedInteger number of + Just int -> return int + _ -> fail "must_be_integer" -double :: (Validatable input) => Validator input Double +double :: Validatable input => Validator input Double double = fromRational . toRational <$> numeric nonEmpty :: Validator input [a] -> Validator input [a] nonEmpty validator = - Validator $ \input -> - case (run validator input) of - Valid [] -> Invalid (errMessage $ Text.pack ("must_have_at_least_one_in_list")) - result -> result + Validator $ \input -> + case (run validator input) of + Valid [] -> Invalid (errMessage $ Text.pack ("must_have_at_least_one_in_list")) + result -> result foldableOf :: - (Validatable input, Applicative f, Monoid (f a)) => - Validator input a -> - Validator input (f a) + (Validatable input, Applicative f, Monoid (f a)) => + Validator input a -> + Validator input (f a) foldableOf validator = - Validator $ \input -> - case arrayItems input of - Just items -> - let itemValidator = runIndexed (pure <$> validator) - in fold (Vec.imap itemValidator items) - _ -> Invalid (errMessage "must_be_array") - -arrayOf :: (Validatable input) => Validator input a -> Validator input [a] + Validator $ \input -> + case arrayItems input of + Just items -> + let + itemValidator = runIndexed (pure <$> validator) + in + fold (Vec.imap itemValidator items) + _ -> Invalid (errMessage "must_be_array") + +arrayOf :: Validatable input => Validator input a -> Validator input [a] arrayOf = foldableOf -nonEmptyOf :: (Validatable input) => Validator input a -> Validator input (NonEmpty.NonEmpty a) +nonEmptyOf :: Validatable input => Validator input a -> Validator input (NonEmpty.NonEmpty a) nonEmptyOf validator = - NonEmpty.fromList <$> nonEmpty (arrayOf validator) + NonEmpty.fromList <$> nonEmpty (arrayOf validator) setIgnoringDuplicatesOf :: - (Validatable input, Ord a) => - Validator input a -> - Validator input (Set.Set a) + (Validatable input, Ord a) => + Validator input a -> + Validator input (Set.Set a) setIgnoringDuplicatesOf validator = - Set.fromList <$> arrayOf validator + Set.fromList <$> arrayOf validator {- | Returns Invalid if the input contains the same element more than once. | WARNING: Does not report duplicate elements if validator does not | pass on every element. -} setRejectingDuplicatesOf :: - forall a input. - (Validatable input, Ord a, Show a) => - Validator input a -> - Validator input (Set.Set a) + forall a input. + (Validatable input, Ord a, Show a) => + Validator input a -> + Validator input (Set.Set a) setRejectingDuplicatesOf validator = do - list <- arrayOf validator - let - withOnes = [(c :: a, 1) | c <- list] - valueToFreq = Map.fromListWith (+) withOnes + list <- arrayOf validator + let + withOnes = [(c :: a, 1) | c <- list] + valueToFreq = Map.fromListWith (+) withOnes - sortBySndDescending = map (fmap (\(Down x) -> x)) . sortOn snd . map (fmap Down) + sortBySndDescending = map (fmap (\(Down x) -> x)) . sortOn snd . map (fmap Down) - sortedByFreq :: [(a, Int)] - sortedByFreq = sortBySndDescending $ Map.toList valueToFreq + sortedByFreq :: [(a, Int)] + sortedByFreq = sortBySndDescending $ Map.toList valueToFreq - duplicates :: [(a, Int)] - duplicates = takeWhile ((> 1) . snd) sortedByFreq + duplicates :: [(a, Int)] + duplicates = takeWhile ((> 1) . snd) sortedByFreq - errs :: [Text.Text] - errs = map makeSetErr duplicates + errs :: [Text.Text] + errs = map makeSetErr duplicates - if length errs /= 0 - then Validator $ \_ -> Invalid $ Messages $ Set.fromList errs - else pure $ Set.fromList list + if length errs /= 0 + then Validator $ \_ -> Invalid $ Messages $ Set.fromList errs + else pure $ Set.fromList list -makeSetErr :: (Show a) => (a, Int) -> Text.Text +makeSetErr :: Show a => (a, Int) -> Text.Text makeSetErr (value, occurrances) = - Text.pack $ "duplicate_element_in_array_validated_as_set: " ++ show value ++ " occurs " ++ show occurrances ++ " times" + Text.pack $ "duplicate_element_in_array_validated_as_set: " ++ show value ++ " occurs " ++ show occurrances ++ " times" ifInvalid :: - Validator input a -> - Validator input b -> - Validator input (Either a b) + Validator input a -> + Validator input b -> + Validator input (Either a b) ifInvalid validA validB = Validator $ \input -> - case run validA input of - Valid a -> Valid (Left a) - Invalid _ -> Right <$> run validB input + case run validA input of + Valid a -> Valid (Left a) + Invalid _ -> Right <$> run validB input firstValid :: Validator input a -> Validator input a -> Validator input a firstValid v1 v2 = either id id <$> ifInvalid v1 v2 @@ -170,19 +172,19 @@ firstValid v1 v2 = either id id <$> ifInvalid v1 v2 foldUntilValid :: NE.NonEmpty (Validator input a) -> Validator input a foldUntilValid = foldl1 firstValid -validConversion :: (Convertible a b) => Validator input a -> Validator input b +validConversion :: Convertible a b => Validator input a -> Validator input b validConversion validator = do - a <- validator + a <- validator - case safeConvert a of - Right b -> pure b - Left err -> fail (convErrorMessage err) + case safeConvert a of + Right b -> pure b + Left err -> fail (convErrorMessage err) runIndexed :: - Validator input a -> - Int -> - input -> - ValidationResult a + Validator input a -> + Int -> + input -> + ValidationResult a runIndexed validator idx = run (nestIndex idx validator) nestIndex :: Int -> Validator input a -> Validator input a @@ -191,64 +193,64 @@ nestIndex = nest . Text.pack . show nest :: Text.Text -> Validator input a -> Validator input a nest attr validator = mapErrors (nestErrors attr) `mapResult` validator -mustBeNull :: (Validatable input) => Validator input () +mustBeNull :: Validatable input => Validator input () mustBeNull = Validator $ \input -> - case inputNull input of - IsNull -> Valid () - NotNull -> Invalid (errMessage "must_be_null") - InvalidNull text -> Invalid (errMessage text) + case inputNull input of + IsNull -> Valid () + NotNull -> Invalid (errMessage "must_be_null") + InvalidNull text -> Invalid (errMessage text) -canBeNull :: (Validatable input) => Validator input () +canBeNull :: Validatable input => Validator input () canBeNull = Validator $ \input -> - case inputNull input of - IsNull -> Valid () - NotNull -> Valid () - InvalidNull text -> Invalid (errMessage text) + case inputNull input of + IsNull -> Valid () + NotNull -> Valid () + InvalidNull text -> Invalid (errMessage text) -nullable' :: (Validatable input) => Validator input a -> Validator input (Maybe a) +nullable' :: Validatable input => Validator input a -> Validator input (Maybe a) nullable' validator = - either (const Nothing) Just - <$> (mustBeNull `ifInvalid` validator) + either (const Nothing) Just + <$> (mustBeNull `ifInvalid` validator) -nullable :: (Validatable input) => Validator input a -> Validator input (Maybe a) +nullable :: Validatable input => Validator input a -> Validator input (Maybe a) nullable validator = Validator $ \input -> - case run canBeNull input of - Valid _ -> run (nullable' validator) input - Invalid err -> Invalid err + case run canBeNull input of + Valid _ -> run (nullable' validator) input + Invalid err -> Invalid err -required :: (Validatable input) => Text.Text -> Validator input a -> Validator input a +required :: Validatable input => Text.Text -> Validator input a -> Validator input a attrName `required` validator = validateAttr attrName req - where - req (Just subvalue) = run validator subvalue - req Nothing = Invalid (errMessage "must_be_present") + where + req (Just subvalue) = run validator subvalue + req Nothing = Invalid (errMessage "must_be_present") -optional :: (Validatable input) => Text.Text -> Validator input a -> Validator input (Maybe a) +optional :: Validatable input => Text.Text -> Validator input a -> Validator input (Maybe a) attrName `optional` validator = validateAttr attrName opt - where - opt (Just value) = Just <$> run validator value - opt Nothing = Valid Nothing + where + opt (Just value) = Just <$> run validator value + opt Nothing = Valid Nothing -optionalAndNullable :: (Validatable input) => Text.Text -> Validator input a -> Validator input (Maybe a) +optionalAndNullable :: Validatable input => Text.Text -> Validator input a -> Validator input (Maybe a) attrName `optionalAndNullable` validator = join <$> attrName `optional` nullable validator infixr 5 `required` infixr 5 `optional` -notPresent :: (Validatable input) => Text.Text -> Validator input () +notPresent :: Validatable input => Text.Text -> Validator input () notPresent attr = validateAttr attr $ isNotPresent - where - isNotPresent (Just _) = Invalid (errMessage "must_not_be_present") - isNotPresent Nothing = Valid () + where + isNotPresent (Just _) = Invalid (errMessage "must_not_be_present") + isNotPresent Nothing = Valid () validateAttr :: - (Validatable input) => - Text.Text -> - (Maybe input -> ValidationResult a) -> - Validator input a + Validatable input => + Text.Text -> + (Maybe input -> ValidationResult a) -> + Validator input a validateAttr attrName f = - Validator $ \input -> - case lookupChild attrName input of - LookupResult result -> - mapErrors (nestErrors attrName) (f result) - InvalidLookup -> - Invalid (errMessage "must_be_object") + Validator $ \input -> + case lookupChild attrName input of + LookupResult result -> + mapErrors (nestErrors attrName) (f result) + InvalidLookup -> + Invalid (errMessage "must_be_object") diff --git a/src/Data/Validation/Types.hs b/src/Data/Validation/Types.hs index 1bcec7d..2d4c769 100644 --- a/src/Data/Validation/Types.hs +++ b/src/Data/Validation/Types.hs @@ -1,7 +1,7 @@ -module Data.Validation.Types ( - module Data.Validation.Types.Pure, - module Data.Validation.Types.Trans, -) where +module Data.Validation.Types + ( module Data.Validation.Types.Pure + , module Data.Validation.Types.Trans + ) where import Data.Validation.Types.Pure import Data.Validation.Types.Trans diff --git a/src/Data/Validation/Types/Pure.hs b/src/Data/Validation/Types/Pure.hs index 77a8483..339f297 100644 --- a/src/Data/Validation/Types/Pure.hs +++ b/src/Data/Validation/Types/Pure.hs @@ -1,19 +1,19 @@ {-# LANGUAGE Rank2Types #-} -module Data.Validation.Types.Pure ( - CanNull (..), - Validator (..), - Validatable (..), - Lookup (..), - ValidationResult (..), - Errors (..), - errMessage, - nestErrors, - mapResult, - mapErrors, - errorsAppend, - validationResultAppend, -) where +module Data.Validation.Types.Pure + ( CanNull (..) + , Validator (..) + , Validatable (..) + , Lookup (..) + , ValidationResult (..) + , Errors (..) + , errMessage + , nestErrors + , mapResult + , mapErrors + , errorsAppend + , validationResultAppend + ) where import Control.Applicative import qualified Data.Map.Strict as Map @@ -24,36 +24,36 @@ import Data.Typeable (Typeable) import qualified Data.Vector as Vec newtype Validator input a = Validator - { run :: input -> ValidationResult a - } + { run :: input -> ValidationResult a + } data CanNull - = IsNull - | NotNull - | InvalidNull Text.Text - deriving (Show, Eq) - -class (Typeable input) => Validatable input where - inputText :: input -> Maybe Text.Text - inputBool :: input -> Maybe Bool - inputNull :: input -> CanNull - arrayItems :: input -> Maybe (Vec.Vector input) - scientificNumber :: input -> Maybe Scientific - lookupChild :: Text.Text -> input -> Lookup input + = IsNull + | NotNull + | InvalidNull Text.Text + deriving (Show, Eq) + +class Typeable input => Validatable input where + inputText :: input -> Maybe Text.Text + inputBool :: input -> Maybe Bool + inputNull :: input -> CanNull + arrayItems :: input -> Maybe (Vec.Vector input) + scientificNumber :: input -> Maybe Scientific + lookupChild :: Text.Text -> input -> Lookup input data Lookup input - = LookupResult (Maybe input) - | InvalidLookup + = LookupResult (Maybe input) + | InvalidLookup data ValidationResult a - = Valid a - | Invalid Errors - deriving (Eq, Show) + = Valid a + | Invalid Errors + deriving (Eq, Show) data Errors - = Messages (Set.Set Text.Text) - | Group (Map.Map Text.Text Errors) - deriving (Eq, Show) + = Messages (Set.Set Text.Text) + | Group (Map.Map Text.Text Errors) + deriving (Eq, Show) -- Helpers for building primitive validators @@ -64,9 +64,9 @@ nestErrors :: Text.Text -> Errors -> Errors nestErrors attr err = Group (Map.singleton attr err) mapResult :: - (ValidationResult a -> ValidationResult b) -> - Validator input a -> - Validator input b + (ValidationResult a -> ValidationResult b) -> + Validator input a -> + Validator input b mapResult f v = Validator $ \value -> f (run v value) mapErrors :: (Errors -> Errors) -> ValidationResult a -> ValidationResult a @@ -75,83 +75,83 @@ mapErrors _ valid = valid -- Instances instance Semigroup Errors where - (<>) = errorsAppend + (<>) = errorsAppend instance Monoid Errors where - mempty = Messages Set.empty - mappend = (<>) + mempty = Messages Set.empty + mappend = (<>) errorsAppend :: - Errors -> - Errors -> - Errors + Errors -> + Errors -> + Errors errorsAppend (Messages m) (Messages m') = Messages (m `mappend` m') errorsAppend (Group g) (Group g') = Group (Map.unionWith mappend g g') errorsAppend g m@(Messages _) = g `mappend` nestErrors "" m errorsAppend m g = nestErrors "" m `mappend` g -instance (Monoid a) => Semigroup (ValidationResult a) where - (<>) = validationResultAppend +instance Monoid a => Semigroup (ValidationResult a) where + (<>) = validationResultAppend -instance (Monoid a) => Monoid (ValidationResult a) where - mempty = Valid mempty - mappend = (<>) +instance Monoid a => Monoid (ValidationResult a) where + mempty = Valid mempty + mappend = (<>) validationResultAppend :: - (Monoid m) => - ValidationResult m -> - ValidationResult m -> - ValidationResult m + Monoid m => + ValidationResult m -> + ValidationResult m -> + ValidationResult m validationResultAppend (Valid a) (Valid a') = Valid (a `mappend` a') validationResultAppend (Invalid e) (Invalid e') = Invalid (e `mappend` e') validationResultAppend (Valid _) invalid = invalid validationResultAppend invalid (Valid _) = invalid instance Functor ValidationResult where - f `fmap` (Valid a) = Valid (f a) - _ `fmap` (Invalid errors) = Invalid errors + f `fmap` (Valid a) = Valid (f a) + _ `fmap` (Invalid errors) = Invalid errors instance Applicative ValidationResult where - pure = Valid + pure = Valid - (Valid f) <*> (Valid a) = Valid (f a) - (Invalid errs) <*> (Invalid errs') = Invalid (errs `mappend` errs') - Invalid errs <*> _ = Invalid errs - _ <*> Invalid errs = Invalid errs + (Valid f) <*> (Valid a) = Valid (f a) + (Invalid errs) <*> (Invalid errs') = Invalid (errs `mappend` errs') + Invalid errs <*> _ = Invalid errs + _ <*> Invalid errs = Invalid errs instance Functor (Validator input) where - f `fmap` v = mapResult (fmap f) v + f `fmap` v = mapResult (fmap f) v instance Applicative (Validator input) where - pure a = Validator (const (pure a)) - v <*> v' = Validator $ \value -> run v value <*> run v' value + pure a = Validator (const (pure a)) + v <*> v' = Validator $ \value -> run v value <*> run v' value instance Monad (Validator input) where - v >>= f = Validator $ \input -> - case run v input of - Invalid errors -> Invalid errors - Valid a -> run (f a) input + v >>= f = Validator $ \input -> + case run v input of + Invalid errors -> Invalid errors + Valid a -> run (f a) input internalFail :: [Char] -> Validator input a internalFail str = Validator $ \_ -> Invalid (errMessage (Text.pack str)) instance MonadFail (Validator input) where - fail = internalFail + fail = internalFail instance Functor Lookup where - fmap _ InvalidLookup = InvalidLookup - fmap f (LookupResult r) = LookupResult (fmap f r) + fmap _ InvalidLookup = InvalidLookup + fmap f (LookupResult r) = LookupResult (fmap f r) instance Applicative Lookup where - pure = LookupResult . pure + pure = LookupResult . pure - InvalidLookup <*> _ = InvalidLookup - _ <*> InvalidLookup = InvalidLookup - (LookupResult f) <*> (LookupResult a) = LookupResult (f <*> a) + InvalidLookup <*> _ = InvalidLookup + _ <*> InvalidLookup = InvalidLookup + (LookupResult f) <*> (LookupResult a) = LookupResult (f <*> a) instance Alternative Lookup where - empty = LookupResult Nothing + empty = LookupResult Nothing - InvalidLookup <|> other = other - other <|> InvalidLookup = other - (LookupResult a) <|> (LookupResult b) = LookupResult (a <|> b) + InvalidLookup <|> other = other + other <|> InvalidLookup = other + (LookupResult a) <|> (LookupResult b) = LookupResult (a <|> b) diff --git a/src/Data/Validation/Types/Trans.hs b/src/Data/Validation/Types/Trans.hs index 7c82787..d90d6cb 100644 --- a/src/Data/Validation/Types/Trans.hs +++ b/src/Data/Validation/Types/Trans.hs @@ -1,9 +1,9 @@ {-# LANGUAGE Rank2Types #-} -module Data.Validation.Types.Trans ( - ValidatorT (..), - liftV, -) +module Data.Validation.Types.Trans + ( ValidatorT (..) + , liftV + ) where import Control.Monad.Trans.Class @@ -11,34 +11,34 @@ import qualified Data.Text as Text import Data.Validation.Types.Pure newtype ValidatorT input m a = ValidatorT - { runValidatorT :: input -> m (ValidationResult a) - } + { runValidatorT :: input -> m (ValidationResult a) + } -instance (Functor m) => Functor (ValidatorT input m) where - fmap f (ValidatorT ma) = ValidatorT $ fmap (fmap (fmap f)) ma +instance Functor m => Functor (ValidatorT input m) where + fmap f (ValidatorT ma) = ValidatorT $ fmap (fmap (fmap f)) ma -instance (Applicative m) => Applicative (ValidatorT input m) where - pure a = ValidatorT (const (pure (pure a))) +instance Applicative m => Applicative (ValidatorT input m) where + pure a = ValidatorT (const (pure (pure a))) - (ValidatorT mf) <*> (ValidatorT ma) = ValidatorT $ \input -> - fmap (<*>) (mf input) <*> ma input + (ValidatorT mf) <*> (ValidatorT ma) = ValidatorT $ \input -> + fmap (<*>) (mf input) <*> ma input -instance (Monad m) => Monad (ValidatorT input m) where - return = pure - (ValidatorT ma) >>= f = ValidatorT $ \input -> do - result <- ma input - case result of - Valid a -> runValidatorT (f a) input - Invalid errs -> pure (Invalid errs) +instance Monad m => Monad (ValidatorT input m) where + return = pure + (ValidatorT ma) >>= f = ValidatorT $ \input -> do + result <- ma input + case result of + Valid a -> runValidatorT (f a) input + Invalid errs -> pure (Invalid errs) -internalFail :: (Applicative a) => [Char] -> ValidatorT input a b +internalFail :: Applicative a => [Char] -> ValidatorT input a b internalFail str = ValidatorT $ \_ -> pure $ Invalid (errMessage (Text.pack str)) -instance (Monad m) => MonadFail (ValidatorT input m) where - fail = internalFail +instance Monad m => MonadFail (ValidatorT input m) where + fail = internalFail instance MonadTrans (ValidatorT input) where - lift ma = ValidatorT (const (Valid <$> ma)) + lift ma = ValidatorT (const (Valid <$> ma)) -liftV :: (Applicative m) => Validator input a -> ValidatorT input m a +liftV :: Applicative m => Validator input a -> ValidatorT input m a liftV validator = ValidatorT $ \input -> pure (run validator input) diff --git a/src/Data/Validation/XML.hs b/src/Data/Validation/XML.hs index 10219bc..4308240 100644 --- a/src/Data/Validation/XML.hs +++ b/src/Data/Validation/XML.hs @@ -15,22 +15,22 @@ import Data.Validation.Types decodeValidXML :: Validator VXML a -> LazyBS.ByteString -> ValidationResult a decodeValidXML validator input = - case parseLBS def input of - Left err -> Invalid (errMessage $ Text.pack (show err)) - Right doc -> run validator (VDoc doc) + case parseLBS def input of + Left err -> Invalid (errMessage $ Text.pack (show err)) + Right doc -> run validator (VDoc doc) data VXML - = VDoc Document - | VElem Element - | VText Text.Text + = VDoc Document + | VElem Element + | VText Text.Text instance Validatable VXML where - inputBool = getBool - inputText = getText - inputNull = getNull - arrayItems = getArray - scientificNumber = getNumber - lookupChild = getChild + inputBool = getBool + inputText = getText + inputNull = getNull + arrayItems = getArray + scientificNumber = getNumber + lookupChild = getChild getBool :: VXML -> Maybe Bool getBool vxml = getText vxml >>= parseBool @@ -45,7 +45,7 @@ getNull _ = InvalidNull "xml_cannot_use_null" getArray :: VXML -> Maybe (Vec.Vector VXML) getArray (VElem (Element _ _ nodes)) = - Just $ Vec.fromList (mapMaybe (fmap VElem . nodeElem) nodes) + Just $ Vec.fromList (mapMaybe (fmap VElem . nodeElem) nodes) getArray (VDoc (Document _ root _)) = getArray (VElem root) getArray (VText _) = Nothing @@ -55,36 +55,36 @@ getNumber vxml = getText vxml >>= parseNumber getChild :: Text.Text -> VXML -> Lookup VXML getChild _ (VText _) = InvalidLookup getChild childName (VElem (Element _ attrs nodes)) = - (VElem <$> findNode childName nodes) - <|> (VText <$> findAttr childName attrs) + (VElem <$> findNode childName nodes) + <|> (VText <$> findAttr childName attrs) getChild childName (VDoc (Document prologue root epilogue)) = - case Text.splitAt 1 childName of - ("?", instructionName) -> - LookupResult $ - findProcessingInstruction instructionName (prologueBefore prologue) - <|> findProcessingInstruction instructionName (prologueAfter prologue) - <|> findProcessingInstruction instructionName epilogue - _ -> getChild childName (VElem root) + case Text.splitAt 1 childName of + ("?", instructionName) -> + LookupResult $ + findProcessingInstruction instructionName (prologueBefore prologue) + <|> findProcessingInstruction instructionName (prologueAfter prologue) + <|> findProcessingInstruction instructionName epilogue + _ -> getChild childName (VElem root) findProcessingInstruction :: Text.Text -> [Miscellaneous] -> Maybe VXML findProcessingInstruction name misc = - VText <$> listToMaybe (mapMaybe getData misc) - where - getData (MiscInstruction (Instruction n d)) | name == n = Just d - getData _ = Nothing + VText <$> listToMaybe (mapMaybe getData misc) + where + getData (MiscInstruction (Instruction n d)) | name == n = Just d + getData _ = Nothing findAttr :: Text.Text -> Map.Map Name Text.Text -> Lookup Text.Text findAttr attrName attrs = - LookupResult (Map.lookup attrFullName attrs) - where - attrFullName = Name attrName Nothing Nothing + LookupResult (Map.lookup attrFullName attrs) + where + attrFullName = Name attrName Nothing Nothing findNode :: Text.Text -> [Node] -> Lookup Element findNode elemName nodes = case matches of - [el] -> LookupResult (Just el) - _ -> LookupResult Nothing - where - matches = mapMaybe (elemWithName elemName) nodes + [el] -> LookupResult (Just el) + _ -> LookupResult Nothing + where + matches = mapMaybe (elemWithName elemName) nodes nodeElem :: Node -> Maybe Element nodeElem (NodeElement el) = Just el @@ -92,39 +92,39 @@ nodeElem _ = Nothing elemWithName :: Text.Text -> Node -> Maybe Element elemWithName elemName node = do - el <- nodeElem node + el <- nodeElem node - if elemName == nameLocalName (elementName el) - then Just el - else Nothing + if elemName == nameLocalName (elementName el) + then Just el + else Nothing parseNumber :: Text.Text -> Maybe Scientific parseNumber text = - case reads (Text.unpack (Text.strip text)) of - (n, "") : _ -> Just n - _ -> Nothing + case reads (Text.unpack (Text.strip text)) of + (n, "") : _ -> Just n + _ -> Nothing parseBool :: Text.Text -> Maybe Bool parseBool text = - case reads (Text.unpack (Text.strip text)) of - (n, "") : _ -> Just n - _ -> Nothing + case reads (Text.unpack (Text.strip text)) of + (n, "") : _ -> Just n + _ -> Nothing data Content - = Content Text.Text - | NotContent + = Content Text.Text + | NotContent instance Semigroup Content where - (<>) = contentAppend + (<>) = contentAppend instance Monoid Content where - mempty = Content "" - mappend = (<>) + mempty = Content "" + mappend = (<>) contentAppend :: - Content -> - Content -> - Content + Content -> + Content -> + Content contentAppend (Content t) (Content t') = Content (t `mappend` t') contentAppend _ _ = NotContent diff --git a/test/Main.hs b/test/Main.hs index 171a913..56e536e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -12,9 +12,9 @@ emptyJSON = toJSON ("" :: String) main :: IO () main = do - -- Just verify that they do not throw - result1 <- runValidatorT rejectsAll emptyJSON - print result1 - result2 <- runValidatorT rejectsAllUsingFail emptyJSON - print result2 - pure () + -- Just verify that they do not throw + result1 <- runValidatorT rejectsAll emptyJSON + print result1 + result2 <- runValidatorT rejectsAllUsingFail emptyJSON + print result2 + pure ()