qwe.hs

{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications, AllowAmbiguousTypes, ScopedTypeVariables,
  PolyKinds, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, OverloadedLists, FlexibleContexts,
  TypeOperators #-}

import Data.Aeson
import Data.Proxy
import Data.Typeable
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import GHC.Generics
import GHC.TypeLits

class GStructure a where
  gstructure :: Value

instance (KnownSymbol name, GStructure constructors) => GStructure (D1 (MetaData name m p nt) constructors) where
  gstructure = Object $ HM.fromList
    [ ("name", String $ T.pack $ symbolVal (Proxy @name))
    , ("constructors", gstructure @constructors)
    ]

instance GStructure V1 where
  gstructure = Array []

instance (KnownSymbol name, GStructure arguments) => GStructure (C1 (MetaCons name f s) arguments) where
  gstructure = Array $ V.singleton $ Object $ HM.fromList
    [ ("name", String $ T.pack $ symbolVal (Proxy @name))
    , ("arguments", gstructure @arguments)
    ]

instance (GStructure a, GStructure b) => GStructure (a :+: b) where
  gstructure =
    let Array a = gstructure @a
        Array b = gstructure @b
     in Array $ a <> b

instance GStructure U1 where
  gstructure = Array []

instance Typeable t => GStructure (S1 meta (Rec0 t)) where
  gstructure = Array $ V.singleton $
    String $ T.pack $ show $ typeRep (Proxy @t)

instance (GStructure a, GStructure b) => GStructure (a :*: b) where
  gstructure =
    let Array a = gstructure @a
        Array b = gstructure @b
     in Array $ a <> b

structure :: forall a. (Generic a, GStructure (Rep a)) => Value
structure = gstructure @(Rep a)

-- Example

data A = B Int String | C Bool Int
  deriving Generic

main :: IO ()
main = BS.putStrLn $ encode $ structure @A

-- {"constructors":[{"arguments":["Int","[Char]"],"name":"B"},{"arguments":["Bool","Int"],"name":"C"}],"name":"A"}