content: {-# LANGUAGE AllowAmbiguousTypes #-}
  {-# LANGUAGE CPP                 #-}
  
  module Data.Schematic.DSL where
  
  import           Data.Kind
  import           Data.Schematic.Lens
  import           Data.Schematic.Schema
  import           Data.Scientific
  import           Data.Singletons
  import           Data.Singletons.Prelude hiding ((:.))
  import           Data.Singletons.TypeLits
  import           Data.Tagged
  import           Data.Text as T
  import           Data.Union
  import qualified Data.Vector as V
  import           Data.Vinyl
  import           Data.Vinyl.Functor
  
  
  #if MIN_VERSION_base(4,12,0)
  type Constructor a
    = forall fields b
    . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields)
    => Rec (Tagged fields :. FieldRepr) b
    -> JsonRepr ('SchemaObject fields)
  #else
  type Constructor a
    = forall fields b
    . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
    => Rec (Tagged fields :. FieldRepr) b
    -> JsonRepr ('SchemaObject fields)
  #endif
  withRepr :: Constructor a
  withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
  
  class Representable s where
    constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
  
  instance SingI so => Representable ('SchemaObject so) where
    constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
  
  instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
    constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
  
  instance SingI cs => Representable ('SchemaText cs) where
    constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
  
  instance SingI cs => Representable ('SchemaNumber cs) where
    constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
  
  instance Representable 'SchemaBoolean where
    constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
  
  instance SingI so => Representable ('SchemaOptional so) where
    constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
  
  instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
    constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
  
  construct :: Sing s -> Repr s -> JsonRepr s
  construct s r = case s of
    SSchemaObject _          -> ReprObject r
    SSchemaArray _ _         -> ReprArray r
    SSchemaText _            -> ReprText r
    SSchemaNumber _          -> ReprNumber r
    SSchemaBoolean           -> ReprBoolean r
    SSchemaOptional _        -> ReprOptional r
    SSchemaNull              -> ReprNull
    SSchemaUnion ss          -> case ss of
      SNil      -> error "unconstructable union"
      SCons _ _ -> ReprUnion r
  
  type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
    FieldsOf ('SchemaObject fs) = fs
  
  type FieldConstructor fn =
    forall byField fs. (byField ~ ByField fn fs (FIndex fn fs), Representable byField)
    => Repr byField
    -> (Tagged fs :. FieldRepr) '(fn, byField)
  
  field :: forall fn. KnownSymbol fn => FieldConstructor fn
  field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
  
  type family Repr (s :: Schema) = (ty :: Type) where
    Repr ('SchemaObject so) = Rec FieldRepr so
    Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
    Repr ('SchemaText cs) = Text
    Repr ('SchemaNumber cs) = Scientific
    Repr 'SchemaBoolean = Bool
    Repr ('SchemaOptional so) = Maybe (JsonRepr so)
    Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
  