mu-schema (empty) → 0.1.0.0

raw patch · 17 files changed

+2545/−0 lines, 17 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, sop-core, template-haskell, text, th-abstraction, unordered-containers, vector

Files

• CHANGELOG.md +5/−0
• LICENSE +202/−0
• Setup.hs +2/−0
• mu-schema.cabal +51/−0
• src/Data/Functor/MaybeLike.hs +29/−0
• src/Mu/Adapter/Json.hs +175/−0
• src/Mu/Schema.hs +41/−0
• src/Mu/Schema/Annotations.hs +75/−0
• src/Mu/Schema/Class.hs +546/−0
• src/Mu/Schema/Conversion/SchemaToTypes.hs +300/−0
• src/Mu/Schema/Conversion/TypesToSchema.hs +115/−0
• src/Mu/Schema/Definition.hs +232/−0
• src/Mu/Schema/Examples.hs +105/−0
• src/Mu/Schema/Interpretation.hs +259/−0
• src/Mu/Schema/Interpretation/Anonymous.hs +105/−0
• src/Mu/Schema/Interpretation/Schemaless.hs +235/−0
• src/Mu/Schema/Registry.hs +68/−0

@@ -0,0 +1,5 @@+# Revision history for mu-haskell++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -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. <http://47deg.com>++   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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <http://47deg.com 47 Degrees>+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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+-}

@@ -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")

@@ -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)

@@ -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]

@@ -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+<https://reasonablypolymorphic.com/blog/higher-kinded-data/ higher-kinded data>.+In particular, each interpretation of a 'Field'+wraps its contents into a "wrapper" type @w@,+which may add additional behavior to it.+For example, in Protocol Buffers every field is+optional, and this is expressed by setting+@w@ to 'Maybe'.++In this module we make use of 'NP' and 'NS'+as defined by <https://hackage.haskell.org/package/sop-core sop-core>.+These are the n-ary versions of a pair and+'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

@@ -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

@@ -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

@@ -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+<https://docs.confluent.io/current/schema-registry/index.html Kafka>+and <https://github.com/higherkindness/compendium Compendium>.+-}+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