SimpleJSON.purs 3.35 KB
Newer Older
1 2 3 4 5
module Gargantext.Utils.SimpleJSON where

import Prelude

import Control.Alt ((<|>))
6
import Control.Monad.Except (throwError, withExcept)
7
import Data.Generic.Rep as GR
8 9
import Data.List as L
import Data.List.Types (NonEmptyList(..))
10
import Data.Maybe (Maybe(..))
11
import Data.NonEmpty (NonEmpty(..))
12 13 14 15 16
import Data.Tuple (Tuple(..))
import Foreign (Foreign, ForeignError(..), fail)
import Foreign as Foreign
import Foreign.Object as FO
import Simple.JSON as JSON
17 18
import Type.Prelude (class IsSymbol, reflectSymbol)
import Type.Proxy (Proxy(..))
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45

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
arturo's avatar
arturo committed
46
    -- if r."type" == name
47 48 49 50 51 52 53 54 55 56 57
    --   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
58
      nameP = Proxy :: Proxy name
59 60 61 62 63 64 65 66
      name = reflectSymbol nameP

instance ( JSON.ReadForeign a
         ) => GenericTaggedSumRep (GR.Argument a) where
  genericTaggedSumRep f = GR.Argument <$> JSON.readImpl f



arturo's avatar
arturo committed
67
-----------------------------------------------------------
68

arturo's avatar
arturo committed
69 70 71 72 73
-- | 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
74

arturo's avatar
arturo committed
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
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
92 93


94 95
-- | A helper function to wrap the complexities of throwing an error
-- | from a custom JSON reader.
96 97 98
throwJSONError :: forall a. Foreign.ForeignError -> Foreign.F a
throwJSONError err =
  throwError $ NonEmptyList $ NonEmpty err L.Nil