SimpleJSON.purs 3.01 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
module Gargantext.Utils.SimpleJSON where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (withExcept)
import Data.Generic.Rep as GR
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, ForeignError(..), fail)
import Foreign as Foreign
import Foreign.Object as FO
import Simple.JSON as JSON
14 15
import Type.Prelude (class IsSymbol, reflectSymbol)
import Type.Proxy (Proxy(..))
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42

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
43
    -- if r."type" == name
44 45 46 47 48 49 50 51 52 53 54
    --   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
55
      nameP = Proxy :: Proxy name
56 57 58 59 60 61 62 63
      name = reflectSymbol nameP

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



arturo's avatar
arturo committed
64
-----------------------------------------------------------
65

arturo's avatar
arturo committed
66 67 68 69 70
-- | 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
71

arturo's avatar
arturo committed
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
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