Main.purs

module Main where

import Prelude
import Effect (Effect)
import Control.Monad.Except.Trans (throwError)
import Effect.Console (log)
import Control.Alt ((<|>))
import Data.Generic.Rep as GR
import Foreign (Foreign, ForeignError(..), fail)
import Foreign as Foreign
import Simple.JSON as JSON
import Type.Prelude (class IsSymbol, SProxy(..), reflectSymbol)
import Prim.RowList (class RowToList)
import Record as Record
import Data.Either (Either(..))

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

class UntaggedSumRep rep where
  untaggedSumRep :: Foreign -> Foreign.F rep

data Foo
  = FooA (Node "foo" ( some :: String ))
  | FooB (Node "bar" ( other :: String ))

derive instance genericFoo :: GR.Generic Foo _

instance readForeignFoo :: JSON.ReadForeign Foo where
  readImpl f = GR.to <$> untaggedSumRep f

newtype Node (jsonTagValue :: Symbol) r
  = Node { nodeType :: String | r }

instance readForeignNode ::
  ( IsSymbol jsonTagValue
  , RowToList row rowList
  , JSON.ReadForeignFields rowList () row
  ) =>
  JSON.ReadForeign (Node jsonTagValue row) where
  readImpl f = do
    case (JSON.read f :: JSON.E { nodeType :: String }) of
      Left e -> throwError e
      Right peek ->
        if peek.nodeType == jsonTagValueS then do
          case ( JSON.read f ::
                JSON.ReadForeignFields rowList () row =>
                JSON.E { | row }
            ) of
            Left e -> throwError e
            Right full -> pure $ Node $ Record.union peek full
        else
          fail $ ForeignError
            $ "Wrong type tag "
            <> peek."nodeType"
            <> " where "
            <> jsonTagValueS
            <> " was expected."
    where
    jsonTagValueP = SProxy :: SProxy jsonTagValue

    jsonTagValueS = reflectSymbol jsonTagValueP

main :: Effect Unit
main = case JSON.readJSON """{ "nodeType": "foo", "some": "SUCCESS" }""" of
  Left e -> log $ show e
  Right (r :: Foo) -> case r of
    FooA (Node content) -> log content.some
    FooB (Node content) -> log content.other