{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE TypeOperators       #-}
module Data.Schema.Builder
    ( Builder (..)
    , ToSchema (..)
    , atom
    ) where

import           Control.Applicative (liftA2)
import           Data.Fix            (Fix (..))
import           Data.Schema.Type    (Schema, SchemaF (..), Type (..), prodType)
import           GHC.Generics


data Builder a = Builder
    { Builder a -> a
zero      :: a
    , Builder a -> Schema
getSchema :: Schema
    }
    deriving (ReadPrec [Builder a]
ReadPrec (Builder a)
Int -> ReadS (Builder a)
ReadS [Builder a]
(Int -> ReadS (Builder a))
-> ReadS [Builder a]
-> ReadPrec (Builder a)
-> ReadPrec [Builder a]
-> Read (Builder a)
forall a. Read a => ReadPrec [Builder a]
forall a. Read a => ReadPrec (Builder a)
forall a. Read a => Int -> ReadS (Builder a)
forall a. Read a => ReadS [Builder a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Builder a]
$creadListPrec :: forall a. Read a => ReadPrec [Builder a]
readPrec :: ReadPrec (Builder a)
$creadPrec :: forall a. Read a => ReadPrec (Builder a)
readList :: ReadS [Builder a]
$creadList :: forall a. Read a => ReadS [Builder a]
readsPrec :: Int -> ReadS (Builder a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Builder a)
Read, Int -> Builder a -> ShowS
[Builder a] -> ShowS
Builder a -> String
(Int -> Builder a -> ShowS)
-> (Builder a -> String)
-> ([Builder a] -> ShowS)
-> Show (Builder a)
forall a. Show a => Int -> Builder a -> ShowS
forall a. Show a => [Builder a] -> ShowS
forall a. Show a => Builder a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Builder a] -> ShowS
$cshowList :: forall a. Show a => [Builder a] -> ShowS
show :: Builder a -> String
$cshow :: forall a. Show a => Builder a -> String
showsPrec :: Int -> Builder a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Builder a -> ShowS
Show)

atom :: Type -> a -> Builder a
atom :: Type -> a -> Builder a
atom Type
ty a
z = a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
z (SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Type -> SchemaF Schema
forall a. Type -> SchemaF a
Atom Type
ty))

instance Semigroup (Builder a) where
    Builder a
x Schema
l <> :: Builder a -> Builder a -> Builder a
<> Builder a
_ Schema
r = a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (Schema
l Schema -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema
r)
instance Functor Builder where
    fmap :: (a -> b) -> Builder a -> Builder b
fmap a -> b
f (Builder a
x Schema
s) = b -> Schema -> Builder b
forall a. a -> Schema -> Builder a
Builder (a -> b
f a
x) Schema
s
instance Applicative Builder where
    pure :: a -> Builder a
pure a
x = a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix SchemaF Schema
forall a. SchemaF a
Empty)
    Builder a -> b
f Schema
l <*> :: Builder (a -> b) -> Builder a -> Builder b
<*> Builder a
x Schema
r = b -> Schema -> Builder b
forall a. a -> Schema -> Builder a
Builder (a -> b
f a
x) (Schema -> Schema -> Schema
prodType Schema
l Schema
r)


class GToSchema f where
    gToSchema :: Builder (f a)


class ToSchema a where
    toSchema :: Builder a

    default toSchema :: (Generic a, GToSchema (Rep a)) => Builder a
    toSchema = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Builder (Rep a Any) -> Builder a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder (Rep a Any)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema

instance ToSchema a => ToSchema [a] where
    toSchema :: Builder [a]
toSchema = [a] -> Schema -> Builder [a]
forall a. a -> Schema -> Builder a
Builder [a
v] (SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Schema -> SchemaF Schema
forall a. a -> SchemaF a
List Schema
s))
      where
        Builder a
v Schema
s = Builder a
forall a. ToSchema a => Builder a
toSchema

instance GToSchema U1 where
    gToSchema :: Builder (U1 a)
gToSchema = U1 a -> Schema -> Builder (U1 a)
forall a. a -> Schema -> Builder a
Builder U1 a
forall k (p :: k). U1 p
U1 (SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix SchemaF Schema
forall a. SchemaF a
Empty)

instance (GToSchema a, GToSchema b) => GToSchema (a :*: b) where
    gToSchema :: Builder ((:*:) a b a)
