CombinedSchema.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}

import Data.Aeson
import Data.Monoid
import Data.Proxy
import Data.Text

import GHC.Exts (Constraint)

---

data Dict :: Constraint -> * where
  Dict :: a => Dict a

data DictList :: (k -> Constraint) -> [k] -> * where
  Nil  :: DictList c '[]
  Cons :: Dict (c x) -> DictList c xs -> DictList c (x ': xs)

-- Let GHC do the heavy lifting!
class BuildDictList c ts where
  buildDictList :: DictList c ts

instance BuildDictList c '[] where
  buildDictList = Nil

instance (c t, BuildDictList c ts) => BuildDictList c (t ': ts) where
  buildDictList = Cons Dict buildDictList

---

class MapDictList c ts where
  mapDictList :: (forall a. Dict (c a) -> b) -> DictList c ts -> [b]

instance MapDictList c '[] where
  mapDictList _ Nil = []

instance MapDictList c ts => MapDictList c (t ': ts) where
  mapDictList f (Cons x xs) = f x : mapDictList f xs

---

mapTypes :: forall (c :: k -> Constraint) (ts :: [k]) (b :: *).
            (BuildDictList c ts, MapDictList c ts)
            => Proxy c
            -> Proxy ts
            -> (forall a. c a => Proxy a -> b) -> [b]
mapTypes Proxy Proxy f =
  mapDictList
    (\(Dict :: Dict (c a)) -> f (Proxy :: Proxy a))
    (buildDictList :: DictList c ts)

---

class    Trivial a
instance Trivial a

class    (f a, g a) => (f & g) a
instance (f a, g a) => (f & g) a

---

-- Just for the PoC:
class ToYAML a
instance ToJSON a => ToYAML a

renderJSONSchema :: (ToJSON a) => Proxy a -> Text
renderJSONSchema = undefined

renderYAMLSchema :: (ToYAML a) => Proxy a -> Text
renderYAMLSchema = undefined

---
--- Usage

type SerializedTypes = [Int, Bool, String]

createCombinedJSONSchema =
  mconcat $
    mapTypes
      (Proxy @ToJSON)
      (Proxy @SerializedTypes)
      renderJSONSchema

createCombinedYAMLSchema =
  mconcat $
    mapTypes
      (Proxy @(ToJSON & ToYAML & Show))  -- just e.g.
      (Proxy @SerializedTypes)
      renderYAMLSchema