mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Conversion to logical types (#223)
This commit is contained in:
parent
fe76f23083
commit
2a413c7c48
@ -1,5 +1,5 @@
|
||||
name: mu-schema
|
||||
version: 0.3.0.0
|
||||
version: 0.3.1.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.
|
||||
@ -47,6 +47,7 @@ library
|
||||
, text >=1.2 && <2
|
||||
, th-abstraction >=0.3.2 && <0.4
|
||||
, unordered-containers >=0.2 && <0.3
|
||||
, uuid >=1.3 && <2
|
||||
, vector >=0.12 && <0.13
|
||||
|
||||
hs-source-dirs: src
|
||||
|
@ -29,6 +29,7 @@ module Mu.Schema (
|
||||
, FromSchema(..), fromSchema'
|
||||
, ToSchema(..), toSchema'
|
||||
, CustomFieldMapping(..)
|
||||
, Underlying(..), UnderlyingConversion(..)
|
||||
-- ** Mappings between fields
|
||||
, Mapping(..), Mappings, MappingRight, MappingLeft
|
||||
-- ** Field annotations
|
||||
|
@ -37,13 +37,19 @@ module Mu.Schema.Class (
|
||||
, ToSchema(..), toSchema'
|
||||
, CustomFieldMapping(..)
|
||||
, Mapping(..), Mappings, MappingRight, MappingLeft
|
||||
, Underlying(..), UnderlyingConversion(..)
|
||||
-- * Internal use only
|
||||
, GToSchemaRecord(..)
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Kind
|
||||
import Data.Map as M
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.SOP
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.UUID as U
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
|
||||
@ -140,6 +146,33 @@ 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)
|
||||
|
||||
-- | This 'newtype' is used to wrap types for which
|
||||
-- we want a "logical" representation as a Haskell
|
||||
-- type, but the underlying representation is
|
||||
-- lower level, like 'UUID's as 'ByteString's.
|
||||
newtype Underlying basic logical
|
||||
= Underlying { unUnderlying :: logical }
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | This class defines the actual conversion between
|
||||
-- a "logical" type and its low-level representation.
|
||||
class UnderlyingConversion basic logical where
|
||||
toUnderlying :: logical -> basic
|
||||
fromUnderlying :: basic -> logical
|
||||
|
||||
instance UnderlyingConversion String U.UUID where
|
||||
toUnderlying = U.toString
|
||||
fromUnderlying = fromJust . U.fromString
|
||||
instance UnderlyingConversion T.Text U.UUID where
|
||||
toUnderlying = U.toText
|
||||
fromUnderlying = fromJust . U.fromText
|
||||
instance UnderlyingConversion BL.ByteString U.UUID where
|
||||
toUnderlying = U.toByteString
|
||||
fromUnderlying = fromJust . U.fromByteString
|
||||
instance UnderlyingConversion BS.ByteString U.UUID where
|
||||
toUnderlying = BL.toStrict . U.toByteString
|
||||
fromUnderlying = fromJust . U.fromByteString . BL.fromStrict
|
||||
|
||||
-- ======================
|
||||
-- CRAZY GENERICS SECTION
|
||||
-- ======================
|
||||
@ -245,6 +278,12 @@ instance GToSchemaFieldType sch 'TNull () where
|
||||
toSchemaFieldType _ = FNull
|
||||
instance GFromSchemaFieldType sch 'TNull () where
|
||||
fromSchemaFieldType _ = ()
|
||||
instance (UnderlyingConversion t l)
|
||||
=> GToSchemaFieldType sch ('TPrimitive t) (Underlying t l) where
|
||||
toSchemaFieldType = FPrimitive . toUnderlying . unUnderlying
|
||||
instance (UnderlyingConversion t l)
|
||||
=> GFromSchemaFieldType sch ('TPrimitive t) (Underlying t l) where
|
||||
fromSchemaFieldType (FPrimitive x) = Underlying (fromUnderlying x)
|
||||
instance GToSchemaFieldType sch ('TPrimitive t) t where
|
||||
toSchemaFieldType = FPrimitive
|
||||
instance GFromSchemaFieldType sch ('TPrimitive t) t where
|
||||
|
Loading…
Reference in New Issue
Block a user