diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mu-haskell + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2019-2020 47 Degrees. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mu-schema.cabal b/mu-schema.cabal new file mode 100644 --- /dev/null +++ b/mu-schema.cabal @@ -0,0 +1,51 @@ +cabal-version: >=1.10 +name: mu-schema +version: 0.1.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. +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell + +library + exposed-modules: Mu.Schema + , Mu.Schema.Definition + , Mu.Schema.Interpretation + , Mu.Schema.Interpretation.Schemaless + , Mu.Schema.Interpretation.Anonymous + , Mu.Schema.Class + , Mu.Schema.Registry + , Mu.Schema.Conversion.TypesToSchema + , Mu.Schema.Conversion.SchemaToTypes + , Mu.Schema.Examples + , Mu.Schema.Annotations + , Mu.Adapter.Json + , Data.Functor.MaybeLike + -- other-modules: + -- other-extensions: + build-depends: base >=4.12 && <5 + , sop-core + , containers + , unordered-containers + , bytestring + , vector + , text + , aeson + , template-haskell >= 2.12 + , th-abstraction + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -fprint-potential-instances diff --git a/src/Data/Functor/MaybeLike.hs b/src/Data/Functor/MaybeLike.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/MaybeLike.hs @@ -0,0 +1,29 @@ +{-| +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 diff --git a/src/Mu/Adapter/Json.hs b/src/Mu/Adapter/Json.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Adapter/Json.hs @@ -0,0 +1,175 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Description : Adapter for JSON serialization + +Just import the module and you can turn any +value with a 'ToSchema' and 'FromSchema' from +and to JSON values. +-} +module Mu.Adapter.Json () where + +import Control.Applicative ((<|>)) +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 + +import Mu.Schema +import qualified Mu.Schema.Interpretation.Schemaless as SLess + +instance Applicative w => SLess.ToSchemalessTerm Value w where + toSchemalessTerm (Object o) + = SLess.TRecord $ map (\(k,v) -> SLess.Field k (pure $ SLess.toSchemalessValue v)) + $ HM.toList o + toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) + +instance Applicative w => SLess.ToSchemalessValue Value w where + toSchemalessValue r@(Object _) + = SLess.FSchematic (SLess.toSchemalessTerm r) + toSchemalessValue Null = SLess.FNull + toSchemalessValue (String s) = SLess.FPrimitive s + toSchemalessValue (Number n) = SLess.FPrimitive n + toSchemalessValue (Bool b) = SLess.FPrimitive b + 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 ToJSONFields sch args => ToJSON (Term Identity sch ('DRecord name args)) where + toJSON (TRecord fields) = Object (toJSONFields fields) +instance FromJSONFields w sch args => FromJSON (Term w 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 +instance ToJSONFields sch '[] where + toJSONFields _ = HM.empty +instance (KnownName name, ToJSON (FieldValue Identity sch t), ToJSONFields sch fs) + => ToJSONFields sch ('FieldDef name t ': fs) where + toJSONFields (Field (Identity 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 + where key = T.pack (nameVal (Proxy @name)) + +instance ToJSONEnum choices => ToJSON (Term w sch ('DEnum name choices)) where + toJSON (TEnum choice) = String (toJSONEnum choice) +instance FromJSONEnum choices => FromJSON (Term w sch ('DEnum name choices)) where + parseJSON (String s) = TEnum <$> parseJSONEnum s + parseJSON _ = fail "expected string" + +class ToJSONEnum choices where + toJSONEnum :: NS Proxy choices -> T.Text +instance ToJSONEnum '[] where + toJSONEnum = error "empty enum" +instance (KnownName c, ToJSONEnum cs) + => ToJSONEnum ('ChoiceDef c ': cs) where + toJSONEnum (Z _) = T.pack (nameVal (Proxy @c)) + toJSONEnum (S v) = toJSONEnum v + +class FromJSONEnum choices where + parseJSONEnum :: T.Text -> Parser (NS Proxy choices) +instance FromJSONEnum '[] where + parseJSONEnum _ = fail "unknown enum value" +instance (KnownName c, FromJSONEnum cs) + => FromJSONEnum ('ChoiceDef c ': cs) where + parseJSONEnum v + | v == key = return (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 + toJSON (TSimple x) = toJSON x +instance FromJSON (FieldValue w sch t) => FromJSON (Term w sch ('DSimple t)) where + parseJSON v = TSimple <$> parseJSON v + +instance ToJSON (FieldValue w sch 'TNull) where + toJSON FNull = Null +instance ToJSON t => ToJSON (FieldValue w sch ('TPrimitive t)) where + toJSON (FPrimitive v) = toJSON v +instance ToJSONKey t => ToJSONKey (FieldValue w 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 + toJSON (FSchematic v) = toJSON v +instance ToJSON (FieldValue w sch t) + => ToJSON (FieldValue w sch ('TOption t)) where + toJSON (FOption v) = toJSON v +instance ToJSON (FieldValue w sch t) + => ToJSON (FieldValue w 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 + toJSON (FMap v) = toJSON v +instance (ToJSONUnion w sch us) + => ToJSON (FieldValue w 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 + unionToJSON = error "this should never happen" +instance (ToJSON (FieldValue w sch u), ToJSONUnion w sch us) + => ToJSONUnion w 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 + parseJSON _ = fail "expected null" +instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where + parseJSON v = FPrimitive <$> parseJSON v +instance FromJSONKey t => FromJSONKey (FieldValue w 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 + parseJSON v = FSchematic <$> parseJSON v +instance FromJSON (FieldValue w sch t) + => FromJSON (FieldValue w sch ('TOption t)) where + parseJSON v = FOption <$> parseJSON v +instance FromJSON (FieldValue w sch t) + => FromJSON (FieldValue w 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 + parseJSON v = FMap <$> parseJSON v +instance (FromJSONUnion w sch us) + => FromJSON (FieldValue w 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 + 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 + unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v diff --git a/src/Mu/Schema.hs b/src/Mu/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema.hs @@ -0,0 +1,41 @@ +{-# language DataKinds #-} +{-| +Description : Schemas for Mu microservices + +Definition and interpretation of schemas in +the vein of Avro, Protocol Buffers, or JSON Schema. + +Each 'Schema' is made out of types (which in turn +be records or enumerations). A value which obbeys +such a schema is called a 'Term'. Conversion between +Haskell types and schema types is mediated by the +type classes 'ToSchema' and 'FromSchema'. +-} +module Mu.Schema ( + -- * Schema definition + Schema, Schema' +, KnownName(..) +, TypeDef, TypeDefB(..) +, ChoiceDef(..) +, FieldDef, FieldDefB(..) +, FieldType, FieldTypeB(..) + -- ** Lookup type in schema +, (:/:) + -- * Interpretation of schemas +, Term(..), Field(..), FieldValue(..) +, NS(..), NP(..), Proxy(..) + -- * Conversion from types to schemas +, WithSchema(..) +, FromSchema(..), fromSchema' +, ToSchema(..), toSchema' +, CustomFieldMapping(..) + -- ** Mappings between fields +, Mapping(..), Mappings, MappingRight, MappingLeft + -- ** Field annotations +, AnnotatedSchema, AnnotationDomain, Annotation(..) +) where + +import Mu.Schema.Annotations +import Mu.Schema.Class +import Mu.Schema.Definition +import Mu.Schema.Interpretation diff --git a/src/Mu/Schema/Annotations.hs b/src/Mu/Schema/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Annotations.hs @@ -0,0 +1,75 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Protocol-defined annotations. + +Libraries can define custom annotations to +indicate additional information not found +in the 'Schema' itself. For example, Protocol +Buffers requires a numerical identifier for +each field in a record. +-} +module Mu.Schema.Annotations ( + -- * Annotate a schema + Annotation(..) +, AnnotatedSchema +, AnnotationDomain + -- * Find annotations for an element +, GetSchemaAnnotation +, GetTypeAnnotation +, GetFieldAnnotation +) where + +import Data.Kind +import GHC.TypeLits + +import Mu.Schema.Definition + +-- | Each annotation belongs to a domain. +type AnnotationDomain = Type + +-- | Annotations proper. +data Annotation domain typeName fieldName where + -- | Annotation over the whole schema. + AnnSchema :: domain + -> Annotation domain typeName fieldName + -- | Annotation over a type in the schema. + AnnType :: typeName -> domain + -> Annotation domain typeName fieldName + -- | Annotation over a field in a record + -- or a choice in an enumeration. + AnnField :: typeName -> fieldName -> domain + -> Annotation domain typeName fieldName + +-- | This type family links each schema to +-- its corresponding annotations from one domain. +type family AnnotatedSchema domain (sch :: Schema typeName fieldName) + :: [Annotation domain typeName fieldName] + +-- | Find the annotation over the schema in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetSchemaAnnotation (anns :: [Annotation domain t f]) :: domain where + GetSchemaAnnotation '[] + = TypeError ('Text "cannot find schema annotation") + GetSchemaAnnotation ('AnnSchema d ': rs) = d + GetSchemaAnnotation (r ': rs) = GetSchemaAnnotation rs + +-- | Find the annotation over the given type in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetTypeAnnotation (anns :: [Annotation domain t f]) (ty :: t) :: domain where + GetTypeAnnotation '[] ty + = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty) + GetTypeAnnotation ('AnnType ty d ': rs) ty = d + GetTypeAnnotation (r ': rs) ty = GetTypeAnnotation rs ty + +-- | Find the annotation over the given field or choice in the given type. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetFieldAnnotation (anns :: [Annotation domain t f]) (ty :: t) (fl :: f) :: domain where + GetFieldAnnotation '[] ty fl + = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty ':<>: 'Text "/" ':<>: 'ShowType fl) + GetFieldAnnotation ('AnnField ty fl d ': rs) ty fl = d + GetFieldAnnotation (r ': rs) ty fl = GetFieldAnnotation rs ty fl diff --git a/src/Mu/Schema/Class.hs b/src/Mu/Schema/Class.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Class.hs @@ -0,0 +1,546 @@ +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Conversion from types to schemas + +This module defines a couple of type classes +'ToSchema' and 'FromSchema' to turn Haskell +types back and forth @mu-haskell@ 'Term's. + +In most cases, the instances can be automatically +derived. If you enable the extensions +@DeriveGeneric@ and @DeriveAnyClass@, you can do: + +> data MyHaskellType = ... +> deriving ( ToSchema f MySchema "MySchemaType" MyHaskellType +> , FromSchema f MySchema "MySchemaType" MyHaskellType) + +If the default mapping which required identical +names for fields in the Haskell and schema types +does not suit you, use 'CustomFieldMapping'. +-} +module Mu.Schema.Class ( + WithSchema(..) +, FromSchema(..), fromSchema' +, 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 +import GHC.Generics +import GHC.TypeLits + +import Mu.Schema.Definition +import Mu.Schema.Interpretation + +-- | Tags a value with its schema. +-- For usage with @deriving via@. +newtype WithSchema (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a = WithSchema a + +-- | Defines the conversion of a type @t@ into a 'Term' +-- which follows the schema @sch@. +-- 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) + | sch t -> sty where + -- | Conversion from Haskell type to schema term. + toSchema :: t -> Term w sch (sch :/: sty) + + default + toSchema :: (Generic t, GToSchemaTypeDef w sch '[] (sch :/: sty) (Rep t)) + => t -> Term w sch (sch :/: sty) + toSchema x = toSchemaTypeDef (Proxy @'[]) (from x) + +-- | Defines the conversion from a 'Term' +-- which follows the schema @sch@ into a type @t@. +-- 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) + | sch t -> sty where + -- | Conversion from schema term to Haskell type. + fromSchema :: Term w sch (sch :/: sty) -> t + + default + fromSchema :: (Generic t, GFromSchemaTypeDef w sch '[] (sch :/: sty) (Rep t) ) + => Term w sch (sch :/: sty) -> t + fromSchema x = to (fromSchemaTypeDef (Proxy @'[]) x) + +-- | 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' = 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' = fromSchema + +-- | By default, the names of the fields in the Haskell type +-- and those of the schema types must coincide. By using +-- this wrapper you can override this default setting. +-- +-- This type should be used with @DerivingVia@, as follows: +-- +-- > type MyCustomFieldMapping = '[ "A" ':-> "a", ...] +-- > data MyHaskellType = ... +-- > deriving ( ToSchema f MySchema "MySchemaType" MyHaskellType +-- > , FromSchema f MySchema "MySchemaType" MyHaskellType) +-- > via (CustomFieldMapping "MySchemaType" MyCustomFieldMapping MyHaskellType) +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 + 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 + 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 +-- ====================== + +-- Auxiliary type families to find elements in lists +-- They return an indication of where the thing was found +-- +-- 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 + +type family Find (xs :: [k]) (x :: k) :: Where where + Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y) + Find (y ': xs) y = 'Here + Find (x ': xs) y = 'There (Find xs y) + +type family FindCon (xs :: * -> *) (x :: Symbol) :: Where where + FindCon (C1 ('MetaCons x p s) f) x = 'Here + FindCon (C1 ('MetaCons x p s) f :+: rest) x = 'Here + FindCon (other :+: rest) x = 'There (FindCon rest x) + FindCon nothing x = TypeError ('Text "Could not find constructor " ':<>: 'ShowType x) + +type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where + FindSel (S1 ('MetaSel ('Just x) u ss ds) f) x = 'Here + 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 (other :*: rest) x = 'There (FindSel rest x) + FindSel nothing x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x) + +type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where + FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x) + FindEnumChoice ('ChoiceDef name ': xs) name = 'Here + FindEnumChoice (other ': xs) name = 'There (FindEnumChoice xs name) + +type family FindField (xs :: [FieldDef ts fs]) (x :: fs) :: Where where + FindField '[] x = TypeError ('Text "Could not find field " ':<>: 'ShowType x) + FindField ('FieldDef name t ': xs) name = 'Here + FindField (other ': xs) name = 'There (FindField xs name) + +-- Generic type definitions +class GToSchemaTypeDef + (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch t +class GFromSchemaTypeDef + (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + fromSchemaTypeDef :: Proxy fmap -> Term w sch t -> f a + +-- ------------------ +-- TYPES OF FIELDS -- +-- ------------------ + +instance GToSchemaFieldTypeWrap w sch t f + => GToSchemaTypeDef w 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 + fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x + +class GToSchemaFieldTypeWrap + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + toSchemaFieldTypeW :: f a -> FieldValue w sch t +class GFromSchemaFieldTypeWrap + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + fromSchemaFieldTypeW :: FieldValue w sch t -> f a + +instance GToSchemaFieldType w sch t f + => GToSchemaFieldTypeWrap w 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 + fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x) +instance GToSchemaFieldTypeWrap w sch t f + => GToSchemaFieldTypeWrap w 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 + fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x) + +class GToSchemaFieldType + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + toSchemaFieldType :: f -> FieldValue w sch t +class GFromSchemaFieldType + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + fromSchemaFieldType :: FieldValue w sch t -> f + +class GToSchemaFieldTypeUnion + (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + toSchemaFieldTypeUnion :: f a -> NS (FieldValue w sch) t +class GFromSchemaFieldTypeUnion + (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + fromSchemaFieldTypeUnion :: NS (FieldValue w sch) t -> f a + +-- These instances are straightforward, +-- just turn the "real types" into their +-- schema correspondants. +instance GToSchemaFieldType w sch 'TNull () where + toSchemaFieldType _ = FNull +instance GFromSchemaFieldType w sch 'TNull () where + fromSchemaFieldType _ = () +instance GToSchemaFieldType w sch ('TPrimitive t) t where + toSchemaFieldType = FPrimitive +instance GFromSchemaFieldType w 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 + toSchemaFieldType x = FSchematic $ toSchema x +instance FromSchema w sch t v + => GFromSchemaFieldType w sch ('TSchematic t) v where + fromSchemaFieldType (FSchematic x) = fromSchema x +instance GToSchemaFieldType w sch t v + => GToSchemaFieldType w 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 + fromSchemaFieldType (FOption x) = fromSchemaFieldType <$> x +instance GToSchemaFieldType w sch t v + => GToSchemaFieldType w sch ('TList t) [v] where + toSchemaFieldType x = FList (toSchemaFieldType <$> x) +instance GFromSchemaFieldType w sch t v + => GFromSchemaFieldType w 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 + 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 + 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 + toSchemaFieldType t = FUnion (go t) + where go :: AllZip (GToSchemaFieldType w sch) tss vss + => NS I vss -> NS (FieldValue w 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 + fromSchemaFieldType (FUnion t) = go t + where go :: AllZip (GFromSchemaFieldType w sch) tss vss + => NS (FieldValue w 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 + toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) +instance {-# OVERLAPPABLE #-} + (Generic f, GFromSchemaFieldTypeUnion w sch ts (Rep f)) + => GFromSchemaFieldType w sch ('TUnion ts) f where + fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) + +instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion w sch '[] U1 where + toSchemaFieldTypeUnion U1 = error "this should never happen" +instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion w sch '[] U1 where + fromSchemaFieldTypeUnion _ = U1 +instance {-# OVERLAPPABLE #-} + TypeError ('Text "the type does not match the union") + => GToSchemaFieldTypeUnion w 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 + fromSchemaFieldTypeUnion = error "this should never happen" + +instance (GToSchemaFieldTypeWrap w sch t v) + => GToSchemaFieldTypeUnion w sch '[t] v where + toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x) +instance (GFromSchemaFieldTypeWrap w sch t v) + => GFromSchemaFieldTypeUnion w 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 + 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 + 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 + 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 + fromSchemaFieldTypeUnion (Z x) = L1 (L1 (fromSchemaFieldTypeW x)) + fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x)) + fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r) + + +-- --------------- +-- ENUMERATIONS -- +------------------ + +instance {-# OVERLAPPABLE #-} + (GToSchemaEnumDecompose fmap choices f) + => GToSchemaTypeDef w 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 + 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 + 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 + fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) + +-- 'toSchema' for enumerations: +-- 1. recursively decompose the (:+:)s into their atomic components +-- this is done by 'GToSchemaEnumSymbol' +-- 2. for each atomic component, figure out which is the element +-- in the schema's enumeration that it corresponds to +-- this is done by 'MappingRight' and 'Find' +-- 3. from that location, build a 'Proxy' value +-- this is done by 'GToSchemaEnumProxy' +class GToSchemaEnumDecompose (fmap :: Mappings Symbol fs) + (choices :: [ChoiceDef fs]) (f :: * -> *) where + toSchemaEnumDecomp :: Proxy fmap -> f a -> NS Proxy choices +instance (GToSchemaEnumDecompose fmap choices oneway, GToSchemaEnumDecompose fmap choices oranother) + => GToSchemaEnumDecompose fmap choices (oneway :+: oranother) where + toSchemaEnumDecomp p (L1 x) = toSchemaEnumDecomp p x + toSchemaEnumDecomp p (R1 x) = toSchemaEnumDecomp p x +instance GToSchemaEnumProxy choices (FindEnumChoice choices (MappingRight fmap c)) + => GToSchemaEnumDecompose fmap choices (C1 ('MetaCons c p s) f) where + toSchemaEnumDecomp _ _ + = toSchemaEnumProxy (Proxy @choices) (Proxy @(FindEnumChoice choices (MappingRight fmap c))) +-- Types which have no constructor information cannot be used here + +class GToSchemaEnumProxy (choices :: [k]) (w :: Where) where + toSchemaEnumProxy :: Proxy choices -> Proxy w -> NS Proxy choices +instance GToSchemaEnumProxy (c ': cs) 'Here where + toSchemaEnumProxy _ _ = Z Proxy +instance forall c cs w. GToSchemaEnumProxy cs w + => GToSchemaEnumProxy (c ': cs) ('There w) where + toSchemaEnumProxy _ _ = S (toSchemaEnumProxy (Proxy @cs) (Proxy @w)) + +-- 'fromSchema' for enumerations: +-- 1. for each element in the list of choices +-- (this iteration is done by 'GFromSchemaEnumDecomp') +-- figure out the constructor it corresponds to +-- this is done by 'MappingLeft' and 'FindCon' +-- 2. from that location, build a 'U1' value wrapped +-- in as many 'L1' and 'R1' required. +-- this is done by 'GFromSchemaEnumU1' +class GFromSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs]) (f :: * -> *) where + fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy choices -> f a +instance GFromSchemaEnumDecompose fmap '[] f where + fromSchemaEnumDecomp _ _ = error "This should never happen" +instance (GFromSchemaEnumU1 f (FindCon f (MappingLeft fmap c)), GFromSchemaEnumDecompose fmap cs f) + => GFromSchemaEnumDecompose fmap ('ChoiceDef c ': cs) f where + fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c))) + fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x + +class GFromSchemaEnumU1 (f :: * -> *) (w :: Where) where + fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a +instance GFromSchemaEnumU1 (C1 m U1 :+: rest) 'Here where + fromSchemaEnumU1 _ _ = L1 (M1 U1) +instance GFromSchemaEnumU1 (C1 m U1) 'Here where + fromSchemaEnumU1 _ _ = M1 U1 +instance forall other rest w. GFromSchemaEnumU1 rest w + => GFromSchemaEnumU1 (other :+: rest) ('There w) where + fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @rest) (Proxy @w)) + +-- ---------- +-- RECORDS -- +------------- + +instance {-# OVERLAPPABLE #-} + (GToSchemaRecord w sch fmap args f) + => GToSchemaTypeDef w 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 + 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 + 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 + 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 + 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 + fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) + +-- 'toSchema' for records: +-- 1. iterate over each field in the schema of the record +-- this is done by 'GToSchemaRecord' +-- 2. figure out the selector (field) in the Haskell type +-- to which that record corresponds to +-- this is done by 'MappingLeft' and 'FindSel' +-- 3. using that location, obtain the value of the field +-- this is done by 'GToSchemaRecordSearch' +-- +-- Due to some glitch in 'GHC.Generics', sometimes products +-- are not represented by a linear sequence of ':*:', +-- so we need to handle some cases in a special way +-- (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) + (args :: [FieldDef ts fs]) (f :: * -> *) where + toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) args +instance GToSchemaRecord w 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 + where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x) + +class GToSchemaRecordSearch (w :: * -> *) (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 _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs + +-- 'fromSchema' for records +-- 1. decompose the sequence of products into atomic components +-- until we arrive to the selector metadata 'S1' +-- this is done by 'GFromSchemaRecord' +-- 2. figure out the field in the schema it corresponds to +-- 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) + (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 p x = fromSchemaRecord p x :*: fromSchemaRecord p x +instance GFromSchemaRecord w sch fmap args U1 where + fromSchemaRecord _ _ = U1 + +class GFromSchemaRecordSearch (w :: * -> *) (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 _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs diff --git a/src/Mu/Schema/Conversion/SchemaToTypes.hs b/src/Mu/Schema/Conversion/SchemaToTypes.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -0,0 +1,300 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeOperators #-} +{-| +Description : (Deprecated) Generate a set of Haskell types from a 'Schema' + +This module is deprecated. Haskell types +corresponding to schema types should be +written manually. +-} +module Mu.Schema.Conversion.SchemaToTypes ( + generateTypesFromSchema +, Namer +) where + +import Control.Applicative +import Data.Char +import qualified Data.Map as M +import Data.SOP +import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Mu.Schema.Definition + +-- | Generate the name from each new Haskell type +-- from the name given in the schema. +type Namer = String -> String + +-- | Generates types to represent each of the types +-- in a given schema. You should call it as: +-- > $(generateTypesFromSchema f 'Schema) +-- where @f@ is a function @String -> String@ +-- which obtains the Haskell name for a type +-- given the name in the schema. The second argument +-- is simply the name of the schema. +generateTypesFromSchema :: Namer -> Name -> Q [Dec] +generateTypesFromSchema namer schemaTyName + = do let schemaTy = ConT schemaTyName + schDef <- typeToSchemaDef schemaTy + case schDef of + Nothing -> fail "schema cannot be parsed" + Just sd -> concat <$> traverse (typeDefToDecl schemaTy namer) sd + +-- Generation of types +-- =================== + +typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec] +-- Records with one field +typeDefToDecl _schemaTy namer (DRecord name [f]) + = do let complete = completeName namer name + fVar <- newName "f" + d <- newtypeD (pure []) + (mkName complete) + [PlainTV fVar] + Nothing + (pure (RecC (mkName complete) [fieldDefToDecl namer complete fVar f])) + [pure (DerivClause Nothing [ConT ''Generic])] + _wTy <- VarT <$> newName "w" + -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f]) + return [d] -- , hsi] +-- Records with more than one field +typeDefToDecl _schemaTy namer (DRecord name fields) + = do let complete = completeName namer name + fVar <- newName "f" + d <- dataD (pure []) + (mkName complete) + [PlainTV fVar] + Nothing + [pure (RecC (mkName complete) (map (fieldDefToDecl namer complete fVar) fields))] + [pure (DerivClause Nothing [ConT ''Generic])] + _wTy <- VarT <$> newName "w" + -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields) + return [d] -- , hsi] +-- Enumerations +typeDefToDecl _schemaTy namer (DEnum name choices) + = do let complete = completeName namer name + fVar <- newName "f" + d <- dataD (pure []) + (mkName complete) + [PlainTV fVar] + Nothing + [ pure (RecC (mkName (choiceName complete choicename)) []) + | ChoiceDef choicename <- choices] + [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] +-- Simple things +typeDefToDecl _ _ (DSimple _) + = fail "DSimple is not supported" + +fieldDefToDecl :: Namer -> String -> Name -> FieldDefB Type String String -> (Name, Bang, Type) +fieldDefToDecl namer complete fVar (FieldDef name ty) + = ( mkName (fieldName complete name) + , Bang NoSourceUnpackedness NoSourceStrictness + , AppT (VarT fVar) (fieldTypeToDecl namer fVar ty) ) + +{- broken for now +generateBuiltinInstance :: Bool -> Type -> String -> Name -> Dec +generateBuiltinInstance withPrereq wTy complete className +#if MIN_VERSION_template_haskell(2,12,0) + = StandaloneDerivD Nothing ctx ty +#else + = StandaloneDerivD ctx ty + +#endif + where + me = ConT (mkName complete) + ctx = [AppT (ConT className) (AppT wTy (AppT me wTy)) | withPrereq] + ty = AppT (ConT className) (AppT me wTy) +-} + +{- +generateHasSchemaInstance :: Type -> Type -> String -> String -> Type -> Dec +generateHasSchemaInstance wTy schemaTy schemaName complete mapping + = InstanceD Nothing [AppT (ConT ''Applicative) wTy] + (AppT (AppT (AppT (AppT (ConT ''HasSchema) + wTy ) + schemaTy ) + (LitT (StrTyLit schemaName))) + (AppT (ConT (mkName complete)) wTy) ) +#if MIN_VERSION_template_haskell(2,15,0) + [TySynInstD (TySynEqn Nothing + (AppT (AppT (AppT (AppT (ConT ''FieldMapping) + wTy ) + schemaTy ) + (LitT (StrTyLit schemaName)) ) + (AppT (ConT (mkName complete)) wTy)) + mapping) ] +#else + [TySynInstD ''FieldMapping + (TySynEqn [ wTy, schemaTy, LitT (StrTyLit schemaName) + , AppT (ConT (mkName complete)) wTy ] + mapping) ] +#endif +-} + +{- +fieldMapping :: String -> [FieldDefB Type String String] -> Type +fieldMapping _complete [] = PromotedNilT +fieldMapping complete (FieldDef name _ : rest) + = AppT (AppT PromotedConsT thisMapping) (fieldMapping complete rest) + where thisMapping + = AppT (AppT (PromotedT '(:->)) + (LitT (StrTyLit (fieldName complete name)))) + (LitT (StrTyLit name)) + +choiceMapping :: String -> [ChoiceDef String] -> Type +choiceMapping _complete [] = PromotedNilT +choiceMapping complete (ChoiceDef name : rest) + = AppT (AppT PromotedConsT thisMapping) (choiceMapping complete rest) + where thisMapping + = AppT (AppT (PromotedT '(:->)) + (LitT (StrTyLit (choiceName complete name)))) + (LitT (StrTyLit name)) +-} + +-- Name manipulation +-- ================= + +completeName :: Namer -> String -> String +completeName namer name = firstUpper (namer (firstUpper name)) + +choiceName :: String -> String -> String +choiceName complete cname = firstUpper (complete ++ firstUpper cname) + +fieldName :: String -> String -> String +fieldName complete fname = firstLower (complete ++ firstUpper fname) + +firstUpper :: String -> String +firstUpper [] = error "Empty names are not allowed" +firstUpper (x:rest) = toUpper x : rest + +firstLower :: String -> String +firstLower [] = error "Empty names are not allowed" +firstLower (x:rest) = toLower x : rest + +fieldTypeToDecl :: Namer -> Name -> FieldTypeB Type String -> Type +fieldTypeToDecl _namer _fVar TNull + = ConT ''() +fieldTypeToDecl _namer _fVar (TPrimitive t) + = t +fieldTypeToDecl namer fVar (TSchematic nm) + = AppT (ConT (mkName $ completeName namer nm)) (VarT fVar) +fieldTypeToDecl namer fVar (TOption t) + = AppT (ConT ''Maybe) (fieldTypeToDecl namer fVar t) +fieldTypeToDecl namer fVar (TList t) + = AppT ListT (fieldTypeToDecl namer fVar t) +fieldTypeToDecl namer fVar (TMap k v) + = AppT (AppT (ConT ''M.Map) (fieldTypeToDecl namer fVar k)) (fieldTypeToDecl namer fVar v) +fieldTypeToDecl namer fVar (TUnion ts) + = AppT (AppT (ConT ''NS) (ConT ''I)) (fieldTypeUnion namer fVar ts) + +fieldTypeUnion :: Namer -> Name -> [FieldTypeB Type String] -> Type +fieldTypeUnion _ _fVar [] = PromotedNilT +fieldTypeUnion namer fVar (t:ts) + = AppT (AppT PromotedConsT (fieldTypeToDecl namer fVar t)) (fieldTypeUnion namer fVar ts) + +-- Parsing +-- ======= + +typeToSchemaDef :: Type -> Q (Maybe (SchemaB Type String String)) +typeToSchemaDef toplevelty + = typeToSchemaDef' <$> resolveTypeSynonyms toplevelty + where + typeToSchemaDef' :: Type -> Maybe (SchemaB Type String String) + typeToSchemaDef' expanded + = do types <- tyList expanded + mapM typeToTypeDef types + + typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType + :: Type -> Maybe (TypeDefB Type String String) + typeToTypeDef t + = typeToRecordDef t <|> typeToEnumDef t <|> typeToSimpleType t + typeToRecordDef t + = do (nm, fields) <- tyD2 'DRecord t + DRecord <$> tyString nm + <*> (mapM typeToFieldDef =<< tyList fields) + typeToEnumDef t + = do (nm, choices) <- tyD2 'DEnum t + DEnum <$> tyString nm + <*> (mapM typeToChoiceDef =<< tyList choices) + typeToSimpleType t + = do innerT <- tyD1 'DSimple t + DSimple <$> typeToFieldType innerT + + typeToFieldDef :: Type -> Maybe (FieldDefB Type String String) + typeToFieldDef t + = do (nm, innerTy) <- tyD2 'FieldDef t + FieldDef <$> tyString nm + <*> typeToFieldType innerTy + + typeToChoiceDef :: Type -> Maybe (ChoiceDef String) + typeToChoiceDef t + = do nm <- tyD1 'ChoiceDef t + ChoiceDef <$> tyString nm + + typeToFieldType :: Type -> Maybe (FieldTypeB Type String) + typeToFieldType t + = TNull <$ tyD0 'TNull t + <|> TPrimitive <$>tyD1 'TPrimitive t + <|> (do sch <- tyD1 'TSchematic t + TSchematic <$> tyString sch) + <|> (do inner <- tyD1 'TOption t + TOption <$> typeToFieldType inner) + <|> (do inner <- tyD1 'TList t + TList <$> typeToFieldType inner) + <|> (do (k,v) <- tyD2 'TMap t + TMap <$> typeToFieldType k <*> typeToFieldType v) + <|> (do inners <- tyD1 'TUnion t + TUnion <$> (mapM typeToFieldType =<< tyList inners)) + +tyString :: Type -> Maybe String +tyString (SigT t _) + = tyString t +tyString (LitT (StrTyLit s)) + = Just s +tyString _ + = Nothing + +tyList :: Type -> Maybe [Type] +tyList (SigT t _) + = tyList t +tyList PromotedNilT + = Just [] +tyList (AppT (AppT PromotedConsT ty) rest) + = (ty :) <$> tyList rest +tyList _ = Nothing + +tyD0 :: Name -> Type -> Maybe () +tyD0 name (SigT t _) = tyD0 name t +tyD0 name (PromotedT c) + | c == name = Just () + | otherwise = Nothing +tyD0 _ _ = Nothing + +tyD1 :: Name -> Type -> Maybe Type +tyD1 name (SigT t _) = tyD1 name t +tyD1 name (AppT (PromotedT c) x) + | c == name = Just x + | otherwise = Nothing +tyD1 _ _ = Nothing + +tyD2 :: Name -> Type -> Maybe (Type, Type) +tyD2 name (SigT t _) = tyD2 name t +tyD2 name (AppT (AppT (PromotedT c) x) y) + | c == name = Just (x, y) + | otherwise = Nothing +tyD2 _ _ = Nothing + +{- +tyD3 :: Name -> Type -> Maybe (Type, Type, Type) +tyD3 name (SigT t _) = tyD3 name t +tyD3 name (AppT (AppT (AppT (PromotedT c) x) y) z) + | c == name = Just (x, y, z) + | otherwise = Nothing +tyD3 _ _ = Nothing +-} diff --git a/src/Mu/Schema/Conversion/TypesToSchema.hs b/src/Mu/Schema/Conversion/TypesToSchema.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Conversion/TypesToSchema.hs @@ -0,0 +1,115 @@ +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description: From 'Schema' to Haskell types. + +Obtains a 'Schema' from a set of Haskell types. + +Unfortunately, GHC does not allow type families +to appear in instances, so you cannot use the +resulting type directly. Instead, evaluate it +in an interpreter session using @:kind!@ and +copy the result to the file. +-} +module Mu.Schema.Conversion.TypesToSchema ( + SchemaFromTypes +, FromType(..) +, AsRecord, AsEnum +) where + +import Data.Kind +import Data.Map as M +import Data.SOP +import GHC.Generics +import GHC.TypeLits + +import Mu.Schema.Definition + +-- | Defines whether to turn each Haskell type +-- into a record or an enumeration. +-- Any type not declared in the given list +-- of 'FromType's is considered primitive. +data FromType tn fn + = -- | Declares that the type should become a record. + AsRecord' Type tn (Mappings Symbol fn) + -- | Declares that the type should become an enumeration. + | AsEnum' Type tn (Mappings Symbol fn) + +-- | Declares that the type should become a record. +type AsRecord t tn = 'AsRecord' t tn '[] +-- | Declares that the type should become an enumeration. +type AsEnum t tn = 'AsEnum' t tn '[] + +-- | Convert a set of types into a 'Schema'. +type family SchemaFromTypes (f :: [FromType tn fn]) :: Schema tn fn where + SchemaFromTypes f = SchemaFromTypes' f f + +type family SchemaFromTypes' (all :: [FromType tn fn]) (f :: [FromType tn fn]) :: Schema tn fn where + SchemaFromTypes' all '[] = '[] + SchemaFromTypes' all (t ': ts) = TypeDefFromType all t ': SchemaFromTypes' all ts + +type family TypeDefFromType (all :: [FromType tn fn]) (info :: FromType tn fn) + :: TypeDef tn fn where + TypeDefFromType all ('AsRecord' t name mp) = 'DRecord name (FieldsFromType all mp (Rep t)) + TypeDefFromType all ('AsEnum' t name mp) = 'DEnum name (ChoicesFromType all mp (Rep t)) + +type family FieldsFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) (f :: * -> *) + :: [FieldDef tn fn] where + FieldsFromType all mp (x :+: y) + = TypeError ('Text "sum types cannot be converted to record schemas") + FieldsFromType all mp (D1 meta f) + = FieldsFromType all mp f -- go through data info + FieldsFromType all mp (C1 meta f) + = FieldsFromType all mp f -- go through constructor info + FieldsFromType all mp (x :*: y) + = ConcatList (FieldsFromType all mp x) (FieldsFromType all mp y) + FieldsFromType all mp (S1 ('MetaSel ('Just x) u ss ds) (K1 i t)) + = '[ 'FieldDef (MappingRight mp x) (ChooseFieldType all t) ] + FieldsFromType all mp v + = TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to record schema") + +type family ConcatList (xs :: [k]) (ys :: [k]) :: [k] where + ConcatList '[] ys = ys + ConcatList (x ': xs) ys = x ': ConcatList xs ys + +type family ChooseFieldType (all :: [FromType tn fn]) (t :: Type) + :: FieldType tn where + ChooseFieldType all () = 'TNull + ChooseFieldType all (Maybe t) = 'TOption (ChooseFieldType all t) + ChooseFieldType all [t] = 'TList (ChooseFieldType all t) + ChooseFieldType all (M.Map k v) = 'TMap (ChooseFieldType all k) (ChooseFieldType all v) + ChooseFieldType all (NS I choices) = 'TUnion (ChooseFieldUnion all choices) + ChooseFieldType all t = ChooseFieldPrimitiveOrSchematic t (FindTypeName all t) + +type family ChooseFieldUnion (all :: [FromType tn fn]) (t :: [Type]) + :: [FieldType tn] where + ChooseFieldUnion all '[] = '[] + ChooseFieldUnion all (t ': ts) = ChooseFieldType all t ': ChooseFieldUnion all ts + +type family FindTypeName (all :: [FromType tn fn]) (t :: Type) + :: Maybe tn where + FindTypeName '[] t = 'Nothing + FindTypeName ('AsRecord' t tn mp ': rest) t = 'Just tn + FindTypeName ('AsEnum' t tn mp ': rest) t = 'Just tn + FindTypeName (other ': rest) t = FindTypeName rest t + +type family ChooseFieldPrimitiveOrSchematic (t :: Type) (ref :: Maybe tn) + :: FieldType tn where + ChooseFieldPrimitiveOrSchematic t ('Just name) = 'TSchematic name + ChooseFieldPrimitiveOrSchematic t 'Nothing = 'TPrimitive t + +type family ChoicesFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) (f :: * -> *) + :: [ChoiceDef fn] where + ChoicesFromType all mp (D1 meta f) + = ChoicesFromType all mp f -- go through data info + ChoicesFromType all mp (x :+: y) + = ConcatList (ChoicesFromType all mp x) (ChoicesFromType all mp y) + ChoicesFromType all mp (C1 ('MetaCons cname p s) U1) + = '[ 'ChoiceDef (MappingRight mp cname) ] -- go through constructor info + ChoicesFromType all mp (C1 ('MetaCons cname p s) f) + = TypeError ('Text "constructor " ':<>: 'ShowType cname ':<>: 'Text "has fields and cannot be turned into an enumeration schema") + ChoicesFromType all mp v + = TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to enumeration schema") diff --git a/src/Mu/Schema/Definition.hs b/src/Mu/Schema/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Definition.hs @@ -0,0 +1,232 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Definition of schemas + +This module gives a set of combinators +to define schemas in the sense of Avro +or Protocol Buffers. + +In order to re-use definitions at both +the type and term levels, the actual +constructors are defined in types ending +with @B@, and are parametrized by the type +used to describe identifiers. +The versions without the suffix set this +parameter to 'Type', and are thought as the +API to be used in the type-level. +If you use 'reflectSchema' to obtain a term- +level representation, the parameter is set +to 'TypeRep'. +-} +module Mu.Schema.Definition ( +-- * Definition of schemas + Schema', Schema, SchemaB +, TypeDef, TypeDefB(..) +, ChoiceDef(..) +, FieldDef, FieldDefB(..) +, FieldType, FieldTypeB(..) +, (:/:) +-- * One-to-one mappings +, Mapping(..), Mappings +-- ** Finding correspondences +, MappingRight, MappingLeft +-- * Reflection to term-level +, reflectSchema +, reflectFields, reflectChoices +, reflectFieldTypes, reflectFieldType +-- * Supporting type classes +, KnownName(..) +) where + +import Data.Kind +import Data.Proxy +import Data.Typeable +import GHC.TypeLits + +-- | A set of type definitions, +-- where the names of types and fields are +-- defined by type-level strings ('Symbol's). +type Schema' = Schema Symbol Symbol + +-- | Type names and field names can be of any +-- kind, but for many uses we need a way +-- to turn them into strings at run-time. +-- This class generalizes 'KnownSymbol'. +class KnownName (a :: k) where + nameVal :: proxy a -> String +instance KnownSymbol s => KnownName (s :: Symbol) where + nameVal = symbolVal +instance KnownName 'True where + nameVal _ = "True" +instance KnownName 'False where + nameVal _ = "False" +instance KnownNat n => KnownName (n :: Nat) where + nameVal = show . natVal + +-- | A set of type definitions. +-- In general, we can use any kind we want for +-- both type and field names, although in practice +-- you always want to use 'Symbol'. +type Schema typeName fieldName + = SchemaB Type typeName fieldName +-- | A set of type definitions, +-- parametric on type representations. +type SchemaB builtin typeName fieldName + = [TypeDefB builtin typeName fieldName] + +-- | Defines a type in a schema. +-- Each type can be: +-- * a record: a list of key-value pairs, +-- * an enumeration: an element of a list of choices, +-- * a reference to a primitive type. +type TypeDef = TypeDefB Type +-- | Defines a type in a schema, +-- parametric on type representations. +data TypeDefB builtin typeName fieldName + = -- | A list of key-value pairs. + DRecord typeName [FieldDefB builtin typeName fieldName] + -- | An element of a list of choices. + | DEnum typeName [ChoiceDef fieldName] + -- | A reference to a primitive type. + | DSimple (FieldTypeB builtin typeName) + +-- | Defines each of the choices in an enumeration. +newtype ChoiceDef fieldName + = -- | One single choice from an enumeration. + ChoiceDef fieldName + +-- | Defines a field in a record +-- by a name and the corresponding type. +type FieldDef = FieldDefB Type +-- | Defines a field in a record, +-- parametric on type representations. +data FieldDefB builtin typeName fieldName + = -- | One single field in a record. + FieldDef fieldName (FieldTypeB builtin typeName) + +-- | Types of fields of a record. +-- References to other types in the same schema +-- are done via the 'TSchematic' constructor. +type FieldType = FieldTypeB Type +-- | Types of fields of a record, +-- parametric on type representations. +data FieldTypeB builtin typeName + = -- | Null, as found in Avro. + TNull + -- | Reference to a primitive type, such as integers or Booleans. + -- The set of supported primitive types depends on the protocol. + | TPrimitive builtin + -- | Reference to another type in the schema. + | TSchematic typeName + -- | Optional value. + | TOption (FieldTypeB builtin typeName) + -- | List of values. + | TList (FieldTypeB builtin typeName) + -- | Map of values. + -- The set of supported key types depends on the protocol. + | TMap (FieldTypeB builtin typeName) (FieldTypeB builtin typeName) + -- | Represents a choice between types. + | TUnion [FieldTypeB builtin typeName] + +-- | Lookup a type in a schema by its name. +type family (sch :: Schema t f) :/: (name :: t) :: TypeDef t f where + '[] :/: name = TypeError ('Text "Cannot find type " ':<>: 'ShowType name ':<>: 'Text " in the schema") + ('DRecord name fields ': rest) :/: name = 'DRecord name fields + ('DEnum name choices ': rest) :/: name = 'DEnum name choices + (other ': rest) :/: name = rest :/: name + +-- | Defines a mapping between two elements. +data Mapping a b = a :-> b +-- | Defines a set of mappings between elements of @a@ and @b@. +type Mappings a b = [Mapping a b] + +-- | Finds the corresponding right value of @v@ +-- in a mapping @ms@. When the kinds are 'Symbol', +-- return the same value if not found. +type family MappingRight (ms :: Mappings a b) (v :: a) :: b where + MappingRight '[] (v :: Symbol) = v + MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) + MappingRight ((x ':-> y) ': rest) x = y + MappingRight (other ': rest) x = MappingRight rest x + +-- | Finds the corresponding left value of @v@ +-- in a mapping @ms@. When the kinds are 'Symbol', +-- return the same value if not found. +type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where + MappingLeft '[] (v :: Symbol) = v + MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) + MappingLeft ((x ':-> y) ': rest) y = x + MappingLeft (other ': rest) y = MappingLeft rest y + +class ReflectSchema (s :: Schema tn fn) where + -- | Reflect a schema into term-level. + reflectSchema :: Proxy s -> SchemaB TypeRep String String +instance ReflectSchema '[] where + reflectSchema _ = [] +instance (ReflectFields fields, KnownName name, ReflectSchema s) + => ReflectSchema ('DRecord name fields ': s) where + reflectSchema _ = DRecord (nameVal (Proxy @name)) (reflectFields (Proxy @fields)) + : reflectSchema (Proxy @s) +instance (ReflectChoices choices, KnownName name, ReflectSchema s) + => ReflectSchema ('DEnum name choices ': s) where + reflectSchema _ = DEnum (nameVal (Proxy @name)) (reflectChoices (Proxy @choices)) + : reflectSchema (Proxy @s) +instance (ReflectFieldType ty, ReflectSchema s) + => ReflectSchema ('DSimple ty ': s) where + reflectSchema _ = DSimple (reflectFieldType (Proxy @ty)) + : reflectSchema (Proxy @s) + +class ReflectFields (fs :: [FieldDef tn fn]) where + -- | Reflect a list of fields into term-level. + reflectFields :: Proxy fs -> [FieldDefB TypeRep String String] +instance ReflectFields '[] where + reflectFields _ = [] +instance (KnownName name, ReflectFieldType ty, ReflectFields fs) + => ReflectFields ('FieldDef name ty ': fs) where + reflectFields _ = FieldDef (nameVal (Proxy @name)) (reflectFieldType (Proxy @ty)) + : reflectFields (Proxy @fs) + +class ReflectChoices (cs :: [ChoiceDef fn]) where + -- | Reflect a list of enumeration choices into term-level. + reflectChoices :: Proxy cs -> [ChoiceDef String] +instance ReflectChoices '[] where + reflectChoices _ = [] +instance (KnownName name, ReflectChoices cs) + => ReflectChoices ('ChoiceDef name ': cs) where + reflectChoices _ = ChoiceDef (nameVal (Proxy @name)) + : reflectChoices (Proxy @cs) + +class ReflectFieldType (ty :: FieldType tn) where + -- | Reflect a schema type into term-level. + reflectFieldType :: Proxy ty -> FieldTypeB TypeRep String +instance ReflectFieldType 'TNull where + reflectFieldType _ = TNull +instance (Typeable ty) => ReflectFieldType ('TPrimitive ty) where + reflectFieldType _ = TPrimitive (typeRep (Proxy @ty)) +instance (KnownName nm) => ReflectFieldType ('TSchematic nm) where + reflectFieldType _ = TSchematic (nameVal (Proxy @nm)) +instance (ReflectFieldType t) => ReflectFieldType ('TOption t) where + reflectFieldType _ = TOption (reflectFieldType (Proxy @t)) +instance (ReflectFieldType t) => ReflectFieldType ('TList t) where + reflectFieldType _ = TList (reflectFieldType (Proxy @t)) +instance (ReflectFieldType k, ReflectFieldType v) + => ReflectFieldType ('TMap k v) where + reflectFieldType _ = TMap (reflectFieldType (Proxy @k)) (reflectFieldType (Proxy @v)) +instance (ReflectFieldTypes ts) => ReflectFieldType ('TUnion ts) where + reflectFieldType _ = TUnion (reflectFieldTypes (Proxy @ts)) + +class ReflectFieldTypes (ts :: [FieldType tn]) where + -- | Reflect a list of schema types into term-level. + reflectFieldTypes :: Proxy ts -> [FieldTypeB TypeRep String] +instance ReflectFieldTypes '[] where + reflectFieldTypes _ = [] +instance (ReflectFieldType t, ReflectFieldTypes ts) + => ReflectFieldTypes (t ': ts) where + reflectFieldTypes _ = reflectFieldType (Proxy @t) : reflectFieldTypes (Proxy @ts) diff --git a/src/Mu/Schema/Examples.hs b/src/Mu/Schema/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Examples.hs @@ -0,0 +1,105 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language QuasiQuotes #-} +{-# language StandaloneDeriving #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Examples for schema definitions. + +Look at the source code of this module. +-} +module Mu.Schema.Examples where + +import qualified Data.Aeson as J +import Data.Functor.Identity +import qualified Data.Text as T +import GHC.Generics + +import Mu.Adapter.Json () +import Mu.Schema +import Mu.Schema.Conversion.SchemaToTypes + +data Person + = Person { firstName :: T.Text + , lastName :: T.Text + , age :: Maybe Int + , gender :: Maybe Gender + , address :: Address } + deriving (Eq, Show, Generic) + deriving (ToSchema Identity ExampleSchema "person", FromSchema Identity ExampleSchema "person") + deriving (J.ToJSON, J.FromJSON) + via (WithSchema Identity 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 (J.ToJSON, J.FromJSON) + via (WithSchema Identity ExampleSchema "address" Address) + +type GenderFieldMapping + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" ] + +data Gender = Male | Female | NonBinary + deriving (Eq, Show, Generic) + deriving (ToSchema f ExampleSchema "gender", FromSchema f ExampleSchema "gender") + via (CustomFieldMapping "gender" GenderFieldMapping Gender) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema Identity ExampleSchema "gender" Gender) + +-- Schema for these data types +type ExampleSchema + = '[ 'DEnum "gender" + '[ 'ChoiceDef "male" + , 'ChoiceDef "female" + , 'ChoiceDef "nb" ] + , 'DRecord "address" + '[ 'FieldDef "postcode" ('TPrimitive T.Text) + , 'FieldDef "country" ('TPrimitive T.Text) ] + , 'DRecord "person" + '[ 'FieldDef "firstName" ('TPrimitive T.Text) + , 'FieldDef "lastName" ('TPrimitive T.Text) + , 'FieldDef "age" ('TOption ('TPrimitive Int)) + , 'FieldDef "gender" ('TOption ('TSchematic "gender")) + , 'FieldDef "address" ('TSchematic "address") ] + ] + +$(generateTypesFromSchema (++"Msg") ''ExampleSchema) + +{- +type ExampleSchema2 + = SchemaFromTypes '[ AsRecord Person "person" + , AsRecord Address "address" + , AsEnum Gender "gender" ] +-} +type ExampleSchema2 + = '[ 'DEnum "gender" + '[ 'ChoiceDef "Male" + , 'ChoiceDef "Female" + , 'ChoiceDef "NonBinary" ] + , 'DRecord "address" + '[ 'FieldDef "postcode" ('TPrimitive T.Text) + , 'FieldDef "country" ('TPrimitive T.Text) ] + , 'DRecord "person" + '[ 'FieldDef "firstName" ('TPrimitive T.Text) + , 'FieldDef "lastName" ('TPrimitive T.Text) + , 'FieldDef "age" ('TOption ('TPrimitive Int)) + , 'FieldDef "gender" ('TOption ('TSchematic "gender")) + , 'FieldDef "address" ('TSchematic "address") ] + ] + +type ExampleRegistry + = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] diff --git a/src/Mu/Schema/Interpretation.hs b/src/Mu/Schema/Interpretation.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Interpretation.hs @@ -0,0 +1,259 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Interpretation of schemas + +This module defines 'Term's which comply with +a given 'Schema'. These 'Term's are the main +form of values used internally by @mu-haskell@. + +This module follows the ideas of +. +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 . +These are the n-ary versions of a pair and +'Either', respectively. In other words, 'NP' +puts together a bunch of values of different +types, 'NS' allows you to choose from a bunch +of types. +-} +module Mu.Schema.Interpretation ( + -- * 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 +import Data.Proxy +import Data.SOP + +import Mu.Schema.Definition + +-- | Interpretation of a type in a schema. +data Term w (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) + -- | An enumeration given by one choice. + TEnum :: NS Proxy choices -> Term w sch ('DEnum name choices) + -- | A primitive value. + TSimple :: FieldValue w sch t -> Term w sch ('DSimple t) + +-- | Interpretation of a field. +data Field w (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) + +-- | Interpretation of a field type, by giving a value of that type. +data FieldValue w (sch :: Schema typeName fieldName) (t :: FieldType typeName) where + -- | Null value, as found in Avro and JSON. + FNull :: FieldValue w sch 'TNull + -- | Value of a primitive type. + FPrimitive :: t -> FieldValue w sch ('TPrimitive t) + -- | Term of another type in the schema. + FSchematic :: Term w sch (sch :/: t) + -> FieldValue w sch ('TSchematic t) + -- | Optional value. + FOption :: Maybe (FieldValue w sch t) + -> FieldValue w sch ('TOption t) + -- | List of values. + FList :: [FieldValue w sch t] + -> FieldValue w 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) + -- | 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) + +-- =========================== +-- CRAZY EQ AND SHOW INSTANCES +-- =========================== + +instance All (Eq `Compose` Field w sch) args + => Eq (Term w 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 + 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 + 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 + 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 (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 + TSimple x == TSimple y = x == y +instance Show (FieldValue w sch t) => Show (Term w sch ('DSimple t)) where + show (TSimple x) = show x + +instance (Eq (w (FieldValue w sch t))) => Eq (Field w 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 + show (Field x) = nameVal (Proxy @name) ++ ": " ++ show x + +instance Eq (FieldValue w sch 'TNull) where + _ == _ = True +instance Eq t => Eq (FieldValue w sch ('TPrimitive t)) where + FPrimitive x == FPrimitive y = x == y +instance Eq (Term w sch (sch :/: t)) => Eq (FieldValue w sch ('TSchematic t)) where + FSchematic x == FSchematic y = x == y +instance Eq (FieldValue w sch t) => Eq (FieldValue w sch ('TOption t)) where + FOption x == FOption y = x == y +instance Eq (FieldValue w sch t) => Eq (FieldValue w 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 + FMap x == FMap y = x == y +instance All (Eq `Compose` FieldValue w sch) choices + => Eq (FieldValue w sch ('TUnion choices)) where + FUnion x == FUnion y = x == y + +instance Ord (FieldValue w sch 'TNull) where + compare _ _ = EQ +instance Ord t => Ord (FieldValue w 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 + compare (FSchematic x) (FSchematic y) = compare x y +instance Ord (FieldValue w sch t) => Ord (FieldValue w 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 + 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 + 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 + compare (FUnion x) (FUnion y) = compare x y + +instance Show (FieldValue w sch 'TNull) where + show _ = "null" +instance Show t => Show (FieldValue w sch ('TPrimitive t)) where + show (FPrimitive x) = show x +instance Show (Term w sch (sch :/: t)) => Show (FieldValue w sch ('TSchematic t)) where + show (FSchematic x) = show x +instance Show (FieldValue w sch t) => Show (FieldValue w 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 + show (FList xs) = show xs +instance (Show (FieldValue w sch k), Show (FieldValue w sch v)) + => Show (FieldValue w 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 + show (FUnion x) = show x diff --git a/src/Mu/Schema/Interpretation/Anonymous.hs b/src/Mu/Schema/Interpretation/Anonymous.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Interpretation/Anonymous.hs @@ -0,0 +1,105 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language StandaloneDeriving #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Anonymous terms for schema types + +This module provides "anonymous terms". These +terms can be used when you don't want to write +your own Haskell type, but simply have a quick +and dirty interpretation for a schema type. +An important limitation is that anonymous terms +may only contain primitive fields. + +The names of the types exposed in this module +refer to the amount of fields in the record. +Hence, use 'V0' for empty record, 'V1' for a record +with one field, 'V2' for two, and so forth. +-} +module Mu.Schema.Interpretation.Anonymous where + +import Data.SOP + +import Mu.Schema + +-- | Anonymous term for a record with zero fields. +data V0 w sch sty where + V0 :: (sch :/: sty ~ 'DRecord nm '[]) + => V0 w sch sty + +deriving instance Show (V0 w sch sty) +deriving instance Eq (V0 w sch sty) +deriving instance Ord (V0 w sch sty) + +instance (sch :/: sty ~ 'DRecord nm '[]) + => ToSchema w sch sty (V0 w sch sty) where + toSchema V0 = TRecord Nil +instance (sch :/: sty ~ 'DRecord nm '[]) + => FromSchema w sch sty (V0 w sch sty) where + fromSchema (TRecord Nil) = V0 + +-- | Anonymous term for a record with one field. +data V1 w sch sty where + V1 :: (sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) + => w a -> V1 w 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) + +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 + unPrimitive (FPrimitive l) = l + +-- | Anonymous term for a record with two fields. +data V2 w sch sty where + V2 :: (sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) + => w a -> w b -> V2 w sch sty + +deriving instance (Show (w a), Show (w 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), + 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), + sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) + => Ord (V2 w sch sty) + +instance ( Functor w + , 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) + , '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 + unPrimitive (FPrimitive l) = l diff --git a/src/Mu/Schema/Interpretation/Schemaless.hs b/src/Mu/Schema/Interpretation/Schemaless.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Interpretation/Schemaless.hs @@ -0,0 +1,235 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Terms without an associated schema + +In the edges of your application it's useful to +consider terms for which a type-level schema has +not yet been applied. Think of receiving a JSON +document: you can parse it but checking the schema +is an additional step. +-} +module Mu.Schema.Interpretation.Schemaless ( + -- * Terms without an associated schema + Term(..), Field(..), FieldValue(..) + -- * Checking and conversion against a schema +, checkSchema, fromSchemalessTerm + -- * For deserialization to schemaless terms +, ToSchemalessTerm(..), ToSchemalessValue(..) + -- * For implementors +, CheckSchema +) where + +import Control.Applicative ((<|>)) +import Data.List (find) +import qualified Data.Map as M +import Data.Proxy +import Data.SOP +import qualified Data.Text as T +import Data.Typeable + +import Mu.Schema.Class +import Mu.Schema.Definition +import qualified Mu.Schema.Interpretation as S + +-- | Interpretation of a type in a schema. +data Term (w :: * -> *) where + -- | A record given by the value of its fields. + TRecord :: [Field w] -> Term w + -- | An enumeration given by one choice. + TEnum :: Int -> Term w + -- | A primitive value. + TSimple :: FieldValue w -> Term w + +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) + +-- | Interpretation of a field. +data Field (w :: * -> *) 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 + +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) + +-- | 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 + +-- | Checks that a schemaless 'Term' obbeys the +-- restrictions for tyoe @t@ of schema @s@. +-- If successful, returns a 'S.Term' indexed +-- by the corresponding schema and type. +-- +-- 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)) +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 + +-- | Deserialization to schemaless terms. +class ToSchemalessTerm t w 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 +-- | Deserialization to schemaless values. +class ToSchemalessValue t w 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 + +-- | 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) +class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where + checkSchemaFields :: Traversable w => [Field w] -> Maybe (NP (S.Field w 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) +class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where + checkSchemaUnion :: Traversable w => FieldValue w -> Maybe (NS (S.FieldValue w s) ts) + +instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm fields) where + checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields + checkSchema' _ = Nothing +instance CheckSchemaFields s '[] where + checkSchemaFields _ = pure Nil +instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest) + => CheckSchemaFields s ('FieldDef nm ty ': rest) where + checkSchemaFields fs + = do let name = T.pack (nameVal (Proxy @nm)) + Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs + v' <- traverse checkSchemaValue v + r' <- checkSchemaFields @_ @_ @s @rest fs + return (S.Field v' :* r') + +instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where + checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n + checkSchema' (TSimple (FPrimitive (n :: a))) + = case (eqT @a @Int, eqT @a @T.Text, eqT @a @String) of + (Just Refl, _, _) -> S.TEnum <$> checkSchemaEnumInt n + (_, Just Refl, _) -> S.TEnum <$> checkSchemaEnumText n + (_, _, Just Refl) -> S.TEnum <$> checkSchemaEnumText (T.pack n) + _ -> Nothing + checkSchema' _ = Nothing +instance CheckSchemaEnum '[] where + checkSchemaEnumInt _ = Nothing + checkSchemaEnumText _ = Nothing +instance (KnownName c, CheckSchemaEnum cs) + => CheckSchemaEnum ('ChoiceDef c ': cs) where + checkSchemaEnumInt 0 = Just (Z Proxy) + checkSchemaEnumInt n = S <$> checkSchemaEnumInt (n-1) + checkSchemaEnumText t + | t == T.pack (nameVal (Proxy @c)) = Just (Z Proxy) + | otherwise = S <$> checkSchemaEnumText t + +instance CheckSchemaValue s f => CheckSchema s ('DSimple f) where + checkSchema' (TSimple t) = S.TSimple <$> checkSchemaValue t + checkSchema' _ = Nothing +instance CheckSchemaValue s 'TNull where + checkSchemaValue FNull = Just S.FNull + checkSchemaValue _ = Nothing +instance Typeable t => CheckSchemaValue s ('TPrimitive t) where + checkSchemaValue (FPrimitive (t :: a)) + = case eqT @a @t of + Just Refl -> Just (S.FPrimitive t) + Nothing -> Nothing + checkSchemaValue _ = Nothing +-- TODO: handle enums better by an if with typedef +instance (CheckSchema s (s :/: t)) + => CheckSchemaValue s ('TSchematic t) where + checkSchemaValue (FSchematic t) = S.FSchematic <$> checkSchema' t + checkSchemaValue _ = Nothing +instance CheckSchemaValue s t => CheckSchemaValue s ('TOption t) where + checkSchemaValue (FOption x) = S.FOption <$> traverse checkSchemaValue x + checkSchemaValue _ = Nothing +instance CheckSchemaValue s t => CheckSchemaValue s ('TList t) where + checkSchemaValue (FList xs) = S.FList <$> traverse checkSchemaValue xs + checkSchemaValue _ = Nothing +-- TODO: how to deal with maps?? +instance CheckSchemaUnion s ts => CheckSchemaValue s ('TUnion ts) where + checkSchemaValue x = S.FUnion <$> checkSchemaUnion x + +instance CheckSchemaUnion s '[] where + checkSchemaUnion _ = Nothing +instance (CheckSchemaValue s t, CheckSchemaUnion s ts) + => CheckSchemaUnion s (t ': ts) where + 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 + FNull == FNull = True + FPrimitive (x :: a) == FPrimitive (y :: b) + = case eqT @a @b of + Nothing -> False + Just Refl -> x == y + FSchematic x == FSchematic y = x == y + FOption x == FOption y = x == y + FList x == FList y = x == y + FMap x == FMap y = x == y + _ == _ = False +instance (Ord (w (FieldValue w))) => Ord (FieldValue w) where + FNull <= _ = True + FPrimitive _ <= FNull = False + FPrimitive (x :: a) <= FPrimitive (y :: b) + = case eqT @a @b of + Nothing -> typeOf x <= typeOf y + Just Refl -> x <= y + FPrimitive _ <= _ = True + FSchematic _ <= FNull = False + FSchematic _ <= FPrimitive _ = False + FSchematic x <= FSchematic y = x <= y + FSchematic _ <= _ = True + FOption _ <= FNull = False + FOption _ <= FPrimitive _ = False + FOption _ <= FSchematic _ = False + FOption x <= FOption y = x <= y + FOption _ <= _ = True + FList _ <= FNull = False + FList _ <= FPrimitive _ = False + FList _ <= FSchematic _ = False + FList _ <= FOption _ = False + FList x <= FList y = x <= y + FList _ <= _ = True + FMap _ <= FNull = False + FMap _ <= FPrimitive _ = False + FMap _ <= FSchematic _ = False + FMap _ <= FOption _ = False + FMap _ <= FList _ = False + FMap x <= FMap y = x <= y + -- FMap _ <= _ = True diff --git a/src/Mu/Schema/Registry.hs b/src/Mu/Schema/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Schema/Registry.hs @@ -0,0 +1,68 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Registry of schemas + +A registry of schemas saves the different schemas +supported by an application. Since messages and +protocols may evolve, it's useful to keep an updated +view of the different shapes of data we can handle. + +Examples of registries are found in + +and . +-} +module Mu.Schema.Registry ( + -- * Registry of schemas + Registry, fromRegistry + -- * Terms without an associated schema +, SLess.Term(..), SLess.Field(..), SLess.FieldValue(..) +) where + +import Control.Applicative +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +import Mu.Schema.Class +import Mu.Schema.Definition +import qualified Mu.Schema.Interpretation.Schemaless as SLess + +-- | A 'Registry' is defined as a map from +-- version numbers to type-level schemas. +-- +-- /Implementation note/: you __must__ +-- write newer schemas at the head of the +-- 'Registry'. Otherwise, older schemas +-- take precedence during conversion. +type Registry = Mappings Nat Schema' + +-- | Converts a schemaless term into a value +-- by checking all the possible schemas in +-- a 'Registry'. +-- +-- /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 = fromRegistry' (Proxy @r) + +class FromRegistry (w :: * -> *) (ms :: Registry) (t :: Type) where + fromRegistry' :: Proxy ms -> SLess.Term w -> Maybe t + +instance FromRegistry w '[] 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