higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-09-11 14:36:01 +03:00
Code Issues Projects Releases Wiki Activity

Take metadata into account for GSchemaFieldTypeUnion (fixes #28) (#33)

Browse Source
This commit is contained in:
Alejandro Serrano 2019-12-05 09:32:18 +01:00 committed by GitHub
parent 3a0c662da7
commit fa2ade13db
1 changed files with 38 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
core/schema/src/Mu/Schema/Class.hs
View File

@ -123,18 +123,21 @@ class GSchemaTypeDef (sch :: Schema ts fs) (fmap :: Mappings Symbol fs)
-- TYPES OF FIELDS --
-- ------------------
instance {-# OVERLAPPABLE #-}
GSchemaFieldType sch t f
=> GSchemaTypeDef sch fmap ('DSimple t) (K1 i f) where
toSchemaTypeDef _ (K1 x) = TSimple (toSchemaFieldType x)
fromSchemaTypeDef _ (TSimple x) = K1 (fromSchemaFieldType x)
-- This instance removes unneeded metadata from the
-- top of the type.
instance {-# OVERLAPS #-}
GSchemaTypeDef sch fmap ('DSimple t) f
=> GSchemaTypeDef sch fmap ('DSimple t) (D1 meta f) where
toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x
fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x)
instance GSchemaFieldTypeWrap sch t f
=> GSchemaTypeDef sch fmap ('DSimple t) f where
toSchemaTypeDef _ x = TSimple (toSchemaFieldTypeW x)
fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x
class GSchemaFieldTypeWrap (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where
toSchemaFieldTypeW :: f a -> FieldValue sch t
fromSchemaFieldTypeW :: FieldValue sch t -> f a
instance GSchemaFieldType sch t f => GSchemaFieldTypeWrap sch t (K1 i f) where
toSchemaFieldTypeW (K1 x) = toSchemaFieldType x
fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x)
instance GSchemaFieldTypeWrap sch t f => GSchemaFieldTypeWrap sch t (M1 s m f) where
toSchemaFieldTypeW (M1 x) = toSchemaFieldTypeW x
fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x)
class GSchemaFieldType (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where
toSchemaFieldType :: f -> FieldValue sch t
@ -194,34 +197,35 @@ instance {-# OVERLAPPABLE #-}
toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x))
fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x)
-- This is not 100% correct, we could have
-- GSchemaFieldTypeUnion sch '[] U1
-- But we would need overlappable instances for that matter
-- and also: who is going to define an empty union?
instance TypeError ('Text "the type does not match the union")
instance {-# OVERLAPS #-} GSchemaFieldTypeUnion sch '[] U1 where
toSchemaFieldTypeUnion U1 = error "this should never happen"
fromSchemaFieldTypeUnion _ = U1
instance {-# OVERLAPPABLE #-}
TypeError ('Text "the type does not match the union")
=> GSchemaFieldTypeUnion sch '[] f where
toSchemaFieldTypeUnion = error "this should never happen"
fromSchemaFieldTypeUnion = error "this should never happen"
instance (GSchemaFieldType sch t v)
=> GSchemaFieldTypeUnion sch '[t] (K1 i v) where
toSchemaFieldTypeUnion (K1 x) = Z (toSchemaFieldType x)
fromSchemaFieldTypeUnion (Z x) = K1 (fromSchemaFieldType x)
fromSchemaFieldTypeUnion (S _) = error "this should never happen"
instance (GSchemaFieldType sch t v, GSchemaFieldTypeUnion sch ts vs)
=> GSchemaFieldTypeUnion sch (t ': ts) (K1 i v :+: vs) where
toSchemaFieldTypeUnion (L1 (K1 x)) = Z (toSchemaFieldType x)
toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r)
fromSchemaFieldTypeUnion (Z x) = L1 (K1 (fromSchemaFieldType x))
instance (GSchemaFieldTypeWrap sch t v)
=> GSchemaFieldTypeUnion sch '[t] v where
toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x)
fromSchemaFieldTypeUnion (Z x) = fromSchemaFieldTypeW x
fromSchemaFieldTypeUnion (S _) = error "this should never happen"
instance (GSchemaFieldTypeWrap sch t v, GSchemaFieldTypeUnion sch ts vs)
=> GSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where
toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x)
toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r)
fromSchemaFieldTypeUnion (Z x) = L1 (fromSchemaFieldTypeW x)
fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r)
-- Weird nested instance produced by GHC
instance (GSchemaFieldType sch t1 v1, GSchemaFieldType sch t2 v2, GSchemaFieldTypeUnion sch ts vs)
=> GSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((K1 i v1 :+: K1 i v2) :+: vs) where
toSchemaFieldTypeUnion (L1 (L1 (K1 x))) = Z (toSchemaFieldType x)
toSchemaFieldTypeUnion (L1 (R1 (K1 x))) = S (Z (toSchemaFieldType x))
toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r))
fromSchemaFieldTypeUnion (Z x) = L1 (L1 (K1 (fromSchemaFieldType x)))
fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (K1 (fromSchemaFieldType x)))
instance ( GSchemaFieldTypeWrap sch t1 v1, GSchemaFieldTypeWrap sch t2 v2
, GSchemaFieldTypeUnion sch ts vs )
=> GSchemaFieldTypeUnion 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))
fromSchemaFieldTypeUnion (Z x) = L1 (L1 (fromSchemaFieldTypeW x))
fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x))
fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r)