Browse Source

new stuff

pull/1/head
piq9117 1 year ago
commit
1c2d918897
100 changed files with 13023 additions and 0 deletions
  1. +21
    -0
      LICENSE
  2. +48
    -0
      README.md
  3. +181
    -0
      changelog.md
  4. +317
    -0
      morpheus-graphql-core.cabal
  5. +68
    -0
      package.yaml
  6. +90
    -0
      src/Data/Morpheus/Core.hs
  7. +15
    -0
      src/Data/Morpheus/Error.hs
  8. +89
    -0
      src/Data/Morpheus/Error/Document/Interface.hs
  9. +60
    -0
      src/Data/Morpheus/Error/Fragment.hs
  10. +37
    -0
      src/Data/Morpheus/Error/Input.hs
  11. +16
    -0
      src/Data/Morpheus/Error/NameCollision.hs
  12. +24
    -0
      src/Data/Morpheus/Error/Operation.hs
  13. +50
    -0
      src/Data/Morpheus/Error/Selection.hs
  14. +35
    -0
      src/Data/Morpheus/Error/Utils.hs
  15. +45
    -0
      src/Data/Morpheus/Error/Variable.hs
  16. +53
    -0
      src/Data/Morpheus/Error/Warning.hs
  17. +24
    -0
      src/Data/Morpheus/Ext/Elems.hs
  18. +20
    -0
      src/Data/Morpheus/Ext/Failure.hs
  19. +37
    -0
      src/Data/Morpheus/Ext/KeyOf.hs
  20. +103
    -0
      src/Data/Morpheus/Ext/Map.hs
  21. +105
    -0
      src/Data/Morpheus/Ext/MergeSet.hs
  22. +91
    -0
      src/Data/Morpheus/Ext/OrdMap.hs
  23. +80
    -0
      src/Data/Morpheus/Ext/SafeHashMap.hs
  24. +81
    -0
      src/Data/Morpheus/Ext/SemigroupM.hs
  25. +52
    -0
      src/Data/Morpheus/Internal/Graph.hs
  26. +244
    -0
      src/Data/Morpheus/Internal/TH.hs
  27. +180
    -0
      src/Data/Morpheus/Internal/Utils.hs
  28. +66
    -0
      src/Data/Morpheus/Parser.hs
  29. +363
    -0
      src/Data/Morpheus/Parsing/Document/TypeSystem.hs
  30. +43
    -0
      src/Data/Morpheus/Parsing/Internal/Arguments.hs
  31. +88
    -0
      src/Data/Morpheus/Parsing/Internal/Internal.hs
  32. +221
    -0
      src/Data/Morpheus/Parsing/Internal/Pattern.hs
  33. +357
    -0
      src/Data/Morpheus/Parsing/Internal/Terms.hs
  34. +107
    -0
      src/Data/Morpheus/Parsing/Internal/Value.hs
  35. +94
    -0
      src/Data/Morpheus/Parsing/Request/Operation.hs
  36. +69
    -0
      src/Data/Morpheus/Parsing/Request/Parser.hs
  37. +132
    -0
      src/Data/Morpheus/Parsing/Request/Selection.hs
  38. +85
    -0
      src/Data/Morpheus/QuasiQuoter.hs
  39. +127
    -0
      src/Data/Morpheus/Rendering/RenderGQL.hs
  40. +342
    -0
      src/Data/Morpheus/Rendering/RenderIntrospection.hs
  41. +43
    -0
      src/Data/Morpheus/Schema/DSL.hs
  42. +152
    -0
      src/Data/Morpheus/Schema/Schema.hs
  43. +109
    -0
      src/Data/Morpheus/Schema/SchemaAPI.hs
  44. +157
    -0
      src/Data/Morpheus/Types/App.hs
  45. +84
    -0
      src/Data/Morpheus/Types/GQLScalar.hs
  46. +40
    -0
      src/Data/Morpheus/Types/ID.hs
  47. +135
    -0
      src/Data/Morpheus/Types/IO.hs
  48. +193
    -0
      src/Data/Morpheus/Types/Internal/AST.hs
  49. +511
    -0
      src/Data/Morpheus/Types/Internal/AST/Base.hs
  50. +35
    -0
      src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs
  51. +358
    -0
      src/Data/Morpheus/Types/Internal/AST/Fields.hs
  52. +340
    -0
      src/Data/Morpheus/Types/Internal/AST/Selection.hs
  53. +30
    -0
      src/Data/Morpheus/Types/Internal/AST/Stage.hs
  54. +60
    -0
      src/Data/Morpheus/Types/Internal/AST/TH.hs
  55. +131
    -0
      src/Data/Morpheus/Types/Internal/AST/TypeCategory.hs
  56. +731
    -0
      src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs
  57. +289
    -0
      src/Data/Morpheus/Types/Internal/AST/Value.hs
  58. +34
    -0
      src/Data/Morpheus/Types/Internal/Config.hs
  59. +128
    -0
      src/Data/Morpheus/Types/Internal/Resolving.hs
  60. +132
    -0
      src/Data/Morpheus/Types/Internal/Resolving/Core.hs
  61. +28
    -0
      src/Data/Morpheus/Types/Internal/Resolving/Event.hs
  62. +450
    -0
      src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs
  63. +188
    -0
      src/Data/Morpheus/Types/Internal/Resolving/ResolverState.hs
  64. +135
    -0
      src/Data/Morpheus/Types/Internal/Stitching.hs
  65. +295
    -0
      src/Data/Morpheus/Types/Internal/Validation.hs
  66. +222
    -0
      src/Data/Morpheus/Types/Internal/Validation/Error.hs
  67. +170
    -0
      src/Data/Morpheus/Types/Internal/Validation/Internal.hs
  68. +105
    -0
      src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs
  69. +525
    -0
      src/Data/Morpheus/Types/Internal/Validation/Validator.hs
  70. +53
    -0
      src/Data/Morpheus/Types/SelectionTree.hs
  71. +391
    -0
      src/Data/Morpheus/Validation/Document/Validation.hs
  72. +169
    -0
      src/Data/Morpheus/Validation/Internal/Arguments.hs
  73. +122
    -0
      src/Data/Morpheus/Validation/Internal/Directive.hs
  74. +323
    -0
      src/Data/Morpheus/Validation/Internal/Value.hs
  75. +120
    -0
      src/Data/Morpheus/Validation/Query/Fragment.hs
  76. +99
    -0
      src/Data/Morpheus/Validation/Query/FragmentPreconditions.hs
  77. +297
    -0
      src/Data/Morpheus/Validation/Query/Selection.hs
  78. +205
    -0
      src/Data/Morpheus/Validation/Query/UnionSelection.hs
  79. +120
    -0
      src/Data/Morpheus/Validation/Query/Validation.hs
  80. +180
    -0
      src/Data/Morpheus/Validation/Query/Variable.hs
  81. +65
    -0
      test/Spec.hs
  82. +63
    -0
      test/Utils/Api.hs
  83. +108
    -0
      test/Utils/MergeSchema.hs
  84. +72
    -0
      test/Utils/Rendering.hs
  85. +88
    -0
      test/Utils/Schema.hs
  86. +169
    -0
      test/Utils/Utils.hs
  87. +79
    -0
      test/api/deity/interface/query.gql
  88. +67
    -0
      test/api/deity/interface/response.json
  89. +8
    -0
      test/api/deity/resolvers.json
  90. +20
    -0
      test/api/deity/schema.gql
  91. +6
    -0
      test/api/deity/simple/query.gql
  92. +8
    -0
      test/api/deity/simple/response.json
  93. +16
    -0
      test/api/validation/fragment/fail-unknown-field-on-interface/query.gql
  94. +12
    -0
      test/api/validation/fragment/fail-unknown-field-on-interface/response.json
  95. +7
    -0
      test/api/validation/fragment/on-interface-fail-without-casting/query.gql
  96. +22
    -0
      test/api/validation/fragment/on-interface-fail-without-casting/response.json
  97. +12
    -0
      test/api/validation/fragment/on-interface-inline/query.gql
  98. +19
    -0
      test/api/validation/fragment/on-interface-inline/response.json
  99. +13
    -0
      test/api/validation/fragment/on-interface-type-casting-inline/query.gql
  100. +20
    -0
      test/api/validation/fragment/on-interface-type-casting-inline/response.json

