mu-schema 0.2.0.0 → 0.3.0.0
raw patch · 12 files changed
+419/−562 lines, 12 files
Files
- mu-schema.cabal +1/−2
- src/Data/Functor/MaybeLike.hs +0/−29
- src/Mu/Adapter/Json.hs +64/−65
- src/Mu/Schema.hs +1/−1
- src/Mu/Schema/Class.hs +179/−196
- src/Mu/Schema/Conversion/SchemaToTypes.hs +3/−3
- src/Mu/Schema/Definition.hs +8/−2
- src/Mu/Schema/Examples.hs +14/−13
- src/Mu/Schema/Interpretation.hs +61/−158
- src/Mu/Schema/Interpretation/Anonymous.hs +40/−44
- src/Mu/Schema/Interpretation/Schemaless.hs +39/−40
- src/Mu/Schema/Registry.hs +9/−9
mu-schema.cabal view
@@ -1,5 +1,5 @@ name: mu-schema-version: 0.2.0.0+version: 0.3.0.0 synopsis: Format-independent schemas for serialization description: With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. See @mu-avro@, @mu-protobuf@ for the actual adapters.@@ -22,7 +22,6 @@ library exposed-modules:- Data.Functor.MaybeLike Mu.Adapter.Json Mu.Schema Mu.Schema.Annotations
− src/Data/Functor/MaybeLike.hs
@@ -1,29 +0,0 @@-{-|-Description : Type constructors which can be turned into 'Maybe'.--Type constructors which can be turned into 'Maybe'.--}-module Data.Functor.MaybeLike where--import Data.Functor.Identity---- | This class may be defined in two ways:------ * Type constructors which can be turned into 'Maybe' generically.--- * Type constructors which admit a natural transformation to 'Maybe'.------ We expect the following rules to hold for those--- instances of 'MaybeLike' which are also 'Control.Applicative.Alternative':------ * @likeMaybe empty = empty = Nothing@--- * @likeMaybe (x <|> y) = likeMaybe x <|> likeMaybe y@-class MaybeLike f where- likeMaybe :: f a -> Maybe a--instance MaybeLike Identity where- likeMaybe = Just . runIdentity-instance MaybeLike Maybe where- likeMaybe = id-instance MaybeLike (Either a) where- likeMaybe (Left _) = Nothing- likeMaybe (Right y) = Just y
src/Mu/Adapter/Json.hs view
@@ -22,7 +22,6 @@ import Data.Aeson import Data.Aeson.Types import Data.Functor.Contravariant-import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Vector as V@@ -30,13 +29,13 @@ import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess -instance Applicative w => SLess.ToSchemalessTerm Value w where+instance SLess.ToSchemalessTerm Value where toSchemalessTerm (Object o)- = SLess.TRecord $ map (\(k,v) -> SLess.Field k (pure $ SLess.toSchemalessValue v))+ = SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v)) $ HM.toList o toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) -instance Applicative w => SLess.ToSchemalessValue Value w where+instance SLess.ToSchemalessValue Value where toSchemalessValue r@(Object _) = SLess.FSchematic (SLess.toSchemalessTerm r) toSchemalessValue Null = SLess.FNull@@ -46,41 +45,41 @@ toSchemalessValue (Array xs) = SLess.FList $ map SLess.toSchemalessValue $ V.toList xs -instance (ToSchema w sch sty a, ToJSON (Term w sch (sch :/: sty)))- => ToJSON (WithSchema w sch sty a) where- toJSON (WithSchema x) = toJSON (toSchema' @_ @_ @sch @w x)-instance (FromSchema w sch sty a, FromJSON (Term w sch (sch :/: sty)))- => FromJSON (WithSchema w sch sty a) where- parseJSON v = WithSchema . fromSchema' @_ @_ @sch @w <$> parseJSON v+instance (ToSchema sch sty a, ToJSON (Term sch (sch :/: sty)))+ => ToJSON (WithSchema sch sty a) where+ toJSON (WithSchema x) = toJSON (toSchema' @_ @_ @sch x)+instance (FromSchema sch sty a, FromJSON (Term sch (sch :/: sty)))+ => FromJSON (WithSchema sch sty a) where+ parseJSON v = WithSchema . fromSchema' @_ @_ @sch <$> parseJSON v -instance ToJSONFields sch args => ToJSON (Term Identity sch ('DRecord name args)) where+instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name args)) where toJSON (TRecord fields) = Object (toJSONFields fields)-instance FromJSONFields w sch args => FromJSON (Term w sch ('DRecord name args)) where+instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name args)) where parseJSON (Object v) = TRecord <$> parseJSONFields v parseJSON _ = fail "expected object" class ToJSONFields sch fields where- toJSONFields :: NP (Field Identity sch) fields -> Object+ toJSONFields :: NP (Field sch) fields -> Object instance ToJSONFields sch '[] where toJSONFields _ = HM.empty-instance (KnownName name, ToJSON (FieldValue Identity sch t), ToJSONFields sch fs)+instance (KnownName name, ToJSON (FieldValue sch t), ToJSONFields sch fs) => ToJSONFields sch ('FieldDef name t ': fs) where- toJSONFields (Field (Identity v) :* rest) = HM.insert key value $ toJSONFields rest+ toJSONFields (Field v :* rest) = HM.insert key value $ toJSONFields rest where key = T.pack (nameVal (Proxy @name)) value = toJSON v -class FromJSONFields w sch fields where- parseJSONFields :: Object -> Parser (NP (Field w sch) fields)-instance FromJSONFields w sch '[] where- parseJSONFields _ = return Nil-instance (Applicative w, KnownName name, FromJSON (FieldValue w sch t), FromJSONFields w sch fs)- => FromJSONFields w sch ('FieldDef name t ': fs) where- parseJSONFields v = (:*) <$> (Field <$> (pure <$> v .: key)) <*> parseJSONFields v+class FromJSONFields sch fields where+ parseJSONFields :: Object -> Parser (NP (Field sch) fields)+instance FromJSONFields sch '[] where+ parseJSONFields _ = pure Nil+instance (KnownName name, FromJSON (FieldValue sch t), FromJSONFields sch fs)+ => FromJSONFields sch ('FieldDef name t ': fs) where+ parseJSONFields v = (:*) <$> (Field <$> v .: key) <*> parseJSONFields v where key = T.pack (nameVal (Proxy @name)) -instance ToJSONEnum choices => ToJSON (Term w sch ('DEnum name choices)) where+instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name choices)) where toJSON (TEnum choice) = String (toJSONEnum choice)-instance FromJSONEnum choices => FromJSON (Term w sch ('DEnum name choices)) where+instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name choices)) where parseJSON (String s) = TEnum <$> parseJSONEnum s parseJSON _ = fail "expected string" @@ -100,76 +99,76 @@ instance (KnownName c, FromJSONEnum cs) => FromJSONEnum ('ChoiceDef c ': cs) where parseJSONEnum v- | v == key = return (Z Proxy)+ | v == key = pure (Z Proxy) | otherwise = S <$> parseJSONEnum v where key = T.pack (nameVal (Proxy @c)) -instance ToJSON (FieldValue w sch t) => ToJSON (Term w sch ('DSimple t)) where+instance ToJSON (FieldValue sch t) => ToJSON (Term sch ('DSimple t)) where toJSON (TSimple x) = toJSON x-instance FromJSON (FieldValue w sch t) => FromJSON (Term w sch ('DSimple t)) where+instance FromJSON (FieldValue sch t) => FromJSON (Term sch ('DSimple t)) where parseJSON v = TSimple <$> parseJSON v -instance ToJSON (FieldValue w sch 'TNull) where+instance ToJSON (FieldValue sch 'TNull) where toJSON FNull = Null-instance ToJSON t => ToJSON (FieldValue w sch ('TPrimitive t)) where+instance ToJSON t => ToJSON (FieldValue sch ('TPrimitive t)) where toJSON (FPrimitive v) = toJSON v-instance ToJSONKey t => ToJSONKey (FieldValue w sch ('TPrimitive t)) where+instance ToJSONKey t => ToJSONKey (FieldValue sch ('TPrimitive t)) where toJSONKey = contramap FPrimitive toJSONKey toJSONKeyList = contramap (map FPrimitive) toJSONKeyList-instance ToJSON (Term w sch (sch :/: t))- => ToJSON (FieldValue w sch ('TSchematic t)) where+instance ToJSON (Term sch (sch :/: t))+ => ToJSON (FieldValue sch ('TSchematic t)) where toJSON (FSchematic v) = toJSON v-instance ToJSON (FieldValue w sch t)- => ToJSON (FieldValue w sch ('TOption t)) where+instance ToJSON (FieldValue sch t)+ => ToJSON (FieldValue sch ('TOption t)) where toJSON (FOption v) = toJSON v-instance ToJSON (FieldValue w sch t)- => ToJSON (FieldValue w sch ('TList t)) where+instance ToJSON (FieldValue sch t)+ => ToJSON (FieldValue sch ('TList t)) where toJSON (FList v) = toJSON v-instance (ToJSONKey (FieldValue w sch k), ToJSON (FieldValue w sch v))- => ToJSON (FieldValue w sch ('TMap k v)) where+instance (ToJSONKey (FieldValue sch k), ToJSON (FieldValue sch v))+ => ToJSON (FieldValue sch ('TMap k v)) where toJSON (FMap v) = toJSON v-instance (ToJSONUnion w sch us)- => ToJSON (FieldValue w sch ('TUnion us)) where+instance (ToJSONUnion sch us)+ => ToJSON (FieldValue sch ('TUnion us)) where toJSON (FUnion v) = unionToJSON v -class ToJSONUnion w sch us where- unionToJSON :: NS (FieldValue w sch) us -> Value-instance ToJSONUnion w sch '[] where+class ToJSONUnion sch us where+ unionToJSON :: NS (FieldValue sch) us -> Value+instance ToJSONUnion sch '[] where unionToJSON = error "this should never happen"-instance (ToJSON (FieldValue w sch u), ToJSONUnion w sch us)- => ToJSONUnion w sch (u ': us) where+instance (ToJSON (FieldValue sch u), ToJSONUnion sch us)+ => ToJSONUnion sch (u ': us) where unionToJSON (Z v) = toJSON v unionToJSON (S r) = unionToJSON r -instance FromJSON (FieldValue w sch 'TNull) where- parseJSON Null = return FNull+instance FromJSON (FieldValue sch 'TNull) where+ parseJSON Null = pure FNull parseJSON _ = fail "expected null"-instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where+instance FromJSON t => FromJSON (FieldValue sch ('TPrimitive t)) where parseJSON v = FPrimitive <$> parseJSON v-instance FromJSONKey t => FromJSONKey (FieldValue w sch ('TPrimitive t)) where+instance FromJSONKey t => FromJSONKey (FieldValue sch ('TPrimitive t)) where fromJSONKey = fmap FPrimitive fromJSONKey fromJSONKeyList = fmap (map FPrimitive) fromJSONKeyList-instance FromJSON (Term w sch (sch :/: t))- => FromJSON (FieldValue w sch ('TSchematic t)) where+instance FromJSON (Term sch (sch :/: t))+ => FromJSON (FieldValue sch ('TSchematic t)) where parseJSON v = FSchematic <$> parseJSON v-instance FromJSON (FieldValue w sch t)- => FromJSON (FieldValue w sch ('TOption t)) where+instance FromJSON (FieldValue sch t)+ => FromJSON (FieldValue sch ('TOption t)) where parseJSON v = FOption <$> parseJSON v-instance FromJSON (FieldValue w sch t)- => FromJSON (FieldValue w sch ('TList t)) where+instance FromJSON (FieldValue sch t)+ => FromJSON (FieldValue sch ('TList t)) where parseJSON v = FList <$> parseJSON v-instance ( FromJSONKey (FieldValue w sch k), FromJSON (FieldValue w sch v)- , Ord (FieldValue w sch k) )- => FromJSON (FieldValue w sch ('TMap k v)) where+instance ( FromJSONKey (FieldValue sch k), FromJSON (FieldValue sch v)+ , Ord (FieldValue sch k) )+ => FromJSON (FieldValue sch ('TMap k v)) where parseJSON v = FMap <$> parseJSON v-instance (FromJSONUnion w sch us)- => FromJSON (FieldValue w sch ('TUnion us)) where+instance (FromJSONUnion sch us)+ => FromJSON (FieldValue sch ('TUnion us)) where parseJSON v = FUnion <$> unionFromJSON v -class FromJSONUnion w sch us where- unionFromJSON :: Value -> Parser (NS (FieldValue w sch) us)-instance FromJSONUnion w sch '[] where+class FromJSONUnion sch us where+ unionFromJSON :: Value -> Parser (NS (FieldValue sch) us)+instance FromJSONUnion sch '[] where unionFromJSON _ = fail "value does not match any of the types of the union"-instance (FromJSON (FieldValue w sch u), FromJSONUnion w sch us)- => FromJSONUnion w sch (u ': us) where+instance (FromJSON (FieldValue sch u), FromJSONUnion sch us)+ => FromJSONUnion sch (u ': us) where unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v
src/Mu/Schema.hs view
@@ -25,7 +25,7 @@ , Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..) -- * Conversion from types to schemas-, WithSchema(..)+, WithSchema(..), unWithSchema , FromSchema(..), fromSchema' , ToSchema(..), toSchema' , CustomFieldMapping(..)
src/Mu/Schema/Class.hs view
@@ -24,8 +24,8 @@ @DeriveGeneric@ and @DeriveAnyClass@, you can do: > data MyHaskellType = ...-> deriving ( ToSchema f MySchema "MySchemaType" MyHaskellType-> , FromSchema f MySchema "MySchemaType" MyHaskellType)+> deriving ( ToSchema MySchema "MySchemaType" MyHaskellType+> , FromSchema MySchema "MySchemaType" MyHaskellType) If the default mapping which required identical names for fields in the Haskell and schema types@@ -37,12 +37,10 @@ , ToSchema(..), toSchema' , CustomFieldMapping(..) , Mapping(..), Mappings, MappingRight, MappingLeft-, transSchema -- * Internal use only , GToSchemaRecord(..) ) where -import Data.Functor.Identity import Data.Kind import Data.Map as M import Data.SOP@@ -54,12 +52,14 @@ -- | Tags a value with its schema. -- For usage with @deriving via@.-newtype WithSchema (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a where- WithSchema :: forall tn fn (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a.- a -> WithSchema w sch sty a+newtype WithSchema (sch :: Schema tn fn) (sty :: tn) a where+ WithSchema :: forall tn fn (sch :: Schema tn fn) (sty :: tn) a.+ a -> WithSchema sch sty a -unWithSchema :: forall tn fn (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a.- WithSchema w sch sty a -> a+-- | Accessor for 'WithSchema'.+-- Intended for usage with @TypeApplications@.+unWithSchema :: forall tn fn (sch :: Schema tn fn) (sty :: tn) a.+ WithSchema sch sty a -> a unWithSchema (WithSchema x) = x -- | Defines the conversion of a type @t@ into a 'Term'@@ -67,14 +67,14 @@ -- You can give an optional mapping between the -- field names of @t@ and that of @sty@ -- by means of 'CustomFieldMapping'.-class ToSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)+class ToSchema (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) | sch t -> sty where -- | Conversion from Haskell type to schema term.- toSchema :: t -> Term w sch (sch :/: sty)+ toSchema :: t -> Term sch (sch :/: sty) default- toSchema :: (Generic t, GToSchemaTypeDef w sch '[] (sch :/: sty) (Rep t))- => t -> Term w sch (sch :/: sty)+ toSchema :: (Generic t, GToSchemaTypeDef sch '[] (sch :/: sty) (Rep t))+ => t -> Term sch (sch :/: sty) toSchema x = toSchemaTypeDef (Proxy @'[]) (from x) -- | Defines the conversion from a 'Term'@@ -82,40 +82,40 @@ -- You can give an optional mapping between the -- field names of @t@ and that of @sty@ -- by means of 'CustomFieldMapping'.-class FromSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type)+class FromSchema (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) | sch t -> sty where -- | Conversion from schema term to Haskell type.- fromSchema :: Term w sch (sch :/: sty) -> t+ fromSchema :: Term sch (sch :/: sty) -> t default- fromSchema :: (Generic t, GFromSchemaTypeDef w sch '[] (sch :/: sty) (Rep t) )- => Term w sch (sch :/: sty) -> t+ fromSchema :: (Generic t, GFromSchemaTypeDef sch '[] (sch :/: sty) (Rep t) )+ => Term sch (sch :/: sty) -> t fromSchema x = to (fromSchemaTypeDef (Proxy @'[]) x) instance (sch :/: sty ~ 'DRecord sty fields)- => ToSchema w sch sty (Term w sch ('DRecord sty fields)) where+ => ToSchema sch sty (Term sch ('DRecord sty fields)) where toSchema = id instance (sch :/: sty ~ 'DEnum sty choices)- => ToSchema w sch sty (Term w sch ('DEnum sty choices)) where+ => ToSchema sch sty (Term sch ('DEnum sty choices)) where toSchema = id instance (sch :/: sty ~ 'DRecord sty fields)- => FromSchema w sch sty (Term w sch ('DRecord sty fields)) where+ => FromSchema sch sty (Term sch ('DRecord sty fields)) where fromSchema = id instance (sch :/: sty ~ 'DEnum sty choices)- => FromSchema w sch sty (Term w sch ('DEnum sty choices)) where+ => FromSchema sch sty (Term sch ('DEnum sty choices)) where fromSchema = id -- | Conversion from Haskell type to schema term. -- This version is intended for usage with @TypeApplications@: -- > toSchema' @MySchema myValue-toSchema' :: forall fn tn (sch :: Schema tn fn) w t sty.- ToSchema w sch sty t => t -> Term w sch (sch :/: sty)+toSchema' :: forall fn tn (sch :: Schema tn fn) t sty.+ ToSchema sch sty t => t -> Term sch (sch :/: sty) toSchema' = toSchema -- | Conversion from schema term to Haskell type. -- This version is intended for usage with @TypeApplications@: -- > fromSchema' @MySchema mySchemaTerm-fromSchema' :: forall fn tn (sch :: Schema tn fn) w t sty.- FromSchema w sch sty t => Term w sch (sch :/: sty) -> t+fromSchema' :: forall fn tn (sch :: Schema tn fn) t sty.+ FromSchema sch sty t => Term sch (sch :/: sty) -> t fromSchema' = fromSchema -- | By default, the names of the fields in the Haskell type@@ -132,23 +132,14 @@ newtype CustomFieldMapping (sty :: typeName) (fmap :: [Mapping Symbol fieldName]) a = CustomFieldMapping a -instance (Generic t, GToSchemaTypeDef w sch fmap (sch :/: sty) (Rep t))- => ToSchema w sch sty (CustomFieldMapping sty fmap t) where+instance (Generic t, GToSchemaTypeDef sch fmap (sch :/: sty) (Rep t))+ => ToSchema sch sty (CustomFieldMapping sty fmap t) where toSchema (CustomFieldMapping x) = toSchemaTypeDef (Proxy @fmap) (from x) -instance (Generic t, GFromSchemaTypeDef w sch fmap (sch :/: sty) (Rep t))- => FromSchema w sch sty (CustomFieldMapping sty fmap t) where+instance (Generic t, GFromSchemaTypeDef sch fmap (sch :/: sty) (Rep t))+ => FromSchema sch sty (CustomFieldMapping sty fmap t) where fromSchema x = CustomFieldMapping $ to (fromSchemaTypeDef (Proxy @fmap) x) --- | Changes the underlying wrapper of a Haskell type,--- by converting back and forth 'Term's with those wrappers.-transSchema- :: forall fn tn (sch :: Schema tn fn) sty u v a b.- ( ToSchema u sch sty a, FromSchema v sch sty b- , Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k) )- => (forall x. u x -> v x) -> Proxy sch -> a -> b-transSchema f _ = fromSchema @_ @_ @v @sch @sty . transWrap f . toSchema @_ @_ @u @sch @sty- -- ====================== -- CRAZY GENERICS SECTION -- ======================@@ -159,7 +150,7 @@ -- Note: it turns out that GHC.Generics generates some weird -- instances for records in the form (x :*: y) :*: z -- and we cover them with the special HereLeft and HereRight-data Where = Here | HereLeft | HereRight | There Where+data Where = Here | HereLeft | HereRight | HereRightThenLeft | HereTwoRights | There Where type family Find (xs :: [k]) (x :: k) :: Where where Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y)@@ -177,6 +168,8 @@ FindSel (S1 ('MetaSel ('Just x) u ss ds) f :*: rest) x = 'Here FindSel ((S1 ('MetaSel ('Just x) u ss ds) f :*: other) :*: rest) x = 'HereLeft FindSel ((other :*: S1 ('MetaSel ('Just x) u ss ds) f) :*: rest) x = 'HereRight+ FindSel ((other1 :*: (S1 ('MetaSel ('Just x) u ss ds) f :*: other2)) :*: rest) x = 'HereRightThenLeft+ FindSel ((other1 :*: (other2 :*: S1 ('MetaSel ('Just x) u ss ds) f)) :*: rest) x = 'HereTwoRights FindSel (other :*: rest) x = 'There (FindSel rest x) FindSel nothing x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x) @@ -192,168 +185,168 @@ -- Generic type definitions class GToSchemaTypeDef- (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)+ (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) where- toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch t+ toSchemaTypeDef :: Proxy fmap -> f a -> Term sch t class GFromSchemaTypeDef- (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)+ (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (t :: TypeDef ts fs) (f :: * -> *) where- fromSchemaTypeDef :: Proxy fmap -> Term w sch t -> f a+ fromSchemaTypeDef :: Proxy fmap -> Term sch t -> f a -- ------------------ -- TYPES OF FIELDS -- -- ------------------ -instance GToSchemaFieldTypeWrap w sch t f- => GToSchemaTypeDef w sch fmap ('DSimple t) f where+instance GToSchemaFieldTypeWrap sch t f+ => GToSchemaTypeDef sch fmap ('DSimple t) f where toSchemaTypeDef _ x = TSimple (toSchemaFieldTypeW x)-instance GFromSchemaFieldTypeWrap w sch t f- => GFromSchemaTypeDef w sch fmap ('DSimple t) f where+instance GFromSchemaFieldTypeWrap sch t f+ => GFromSchemaTypeDef sch fmap ('DSimple t) f where fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x class GToSchemaFieldTypeWrap- (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where- toSchemaFieldTypeW :: f a -> FieldValue w sch t+ (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where+ toSchemaFieldTypeW :: f a -> FieldValue sch t class GFromSchemaFieldTypeWrap- (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where- fromSchemaFieldTypeW :: FieldValue w sch t -> f a+ (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where+ fromSchemaFieldTypeW :: FieldValue sch t -> f a -instance GToSchemaFieldType w sch t f- => GToSchemaFieldTypeWrap w sch t (K1 i f) where+instance GToSchemaFieldType sch t f+ => GToSchemaFieldTypeWrap sch t (K1 i f) where toSchemaFieldTypeW (K1 x) = toSchemaFieldType x-instance GFromSchemaFieldType w sch t f- => GFromSchemaFieldTypeWrap w sch t (K1 i f) where+instance GFromSchemaFieldType sch t f+ => GFromSchemaFieldTypeWrap sch t (K1 i f) where fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x)-instance GToSchemaFieldTypeWrap w sch t f- => GToSchemaFieldTypeWrap w sch t (M1 s m f) where+instance GToSchemaFieldTypeWrap sch t f+ => GToSchemaFieldTypeWrap sch t (M1 s m f) where toSchemaFieldTypeW (M1 x) = toSchemaFieldTypeW x-instance GFromSchemaFieldTypeWrap w sch t f- => GFromSchemaFieldTypeWrap w sch t (M1 s m f) where+instance GFromSchemaFieldTypeWrap sch t f+ => GFromSchemaFieldTypeWrap sch t (M1 s m f) where fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x) class GToSchemaFieldType- (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where- toSchemaFieldType :: f -> FieldValue w sch t+ (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where+ toSchemaFieldType :: f -> FieldValue sch t class GFromSchemaFieldType- (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where- fromSchemaFieldType :: FieldValue w sch t -> f+ (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where+ fromSchemaFieldType :: FieldValue sch t -> f class GToSchemaFieldTypeUnion- (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where- toSchemaFieldTypeUnion :: f a -> NS (FieldValue w sch) t+ (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where+ toSchemaFieldTypeUnion :: f a -> NS (FieldValue sch) t class GFromSchemaFieldTypeUnion- (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where- fromSchemaFieldTypeUnion :: NS (FieldValue w sch) t -> f a+ (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where+ fromSchemaFieldTypeUnion :: NS (FieldValue sch) t -> f a -- These instances are straightforward, -- just turn the "real types" into their -- schema correspondants.-instance GToSchemaFieldType w sch 'TNull () where+instance GToSchemaFieldType sch 'TNull () where toSchemaFieldType _ = FNull-instance GFromSchemaFieldType w sch 'TNull () where+instance GFromSchemaFieldType sch 'TNull () where fromSchemaFieldType _ = ()-instance GToSchemaFieldType w sch ('TPrimitive t) t where+instance GToSchemaFieldType sch ('TPrimitive t) t where toSchemaFieldType = FPrimitive-instance GFromSchemaFieldType w sch ('TPrimitive t) t where+instance GFromSchemaFieldType sch ('TPrimitive t) t where fromSchemaFieldType (FPrimitive x) = x -- These instances "tie the loop" with the whole schema, -- and they are the reason why we need to thread the @sch@ -- type throghout the whole implementation.-instance ToSchema w sch t v- => GToSchemaFieldType w sch ('TSchematic t) v where+instance ToSchema sch t v+ => GToSchemaFieldType sch ('TSchematic t) v where toSchemaFieldType x = FSchematic $ toSchema x-instance FromSchema w sch t v- => GFromSchemaFieldType w sch ('TSchematic t) v where+instance FromSchema sch t v+ => GFromSchemaFieldType sch ('TSchematic t) v where fromSchemaFieldType (FSchematic x) = fromSchema x-instance GToSchemaFieldType w sch t v- => GToSchemaFieldType w sch ('TOption t) (Maybe v) where+instance GToSchemaFieldType sch t v+ => GToSchemaFieldType sch ('TOption t) (Maybe v) where toSchemaFieldType x = FOption (toSchemaFieldType <$> x)-instance GFromSchemaFieldType w sch t v- => GFromSchemaFieldType w sch ('TOption t) (Maybe v) where+instance GFromSchemaFieldType sch t v+ => GFromSchemaFieldType sch ('TOption t) (Maybe v) where fromSchemaFieldType (FOption x) = fromSchemaFieldType <$> x-instance GToSchemaFieldType w sch t v- => GToSchemaFieldType w sch ('TList t) [v] where+instance GToSchemaFieldType sch t v+ => GToSchemaFieldType sch ('TList t) [v] where toSchemaFieldType x = FList (toSchemaFieldType <$> x)-instance GFromSchemaFieldType w sch t v- => GFromSchemaFieldType w sch ('TList t) [v] where+instance GFromSchemaFieldType sch t v+ => GFromSchemaFieldType sch ('TList t) [v] where fromSchemaFieldType (FList x) = fromSchemaFieldType <$> x-instance (GToSchemaFieldType w sch sk hk, GToSchemaFieldType w sch sv hv,- Ord (FieldValue w sch sk)) -- Ord is required to build a map- => GToSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where+instance (GToSchemaFieldType sch sk hk, GToSchemaFieldType sch sv hv,+ Ord (FieldValue sch sk)) -- Ord is required to build a map+ => GToSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType x))-instance (GFromSchemaFieldType w sch sk hk, GFromSchemaFieldType w sch sv hv, Ord hk)- => GFromSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where+instance (GFromSchemaFieldType sch sk hk, GFromSchemaFieldType sch sv hv, Ord hk)+ => GFromSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x) -- This assumes that a union is represented by -- a value of type 'NS', where types are in -- the same order. instance {-# OVERLAPS #-}- AllZip (GToSchemaFieldType w sch) ts vs- => GToSchemaFieldType w sch ('TUnion ts) (NS I vs) where+ AllZip (GToSchemaFieldType sch) ts vs+ => GToSchemaFieldType sch ('TUnion ts) (NS I vs) where toSchemaFieldType t = FUnion (go t)- where go :: AllZip (GToSchemaFieldType w sch) tss vss- => NS I vss -> NS (FieldValue w sch) tss+ where go :: AllZip (GToSchemaFieldType sch) tss vss+ => NS I vss -> NS (FieldValue sch) tss go (Z (I x)) = Z (toSchemaFieldType x) go (S n) = S (go n) instance {-# OVERLAPS #-}- AllZip (GFromSchemaFieldType w sch) ts vs- => GFromSchemaFieldType w sch ('TUnion ts) (NS I vs) where+ AllZip (GFromSchemaFieldType sch) ts vs+ => GFromSchemaFieldType sch ('TUnion ts) (NS I vs) where fromSchemaFieldType (FUnion t) = go t- where go :: AllZip (GFromSchemaFieldType w sch) tss vss- => NS (FieldValue w sch) tss -> NS I vss+ where go :: AllZip (GFromSchemaFieldType sch) tss vss+ => NS (FieldValue sch) tss -> NS I vss go (Z x) = Z (I (fromSchemaFieldType x)) go (S n) = S (go n) -- But we can also use any other if it has -- the right structure instance {-# OVERLAPPABLE #-}- (Generic f, GToSchemaFieldTypeUnion w sch ts (Rep f))- => GToSchemaFieldType w sch ('TUnion ts) f where+ (Generic f, GToSchemaFieldTypeUnion sch ts (Rep f))+ => GToSchemaFieldType sch ('TUnion ts) f where toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) instance {-# OVERLAPPABLE #-}- (Generic f, GFromSchemaFieldTypeUnion w sch ts (Rep f))- => GFromSchemaFieldType w sch ('TUnion ts) f where+ (Generic f, GFromSchemaFieldTypeUnion sch ts (Rep f))+ => GFromSchemaFieldType sch ('TUnion ts) f where fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) -instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion w sch '[] U1 where+instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion sch '[] U1 where toSchemaFieldTypeUnion U1 = error "this should never happen"-instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion w sch '[] U1 where+instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion sch '[] U1 where fromSchemaFieldTypeUnion _ = U1 instance {-# OVERLAPPABLE #-} TypeError ('Text "the type does not match the union")- => GToSchemaFieldTypeUnion w sch '[] f where+ => GToSchemaFieldTypeUnion sch '[] f where toSchemaFieldTypeUnion = error "this should never happen" instance {-# OVERLAPPABLE #-} TypeError ('Text "the type does not match the union")- => GFromSchemaFieldTypeUnion w sch '[] f where+ => GFromSchemaFieldTypeUnion sch '[] f where fromSchemaFieldTypeUnion = error "this should never happen" -instance (GToSchemaFieldTypeWrap w sch t v)- => GToSchemaFieldTypeUnion w sch '[t] v where+instance (GToSchemaFieldTypeWrap sch t v)+ => GToSchemaFieldTypeUnion sch '[t] v where toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x)-instance (GFromSchemaFieldTypeWrap w sch t v)- => GFromSchemaFieldTypeUnion w sch '[t] v where+instance (GFromSchemaFieldTypeWrap sch t v)+ => GFromSchemaFieldTypeUnion sch '[t] v where fromSchemaFieldTypeUnion (Z x) = fromSchemaFieldTypeW x fromSchemaFieldTypeUnion (S _) = error "this should never happen"-instance (GToSchemaFieldTypeWrap w sch t v, GToSchemaFieldTypeUnion w sch ts vs)- => GToSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where+instance (GToSchemaFieldTypeWrap sch t v, GToSchemaFieldTypeUnion sch ts vs)+ => GToSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x) toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r)-instance (GFromSchemaFieldTypeWrap w sch t v, GFromSchemaFieldTypeUnion w sch ts vs)- => GFromSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where+instance (GFromSchemaFieldTypeWrap sch t v, GFromSchemaFieldTypeUnion sch ts vs)+ => GFromSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where fromSchemaFieldTypeUnion (Z x) = L1 (fromSchemaFieldTypeW x) fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r) -- Weird nested instance produced by GHC-instance ( GToSchemaFieldTypeWrap w sch t1 v1- , GToSchemaFieldTypeWrap w sch t2 v2- , GToSchemaFieldTypeUnion w sch ts vs )- => GToSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where+instance ( GToSchemaFieldTypeWrap sch t1 v1+ , GToSchemaFieldTypeWrap sch t2 v2+ , GToSchemaFieldTypeUnion sch ts vs )+ => GToSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where toSchemaFieldTypeUnion (L1 (L1 x)) = Z (toSchemaFieldTypeW x) toSchemaFieldTypeUnion (L1 (R1 x)) = S (Z (toSchemaFieldTypeW x)) toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r))-instance ( GFromSchemaFieldTypeWrap w sch t1 v1- , GFromSchemaFieldTypeWrap w sch t2 v2- , GFromSchemaFieldTypeUnion w sch ts vs )- => GFromSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where+instance ( GFromSchemaFieldTypeWrap sch t1 v1+ , GFromSchemaFieldTypeWrap sch t2 v2+ , GFromSchemaFieldTypeUnion sch ts vs )+ => GFromSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where fromSchemaFieldTypeUnion (Z x) = L1 (L1 (fromSchemaFieldTypeW x)) fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x)) fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r)@@ -365,21 +358,21 @@ instance {-# OVERLAPPABLE #-} (GToSchemaEnumDecompose fmap choices f)- => GToSchemaTypeDef w sch fmap ('DEnum name choices) f where+ => GToSchemaTypeDef sch fmap ('DEnum name choices) f where toSchemaTypeDef p x = TEnum (toSchemaEnumDecomp p x) instance {-# OVERLAPPABLE #-} (GFromSchemaEnumDecompose fmap choices f)- => GFromSchemaTypeDef w sch fmap ('DEnum name choices) f where+ => GFromSchemaTypeDef sch fmap ('DEnum name choices) f where fromSchemaTypeDef p (TEnum x) = fromSchemaEnumDecomp p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-}- GToSchemaTypeDef w sch fmap ('DEnum name choices) f- => GToSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where+ GToSchemaTypeDef sch fmap ('DEnum name choices) f+ => GToSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x instance {-# OVERLAPS #-}- GFromSchemaTypeDef w sch fmap ('DEnum name choices) f- => GFromSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where+ GFromSchemaTypeDef sch fmap ('DEnum name choices) f+ => GFromSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) -- 'toSchema' for enumerations:@@ -443,30 +436,30 @@ ------------- instance {-# OVERLAPPABLE #-}- (GToSchemaRecord w sch fmap args f)- => GToSchemaTypeDef w sch fmap ('DRecord name args) f where+ (GToSchemaRecord sch fmap args f)+ => GToSchemaTypeDef sch fmap ('DRecord name args) f where toSchemaTypeDef p x = TRecord (toSchemaRecord p x) instance {-# OVERLAPPABLE #-}- (GFromSchemaRecord w sch fmap args f)- => GFromSchemaTypeDef w sch fmap ('DRecord name args) f where+ (GFromSchemaRecord sch fmap args f)+ => GFromSchemaTypeDef sch fmap ('DRecord name args) f where fromSchemaTypeDef p (TRecord x) = fromSchemaRecord p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-}- GToSchemaTypeDef w sch fmap ('DRecord name args) f- => GToSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where+ GToSchemaTypeDef sch fmap ('DRecord name args) f+ => GToSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x instance {-# OVERLAPS #-}- GFromSchemaTypeDef w sch fmap ('DRecord name args) f- => GFromSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where+ GFromSchemaTypeDef sch fmap ('DRecord name args) f+ => GFromSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) instance {-# OVERLAPS #-}- GToSchemaTypeDef w sch fmap ('DRecord name args) f- => GToSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where+ GToSchemaTypeDef sch fmap ('DRecord name args) f+ => GToSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x instance {-# OVERLAPS #-}- GFromSchemaTypeDef w sch fmap ('DRecord name args) f- => GFromSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where+ GFromSchemaTypeDef sch fmap ('DRecord name args) f+ => GFromSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) -- 'toSchema' for records:@@ -484,47 +477,41 @@ -- (see 'HereLeft' and 'HereRight' instances) -- | For internal use only: generic conversion of a list of fields.-class GToSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)+class GToSchemaRecord (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs]) (f :: * -> *) where- toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) args-instance GToSchemaRecord w sch fmap '[] f where+ toSchemaRecord :: Proxy fmap -> f a -> NP (Field sch) args+instance GToSchemaRecord sch fmap '[] f where toSchemaRecord _ _ = Nil-instance ( GToSchemaRecord w sch fmap cs f- , GToSchemaRecordSearch w sch t f (FindSel f (MappingLeft fmap name)) )- => GToSchemaRecord w sch fmap ('FieldDef name t ': cs) f where- toSchemaRecord p x = this :* toSchemaRecord p x+instance ( GToSchemaRecord sch fmap cs f+ , GToSchemaRecordSearch sch t f (FindSel f (MappingLeft fmap name)) )+ => GToSchemaRecord sch fmap ('FieldDef name t ': cs) f where+ toSchemaRecord p x = this :* toSchemaRecord p x where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x) -class GToSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs)+class GToSchemaRecordSearch (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) (wh :: Where) where- toSchemaRecordSearch :: Proxy wh -> f a -> w (FieldValue w sch t)-instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v- => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v)) 'Here where- toSchemaRecordSearch _ (M1 (K1 x)) = Identity (toSchemaFieldType x)-instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)- => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v))) 'Here where- toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType <$> x-instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v- => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v) :*: rest) 'Here where- toSchemaRecordSearch _ (M1 (K1 x) :*: _) = Identity (toSchemaFieldType x)-instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)- => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v)) :*: rest) 'Here where- toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType <$> x-instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v- => GToSchemaRecordSearch Identity sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where- toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = Identity (toSchemaFieldType x)-instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)- => GToSchemaRecordSearch w sch t ((S1 m (K1 i (w v)) :*: other) :*: rest) 'HereLeft where- toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType <$> x-instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v- => GToSchemaRecordSearch Identity sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where- toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = Identity (toSchemaFieldType x)-instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v)- => GToSchemaRecordSearch w sch t ((other :*: S1 m (K1 i (w v))) :*: rest) 'HereRight where- toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType <$> x-instance forall sch t other rest n w.- GToSchemaRecordSearch w sch t rest n- => GToSchemaRecordSearch w sch t (other :*: rest) ('There n) where+ toSchemaRecordSearch :: Proxy wh -> f a -> FieldValue sch t+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where+ toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t (S1 m (K1 i v) :*: rest) 'Here where+ toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType x+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where+ toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType x+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where+ toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType x+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t ((other1 :*: (S1 m (K1 i v) :*: other2)) :*: rest) 'HereRightThenLeft where+ toSchemaRecordSearch _ ((_ :*: (M1 (K1 x) :*: _)) :*: _) = toSchemaFieldType x+instance GToSchemaFieldType sch t v+ => GToSchemaRecordSearch sch t ((other1 :*: (other2 :*: S1 m (K1 i v))) :*: rest) 'HereTwoRights where+ toSchemaRecordSearch _ ((_ :*: (_ :*: M1 (K1 x))) :*: _) = toSchemaFieldType x+instance forall sch t other rest n.+ GToSchemaRecordSearch sch t rest n+ => GToSchemaRecordSearch sch t (other :*: rest) ('There n) where toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs -- 'fromSchema' for records@@ -535,31 +522,27 @@ -- this is done by 'MappingRight' and 'FindField' -- 3. using that location, obtain the value of the field -- this is done by 'GFromSchemaRecordSearch'-class GFromSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)+class GFromSchemaRecord (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs]) (f :: * -> *) where- fromSchemaRecord :: Proxy fmap -> NP (Field w sch) args -> f a-instance {-# OVERLAPS #-}- (GFromSchemaRecordSearch Identity sch v args (FindField args (MappingRight fmap name)))- => GFromSchemaRecord Identity sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where- fromSchemaRecord _ x = M1 $ K1 $ runIdentity $ fromSchemaRecordSearch (Proxy @(FindField args (MappingRight fmap name))) x-instance {-# OVERLAPPABLE #-}- (GFromSchemaRecordSearch w sch v args (FindField args (MappingRight fmap name)))- => GFromSchemaRecord w sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v))) where- fromSchemaRecord _ x = M1 $ K1 $ fromSchemaRecordSearch (Proxy @(FindField args (MappingRight fmap name))) x-instance ( GFromSchemaRecord w sch fmap args oneway- , GFromSchemaRecord w sch fmap args oranother )- => GFromSchemaRecord w sch fmap args (oneway :*: oranother) where+ fromSchemaRecord :: Proxy fmap -> NP (Field sch) args -> f a+instance (GFromSchemaRecordSearch sch v args (FindField args (MappingRight fmap name)))+ => GFromSchemaRecord sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where+ fromSchemaRecord _ x+ = M1 $ K1 $ fromSchemaRecordSearch (Proxy @(FindField args (MappingRight fmap name))) x+instance ( GFromSchemaRecord sch fmap args oneway+ , GFromSchemaRecord sch fmap args oranother )+ => GFromSchemaRecord sch fmap args (oneway :*: oranother) where fromSchemaRecord p x = fromSchemaRecord p x :*: fromSchemaRecord p x-instance GFromSchemaRecord w sch fmap args U1 where+instance GFromSchemaRecord sch fmap args U1 where fromSchemaRecord _ _ = U1 -class GFromSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs)+class GFromSchemaRecordSearch (sch :: Schema ts fs) (v :: *) (args :: [FieldDef ts fs]) (wh :: Where) where- fromSchemaRecordSearch :: Proxy wh -> NP (Field w sch) args -> w v-instance (Functor w, GFromSchemaFieldType w sch t v)- => GFromSchemaRecordSearch w sch v ('FieldDef name t ': rest) 'Here where- fromSchemaRecordSearch _ (Field x :* _) = fromSchemaFieldType <$> x-instance forall sch v other rest n w.- GFromSchemaRecordSearch w sch v rest n- => GFromSchemaRecordSearch w sch v (other ': rest) ('There n) where+ fromSchemaRecordSearch :: Proxy wh -> NP (Field sch) args -> v+instance (GFromSchemaFieldType sch t v)+ => GFromSchemaRecordSearch sch v ('FieldDef name t ': rest) 'Here where+ fromSchemaRecordSearch _ (Field x :* _) = fromSchemaFieldType x+instance forall sch v other rest n.+ GFromSchemaRecordSearch sch v rest n+ => GFromSchemaRecordSearch sch v (other ': rest) ('There n) where fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs
src/Mu/Schema/Conversion/SchemaToTypes.hs view
@@ -59,7 +59,7 @@ [pure (DerivClause Nothing [ConT ''Generic])] _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f])- return [d] -- , hsi]+ pure [d] -- , hsi] -- Records with more than one field typeDefToDecl _schemaTy namer (DRecord name fields) = do let complete = completeName namer name@@ -72,7 +72,7 @@ [pure (DerivClause Nothing [ConT ''Generic])] _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields)- return [d] -- , hsi]+ pure [d] -- , hsi] -- Enumerations typeDefToDecl _schemaTy namer (DEnum name choices) = do let complete = completeName namer name@@ -86,7 +86,7 @@ [pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])] _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices)- return [d] --, hsi]+ pure [d] --, hsi] -- Simple things typeDefToDecl _ _ (DSimple _) = fail "DSimple is not supported"
src/Mu/Schema/Definition.hs view
@@ -159,8 +159,11 @@ -- | Finds the corresponding right value of @v@ -- in a mapping @ms@. When the kinds are 'Symbol', -- return the same value if not found.+-- When the return type is 'Type', return ' ()'+-- if the value is not found. type family MappingRight (ms :: Mappings a b) (v :: a) :: b where- MappingRight '[] (v :: Symbol) = v+ MappingRight '[] (v :: Symbol) = (v :: Symbol)+ MappingRight '[] (v :: Symbol) = (() :: Type) MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) MappingRight ((x ':-> y) ': rest) x = y MappingRight (other ': rest) x = MappingRight rest x@@ -168,8 +171,11 @@ -- | Finds the corresponding left value of @v@ -- in a mapping @ms@. When the kinds are 'Symbol', -- return the same value if not found.+-- When the return type is 'Type', return ' ()'+-- if the value is not found. type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where- MappingLeft '[] (v :: Symbol) = v+ MappingLeft '[] (v :: Symbol) = (v :: Symbol)+ MappingLeft '[] (v :: Symbol) = (() :: Type) MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) MappingLeft ((x ':-> y) ': rest) y = x MappingLeft (other ': rest) y = MappingLeft rest y
src/Mu/Schema/Examples.hs view
@@ -21,7 +21,6 @@ module Mu.Schema.Examples where import qualified Data.Aeson as J-import Data.Functor.Identity import qualified Data.Text as T import GHC.Generics @@ -30,23 +29,24 @@ import Mu.Schema.Conversion.SchemaToTypes data Person- = Person { firstName :: T.Text- , lastName :: T.Text- , age :: Maybe Int- , gender :: Maybe Gender- , address :: Address }+ = Person { firstName :: T.Text+ , lastName :: T.Text+ , age :: Maybe Int+ , gender :: Maybe Gender+ , address :: Address+ , lucky_numbers :: [Int] } deriving (Eq, Show, Generic)- deriving (ToSchema Identity ExampleSchema "person", FromSchema Identity ExampleSchema "person")+ deriving (ToSchema ExampleSchema "person", FromSchema ExampleSchema "person") deriving (J.ToJSON, J.FromJSON)- via (WithSchema Identity ExampleSchema "person" Person)+ via (WithSchema ExampleSchema "person" Person) data Address = Address { postcode :: T.Text , country :: T.Text } deriving (Eq, Show, Generic)- deriving (ToSchema Identity ExampleSchema "address", FromSchema Identity ExampleSchema "address")+ deriving (ToSchema ExampleSchema "address", FromSchema ExampleSchema "address") deriving (J.ToJSON, J.FromJSON)- via (WithSchema Identity ExampleSchema "address" Address)+ via (WithSchema ExampleSchema "address" Address) type GenderFieldMapping = '[ "Male" ':-> "male"@@ -55,10 +55,10 @@ data Gender = Male | Female | NonBinary deriving (Eq, Show, Generic)- deriving (ToSchema f ExampleSchema "gender", FromSchema f ExampleSchema "gender")+ deriving (ToSchema ExampleSchema "gender", FromSchema ExampleSchema "gender") via (CustomFieldMapping "gender" GenderFieldMapping Gender) deriving (J.ToJSON, J.FromJSON)- via (WithSchema Identity ExampleSchema "gender" Gender)+ via (WithSchema ExampleSchema "gender" Gender) -- Schema for these data types type ExampleSchema@@ -74,7 +74,8 @@ , 'FieldDef "lastName" ('TPrimitive T.Text) , 'FieldDef "age" ('TOption ('TPrimitive Int)) , 'FieldDef "gender" ('TOption ('TSchematic "gender"))- , 'FieldDef "address" ('TSchematic "address") ]+ , 'FieldDef "address" ('TSchematic "address")+ , 'FieldDef "lucky_numbers" ('TList ('TPrimitive Int)) ] ] $(generateTypesFromSchema (++"Msg") ''ExampleSchema)
src/Mu/Schema/Interpretation.hs view
@@ -17,15 +17,6 @@ a given 'Schema'. These 'Term's are the main form of values used internally by @mu-haskell@. -This module follows the ideas of-<https://reasonablypolymorphic.com/blog/higher-kinded-data/ higher-kinded data>.-In particular, each interpretation of a 'Field'-wraps its contents into a "wrapper" type @w@,-which may add additional behavior to it.-For example, in Protocol Buffers every field is-optional, and this is expressed by setting-@w@ to 'Maybe'.- In this module we make use of 'NP' and 'NS' as defined by <https://hackage.haskell.org/package/sop-core sop-core>. These are the n-ary versions of a pair and@@ -38,11 +29,6 @@ -- * Interpretation Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..)- -- * Transforming the wrapper type-, transWrap, transWrapNoMaps- -- ** For internal use only-, transFields, transFieldsNoMaps-, transValue, transValueNoMaps ) where import Data.Map@@ -52,208 +38,125 @@ import Mu.Schema.Definition -- | Interpretation of a type in a schema.-data Term w (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where+data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where -- | A record given by the value of its fields.- TRecord :: NP (Field w sch) args -> Term w sch ('DRecord name args)+ TRecord :: NP (Field sch) args -> Term sch ('DRecord name args) -- | An enumeration given by one choice.- TEnum :: NS Proxy choices -> Term w sch ('DEnum name choices)+ TEnum :: NS Proxy choices -> Term sch ('DEnum name choices) -- | A primitive value.- TSimple :: FieldValue w sch t -> Term w sch ('DSimple t)+ TSimple :: FieldValue sch t -> Term sch ('DSimple t) -- | Interpretation of a field.-data Field w (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where+data Field (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where -- | A single field. Note that the contents are wrapped in a @w@ type constructor.- Field :: w (FieldValue w sch t) -> Field w sch ('FieldDef name t)+ Field :: FieldValue sch t -> Field sch ('FieldDef name t) -- | Interpretation of a field type, by giving a value of that type.-data FieldValue w (sch :: Schema typeName fieldName) (t :: FieldType typeName) where+data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) where -- | Null value, as found in Avro and JSON.- FNull :: FieldValue w sch 'TNull+ FNull :: FieldValue sch 'TNull -- | Value of a primitive type.- FPrimitive :: t -> FieldValue w sch ('TPrimitive t)+ FPrimitive :: t -> FieldValue sch ('TPrimitive t) -- | Term of another type in the schema.- FSchematic :: Term w sch (sch :/: t)- -> FieldValue w sch ('TSchematic t)+ FSchematic :: Term sch (sch :/: t)+ -> FieldValue sch ('TSchematic t) -- | Optional value.- FOption :: Maybe (FieldValue w sch t)- -> FieldValue w sch ('TOption t)+ FOption :: Maybe (FieldValue sch t)+ -> FieldValue sch ('TOption t) -- | List of values.- FList :: [FieldValue w sch t]- -> FieldValue w sch ('TList t)+ FList :: [FieldValue sch t]+ -> FieldValue sch ('TList t) -- | Dictionary (key-value map) of values.- FMap :: Ord (FieldValue w sch k)- => Map (FieldValue w sch k) (FieldValue w sch v)- -> FieldValue w sch ('TMap k v)+ FMap :: Ord (FieldValue sch k)+ => Map (FieldValue sch k) (FieldValue sch v)+ -> FieldValue sch ('TMap k v) -- | One single value of one of the specified types.- FUnion :: NS (FieldValue w sch) choices- -> FieldValue w sch ('TUnion choices)---- | Change the underlying wrapper of a term.-transWrap- :: forall tn fn (sch :: Schema tn fn) t u v.- (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k))- => (forall a. u a -> v a)- -> Term u sch t -> Term v sch t-transWrap n x = case x of- TRecord f -> TRecord (transFields n f)- TEnum c -> TEnum c- TSimple v -> TSimple (transValue n v)---- | Change the underlying wrapper of a term.--- This version assumes that no field is a map,--- which allows for a more general type.--- If a map is found, an exception is raised.-transWrapNoMaps- :: forall tn fn (sch :: Schema tn fn) t u v.- (Functor u)- => (forall a. u a -> v a)- -> Term u sch t -> Term v sch t-transWrapNoMaps n x = case x of- TRecord f -> TRecord (transFieldsNoMaps n f)- TEnum c -> TEnum c- TSimple v -> TSimple (transValueNoMaps n v)---- | Change the underlying wrapper of a list of fields.-transFields- :: forall tn fn (sch :: Schema tn fn) args u v.- (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k))- => (forall a. u a -> v a)- -> NP (Field u sch) args -> NP (Field v sch) args-transFields _ Nil = Nil-transFields n (Field v :* rest)- = Field (n (fmap (transValue n) v)) :* transFields n rest---- | Change the underlying wrapper of a list of fields.--- This version assumes no maps are present as fields.-transFieldsNoMaps- :: forall tn fn (sch :: Schema tn fn) args u v.- (Functor u)- => (forall a. u a -> v a)- -> NP (Field u sch) args -> NP (Field v sch) args-transFieldsNoMaps _ Nil = Nil-transFieldsNoMaps n (Field v :* rest)- = Field (n (fmap (transValueNoMaps n) v)) :* transFieldsNoMaps n rest---- | Change the underlying wrapper of a value.-transValue- :: forall tn fn (sch :: Schema tn fn) l u v.- (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k))- => (forall a. u a -> v a)- -> FieldValue u sch l -> FieldValue v sch l-transValue _ FNull = FNull-transValue _ (FPrimitive y) = FPrimitive y-transValue n (FSchematic t) = FSchematic (transWrap n t)-transValue n (FOption o) = FOption (transValue n <$> o)-transValue n (FList l) = FList (transValue n <$> l)-transValue n (FMap m) = FMap (mapKeys (transValue n) (transValue n <$> m))-transValue n (FUnion u) = FUnion (transUnion u)- where- transUnion :: NS (FieldValue u sch) us -> NS (FieldValue v sch) us- transUnion (Z z) = Z (transValue n z)- transUnion (S s) = S (transUnion s)---- | Change the underlying wrapper of a value.--- This version assumes that the value is not a map.-transValueNoMaps- :: forall tn fn (sch :: Schema tn fn) l u v.- (Functor u)- => (forall a. u a -> v a)- -> FieldValue u sch l -> FieldValue v sch l-transValueNoMaps _ FNull = FNull-transValueNoMaps _ (FPrimitive y) = FPrimitive y-transValueNoMaps n (FSchematic t) = FSchematic (transWrapNoMaps n t)-transValueNoMaps n (FOption o) = FOption (transValueNoMaps n <$> o)-transValueNoMaps n (FList l) = FList (transValueNoMaps n <$> l)-transValueNoMaps _ (FMap _) = error "this should never happen"-transValueNoMaps n (FUnion u) = FUnion (transUnion u)- where- transUnion :: NS (FieldValue u sch) us -> NS (FieldValue v sch) us- transUnion (Z z) = Z (transValueNoMaps n z)- transUnion (S s) = S (transUnion s)+ FUnion :: NS (FieldValue sch) choices+ -> FieldValue sch ('TUnion choices) -- =========================== -- CRAZY EQ AND SHOW INSTANCES -- =========================== -instance All (Eq `Compose` Field w sch) args- => Eq (Term w sch ('DRecord name args)) where+instance All (Eq `Compose` Field sch) args+ => Eq (Term sch ('DRecord name args)) where TRecord xs == TRecord ys = xs == ys-instance (KnownName name, All (Show `Compose` Field w sch) args)- => Show (Term w sch ('DRecord name args)) where+instance (KnownName name, All (Show `Compose` Field sch) args)+ => Show (Term sch ('DRecord name args)) where show (TRecord xs) = "record " ++ nameVal (Proxy @name) ++ " { " ++ printFields xs ++ " }"- where printFields :: forall fs. All (Show `Compose` Field w sch) fs- => NP (Field w sch) fs -> String+ where printFields :: forall fs. All (Show `Compose` Field sch) fs+ => NP (Field sch) fs -> String printFields Nil = "" printFields (x :* Nil) = show x printFields (x :* rest) = show x ++ ", " ++ printFields rest-instance All (Eq `Compose` Proxy) choices => Eq (Term w sch ('DEnum name choices)) where+instance All (Eq `Compose` Proxy) choices => Eq (Term sch ('DEnum name choices)) where TEnum x == TEnum y = x == y instance (KnownName name, All KnownName choices, All (Show `Compose` Proxy) choices)- => Show (Term w sch ('DEnum name choices)) where+ => Show (Term sch ('DEnum name choices)) where show (TEnum choice) = "enum " ++ nameVal (Proxy @name) ++ " { " ++ printChoice choice ++ " }" where printChoice :: forall cs. All KnownName cs => NS Proxy cs -> String printChoice (Z p) = nameVal p printChoice (S n) = printChoice n-instance Eq (FieldValue w sch t) => Eq (Term w sch ('DSimple t)) where+instance Eq (FieldValue sch t) => Eq (Term sch ('DSimple t)) where TSimple x == TSimple y = x == y-instance Show (FieldValue w sch t) => Show (Term w sch ('DSimple t)) where+instance Show (FieldValue sch t) => Show (Term sch ('DSimple t)) where show (TSimple x) = show x -instance (Eq (w (FieldValue w sch t))) => Eq (Field w sch ('FieldDef name t)) where+instance (Eq (FieldValue sch t)) => Eq (Field sch ('FieldDef name t)) where Field x == Field y = x == y-instance (KnownName name, Show (w (FieldValue w sch t)))- => Show (Field w sch ('FieldDef name t)) where+instance (KnownName name, Show (FieldValue sch t))+ => Show (Field sch ('FieldDef name t)) where show (Field x) = nameVal (Proxy @name) ++ ": " ++ show x -instance Eq (FieldValue w sch 'TNull) where+instance Eq (FieldValue sch 'TNull) where _ == _ = True-instance Eq t => Eq (FieldValue w sch ('TPrimitive t)) where+instance Eq t => Eq (FieldValue sch ('TPrimitive t)) where FPrimitive x == FPrimitive y = x == y-instance Eq (Term w sch (sch :/: t)) => Eq (FieldValue w sch ('TSchematic t)) where+instance Eq (Term sch (sch :/: t)) => Eq (FieldValue sch ('TSchematic t)) where FSchematic x == FSchematic y = x == y-instance Eq (FieldValue w sch t) => Eq (FieldValue w sch ('TOption t)) where+instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TOption t)) where FOption x == FOption y = x == y-instance Eq (FieldValue w sch t) => Eq (FieldValue w sch ('TList t)) where+instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TList t)) where FList x == FList y = x == y-instance (Eq (FieldValue w sch k), Eq (FieldValue w sch v))- => Eq (FieldValue w sch ('TMap k v)) where+instance (Eq (FieldValue sch k), Eq (FieldValue sch v))+ => Eq (FieldValue sch ('TMap k v)) where FMap x == FMap y = x == y-instance All (Eq `Compose` FieldValue w sch) choices- => Eq (FieldValue w sch ('TUnion choices)) where+instance All (Eq `Compose` FieldValue sch) choices+ => Eq (FieldValue sch ('TUnion choices)) where FUnion x == FUnion y = x == y -instance Ord (FieldValue w sch 'TNull) where+instance Ord (FieldValue sch 'TNull) where compare _ _ = EQ-instance Ord t => Ord (FieldValue w sch ('TPrimitive t)) where+instance Ord t => Ord (FieldValue sch ('TPrimitive t)) where compare (FPrimitive x) (FPrimitive y) = compare x y-instance Ord (Term w sch (sch :/: t)) => Ord (FieldValue w sch ('TSchematic t)) where+instance Ord (Term sch (sch :/: t)) => Ord (FieldValue sch ('TSchematic t)) where compare (FSchematic x) (FSchematic y) = compare x y-instance Ord (FieldValue w sch t) => Ord (FieldValue w sch ('TOption t)) where+instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TOption t)) where compare (FOption x) (FOption y) = compare x y-instance Ord (FieldValue w sch t) => Ord (FieldValue w sch ('TList t)) where+instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TList t)) where compare (FList x) (FList y) = compare x y-instance (Ord (FieldValue w sch k), Ord (FieldValue w sch v))- => Ord (FieldValue w sch ('TMap k v)) where+instance (Ord (FieldValue sch k), Ord (FieldValue sch v))+ => Ord (FieldValue sch ('TMap k v)) where compare (FMap x) (FMap y) = compare x y-instance ( All (Ord `Compose` FieldValue w sch) choices- , All (Eq `Compose` FieldValue w sch) choices )- => Ord (FieldValue w sch ('TUnion choices)) where+instance ( All (Ord `Compose` FieldValue sch) choices+ , All (Eq `Compose` FieldValue sch) choices )+ => Ord (FieldValue sch ('TUnion choices)) where compare (FUnion x) (FUnion y) = compare x y -instance Show (FieldValue w sch 'TNull) where+instance Show (FieldValue sch 'TNull) where show _ = "null"-instance Show t => Show (FieldValue w sch ('TPrimitive t)) where+instance Show t => Show (FieldValue sch ('TPrimitive t)) where show (FPrimitive x) = show x-instance Show (Term w sch (sch :/: t)) => Show (FieldValue w sch ('TSchematic t)) where+instance Show (Term sch (sch :/: t)) => Show (FieldValue sch ('TSchematic t)) where show (FSchematic x) = show x-instance Show (FieldValue w sch t) => Show (FieldValue w sch ('TOption t)) where+instance Show (FieldValue sch t) => Show (FieldValue sch ('TOption t)) where show (FOption Nothing) = "none" show (FOption (Just x)) = "some(" ++ show x ++ ")"-instance Show (FieldValue w sch t) => Show (FieldValue w sch ('TList t)) where+instance Show (FieldValue sch t) => Show (FieldValue sch ('TList t)) where show (FList xs) = show xs-instance (Show (FieldValue w sch k), Show (FieldValue w sch v))- => Show (FieldValue w sch ('TMap k v)) where+instance (Show (FieldValue sch k), Show (FieldValue sch v))+ => Show (FieldValue sch ('TMap k v)) where show (FMap x) = show x-instance All (Show `Compose` FieldValue w sch) choices- => Show (FieldValue w sch ('TUnion choices)) where+instance All (Show `Compose` FieldValue sch) choices+ => Show (FieldValue sch ('TUnion choices)) where show (FUnion x) = show x
src/Mu/Schema/Interpretation/Anonymous.hs view
@@ -29,77 +29,73 @@ import Mu.Schema -- | Anonymous term for a record with zero fields.-data V0 w sch sty where+data V0 sch sty where V0 :: (sch :/: sty ~ 'DRecord nm '[])- => V0 w sch sty+ => V0 sch sty -deriving instance Show (V0 w sch sty)-deriving instance Eq (V0 w sch sty)-deriving instance Ord (V0 w sch sty)+deriving instance Show (V0 sch sty)+deriving instance Eq (V0 sch sty)+deriving instance Ord (V0 sch sty) instance (sch :/: sty ~ 'DRecord nm '[])- => ToSchema w sch sty (V0 w sch sty) where+ => ToSchema sch sty (V0 sch sty) where toSchema V0 = TRecord Nil instance (sch :/: sty ~ 'DRecord nm '[])- => FromSchema w sch sty (V0 w sch sty) where+ => FromSchema sch sty (V0 sch sty) where fromSchema (TRecord Nil) = V0 -- | Anonymous term for a record with one field.-data V1 w sch sty where+data V1 sch sty where V1 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ])- => w a -> V1 w sch sty+ => a -> V1 sch sty -deriving instance (Show (w a), sch :/: sty- ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ])- => Show (V1 w sch sty)-deriving instance (Eq (w a), sch :/: sty- ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ])- => Eq (V1 w sch sty)-deriving instance (Ord (w a), sch :/: sty- ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ])- => Ord (V1 w sch sty)+deriving instance ( Show a+ , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )+ => Show (V1 sch sty)+deriving instance ( Eq a+ , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )+ => Eq (V1 sch sty)+deriving instance ( Ord a+ , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )+ => Ord (V1 sch sty) -instance ( Functor w- , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )- => ToSchema w sch sty (V1 w sch sty) where- toSchema (V1 x) = TRecord (Field (FPrimitive <$> x) :* Nil)-instance ( Functor w- , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )- => FromSchema w sch sty (V1 w sch sty) where- fromSchema (TRecord (Field x :* Nil)) = V1 (unPrimitive <$> x)- where unPrimitive :: FieldValue w sch ('TPrimitive t) -> t+instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )+ => ToSchema sch sty (V1 sch sty) where+ toSchema (V1 x) = TRecord (Field (FPrimitive x) :* Nil)+instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] )+ => FromSchema sch sty (V1 sch sty) where+ fromSchema (TRecord (Field x :* Nil)) = V1 (unPrimitive x)+ where unPrimitive :: FieldValue sch ('TPrimitive t) -> t unPrimitive (FPrimitive l) = l -- | Anonymous term for a record with two fields.-data V2 w sch sty where+data V2 sch sty where V2 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ])- => w a -> w b -> V2 w sch sty+ => a -> b -> V2 sch sty -deriving instance (Show (w a), Show (w b),+deriving instance (Show a, Show b, sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ])- => Show (V2 w sch sty)-deriving instance (Eq (w a), Eq (w b),+ => Show (V2 sch sty)+deriving instance (Eq a, Eq b, sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ])- => Eq (V2 w sch sty)-deriving instance (Ord (w a), Ord (w b),+ => Eq (V2 sch sty)+deriving instance (Ord a, Ord b, sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ])- => Ord (V2 w sch sty)+ => Ord (V2 sch sty) -instance ( Functor w- , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a)+instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ] )- => ToSchema w sch sty (V2 w sch sty) where- toSchema (V2 x y) = TRecord (Field (FPrimitive <$> x) :* Field (FPrimitive <$> y) :* Nil)-instance ( Functor w- , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a)+ => ToSchema sch sty (V2 sch sty) where+ toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)+instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ] )- => FromSchema w sch sty (V2 w sch sty) where- fromSchema (TRecord (Field x :* Field y :* Nil)) = V2 (unPrimitive <$> x) (unPrimitive <$> y)- where unPrimitive :: FieldValue w sch ('TPrimitive t) -> t+ => FromSchema sch sty (V2 sch sty) where+ fromSchema (TRecord (Field x :* Field y :* Nil)) = V2 (unPrimitive x) (unPrimitive y)+ where unPrimitive :: FieldValue sch ('TPrimitive t) -> t unPrimitive (FPrimitive l) = l
src/Mu/Schema/Interpretation/Schemaless.hs view
@@ -43,36 +43,35 @@ import qualified Mu.Schema.Interpretation as S -- | Interpretation of a type in a schema.-data Term (w :: * -> *) where+data Term where -- | A record given by the value of its fields.- TRecord :: [Field w] -> Term w+ TRecord :: [Field] -> Term -- | An enumeration given by one choice.- TEnum :: Int -> Term w+ TEnum :: Int -> Term -- | A primitive value.- TSimple :: FieldValue w -> Term w+ TSimple :: FieldValue -> Term -deriving instance Eq (w (FieldValue w)) => Eq (Term w)-deriving instance Ord (w (FieldValue w)) => Ord (Term w)-deriving instance Show (w (FieldValue w)) => Show (Term w)+deriving instance Eq Term+deriving instance Ord Term+deriving instance Show Term -- | Interpretation of a field.-data Field (w :: * -> *) where+data Field where -- | A single field given by its name and its value.- -- Note that the contents are wrapped in a @w@ type constructor.- Field :: T.Text -> w (FieldValue w) -> Field w+ Field :: T.Text -> FieldValue -> Field -deriving instance Eq (w (FieldValue w)) => Eq (Field w)-deriving instance Ord (w (FieldValue w)) => Ord (Field w)-deriving instance Show (w (FieldValue w)) => Show (Field w)+deriving instance Eq Field+deriving instance Ord Field+deriving instance Show Field -- | Interpretation of a field type, by giving a value of that type.-data FieldValue (w :: * -> *) where- FNull :: FieldValue w- FPrimitive :: (Typeable t, Eq t, Ord t, Show t) => t -> FieldValue w- FSchematic :: Term w -> FieldValue w- FOption :: Maybe (FieldValue w) -> FieldValue w- FList :: [FieldValue w] -> FieldValue w- FMap :: M.Map (FieldValue w) (FieldValue w) -> FieldValue w+data FieldValue where+ FNull :: FieldValue+ FPrimitive :: (Typeable t, Eq t, Ord t, Show t) => t -> FieldValue+ FSchematic :: Term -> FieldValue+ FOption :: Maybe FieldValue -> FieldValue+ FList :: [FieldValue] -> FieldValue+ FMap :: M.Map FieldValue FieldValue -> FieldValue -- | Checks that a schemaless 'Term' obbeys the -- restrictions for tyoe @t@ of schema @s@.@@ -82,46 +81,46 @@ -- Use this function to check a schemaless terms -- at the "borders" of your application. checkSchema- :: forall (s :: Schema tn fn) (t :: tn) (w :: * -> *).- (Traversable w, CheckSchema s (s :/: t))- => Proxy t -> Term w -> Maybe (S.Term w s (s :/: t))+ :: forall (s :: Schema tn fn) (t :: tn).+ (CheckSchema s (s :/: t))+ => Proxy t -> Term -> Maybe (S.Term s (s :/: t)) checkSchema _ = checkSchema' -- | Converts a schemaless term to a Haskell type -- by going through the corresponding schema type. fromSchemalessTerm- :: forall sch w t sty.- (Traversable w, FromSchema w sch sty t, CheckSchema sch (sch :/: sty))- => Term w -> Maybe t-fromSchemalessTerm t = fromSchema @_ @_ @w @sch <$> checkSchema (Proxy @sty) t+ :: forall sch t sty.+ (FromSchema sch sty t, CheckSchema sch (sch :/: sty))+ => Term -> Maybe t+fromSchemalessTerm t = fromSchema @_ @_ @sch <$> checkSchema (Proxy @sty) t -- | Deserialization to schemaless terms.-class ToSchemalessTerm t w where+class ToSchemalessTerm t where -- | Turns a document (such as JSON) into a schemaless term. -- This function should handle the "compound" types in that format, -- such as records and enumerations.- toSchemalessTerm :: t -> Term w+ toSchemalessTerm :: t -> Term -- | Deserialization to schemaless values.-class ToSchemalessValue t w where+class ToSchemalessValue t where -- | Turns a document (such as JSON) into a schemaless term. -- This function should handle the "primitive" types in that format.- toSchemalessValue :: t -> FieldValue w+ toSchemalessValue :: t -> FieldValue -- | Type class used to define the generic 'checkSchema'. -- -- Exposed for usage in other modules, -- in particular 'Mu.Schema.Registry'. class CheckSchema (s :: Schema tn fn) (t :: TypeDef tn fn) where- checkSchema' :: Traversable w => Term w -> Maybe (S.Term w s t)+ checkSchema' :: Term -> Maybe (S.Term s t) class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where- checkSchemaFields :: Traversable w => [Field w] -> Maybe (NP (S.Field w s) fields)+ checkSchemaFields :: [Field] -> Maybe (NP (S.Field s) fields) class CheckSchemaEnum (choices :: [ChoiceDef fn]) where checkSchemaEnumInt :: Int -> Maybe (NS Proxy choices) checkSchemaEnumText :: T.Text -> Maybe (NS Proxy choices) class CheckSchemaValue (s :: Schema tn fn) (field :: FieldType tn) where- checkSchemaValue :: Traversable w => FieldValue w -> Maybe (S.FieldValue w s field)+ checkSchemaValue :: FieldValue -> Maybe (S.FieldValue s field) class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where- checkSchemaUnion :: Traversable w => FieldValue w -> Maybe (NS (S.FieldValue w s) ts)+ checkSchemaUnion :: FieldValue -> Maybe (NS (S.FieldValue s) ts) instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm fields) where checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields@@ -133,9 +132,9 @@ checkSchemaFields fs = do let name = T.pack (nameVal (Proxy @nm)) Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs- v' <- traverse checkSchemaValue v+ v' <- checkSchemaValue v r' <- checkSchemaFields @_ @_ @s @rest fs- return (S.Field v' :* r')+ pure (S.Field v' :* r') instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n@@ -191,8 +190,8 @@ checkSchemaUnion x = Z <$> checkSchemaValue @_ @_ @s @t x <|> S <$> checkSchemaUnion x -- Boring instances-deriving instance (Show (w (FieldValue w))) => Show (FieldValue w)-instance (Eq (w (FieldValue w))) => Eq (FieldValue w) where+deriving instance Show FieldValue+instance Eq FieldValue where FNull == FNull = True FPrimitive (x :: a) == FPrimitive (y :: b) = case eqT @a @b of@@ -203,7 +202,7 @@ FList x == FList y = x == y FMap x == FMap y = x == y _ == _ = False-instance (Ord (w (FieldValue w))) => Ord (FieldValue w) where+instance Ord FieldValue where FNull <= _ = True FPrimitive _ <= FNull = False FPrimitive (x :: a) <= FPrimitive (y :: b)
src/Mu/Schema/Registry.hs view
@@ -53,16 +53,16 @@ -- /Implementation note/: schemas are checked -- __in the same order__ in which they appear -- in the 'Registry' definition.-fromRegistry :: forall r t w. FromRegistry w r t- => SLess.Term w -> Maybe t+fromRegistry :: forall r t. FromRegistry r t+ => SLess.Term -> Maybe t fromRegistry = fromRegistry' (Proxy @r) -class FromRegistry (w :: * -> *) (ms :: Registry) (t :: Type) where- fromRegistry' :: Proxy ms -> SLess.Term w -> Maybe t+class FromRegistry (ms :: Registry) (t :: Type) where+ fromRegistry' :: Proxy ms -> SLess.Term -> Maybe t -instance FromRegistry w '[] t where+instance FromRegistry '[] t where fromRegistry' _ _ = Nothing-instance ( Traversable w, FromSchema w s sty t- , SLess.CheckSchema s (s :/: sty), FromRegistry w ms t )- => FromRegistry w ((n ':-> s) ': ms) t where- fromRegistry' _ t = SLess.fromSchemalessTerm @s @w t <|> fromRegistry' (Proxy @ms) t+instance ( Traversable w, FromSchema s sty t+ , SLess.CheckSchema s (s :/: sty), FromRegistry ms t )+ => FromRegistry ((n ':-> s) ': ms) t where+ fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t