aeson gadt

test.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
module Test where
import Data.Aeson
import Data.Aeson.Types
import Data.Text (Text)
import Data.Scientific
import Control.Monad
import Control.Applicative

data Expr a where
  Num :: Int -> Expr Int
  Str :: Text -> Expr Text
  Plus :: Expr Int -> Expr Int -> Expr Int
  ID :: Expr a -> Expr a
  Reverse :: Expr Text -> Expr Text
  Bottom :: Expr a

data SomeExpr where
  SomeExpr :: Expr a -> SomeExpr

class ParseExpr a where
  parseExpr :: Value -> Parser (Expr a)

instance ParseExpr Int where
  parseExpr (Number i) = case floatingOrInteger i of
    Left r -> fail "not an integer"
    Right i -> pure $ Num i
  parseExpr v = parsePlus v <|> parsePoly v

parsePlus :: Value -> Parser (Expr Int)
parsePlus = withObject "plus" $ \v -> do
  fun <- v .: "fun"
  guard (fun == String "+")
  arg1 <- (v .: "arg1") >>= parseExpr
  arg2 <- (v .: "arg1") >>= parseExpr
  pure (Plus arg1 arg2)
    
parsePoly :: ParseExpr a => Value -> Parser (Expr a)
parsePoly (Object v) = do
  fun <- v .: "fun"
  guard (fun == String "id")
  arg1 <- (v .: "arg") >>= parseExpr
  pure (ID arg1)

parsePoly Null = pure Bottom
parsePoly _ = fail "Cannot parse"

instance ParseExpr Text where
  parseExpr (String s) = pure $ Str s
  parseExpr v = parseReverse v <|> parsePoly v

parseReverse :: Value -> Parser (Expr Text)
parseReverse = withObject "reverse" $ \v -> do
  fun <- v .: "fun"
  guard (fun == String "reverse")
  arg1 <- (v .: "arg") >>= parseExpr
  pure (Reverse arg1)

parseSome :: Value -> Parser SomeExpr
parseSome v = 
  (SomeExpr <$> parseExpr @Int v) <|>
  (SomeExpr <$> parseExpr @Text v)