+ 21
- 0
LICENSE View File

@@ -0,0 +1,21 @@
MIT License

Copyright (c) 2019 Daviti Nalchevanidze

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

+ 48
- 0
README.md View File

@@ -0,0 +1,48 @@
# Morpheus GraphQL Core

core Functionalities of Morpheus GraphQL, can be used to build GraphQL server, client ..

- parser
- validar
- api

## Build GraphQL api with Core

```hs
schema :: Schema VALID
schema =
[dsl|
type Query {
deity(name: String): Deity!
}

type Deity {
name: String!
power: [String!]!
}
|]

resolver :: Monad m => RootResModel e m
resolver =
RootResModel
{ query =
pure $
mkObject
"Query"
[("deity", resolveDeity)],
mutation = pure mkNull,
subscription = pure mkNull
}

resolveDeity :: (WithOperation o, Monad m) => Resolver o e m (ResModel o e m)
resolveDeity =
pure $
mkObject
"Deity"
[ ("name", pure $ mkString "Morpheus"),
("power", pure $ mkList [mkString "Shapeshifting"])
]

api :: ByteString -> IO ByteString
api = runApp (mkApp schema resolver)
```

+ 181
- 0
changelog.md View File

@@ -0,0 +1,181 @@
# Changelog

## 0.16.0 - unreleased

### Breaking Changes

- signature changes:

- `render`:
`a -> Text`
to `a -> ByteString`
- parseTypeSystemDefinition :
`Text -> Eventless (Schema VALID)`
to `ByteString -> Eventless (Schema VALID)`

- parseTypeDefinitions:
`Text -> Eventless [TypeDefinition ANY CONST]`
to `ByteString -> Eventless [TypeDefinition ANY CONST]`

### new features

### Minor Changes

- parser performance optimization

## 0.15.1 - 12.09.2020

relaxed upper boundary of `megaparsec` up to 10.0.0

## 0.15.0 - 12.09.2020

### new features

- `render` renders SchemaDefinition e.g

```graphql
schema {
query: MyQuery
}
```

- query validator automatically adds `__typename` to interface types

- type : `App`

```hs
api :: a -> m b
api = runApp (mkApp schema resolvers)
```

- `App` supports semigroup(`schema Stitching`):

if whe have two apps `app1` and `app2` with type `Api EVENT IO` we can merge it as.

```hs
mergedApi :: a -> m b
mergedApi = runApp (app1 <> app2)
```

- `runApp` changed signature to:

```hs
runApp :: Api e m -> a -> m b
```

### Breaking Changes

- removed `runApi`.

### Minor Changes

- internal refactoring

## 0.14.1 - 16.08.2020

## 0.14.0 - 15.08.2020

### new features

- query validation supports interfaces
- exposed: `Data.Morpheus.Types.SelectionTree`
- configurable api: `Data.Morpheus.Core` exports

- `Config`
- `defaultConfig`
- `debugConfig`

- for better debugging, internal errors messages will display resolving state:
- `current TypeName`
- `current Selection`
- `OperationDefinition`
- `SchemaDefinition`
- rendering graphql "AST". e.g `render (selection :: Selection VALID)` will render

```graphql
{
user(arg1: 1) {
name
}
}
```

- quasiquoter `[dsl| <type definitions> |]` generates `Schema VALID`.
- parser supports custom directive definition. e.g

```graphql
directive @MyDirective on FIELD_DEFINITION | OBJECT
```

- directive Validation for Document (TypeSystem).
- supports of block string values. e.g:

```graphql
query {
createDeity(
name: """
power
bla \n sd
blu \\ date
"""
) {
name
}
}
```

- support of `schema`. issue #412

```graphql
schema {
query: MyQuery
}
```

### Breaking Changes

- `Context' renamed to`ResolverContext'
- removed : `EventCon` from `Data.Morpheus.Core`
- internal refactoring: changed AST.
Schema AST Types now need parameter `stage = RAW | CONST | VALID`.
- `Schema VALID`
- `TypeDefinition VALID`
- `FieldDefinition IN VALID`
- ...
- runApi requires argument config

```hs
runApi ::
Schema s ->
RootResModel event m ->
Config ->
GQLRequest ->
ResponseStream event m (Value VALID)
```

## 0.13.0 - 22.06.2020

### new features

- exposed: `Data.Morpheus.Types.GQLScalar`
- exposed: `Data.Morpheus.Types.ID`
- finished interface validation
- supports default values

## minor changes

- internal refactoring
- added dependency `mtl`
- validates strings as enum from JSON value

## 0.12.0 - 21.05.2020

## New features

- parser supports implements interfaces separated with empty spaces

```gql
type T implements A , B C & D {
```

- introspection can render interfaces

+ 317
- 0
morpheus-graphql-core.cabal View File

@@ -0,0 +1,317 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 9be3caf85f16147f538a91eb99e807439d7c4568f80fd336f068ac3b563ee908

