module Gargantext.Utils.SimpleJSON where import Prelude import Control.Alt ((<|>)) import Control.Monad.Except (throwError, withExcept) import Data.Generic.Rep as GR import Data.List as L import Data.List.Types (NonEmptyList(..)) import Data.Maybe (Maybe(..)) import Data.NonEmpty (NonEmpty(..)) import Data.Tuple (Tuple(..)) import Foreign (Foreign, ForeignError(..), fail) import Foreign as Foreign import Foreign.Object as FO import Simple.JSON as JSON import Type.Prelude (class IsSymbol, reflectSymbol) import Type.Proxy (Proxy(..)) taggedSumRep :: forall a rep . GR.Generic a rep => GenericTaggedSumRep rep => Foreign -> Foreign.F a taggedSumRep f = GR.to <$> genericTaggedSumRep f -- | Generic Tagged Sum Representations, with "type" as key and rest -- of key/values representing the object. Note that this is slightly -- difrerent than what Simple.JSON generics provides as it wrapes the -- tag in "type" and object under "value" key. class GenericTaggedSumRep rep where genericTaggedSumRep :: Foreign -> Foreign.F rep instance ( GenericTaggedSumRep a , GenericTaggedSumRep b ) => GenericTaggedSumRep (GR.Sum a b) where genericTaggedSumRep f = GR.Inl <$> genericTaggedSumRep f <|> GR.Inr <$> genericTaggedSumRep f instance ( GenericTaggedSumRep a , IsSymbol name ) => GenericTaggedSumRep (GR.Constructor name a) where genericTaggedSumRep f = do -- r :: { "type" :: String } <- JSON.read' f -- if r."type" == name -- then withExcept (map $ ErrorAtProperty name) $ GR.Constructor <$> genericTaggedSumRep r -- else fail $ ForeignError $ "Wrong type tag " <> r."type" <> " where " <> name <> " was expected." r :: FO.Object Foreign <- JSON.read' f case FO.pop "type" r of Nothing -> fail $ ForeignError $ "Key 'type' not found." Just (Tuple name' obj) -> do n' <- Foreign.readString name' if n' == name then withExcept (map $ ErrorAtProperty name) $ GR.Constructor <$> (genericTaggedSumRep $ Foreign.unsafeToForeign obj) else fail $ ForeignError $ "Wrong type tag " <> n' <> " where " <> name <> " was expected." where nameP = Proxy :: Proxy name name = reflectSymbol nameP instance ( JSON.ReadForeign a ) => GenericTaggedSumRep (GR.Argument a) where genericTaggedSumRep f = GR.Argument <$> JSON.readImpl f ----------------------------------------------------------- -- | Applying Generics-Rep to decoding untagged JSON values -- | -- | https://purescript-simple-json.readthedocs.io/en/latest/generics-rep.html class UntaggedSumRep rep where untaggedSumRep :: Foreign -> Foreign.F rep instance untaggedSumRepSum :: ( UntaggedSumRep a , UntaggedSumRep b ) => UntaggedSumRep (GR.Sum a b) where untaggedSumRep f = GR.Inl <$> untaggedSumRep f <|> GR.Inr <$> untaggedSumRep f instance untaggedSumRepConstructor :: ( UntaggedSumRep a ) => UntaggedSumRep (GR.Constructor name a) where untaggedSumRep f = GR.Constructor <$> untaggedSumRep f instance untaggedSumRepArgument :: ( JSON.ReadForeign a ) => UntaggedSumRep (GR.Argument a) where untaggedSumRep f = GR.Argument <$> JSON.readImpl f throwJSONError :: forall a. Foreign.ForeignError -> Foreign.F a throwJSONError err = throwError $ NonEmptyList $ NonEmpty err L.Nil