Generics would be sweet... about envy HOT 4 CLOSED

{-# LANGUAGE OverloadedLists      #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE TemplateHaskell      #-}
module Main where

import Control.Applicative
import GHC.Generics
import Data.Typeable
import Data.Monoid
import qualified Data.Set as S
import Control.Lens hiding (to, from)

newtype SchemaName = SchemaName String deriving (Show, Eq)

instance Monoid SchemaName where
  mempty = SchemaName mempty
  SchemaName x `mappend` _ = SchemaName x

data Schema = Schema {
    _schemaName   :: SchemaName
  , _schemaFields :: [(String, TypeRep)]
  , _requiredFields :: [String]
  } deriving (Show, Eq, Generic)

-- lensies
$(makeLenses ''Schema)

instance Monoid Schema where
  mempty = Schema mempty mempty mempty
  Schema x1 y1 z1 `mappend` Schema x2 y2 z2
    = Schema (x1 <> x2) (y1 <> y2) (z1 <> z2)

class Generic a => Example a where example :: a

class GToSchema f where
  gToSchema :: f a    -- * type rep.
            -> Schema -- * accumulator
            -> Schema -- * final schema

class ToSchema a where
  toSchema :: a -> Schema
  default toSchema :: (Example a, Generic a, GToSchema (Rep a)) => a -> Schema
  toSchema x = gToSchema (from x) mempty

data Person = Person {
    name :: String
  , age  :: Int
  , dogName :: Maybe String
  } deriving (Generic)

instance Example Person where
  example = Person "fizruk" 28 (Just "fido")

instance ToSchema Person

-- Unit
instance GToSchema U1 where
  gToSchema = undefined -- don't need

-- DataType
instance (Datatype d, GToSchema a) => GToSchema (D1 d a) where
  gToSchema m@(M1 x) schema = gToSchema x newSchema
     where
       newSchema = schema & schemaName .~ SchemaName (datatypeName m)

-- Constructors
instance (Constructor i, GToSchema a) => GToSchema (C1 i a) where
  gToSchema m@(M1 x) = gToSchema x
  -- already capturing this info at the dataType (same as Con in this case)
     -- where
     --   newSchema = schema & schemaName .~ conName m

-- Selectors + Values
instance (Typeable a, Selector s) => GToSchema (S1 s (K1 i a)) where
  gToSchema m@(M1 (K1 x)) schema = newSchema
    where
      newSchema = schema & schemaFields %~ (:) (selName m, typeOf x)
                         & requiredFields %~ (:) (selName m)

instance (Typeable a, Selector s) => GToSchema (S1 s (K1 i (Maybe a))) where
  gToSchema m@(M1 (K1 x)) schema = newSchema
    where
      newSchema = schema & schemaFields %~ (:) (selName m, typeOf x)

-- Sums
instance (GToSchema left, GToSchema right) => GToSchema (left :*: right) where
  gToSchema (l :*: r) schema = gToSchema l schema <> gToSchema r schema

-- Products... I say we don't support these now for the sake of simplicity
instance (GToSchema left, GToSchema right) => GToSchema (left :+: right) where
  gToSchema (L1 x) = gToSchema x
  gToSchema (R1 x) = gToSchema x

-- λ> toSchema (example :: Person)
-- Schema {  _schemaName = fromList ["Person"]
--        ,  _schemaFields = [("name",[Char]),("age",Int)]
--        }