name: morpheus-graphql-core
version: 0.15.1
synopsis: Morpheus GraphQL Core
description: Build GraphQL APIs with your favourite functional language!
category: web, graphql
homepage: https://morpheusgraphql.com
bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues
author: Daviti Nalchevanidze
maintainer: d.nalchevanidze@gmail.com
copyright: (c) 2019 Daviti Nalchevanidze
license: MIT
license-file: LICENSE
build-type: Simple
extra-source-files:
changelog.md
README.md
data-files:
test/api/deity/interface/query.gql
test/api/deity/schema.gql
test/api/deity/simple/query.gql
test/api/validation/fragment/fail-unknown-field-on-interface/query.gql
test/api/validation/fragment/on-interface-fail-without-casting/query.gql
test/api/validation/fragment/on-interface-inline/query.gql
test/api/validation/fragment/on-interface-type-casting-inline/query.gql
test/api/validation/fragment/on-interface-type-casting/query.gql
test/api/validation/fragment/on-interface/query.gql
test/api/validation/fragment/on-type/query.gql
test/api/validation/fragment/on-union-type/query.gql
test/api/validation/fragment/schema.gql
test/merge/schema/query-subscription-mutation/api/app.gql
test/merge/schema/query-subscription-mutation/api/ext.gql
test/merge/schema/query-subscription-mutation/expected/ok.gql
test/merge/schema/query-subscription-mutation/request/mutation/query.gql
test/merge/schema/query-subscription-mutation/request/query/query.gql
test/merge/schema/simple-query/api/app.gql
test/merge/schema/simple-query/api/ext.gql
test/merge/schema/simple-query/expected/ok.gql
test/merge/schema/simple-query/request/query/query.gql
test/rendering/simple/directive/query.gql
test/rendering/simple/directive/rendering.gql
test/rendering/simple/fragment/query.gql
test/rendering/simple/fragment/rendering.gql
test/rendering/simple/mutation/query.gql
test/rendering/simple/mutation/rendering.gql
test/rendering/simple/nested/query.gql
test/rendering/simple/nested/rendering.gql
test/rendering/simple/query/query.gql
test/rendering/simple/query/rendering.gql
test/rendering/simple/schema.gql
test/rendering/simple/simple/query.gql
test/rendering/simple/simple/rendering.gql
test/rendering/simple/subscription/query.gql
test/rendering/simple/subscription/rendering.gql
test/rendering/union/interface/query.gql
test/rendering/union/interface/rendering.gql
test/rendering/union/schema.gql
test/rendering/union/union/query.gql
test/rendering/union/union/rendering.gql
test/rendering/variable/enum/query.gql
test/rendering/variable/enum/rendering.gql
test/rendering/variable/include-exclude/query.gql
test/rendering/variable/include-exclude/rendering.gql
test/rendering/variable/input/query.gql
test/rendering/variable/input/rendering.gql
test/rendering/variable/list/query.gql
test/rendering/variable/list/rendering.gql
test/rendering/variable/schema.gql
test/rendering/variable/simple/query.gql
test/rendering/variable/simple/rendering.gql
test/schema/parsing/directive/ok/simple/schema.gql
test/schema/parsing/directive/ok/sophisticated/schema.gql
test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/schema.gql
test/schema/parsing/schema-definition/fail/dupplicate-field/query/schema.gql
test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/schema.gql
test/schema/parsing/schema-definition/fail/unknown-fields/bla/schema.gql
test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/schema.gql
test/schema/parsing/schema-definition/ok/query-mutation-subscription/schema.gql
test/schema/parsing/schema-definition/ok/query-mutation/schema.gql
test/schema/parsing/schema-definition/ok/query/schema.gql
test/schema/validation/default-value/argument/compound-ok/schema.gql
test/schema/validation/default-value/argument/missing-field/schema.gql
test/schema/validation/default-value/argument/unexpected-value/schema.gql
test/schema/validation/default-value/argument/unknown-field/schema.gql
test/schema/validation/default-value/field/compound-ok/schema.gql
test/schema/validation/default-value/field/missing-field/schema.gql
test/schema/validation/default-value/field/unexpected-value/schema.gql
test/schema/validation/default-value/field/unknown-field/schema.gql
test/schema/validation/directive/fail/at-invalid-place/schema.gql
test/schema/validation/directive/fail/missing-argument/schema.gql
test/schema/validation/directive/fail/sopthisticated/schema.gql
test/schema/validation/directive/fail/unexpected-value/schema.gql
test/schema/validation/directive/fail/unknown-directive/schema.gql
test/schema/validation/directive/ok/deprecated/custom-directive/schema.gql
test/schema/validation/directive/ok/deprecated/schema.gql
test/schema/validation/interface/field-args/fail/schema.gql
test/schema/validation/interface/field-args/ok/schema.gql
test/schema/validation/interface/field-type/fail/schema.gql
test/schema/validation/interface/field-type/ok/schema.gql
test/schema/validation/performance-check/schema.gql
test/schema/validation/schema-definition/fail/non-object-kind/from-schema/schema.gql
test/schema/validation/schema-definition/fail/non-object-kind/without-schema/schema.gql
"test/schema/validation/schema-definition/fail/required query/empty/schema.gql"
"test/schema/validation/schema-definition/fail/required query/no-query/schema.gql"
"test/schema/validation/schema-definition/fail/required query/no-schema-no-query/schema.gql"
"test/schema/validation/schema-definition/fail/required query/schema-with-query/schema.gql"
test/schema/validation/schema-definition/fail/unknown-type/unknown/schema.gql
test/schema/validation/schema-definition/ok/full/schema.gql
test/api/deity/interface/response.json
test/api/deity/resolvers.json
test/api/deity/simple/response.json
test/api/validation/fragment/fail-unknown-field-on-interface/response.json
test/api/validation/fragment/on-interface-fail-without-casting/response.json
test/api/validation/fragment/on-interface-inline/response.json
test/api/validation/fragment/on-interface-type-casting-inline/response.json
test/api/validation/fragment/on-interface-type-casting/response.json
test/api/validation/fragment/on-interface/response.json
test/api/validation/fragment/on-type/response.json
test/api/validation/fragment/on-union-type/response.json
test/api/validation/fragment/resolvers.json
test/merge/schema/query-subscription-mutation/api/app.json
test/merge/schema/query-subscription-mutation/api/ext.json
test/merge/schema/query-subscription-mutation/request/mutation/response.json
test/merge/schema/query-subscription-mutation/request/query/response.json
test/merge/schema/simple-query/api/app.json
test/merge/schema/simple-query/api/ext.json
test/merge/schema/simple-query/request/query/response.json
test/rendering/simple/fragment/variables.json
test/rendering/union/interface/variables.json
test/rendering/union/union/variables.json
test/rendering/variable/enum/variables.json
test/rendering/variable/include-exclude/variables.json
test/rendering/variable/input/variables.json
test/rendering/variable/list/variables.json
test/rendering/variable/simple/variables.json
test/schema/parsing/directive/ok/simple/response.json
test/schema/parsing/directive/ok/sophisticated/response.json
test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json
test/schema/parsing/schema-definition/fail/dupplicate-field/query/response.json
test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/response.json
test/schema/parsing/schema-definition/fail/unknown-fields/bla/response.json
test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/response.json
test/schema/parsing/schema-definition/ok/query-mutation-subscription/response.json
test/schema/parsing/schema-definition/ok/query-mutation/response.json
test/schema/parsing/schema-definition/ok/query/response.json
test/schema/validation/default-value/argument/compound-ok/response.json
test/schema/validation/default-value/argument/missing-field/response.json
test/schema/validation/default-value/argument/unexpected-value/response.json
test/schema/validation/default-value/argument/unknown-field/response.json
test/schema/validation/default-value/field/compound-ok/response.json
test/schema/validation/default-value/field/missing-field/response.json
test/schema/validation/default-value/field/unexpected-value/response.json
test/schema/validation/default-value/field/unknown-field/response.json
test/schema/validation/directive/fail/at-invalid-place/response.json
test/schema/validation/directive/fail/missing-argument/response.json
test/schema/validation/directive/fail/sopthisticated/response.json
test/schema/validation/directive/fail/unexpected-value/response.json
test/schema/validation/directive/fail/unknown-directive/response.json
test/schema/validation/directive/ok/deprecated/custom-directive/response.json
test/schema/validation/directive/ok/deprecated/response.json
test/schema/validation/interface/field-args/fail/response.json
test/schema/validation/interface/field-args/ok/response.json
test/schema/validation/interface/field-type/fail/response.json
test/schema/validation/interface/field-type/ok/response.json
test/schema/validation/performance-check/response.json
test/schema/validation/schema-definition/fail/non-object-kind/from-schema/response.json
test/schema/validation/schema-definition/fail/non-object-kind/without-schema/response.json
"test/schema/validation/schema-definition/fail/required query/empty/response.json"
"test/schema/validation/schema-definition/fail/required query/no-query/response.json"
"test/schema/validation/schema-definition/fail/required query/no-schema-no-query/response.json"
"test/schema/validation/schema-definition/fail/required query/schema-with-query/response.json"
test/schema/validation/schema-definition/fail/unknown-type/unknown/response.json
test/schema/validation/schema-definition/ok/full/response.json

source-repository head
type: git
location: https://github.com/nalchevanidze/morpheus-graphql

