module Data.JSON.Schema.Generic (gSchema) where
import Control.Applicative hiding (empty, (<|>))
import Data.Char
import Data.JSON.Schema.Combinators
import Data.JSON.Schema.Types
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import GHC.Generics
import Generics.Deriving.ConNames
import Generics.Generic.IsEnum
import qualified Data.Aeson.Types as Aeson
import qualified Data.Text as T
class GJSONSCHEMA f where
gSchema' :: Bool -> [Text] -> Proxy (f a) -> Schema
instance JSONSchema c => GJSONSCHEMA (K1 i c) where
gSchema' _ _ = schema . fmap unK1
instance GJSONSCHEMA (K1 i String) where
gSchema' _ _ _ = Value unboundedLength
instance GJSONSCHEMA U1 where
gSchema' _ _ _ = empty
instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :+: g) where
gSchema' enm names p =
gSchema' enm names (gL <$> p)
<|> gSchema' enm names (gR <$> p)
where
gL :: (f :+: g) r -> f r
gL _ = undefined
gR :: (f :+: g) r -> g r
gR _ = undefined
gFst :: (f :*: g) r -> f r
gFst (f :*: _) = f
gSnd :: (f :*: g) r -> g r
gSnd (_ :*: g) = g
pv :: Proxy a -> a
pv _ = undefined
toConstant :: Text -> Schema
toConstant = Constant . Aeson.String . firstLetterToLower
instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :*: g) where
gSchema' enm names p = gSchema' enm names (gFst <$> p) `merge` gSchema' enm names (gSnd <$> p)
instance (Constructor c, GJSONSCHEMA f) => GJSONSCHEMA (M1 C c f) where
gSchema' True _ = toConstant . conNameT . pv
gSchema' enm names = wrap . gSchema' enm names . fmap unM1
where
wrap = if multipleConstructors names
then field (firstLetterToLower $ conNameT (undefined :: M1 C c f p)) True
else id
instance GJSONSCHEMA f => GJSONSCHEMA (M1 D c f) where
gSchema' True names p | multipleConstructors names = const (Choice . fmap toConstant $ names) $ p
gSchema' enm names p = gSchema' enm names . fmap unM1 $ p
firstLetterToLower :: Text -> Text
firstLetterToLower m = case T.uncons m of
Nothing -> ""
Just (l, ls) -> T.cons (toLower l) ls
instance (Selector c, JSONSchema a) => GJSONSCHEMA (M1 S c (K1 i (Maybe a))) where
gSchema' _ _ = field (selNameT (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1)
instance Selector c => GJSONSCHEMA (M1 S c (K1 i (Maybe String))) where
gSchema' _ _ _ = field (selNameT (undefined :: M1 S c f p)) False $ Value unboundedLength
instance (Selector c, GJSONSCHEMA f) => GJSONSCHEMA (M1 S c f) where
gSchema' enm names = wrap . gSchema' enm names . fmap unM1
where
wrap = case (T.pack . selName) (undefined :: M1 S c f p) of
"" -> id
s -> field s True
conNameT :: forall c (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Constructor c => t c f a -> Text
conNameT x = T.pack . conName $ x
selNameT :: forall s (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a. Selector s => t s f a -> Text
selNameT x = T.pack . selName $ x
multipleConstructors :: [Text] -> Bool
multipleConstructors = (> 1) . length
gSchema :: (Generic a, GJSONSCHEMA (Rep a), ConNames (Rep a), GIsEnum (Rep a)) => Proxy a -> Schema
gSchema p = gSchema' (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)