Data.Validation.Aeson.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Validation.Aeson where

import           Control.Applicative
import           Control.Lens
import           Data.Aeson
import qualified Data.HashMap.Strict as M
import           Data.Maybe          (fromMaybe)
import           Data.Semigroup
import qualified Data.Text           as T
import           Data.Validation
import           Data.Vector         (toList, (!?))
import           Prelude             hiding (lookup)

type AesonErrors = [AesonError]

data AesonError = MissingKey T.Text Object
                | TypeError String Value
                | OutOfBounds Int Array

vObject :: Validate f => Value -> f AesonErrors Object
vObject (Object m) = _Success # m
vObject v = failWithTypeError "Object" v

vArray :: Validate f => Value -> f AesonErrors Array
vArray (Array m) = _Success # m
vArray v = failWithTypeError "Array" v

vList :: (Validate f, Functor (f AesonErrors)) => Value -> f AesonErrors [Value]
vList = fmap toList . vArray

vText :: Validate f => Value -> f AesonErrors T.Text
vText (String s) = _Success # s
vText v = failWithTypeError "String" v

vString :: (Validate f, Functor (f AesonErrors)) => Value -> f AesonErrors String
vString = fmap T.unpack . vText

vNumber (Number s) = _Success # s
vNumber v = failWithTypeError "String" v

vIntegral :: (Integral a, Validate f, Functor (f AesonErrors)) => Value -> f AesonErrors a
vIntegral = fmap floor . vNumber

failWithTypeError :: Validate f => String -> Value -> f AesonErrors a
failWithTypeError t v  =_Failure # pure (TypeError t v)

vKey :: Validate f => T.Text -> Object -> f AesonErrors Value
vKey key o = maybeToV (pure $ MissingKey key o) (key `M.lookup` o)

vIx :: Validate f => Int -> Array -> f AesonErrors Value
vIx idx arr = maybeToV [OutOfBounds idx arr] $ arr !? idx

_ValMaybe ::
  Validate f =>
  Prism (Maybe a) (Maybe b) (f e a) (f e b)
_ValMaybe = prism f2m m2f
    where f2m = (^? _Success)
          m2f = maybe (Left Nothing) (Right . review _Success)

as v x = (v >>= x) ^. _AccValidation

maybeToV :: Validate v => e -> Maybe a -> v e a
maybeToV e m = fromMaybe (_Failure # e) $ m ^? _ValMaybe

data Widget = Widget String String

parseWidget :: Object -> AccValidation [AesonError] Widget
parseWidget v = Widget <$> ((vKey "name" v >>= vString :: Validation [AesonError] String) ^. _AccValidation :: AccValidation [AesonError] String)
                <*> pure "what"

example v = do
  x <- vObject v
  vKey "at" x <|> vKey "baz" x