library
exposed-modules:
Data.Morpheus.Core
Data.Morpheus.QuasiQuoter
Data.Morpheus.Error
Data.Morpheus.Internal.TH
Data.Morpheus.Internal.Utils
Data.Morpheus.Types.Internal.AST
Data.Morpheus.Types.IO
Data.Morpheus.Types.Internal.Resolving
Data.Morpheus.Types.GQLScalar
Data.Morpheus.Types.ID
Data.Morpheus.Types.SelectionTree
other-modules:
Data.Morpheus.Error.Document.Interface
Data.Morpheus.Error.Fragment
Data.Morpheus.Error.Input
Data.Morpheus.Error.NameCollision
Data.Morpheus.Error.Operation
Data.Morpheus.Error.Selection
Data.Morpheus.Error.Utils
Data.Morpheus.Error.Variable
Data.Morpheus.Error.Warning
Data.Morpheus.Ext.Elems
Data.Morpheus.Ext.Failure
Data.Morpheus.Ext.KeyOf
Data.Morpheus.Ext.Map
Data.Morpheus.Ext.MergeSet
Data.Morpheus.Ext.OrdMap
Data.Morpheus.Ext.SafeHashMap
Data.Morpheus.Ext.SemigroupM
Data.Morpheus.Internal.Graph
Data.Morpheus.Parser
Data.Morpheus.Parsing.Document.TypeSystem
Data.Morpheus.Parsing.Internal.Arguments
Data.Morpheus.Parsing.Internal.Internal
Data.Morpheus.Parsing.Internal.Pattern
Data.Morpheus.Parsing.Internal.Terms
Data.Morpheus.Parsing.Internal.Value
Data.Morpheus.Parsing.Request.Operation
Data.Morpheus.Parsing.Request.Parser
Data.Morpheus.Parsing.Request.Selection
Data.Morpheus.Rendering.RenderGQL
Data.Morpheus.Rendering.RenderIntrospection
Data.Morpheus.Schema.DSL
Data.Morpheus.Schema.Schema
Data.Morpheus.Schema.SchemaAPI
Data.Morpheus.Types.App
Data.Morpheus.Types.Internal.AST.Base
Data.Morpheus.Types.Internal.AST.DirectiveLocation
Data.Morpheus.Types.Internal.AST.Fields
Data.Morpheus.Types.Internal.AST.Selection
Data.Morpheus.Types.Internal.AST.Stage
Data.Morpheus.Types.Internal.AST.TH
Data.Morpheus.Types.Internal.AST.TypeCategory
Data.Morpheus.Types.Internal.AST.TypeSystem
Data.Morpheus.Types.Internal.AST.Value
Data.Morpheus.Types.Internal.Config
Data.Morpheus.Types.Internal.Resolving.Core
Data.Morpheus.Types.Internal.Resolving.Event
Data.Morpheus.Types.Internal.Resolving.Resolver
Data.Morpheus.Types.Internal.Resolving.ResolverState
Data.Morpheus.Types.Internal.Stitching
Data.Morpheus.Types.Internal.Validation
Data.Morpheus.Types.Internal.Validation.Error
Data.Morpheus.Types.Internal.Validation.Internal
Data.Morpheus.Types.Internal.Validation.SchemaValidator
Data.Morpheus.Types.Internal.Validation.Validator
Data.Morpheus.Validation.Document.Validation
Data.Morpheus.Validation.Internal.Arguments
Data.Morpheus.Validation.Internal.Directive
Data.Morpheus.Validation.Internal.Value
Data.Morpheus.Validation.Query.Fragment
Data.Morpheus.Validation.Query.FragmentPreconditions
Data.Morpheus.Validation.Query.Selection
Data.Morpheus.Validation.Query.UnionSelection
Data.Morpheus.Validation.Query.Validation
Data.Morpheus.Validation.Query.Variable
Paths_morpheus_graphql_core
hs-source-dirs:
src
ghc-options: -Wall -XNoImplicitPrelude
build-depends:
aeson >=1.4.4.0 && <=1.6
, base >=4.7 && <5
, bytestring >=0.10.4 && <0.11
, hashable >=1.0.0
, megaparsec >=7.0.0 && <10.0.0
, mtl >=2.0 && <=3.0
, relude >=0.3.0
, scientific >=0.3.6.2 && <0.4
, template-haskell >=2.0 && <=3.0
, text >=1.2.3.0 && <1.3
, th-lift-instances >=0.1.1 && <=0.3
, transformers >=0.3.0.0 && <0.6
, unordered-containers >=0.2.8.0 && <0.3
, vector >=0.12.0.1 && <0.13
default-language: Haskell2010

test-suite morpheus-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Utils.Api
Utils.MergeSchema
Utils.Rendering
Utils.Schema
Utils.Utils
Paths_morpheus_graphql_core
hs-source-dirs:
test
ghc-options: -Wall -XNoImplicitPrelude
build-depends:
aeson
, base >=4.7 && <5
, bytestring >=0.10.4 && <0.11
, directory >=1.0
, hashable >=1.0.0
, megaparsec >=7.0.0 && <10.0.0
, morpheus-graphql-core
, mtl >=2.0 && <=3.0
, relude >=0.3.0
, scientific >=0.3.6.2 && <0.4
, tasty
, tasty-hunit
, template-haskell >=2.0 && <=3.0
, text >=1.2.3.0 && <1.3
, th-lift-instances >=0.1.1 && <=0.3
, transformers >=0.3.0.0 && <0.6
, unordered-containers >=0.2.8.0 && <0.3
, vector >=0.12.0.1 && <0.13
default-language: Haskell2010

+ 68
- 0
package.yaml View File

@@ -0,0 +1,68 @@
name: morpheus-graphql-core
version: 0.15.1
github: "nalchevanidze/morpheus-graphql"
license: MIT
author: "Daviti Nalchevanidze"
category: web, graphql
synopsis: Morpheus GraphQL Core
maintainer: "d.nalchevanidze@gmail.com"
homepage: https://morpheusgraphql.com
copyright: "(c) 2019 Daviti Nalchevanidze"
license-file: LICENSE
description: Build GraphQL APIs with your favourite functional language!

extra-source-files:
- changelog.md
- README.md

data-files:
- test/**/*.gql
- test/**/*.json

dependencies:
- base >= 4.7 && < 5
- bytestring >= 0.10.4 && < 0.11
- text >= 1.2.3.0 && < 1.3
- megaparsec >= 7.0.0 && < 10.0.0
- aeson >= 1.4.4.0 && <= 1.6
- unordered-containers >= 0.2.8.0 && < 0.3
- transformers >= 0.3.0.0 && < 0.6
- scientific >= 0.3.6.2 && < 0.4
- vector >= 0.12.0.1 && < 0.13
- template-haskell >= 2.0 && <= 3.0
- th-lift-instances >= 0.1.1 && <= 0.3
- hashable >= 1.0.0
- mtl >= 2.0 && <= 3.0
- relude >= 0.3.0

library:
source-dirs: src
exposed-modules:
- Data.Morpheus.Core
- Data.Morpheus.QuasiQuoter
- Data.Morpheus.Error
- Data.Morpheus.Internal.TH
- Data.Morpheus.Internal.Utils
- Data.Morpheus.Types.Internal.AST
- Data.Morpheus.Types.IO
- Data.Morpheus.Types.Internal.Resolving
- Data.Morpheus.Types.GQLScalar
- Data.Morpheus.Types.ID
- Data.Morpheus.Types.SelectionTree

ghc-options: -Wall
-XNoImplicitPrelude

tests:
morpheus-test:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
-XNoImplicitPrelude
dependencies:
- morpheus-graphql-core
- tasty
- tasty-hunit
- aeson
- directory >= 1.0
- relude >= 0.3.0

+ 90
- 0
src/Data/Morpheus/Core.hs View File

@@ -0,0 +1,90 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Morpheus.Core
( parseDSL,
parseFullGQLDocument,
parseGQLDocument,
parseTypeSystemDefinition,
parseTypeDefinitions,
validateRequest,
parseRequestWith,
validateSchema,
parseRequest,
SelectionTree (..),
Config (..),
VALIDATION_MODE (..),
defaultConfig,
debugConfig,
App (..),
AppData (..),
runApp,
withDebugger,
mkApp,
runAppStream,
render,
RenderGQL,
)
where

import Data.ByteString.Lazy.Char8
( ByteString,
)
import Data.Morpheus.Ext.SemigroupM
( (<:>),
)
import Data.Morpheus.Parser
( parseRequest,
parseRequestWith,
parseTypeDefinitions,
parseTypeSystemDefinition,
)
import Data.Morpheus.Rendering.RenderGQL (RenderGQL)
import qualified Data.Morpheus.Rendering.RenderGQL as R
import Data.Morpheus.Schema.Schema (internalSchema)
import Data.Morpheus.Types.App
( App (..),
AppData (..),
mkApp,
runApp,
runAppStream,
withDebugger,
)
import Data.Morpheus.Types.Internal.AST
( Schema,
VALID,
)
import Data.Morpheus.Types.Internal.Config
( Config (..),
VALIDATION_MODE (..),
debugConfig,
defaultConfig,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
resultOr,
sortErrors,
)
import Data.Morpheus.Types.SelectionTree (SelectionTree (..))
import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..))
import Data.Morpheus.Validation.Query.Validation
( validateRequest,
)
import Relude hiding (ByteString)

render :: RenderGQL a => a -> ByteString
render = R.renderGQL

parseDSL :: ByteString -> Either String (Schema VALID)
parseDSL = resultOr (Left . show) pure . parseGQLDocument

parseGQLDocument :: ByteString -> Eventless (Schema VALID)
parseGQLDocument = sortErrors . parseTypeSystemDefinition

parseFullGQLDocument :: ByteString -> Eventless (Schema VALID)
parseFullGQLDocument = parseGQLDocument >=> (internalSchema <:>)

+ 15
- 0
src/Data/Morpheus/Error.hs View File

@@ -0,0 +1,15 @@
module Data.Morpheus.Error
( errorMessage,
globalErrorMessage,
gqlWarnings,
renderGQLErrors,
deprecatedField,
)
where

