module Text.Digestive.Aeson
( digestJSON
, jsonErrors
) where
import Control.Lens
import Data.Aeson (ToJSON(toJSON), Value(..), object)
import Data.Aeson.Lens
import Data.Maybe (fromMaybe)
import Safe
import Text.Digestive
import Text.Digestive.Form.List (unparseIndices)
import qualified Data.Text as T
import qualified Data.Vector as V
digestJSON :: Monad m
=> Form v m a
-> Value
-> m (View v, Maybe a)
digestJSON f json = postForm "" f (jsonEnv json)
where jsonEnv :: Monad m => Value -> Env m
jsonEnv v p
| head (reverse p) == "indices" = case Just v ^. pathToLens (init p) of
Just (Array a) -> return $ return . TextInput $
unparseIndices [0 .. (pred $ V.length a)]
_ -> return [ TextInput "" ]
| otherwise = return . maybe [] jsonToText $ Just v ^. pathToLens p
jsonToText (String s) = [TextInput s]
jsonToText (Bool b) = showPack b
jsonToText (Number n) = showPack n
jsonToText Null = []
jsonToText (Object _) = []
jsonToText (Array _) = []
showPack = return . TextInput . T.pack . show
jsonErrors :: ToJSON a => View a -> Value
jsonErrors = fromMaybe (error "Constructing error tree failed!") .
foldl encodeError (Just $ object []) . viewErrors
where
encodeError json (path, message) =
json & pathToLens path .~ Just (toJSON message)
pathToLens :: Functor f
=> [T.Text]
-> (Maybe Value -> f (Maybe Value))
-> Maybe Value
-> f (Maybe Value)
pathToLens = foldl (.) id . map pathElem . filter (not . T.null)
where
pathElem p = maybe (key p) nth (readMay $ T.unpack p)