Skip to content

Instantly share code, notes, and snippets.

@kana-sama

kana-sama/qwe.hs

Created Jun 24, 2020
Embed
What would you like to do?
{-# 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"}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.