import Data.Morpheus.Error.Utils
import Data.Morpheus.Error.Warning
( deprecatedField,
gqlWarnings,
renderGQLErrors,
)

+ 89
- 0
src/Data/Morpheus/Error/Document/Interface.hs View File

@@ -0,0 +1,89 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Document.Interface
( unknownInterface,
PartialImplements (..),
ImplementsError (..),
Place (..),
)
where

import Data.Maybe (Maybe (..))
import Data.Morpheus.Types.Internal.AST.Base
( FieldName (..),
TypeName (..),
TypeRef,
ValidationError,
msgValidation,
)
import Data.Morpheus.Types.Internal.Validation.SchemaValidator
( Field (..),
Interface (..),
renderField,
)
import Data.Semigroup ((<>))

unknownInterface :: TypeName -> ValidationError
unknownInterface name = "Unknown Interface " <> msgValidation name <> "."

data ImplementsError
= UnexpectedType
{ expectedType :: TypeRef,
foundType :: TypeRef
}
| Missing

data Place = Place
{ fieldname :: TypeName,
typename :: FieldName,
fieldArg :: Maybe (FieldName, TypeName)
}

class PartialImplements ctx where
partialImplements :: ctx -> ImplementsError -> ValidationError

instance PartialImplements (Interface, FieldName) where
partialImplements (Interface interfaceName typename, fieldname) errorType =
"Interface field "
<> renderField interfaceName fieldname Nothing
<> detailedMessage errorType
where
detailedMessage UnexpectedType {expectedType, foundType} =
" expects type "
<> msgValidation expectedType
<> " but "
<> renderField typename fieldname Nothing
<> " is type "
<> msgValidation foundType
<> "."
detailedMessage Missing =
" expected but "
<> msgValidation typename
<> " does not provide it."

-- Interface field TestInterface.name expected but User does not provide it.
-- Interface field TestInterface.name expects type String! but User.name is type Int!.

instance PartialImplements (Interface, Field) where
partialImplements (Interface interfaceName typename, Field fieldname argName) errorType =
"Interface field argument "
<> renderField interfaceName fieldname (Just argName)
<> detailedMessage errorType
where
detailedMessage UnexpectedType {expectedType, foundType} =
" expects type"
<> msgValidation expectedType
<> " but "
<> renderField typename fieldname (Just argName)
<> " is type "
<> msgValidation foundType
<> "."
detailedMessage Missing =
" expected but "
<> renderField typename fieldname Nothing
<> " does not provide it."

-- Interface field argument TestInterface.name(id:) expected but User.name does not provide it.
-- Interface field argument TestInterface.name(id:) expects type ID but User.name(id:) is type String.

+ 60
- 0
src/Data/Morpheus/Error/Fragment.hs View File

@@ -0,0 +1,60 @@
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Fragment
( cannotSpreadWithinItself,
cannotBeSpreadOnType,
)
where

-- MORPHEUS
import Data.Morpheus.Error.Utils (validationErrorMessage)
import Data.Morpheus.Types.Internal.AST.Base
( FieldName,
Position,
Ref (..),
TypeName,
ValidationError (..),
msg,
msgSepBy,
)
import Relude

{-
FRAGMENT:
type Experience {
experience ( lang: LANGUAGE ) : String ,
date: String
}
fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."
fragment H on T1 { ...A} , fragment A on T { ...H } -> "Cannot spread fragment \"H\" within itself via A."
fragment H on D {...} -> "Unknown type \"D\"."
{...H} -> "Unknown fragment \"H\"."
-}

cannotSpreadWithinItself :: NonEmpty Ref -> ValidationError
cannotSpreadWithinItself (fr :| frs) = ValidationError text (fmap refPosition (fr : frs))
where
text =
"Cannot spread fragment "
<> msg (refName fr)
<> " within itself via "
<> msgSepBy ", " (fmap refName (fr : frs))
<> "."

-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."
cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> ValidationError
cannotBeSpreadOnType key fragmentType position typeMembers =
validationErrorMessage
(Just position)
text
where
text =
"Fragment "
<> getName key
<> "cannot be spread here as objects of type "
<> msgSepBy ", " typeMembers
<> " can never be of type "
<> msg fragmentType
<> "."
getName (Just x) = msg x <> " "
getName Nothing = ""

+ 37
- 0
src/Data/Morpheus/Error/Input.hs View File

@@ -0,0 +1,37 @@
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Input
( typeViolation,
)
where

import Data.Morpheus.Types.Internal.AST
( TypeRef (..),
ValidationError,
Value,
msgValidation,
)
import Data.Semigroup ((<>))

typeViolation :: TypeRef -> Value s -> ValidationError
typeViolation expected found =
"Expected type "
<> msgValidation expected
<> " found "
<> msgValidation found
<> "."

{-
ARGUMENTS:
type Experience {
experience ( lang: LANGUAGE ) : String ,
date: String
}

- required field !?
- experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"."
- experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla."
- experience( lang: 1 ) -> "Expected type LANGUAGE, found 1."
- experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".",
- date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"."
-}

+ 16
- 0
src/Data/Morpheus/Error/NameCollision.hs View File

@@ -0,0 +1,16 @@
module Data.Morpheus.Error.NameCollision
( NameCollision (..),
)
where

import Data.Morpheus.Ext.Map (Indexed (..))
import Data.Morpheus.Types.Internal.AST.Base
( ValidationError,
)
import Relude

class NameCollision a where
nameCollision :: a -> ValidationError

instance NameCollision a => NameCollision (Indexed k a) where
nameCollision = nameCollision . indexedValue

+ 24
- 0
src/Data/Morpheus/Error/Operation.hs View File

@@ -0,0 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Operation
( mutationIsNotDefined,
subscriptionIsNotDefined,
)
where

import Data.Morpheus.Types.Internal.AST.Base
( Position,
ValidationError (..),
)

mutationIsNotDefined :: Position -> ValidationError
mutationIsNotDefined position =
ValidationError
"Schema is not configured for mutations."
[position]

subscriptionIsNotDefined :: Position -> ValidationError
subscriptionIsNotDefined position =
ValidationError
"Schema is not configured for subscriptions."
[position]

+ 50
- 0
src/Data/Morpheus/Error/Selection.hs View File

@@ -0,0 +1,50 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Selection
( unknownSelectionField,
subfieldsNotSelected,
hasNoSubfields,
)
where

import Data.Morpheus.Types.Internal.AST
( FieldName,
Position,
Ref (..),
TypeDefinition (..),
TypeName,
VALID,
ValidationError (..),
msg,
)
import Data.Semigroup ((<>))

-- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."
hasNoSubfields :: Ref -> TypeDefinition s VALID -> ValidationError
hasNoSubfields (Ref selectionName position) TypeDefinition {typeName} = ValidationError text [position]
where
text =
"Field "
<> msg selectionName
<> " must not have a selection since type "
<> msg typeName
<> " has no subfields."

unknownSelectionField :: TypeName -> Ref -> ValidationError
unknownSelectionField typeName Ref {refName, refPosition} = ValidationError text [refPosition]
where
text =
"Cannot query field " <> msg refName
<> " on type "
<> msg typeName
<> "."

-- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?
subfieldsNotSelected :: FieldName -> TypeName -> Position -> ValidationError
subfieldsNotSelected fieldName typeName position = ValidationError text [position]
where
text =
"Field " <> msg fieldName <> " of type "
<> msg typeName
<> " must have a selection of subfields"

+ 35
- 0
src/Data/Morpheus/Error/Utils.hs View File

@@ -0,0 +1,35 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Utils
( errorMessage,
globalErrorMessage,
badRequestError,
validationErrorMessage,
)
where

import Data.ByteString.Lazy.Char8
( ByteString,
pack,
)
import Data.Morpheus.Types.Internal.AST.Base
( GQLError (..),
GQLErrors,
Message,
Position (..),
ValidationError (..),
)
import Relude hiding (ByteString)

validationErrorMessage :: Maybe Position -> Message -> ValidationError
validationErrorMessage pos message = ValidationError message (maybeToList pos)

errorMessage :: Position -> Message -> GQLErrors
errorMessage position message = [GQLError {message, locations = [position]}]