gToSchema = (a a -> b a -> (:*:) a b a)
-> Builder (a a) -> Builder (b a) -> Builder ((:*:) a b a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) Builder (a a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema Builder (b a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema

instance (GToSchema a, GToSchema b) => GToSchema (a :+: b) where
    gToSchema :: Builder ((:+:) a b a)
gToSchema = (a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Builder (a a) -> Builder ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder (a a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema) Builder ((:+:) a b a)
-> Builder ((:+:) a b a) -> Builder ((:+:) a b a)
forall a. Semigroup a => a -> a -> a
<> (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Builder (b a) -> Builder ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder (b a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema)

instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
    gToSchema :: Builder (D1 d f a)
gToSchema =
        f a -> D1 d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> D1 d f a) -> Builder (f a) -> Builder (D1 d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Builder (f a) -> Builder (f a)
forall a. String -> String -> Builder a -> Builder a
addDatatypeName
            (M1 D d f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
moduleName (forall a. M1 D d f a
forall a. HasCallStack => a
undefined :: D1 d f a))
            (M1 D d f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall a. M1 D d f a
forall a. HasCallStack => a
undefined :: D1 d f a))
            Builder (f a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema
      where
        addDatatypeName :: String -> String -> Builder a -> Builder a
        addDatatypeName :: String -> String -> Builder a -> Builder a
addDatatypeName String
mName String
dName (Builder a
x (Fix (Sum Maybe DatatypeName
Nothing [Schema]
cs))) =
            a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (Schema -> Builder a)
-> ([Schema] -> Schema) -> [Schema] -> Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SchemaF Schema -> Schema)
-> ([Schema] -> SchemaF Schema) -> [Schema] -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DatatypeName -> [Schema] -> SchemaF Schema
forall a. Maybe DatatypeName -> [a] -> SchemaF a
Sum (DatatypeName -> Maybe DatatypeName
forall a. a -> Maybe a
Just (String
mName, String
dName)) ([Schema] -> Builder a) -> [Schema] -> Builder a
forall a b. (a -> b) -> a -> b
$ [Schema]
cs
        addDatatypeName String
_ String
_ Builder a
s = Builder a
s

instance (Constructor c, GToSchema f) => GToSchema (C1 c f) where
    gToSchema :: Builder (C1 c f a)
gToSchema = f a -> C1 c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> C1 c f a) -> Builder (f a) -> Builder (C1 c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Builder (f a) -> Builder (f a)
forall a. String -> Builder a -> Builder a
addConName (M1 C c f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall a. M1 C c f a
forall a. HasCallStack => a
undefined :: C1 c f a)) Builder (f a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema
      where
        addConName :: String -> Builder a -> Builder a
        addConName :: String -> Builder a -> Builder a
addConName String
name (Builder a
x (Fix SchemaF Schema
Empty)) =
            a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (Schema -> Builder a) -> (String -> Schema) -> String -> Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SchemaF Schema -> Schema)
-> (String -> SchemaF Schema) -> String -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> SchemaF Schema
forall a. Type -> SchemaF a
Atom (Type -> SchemaF Schema)
-> (String -> Type) -> String -> SchemaF Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Type
TyName (String -> Builder a) -> String -> Builder a
forall a b. (a -> b) -> a -> b
$ String
name
        addConName String
name (Builder a
x Schema
s) =
            a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (Schema -> Builder a) -> (Schema -> Schema) -> Schema -> Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SchemaF Schema -> Schema)
-> (Schema -> SchemaF Schema) -> Schema -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DatatypeName -> [Schema] -> SchemaF Schema
forall a. Maybe DatatypeName -> [a] -> SchemaF a
Sum Maybe DatatypeName
forall a. Maybe a
Nothing ([Schema] -> SchemaF Schema)
-> (Schema -> [Schema]) -> Schema -> SchemaF Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
:[]) (Schema -> [Schema]) -> (Schema -> Schema) -> Schema -> [Schema]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SchemaF Schema -> Schema)
-> (Schema -> SchemaF Schema) -> Schema -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Schema -> SchemaF Schema
forall a. String -> a -> SchemaF a
Con String
name (Schema -> Builder a) -> Schema -> Builder a
forall a b. (a -> b) -> a -> b
$ Schema
s

instance (Selector s, GToSchema f) => GToSchema (S1 s f) where
    gToSchema :: Builder (S1 s f a)
gToSchema = f a -> S1 s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 s f a) -> Builder (f a) -> Builder (S1 s f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Builder (f a) -> Builder (f a)
forall a. String -> Builder a -> Builder a
addSelName (M1 S s f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. M1 S s f a
forall a. HasCallStack => a
undefined :: S1 s f a)) Builder (f a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema
      where
        addSelName :: String -> Builder a -> Builder a
        addSelName :: String -> Builder a -> Builder a
addSelName String
"" Builder a
b               = Builder a
b
        addSelName String
name (Builder a
x Schema
s) = a -> Schema -> Builder a
forall a. a -> Schema -> Builder a
Builder a
x (Schema -> Builder a) -> (Schema -> Schema) -> Schema -> Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaF Schema -> Schema
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SchemaF Schema -> Schema)
-> (Schema -> SchemaF Schema) -> Schema -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Schema -> SchemaF Schema
forall a. String -> a -> SchemaF a
Field String
name (Schema -> Builder a) -> Schema -> Builder a
forall a b. (a -> b) -> a -> b
$ Schema
s

instance GToSchema a => GToSchema (M1 t c a) where
    gToSchema :: Builder (M1 t c a a)
gToSchema = a a -> M1 t c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 t c a a) -> Builder (a a) -> Builder (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder (a a)
forall (f :: * -> *) a. GToSchema f => Builder (f a)
gToSchema

instance ToSchema a => GToSchema (K1 i a) where
    gToSchema :: Builder (K1 i a a)
gToSchema = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> Builder a -> Builder (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder a
forall a. ToSchema a => Builder a
toSchema