globalErrorMessage :: Message -> GQLErrors
globalErrorMessage message = [GQLError {message, locations = []}]

badRequestError :: String -> ByteString
badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack

+ 45
- 0
src/Data/Morpheus/Error/Variable.hs View File

@@ -0,0 +1,45 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Variable
( uninitializedVariable,
incompatibleVariableType,
)
where

import Data.Morpheus.Error.Utils (validationErrorMessage)
import Data.Morpheus.Types.Internal.AST
( Ref (..),
TypeRef,
ValidationError,
Variable (..),
msg,
)
import Relude

-- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."
incompatibleVariableType :: Ref -> Variable s -> TypeRef -> ValidationError
incompatibleVariableType
(Ref variableName argPosition)
Variable {variableType}
argumentType =
validationErrorMessage (Just argPosition) text
where
text =
"Variable "
<> msg ("$" <> variableName)
<> " of type "
<> msg variableType
<> " used in position expecting type "
<> msg argumentType
<> "."

uninitializedVariable :: Variable s -> ValidationError
uninitializedVariable Variable {variableName, variableType, variablePosition} =
validationErrorMessage
(Just variablePosition)
$ "Variable "
<> msg ("$" <> variableName)
<> " of required type "
<> msg variableType
<> " was not provided."

+ 53
- 0
src/Data/Morpheus/Error/Warning.hs View File

@@ -0,0 +1,53 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Morpheus.Error.Warning
( renderGQLErrors,
deprecatedEnum,
deprecatedField,
gqlWarnings,
)
where

import Data.Aeson (encode)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Morpheus.Error.Utils (errorMessage)
import Data.Morpheus.Types.Internal.AST.Base
( Description,
FieldName,
GQLErrors,
Ref (..),
msg,
)
import Language.Haskell.TH (Q, reportWarning)
import Relude

renderGQLErrors :: GQLErrors -> String
renderGQLErrors = unpack . encode

deprecatedEnum :: FieldName -> Ref -> Maybe Description -> GQLErrors
deprecatedEnum typeName Ref {refPosition, refName} reason =
errorMessage refPosition $
"the enum value "
<> msg typeName
<> "."
<> msg refName
<> " is deprecated."
<> msg (maybe "" (" " <>) reason)

deprecatedField :: FieldName -> Ref -> Maybe Description -> GQLErrors
deprecatedField typeName Ref {refPosition, refName} reason =
errorMessage refPosition $
"the field "
<> msg typeName
<> "."
<> msg refName
<> " is deprecated."
<> msg (maybe "" (" " <>) reason)

gqlWarnings :: GQLErrors -> Q ()
gqlWarnings [] = pure ()
gqlWarnings warnings = traverse_ handleWarning warnings
where
handleWarning warning =
reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning)

+ 24
- 0
src/Data/Morpheus/Ext/Elems.hs View File

@@ -0,0 +1,24 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

module Data.Morpheus.Ext.Elems
( Elems (..),
size,
)
where

import qualified Data.HashMap.Lazy as HM
import Instances.TH.Lift ()
import Relude

class Elems a coll | coll -> a where
elems :: coll -> [a]

instance Elems a (HashMap k a) where
elems = HM.elems

instance Elems a [a] where
elems = id

size :: Elems a coll => coll -> Int
size = length . elems

+ 20
- 0
src/Data/Morpheus/Ext/Failure.hs View File

@@ -0,0 +1,20 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}

module Data.Morpheus.Ext.Failure
( Failure (..),
)
where

import Relude

-- Failure: for custom Morpheus GrapHQL errors
class Applicative f => Failure error (f :: * -> *) where
failure :: error -> f v

instance Failure error (Either error) where
failure = Left

instance (Monad m, Failure errors m) => Failure errors (ReaderT ctx m) where
failure = lift . failure

+ 37
- 0
src/Data/Morpheus/Ext/KeyOf.hs View File

@@ -0,0 +1,37 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

module Data.Morpheus.Ext.KeyOf
( KeyOf (..),
toPair,
)
where

import Data.Morpheus.Ext.Map
( Indexed (..),
)
import Data.Morpheus.Types.Internal.AST.Base
( FieldName (..),
Ref (..),
TypeName (..),
TypeNameRef (..),
)
import Relude

class (Eq k, Hashable k) => KeyOf k a | a -> k where
keyOf :: a -> k

instance (Eq k, Hashable k) => KeyOf k (k, a) where
keyOf = fst

instance KeyOf FieldName Ref where
keyOf = refName

instance KeyOf TypeName TypeNameRef where
keyOf = typeNameRef

instance (Eq k, Hashable k) => KeyOf k (Indexed k a) where
keyOf = indexedKey

toPair :: KeyOf k a => a -> (k, a)
toPair x = (keyOf x, x)

+ 103
- 0
src/Data/Morpheus/Ext/Map.hs View File

@@ -0,0 +1,103 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module Data.Morpheus.Ext.Map
( Indexed (..),
indexed,
fromListT,
resolveWith,
runResolutionT,
ResolutionT,
)
where

import Data.Foldable (foldl)
import qualified Data.HashMap.Lazy as HM
import Language.Haskell.TH.Syntax (Lift)
import Relude

sortedEntries :: [Indexed k a] -> [(k, a)]
sortedEntries = fmap f . sortOn index
where
f a = (indexedKey a, indexedValue a)

fromListT :: (Monad m, Eq k, Hashable k) => [(k, a)] -> ResolutionT k a coll m coll
fromListT = traverse resolveDuplicatesM . fromListDuplicates >=> fromNoDuplicatesM

resolveWith ::
Monad m =>
(a -> a -> m a) ->
NonEmpty a ->
m a
resolveWith f (x :| xs) = foldlM f x xs

data Indexed k a = Indexed
{ index :: Int,
indexedKey :: k,
indexedValue :: a
}
deriving
( Show,
Eq,
Functor,
Traversable,
Foldable,
Lift
)

fromListDuplicates :: (Eq k, Hashable k) => [(k, a)] -> [(k, NonEmpty a)]
fromListDuplicates xs =
sortedEntries
$ HM.elems
$ clusterDuplicates (indexed xs) HM.empty

indexed :: [(k, a)] -> [Indexed k a]
indexed = __indexed 0
where
__indexed :: Int -> [(k, a)] -> [Indexed k a]
__indexed _ [] = []
__indexed i ((k, x) : xs) = Indexed i k x : __indexed (i + 1) xs

resolveDuplicatesM :: Monad m => (k, NonEmpty a) -> ResolutionT k a coll m (k, a)
resolveDuplicatesM (k, xs) = asks resolveDuplicates >>= lift . fmap (k,) . (xs &)

fromNoDuplicatesM :: Monad m => [(k, a)] -> ResolutionT k a coll m coll
fromNoDuplicatesM xs = asks ((xs &) . fromNoDuplicates)

insertWithList :: (Eq k, Hashable k) => Indexed k (NonEmpty a) -> HashMap k (Indexed k (NonEmpty a)) -> HashMap k (Indexed k (NonEmpty a))
insertWithList (Indexed i1 key value) = HM.alter (Just . updater) key
where
updater Nothing = Indexed i1 key value
updater (Just (Indexed i2 _ x)) = Indexed i2 key (x <> value)

clusterDuplicates :: (Eq k, Hashable k) => [Indexed k a] -> HashMap k (Indexed k (NonEmpty a)) -> HashMap k (Indexed k (NonEmpty a))
clusterDuplicates [] = id
clusterDuplicates xs = flip (foldl (\coll x -> insertWithList (fmap (:| []) x) coll)) xs

data Resolution k a coll m = Resolution
{ resolveDuplicates :: NonEmpty a -> m a,
fromNoDuplicates :: [(k, a)] -> coll
}

runResolutionT ::
ResolutionT k a coll m b ->
([(k, a)] -> coll) ->
(NonEmpty a -> m a) ->
m b
runResolutionT (ResolutionT x) fromNoDuplicates resolveDuplicates = runReaderT x Resolution {..}

newtype ResolutionT k a coll m x = ResolutionT
{ _runResolutionT :: ReaderT (Resolution k a coll m) m x
}
deriving
( Functor,
Monad,
Applicative,
MonadReader (Resolution k a coll m)
)

instance MonadTrans (ResolutionT k a coll) where
lift = ResolutionT . lift

+ 105
- 0
src/Data/Morpheus/Ext/MergeSet.hs View File

@@ -0,0 +1,105 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Data.Morpheus.Ext.MergeSet
( MergeSet,
)
where

import Data.Morpheus.Ext.Elems (Elems (..))
import Data.Morpheus.Ext.Map
( fromListT,
resolveWith,
runResolutionT,
)
import Data.Morpheus.Ext.SemigroupM
( SemigroupM (..),
)
import Data.Morpheus.Internal.Utils
( Collection (..),
Failure (..),
FromElems (..),
KeyOf (..),
Selectable (..),
toPair,
)
import Data.Morpheus.Types.Internal.AST.Base
( Ref,
ValidationErrors,
)
import Data.Morpheus.Types.Internal.AST.Stage
( RAW,
Stage,
VALID,
)
import Language.Haskell.TH.Syntax (Lift (..))
import Relude

-- set with mergeable components
newtype MergeSet (dups :: Stage) k a = MergeSet
{ unpack :: [a]
}
deriving
( Show,
Eq,
Functor,
Foldable,
Lift,
Traversable,
Collection a,
Elems a
)

instance (KeyOf k a) => Selectable k a (MergeSet opt k a) where
selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)

instance
( KeyOf k a,
SemigroupM m a,
Monad m,
Failure ValidationErrors m,
Eq a
) =>
SemigroupM m (MergeSet VALID k a)
where
mergeM path (MergeSet x) (MergeSet y) = resolveMergable path (x <> y)

resolveMergable ::
( KeyOf k a,
Monad m,
Eq a,
SemigroupM m a,
Failure ValidationErrors m
) =>
[Ref] ->
[a] ->
m (MergeSet dups k a)
resolveMergable path xs = runResolutionT (fromListT (toPair <$> xs)) (MergeSet . fmap snd) (resolveWith (resolveConflict path))

instance
( KeyOf k a,
SemigroupM m a,
Monad m,
Failure ValidationErrors m,
Eq a
) =>
FromElems m a (MergeSet VALID k a)
where
fromElems = resolveMergable []

instance Applicative m => SemigroupM m (MergeSet RAW k a) where
mergeM _ (MergeSet x) (MergeSet y) = pure $ MergeSet $ x <> y

instance Applicative m => FromElems m a (MergeSet RAW k a) where
fromElems = pure . MergeSet

resolveConflict :: (Monad m, Eq a, KeyOf k a, SemigroupM m a, Failure ValidationErrors m) => [Ref] -> a -> a -> m a
resolveConflict path oldValue newValue
| oldValue == newValue = pure oldValue
| otherwise = mergeM path oldValue newValue

+ 91
- 0
src/Data/Morpheus/Ext/OrdMap.hs View File

@@ -0,0 +1,91 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Morpheus.Ext.OrdMap
( OrdMap (..),
unsafeFromList,
)
where

import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Error.NameCollision (NameCollision (..))
import Data.Morpheus.Ext.Elems (Elems (..))
import Data.Morpheus.Ext.Map
( Indexed (..),
indexed,
)
import Data.Morpheus.Ext.SemigroupM
( SemigroupM (..),
)
import Data.Morpheus.Internal.Utils
( Collection (..),
Failure,
FromElems (..),
KeyOf (..),
Selectable (..),
toPair,
)
import Data.Morpheus.Types.Internal.AST.Base (ValidationErrors)
import Language.Haskell.TH.Syntax (Lift (..))
import Relude

-- OrdMap
newtype OrdMap k a = OrdMap
{ mapEntries :: HashMap k (Indexed k a)
}
deriving
( Show,
Eq,
Functor,
Traversable
)

instance (Lift a, Lift k, Eq k, Hashable k) => Lift (OrdMap k a) where
lift (OrdMap x) = [|OrdMap (HM.fromList ls)|]
where
ls = HM.toList x

#if MIN_VERSION_template_haskell(2,16,0)
liftTyped (OrdMap x) = [||OrdMap (HM.fromList ls)||]
where
ls = HM.toList x
#endif

instance (Eq k, Hashable k) => Foldable (OrdMap k) where
foldMap f = foldMap f . getElements

getElements :: (Eq k, Hashable k) => OrdMap k b -> [b]
getElements = fmap indexedValue . sortOn index . toList . mapEntries

instance (KeyOf k a, Hashable k) => Collection a (OrdMap k a) where
empty = OrdMap HM.empty
singleton x = OrdMap $ HM.singleton (keyOf x) (Indexed 0 (keyOf x) x)

instance (Eq k, Hashable k) => Selectable k a (OrdMap k a) where
selectOr fb f key OrdMap {mapEntries} = maybe fb (f . indexedValue) (HM.lookup key mapEntries)

instance (NameCollision a, Monad m, KeyOf k a, Failure ValidationErrors m) => SemigroupM m (OrdMap k a) where
mergeM ref (OrdMap x) (OrdMap y) = OrdMap <$> mergeM ref x y

instance (NameCollision a, Monad m, Failure ValidationErrors m, KeyOf k a, Hashable k) => FromElems m a (OrdMap k a) where
fromElems values = OrdMap <$> fromElems (indexed (toPair <$> values))

instance (Eq k, Hashable k) => Elems a (OrdMap k a) where
elems = getElements

unsafeFromList ::
(Hashable k, Eq k) =>
[(k, a)] ->
OrdMap k a
unsafeFromList = OrdMap . HM.fromList . fmap withKey . indexed
where
withKey idx = (indexedKey idx, idx)

+ 80
- 0
src/Data/Morpheus/Ext/SafeHashMap.hs View File

@@ -0,0 +1,80 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Morpheus.Ext.SafeHashMap
( SafeHashMap,
unsafeFromList,
insert,
)
where

import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Error.NameCollision (NameCollision (..))
import Data.Morpheus.Ext.Elems (Elems)
import Data.Morpheus.Ext.SemigroupM
( (<:>),
SemigroupM (..),
)
import Data.Morpheus.Internal.Utils
( Collection (..),
Failure (..),
FromElems (..),
KeyOf (..),
Selectable (..),
)
import Data.Morpheus.Types.Internal.AST.Base (ValidationErrors)
import Language.Haskell.TH.Syntax (Lift (..))
import Relude

newtype SafeHashMap k a = SafeHashMap
{ unpackSafeHashMap :: HashMap k a
}
deriving
( Show,
Eq,
Functor,
Foldable,
Traversable
)
deriving newtype
( Collection a,
Selectable k a,
Elems a
)

instance (Lift a, Lift k, Eq k, Hashable k) => Lift (SafeHashMap k a) where
lift (SafeHashMap x) = let ls = HM.toList x in [|SafeHashMap (HM.fromList ls)|]

#if MIN_VERSION_template_haskell(2,16,0)
liftTyped (SafeHashMap x) = let ls = HM.toList x in [||SafeHashMap (HM.fromList ls)||]
#endif

instance (NameCollision a, Monad m, KeyOf k a, Failure ValidationErrors m) => SemigroupM m (SafeHashMap k a) where
mergeM ref (SafeHashMap x) (SafeHashMap y) = SafeHashMap <$> mergeM ref x y

instance (NameCollision a, Failure ValidationErrors m, Monad m, KeyOf k a, Hashable k) => FromElems m a (SafeHashMap k a) where
fromElems = fmap SafeHashMap . fromElems

unsafeFromList :: (Eq k, KeyOf k a) => [(k, a)] -> SafeHashMap k a
unsafeFromList = SafeHashMap . HM.fromList

insert ::
( NameCollision a,
KeyOf k a,
Monad m,
Failure ValidationErrors m
) =>
a ->
SafeHashMap k a ->
m (SafeHashMap k a)
insert x = (<:> singleton x)

+ 81
- 0
src/Data/Morpheus/Ext/SemigroupM.hs View File

@@ -0,0 +1,81 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Data.Morpheus.Ext.SemigroupM
( SemigroupM (..),
(<:>),
concatTraverse,
join,
)
where

import qualified Data.HashMap.Lazy as HM
import Data.HashMap.Lazy (HashMap)
import Data.Morpheus.Error.NameCollision (NameCollision)
import Data.Morpheus.Ext.KeyOf (KeyOf (..))
import Data.Morpheus.Ext.Map
( fromListT,
runResolutionT,
)
import Data.Morpheus.Internal.Utils
( Collection (..),
Elems (..),
Failure,
failOnDuplicates,
)
import Data.Morpheus.Types.Internal.AST.Base
( Ref,
ValidationErrors,
)
import Relude
( ($),
Applicative (..),
Monad (..),
Semigroup (..),
Traversable (..),
)

class SemigroupM (m :: * -> *) a where
mergeM :: [Ref] -> a -> a -> m a

instance
( NameCollision a,
Monad m,
KeyOf k a,
Failure ValidationErrors m
) =>
SemigroupM m (HashMap k a)
where
mergeM _ x y = runResolutionT (fromListT $ HM.toList x <> HM.toList y) HM.fromList failOnDuplicates

concatTraverse ::
( Monad m,
Failure ValidationErrors m,
Collection b cb,
Elems a ca,
SemigroupM m cb
) =>
(a -> m cb) ->
ca ->
m cb
concatTraverse f smap =
traverse f (elems smap)
>>= join

join ::
( Collection e a,
Monad m,
Failure ValidationErrors m,
SemigroupM m a
) =>
[a] ->
m a
join = __join empty
where
__join acc [] = pure acc
__join acc (x : xs) = acc <:> x >>= (`__join` xs)

(<:>) :: SemigroupM m a => a -> a -> m a
(<:>) = mergeM []

+ 52
- 0
src/Data/Morpheus/Internal/Graph.hs View File

@@ -0,0 +1,52 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}

module Data.Morpheus.Internal.Graph
( cycleChecking,
Node,
Graph,
Edges,
)
where

import Data.List (lookup)
import Data.Morpheus.Types.Internal.AST (Ref (..))
import Relude

type Node = Ref

type Edges = (Ref, [Ref])

type Graph = [Edges]

cycleChecking ::
Applicative m =>
(NonEmpty Ref -> m ()) ->
Graph ->
m ()
cycleChecking fail' graph = traverse_ checkNode graph
where
checkNode (node, _) = cycleCheckingWith graph node [node] fail'

cycleCheckingWith ::
Applicative m =>
Graph ->
Ref ->
[Ref] ->
(NonEmpty Ref -> m ()) ->
m ()
cycleCheckingWith graph parentNode history fail' =
case lookup parentNode graph of
Just node -> traverse_ checkNode node
Nothing -> pure ()
where
checkNode node
| node `elem` history =
fail' (node :| history)
| otherwise =
cycleCheckingWith
graph
node
(history <> [node])
fail'

+ 244
- 0
src/Data/Morpheus/Internal/TH.hs View File

@@ -0,0 +1,244 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Morpheus.Internal.TH
( _',
apply,
applyCons,
applyVars,
decArgs,
declareTypeRef,
funDProxy,
funDSimple,
infoTyVars,
isEnum,
m',
nameSpaceField,
nameSpaceType,
toCon,
toConE,
toConT,
toVar,
ToName (..),
toString,
toVarE,
toVarT,
tyConArgs,
typeInstanceDec,
v',
cat',
_2',
o',
e',
vars,
)
where

import Data.Foldable (foldl)
import Data.Morpheus.Internal.Utils
( capitalize,
nameSpaceField,
nameSpaceType,
)
import Data.Morpheus.Types.Internal.AST
( FieldName (..),
TypeKind (..),
TypeName (..),
TypeRef (..),
TypeWrapper (..),
convertToHaskellName,
isEnum,
isOutputObject,
readName,
)
import Data.Text (unpack)
import Language.Haskell.TH
import Relude hiding (ToString (..), Type)

m' :: Type
m' = VarT (mkName "m")

o' :: Type
o' = VarT (mkName "o")

e' :: Type
e' = VarT (mkName "event")

_' :: PatQ
_' = toVar (mkName "_")

_2' :: PatQ
_2' = toVar (mkName "_2")

v' :: ToVar Name a => a
v' = toVar (mkName "v")

cat' :: Type
cat' = VarT (mkName "cat")

declareTypeRef :: TypeRef -> Type
declareTypeRef TypeRef {typeConName, typeWrappers, typeArgs} =
wrappedT
typeWrappers
where
wrappedT :: [TypeWrapper] -> Type
wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs
wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs
wrappedT [] = decType typeArgs
--------------------------------------------
decType :: Maybe String -> Type
decType (Just par) = apply typeConName [toVar par]
decType _ = toCon typeConName

tyConArgs :: TypeKind -> [String]
tyConArgs kindD
| isOutputObject kindD || kindD == KindUnion = ["m"]
| otherwise = []

cons :: ToCon a b => [a] -> [b]
cons = map toCon

vars :: ToVar a b => [a] -> [b]
vars = map toVar

class ToName a where
toName :: a -> Name

instance ToName String where
toName = mkName

instance ToName Name where
toName = id

instance ToName TypeName where
toName = mkName . unpack . capitalize . readTypeName

instance ToName FieldName where
toName = mkName . unpack . readName . convertToHaskellName

class ToString a b where
toString :: a -> b

instance ToString a b => ToString a (Q b) where
toString = pure . toString

instance ToString TypeName Lit where
toString = stringL . unpack . readTypeName

instance ToString TypeName Pat where
toString = LitP . toString

instance ToString FieldName Lit where
toString (FieldName x) = stringL (unpack x)

instance ToString TypeName Exp where
toString = LitE . toString

instance ToString FieldName Exp where
toString = LitE . toString

class ToCon a b where
toCon :: a -> b

instance ToCon a b => ToCon a (Q b) where
toCon = pure . toCon

instance (ToName a) => ToCon a Type where
toCon = ConT . toName

instance (ToName a) => ToCon a Exp where
toCon = ConE . toName

class ToVar a b where
toVar :: a -> b

instance ToVar a b => ToVar a (Q b) where
toVar = pure . toVar

instance (ToName a) => ToVar a Type where
toVar = VarT . toName

instance (ToName a) => ToVar a Exp where
toVar = VarE . toName

instance (ToName a) => ToVar a Pat where
toVar = VarP . toName

class Apply a where
apply :: ToCon i a => i -> [a] -> a

instance Apply TypeQ where
apply = foldl appT . toCon

instance Apply Type where
apply = foldl AppT . toCon

instance Apply Exp where
apply = foldl AppE . toCon

instance Apply ExpQ where
apply = foldl appE . toCon

applyVars ::
( ToName con,
ToName var,
Apply res,
ToCon con res,
ToVar var res
) =>
con ->
[var] ->
res
applyVars name li = apply name (vars li)

applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type
applyCons name li = apply name (cons li)

funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy = map fun
where
fun (name, body) = funDSimple name [_'] body

funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ
funDSimple name args body = funD name [clause args (normalB body) []]

infoTyVars :: Info -> [TyVarBndr]
infoTyVars (TyConI x) = decArgs x
infoTyVars _ = []

decArgs :: Dec -> [TyVarBndr]
decArgs (DataD _ _ args _ _ _) = args
decArgs (NewtypeD _ _ args _ _ _) = args
decArgs (TySynD _ args _) = args
decArgs _ = []

toConT :: ToName a => a -> Q Type
toConT = conT . toName

toVarT :: ToVar a TypeQ => a -> TypeQ
toVarT = toVar

toVarE :: ToVar a Exp => a -> ExpQ
toVarE = toVar

toConE :: ToCon a Exp => a -> ExpQ
toConE = toCon

#if MIN_VERSION_template_haskell(2,15,0)
-- fix breaking changes
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)
#else
--
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)
#endif

+ 180
- 0
src/Data/Morpheus/Internal/Utils.hs View File

@@ -0,0 +1,180 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}

module Data.Morpheus.Internal.Utils
( capitalize,
nameSpaceField,
nameSpaceType,
capitalTypeName,
Collection (..),
Selectable (..),
FromElems (..),
Failure (..),
KeyOf (..),