├── README.md ├── docs ├── priorities.md └── specification.md ├── misc ├── MIT-LICENSE.txt ├── editor.png └── logo.png ├── plate.cabal ├── src ├── Plate.hs ├── Plate │ ├── Prelude.hs │ ├── Schema.hs │ ├── Validation.hs │ └── Value.hs └── PlateExamples.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Test.hs ├── Test ├── Prelude.hs ├── ReadmeExamples.hs ├── SimplePlate.hs └── Validation.hs └── generated ├── concrete.json ├── examples.json ├── expressions.json ├── readme-instance.json └── readme-schema.json /README.md: -------------------------------------------------------------------------------- 1 | Plate 2 | 3 | Language-agnostic schemas based on Haskell's type system. 4 | 5 | # Why Schemas 6 | 7 | Schema languages like [JSON Schema](http://json-schema.org/) let you to describe data in a way that can be understood by any programming language. They're one of the core components of API description tools like [Swagger](http://swagger.io/). Once you write schemas to describe the data your API deals with you can use them to automatically generate documentation, UIs, and client code. This avoids lots of manual, error-prone work at your application boundary. 8 | 9 | # Why Another Schema Language 10 | 11 | Writing a schema language is trickier than it looks. You have to strike a careful balance between over and under-expressiveness. 12 | 13 | If you make your schema under-expressive it becomes little better than no schema at all. For example [JSchema](http://jschema.org/) allows all values described by the schema to be `null`. While it's easy to find nice things to say about JSchema (such as its simplicity), implicit nulls don't allow enough structure for many tasks. 14 | 15 | On the other hand you can error by allowing too much expressiveness. For instance in [JSON Schema](http://json-schema.org/) a clever combination of the `"anyOf"`, `"allOf"`, and `"not"` keywords is enough to build if and case statements (discovered by [Evgeny Poberezkin](https://github.com/json-schema-org/json-schema-spec/issues/64#issuecomment-257027551)). 16 | 17 | This allows schemas to describe enormously complex structures for which it's impossible to automatically generate clean UIs or client code. Once again this defeats the original purpose. One solution would be to ask schema writers to work in only some subset of the schema langauge, but which subset? We're back to the original problem. 18 | 19 | # The Idea Behind Plate 20 | 21 | The solution is to look for rescue from a related field. Language-specific type system writers have been feeling out the sweet spot of expressiveness longer than the other tools mentioned here have existed. Even better, many of them are battle-hardened and sit on a principled theoretical foundation. 22 | 23 | And of course the most glorious, battle-hardened, and principled of these is Haskell. Plate is what you get when you steal the most basic, essential features of Haskell's type system and build a schema language from them. Hopefully this lets Plate strike the right level of expressiveness for many tasks. 24 | 25 | # Status 26 | 27 | Work-in-progress. Nothing is final or production ready. Everything is a mess. Documentation is wrong. 28 | 29 | # Example 30 | 31 | Say we have the following Haskell type: 32 | ```haskell 33 | data Album = Album 34 | { title :: Text 35 | , artist :: Text 36 | , tracks :: [Text] 37 | } 38 | ``` 39 | 40 | We can also express it as a Plate schema using the `plate` library: 41 | ```haskell 42 | album :: Schema 43 | album = ProductType (HM.fromList 44 | [ ("title", Builtin SString) 45 | , ("artist", Builtin SString) 46 | , ("tracks", Builtin (SSequence (Builtin SString))) 47 | ]) 48 | ``` 49 | (It won't be hard to make this conversion automatic, though I haven't gotten around to it yet.) 50 | 51 | We can then generate a JSON representation of the schema for other tools to use: 52 | ```json 53 | { 54 | "schema.product": { 55 | "title": { 56 | "type": { 57 | "schema.string": {} 58 | } 59 | }, 60 | "artist": { 61 | "type": { 62 | "schema.string": {} 63 | } 64 | }, 65 | "tracks": { 66 | "type": { 67 | "schema.sequence": { 68 | "type": { 69 | "schema.string": {} 70 | } 71 | } 72 | } 73 | } 74 | } 75 | } 76 | ``` 77 | 78 | We can also generate UIs so users can conveniently create instances of our schema: 79 | 80 | ![](./misc/editor.png) 81 | 82 | (Note: the editor isn't released yet) 83 | 84 | Then say a user creates this piece of data: 85 | ```json 86 | { 87 | "title": "Interstellar: Original Motion Picture Soundtrack", 88 | "artist": "Hans Zimmer", 89 | "tracks": { 90 | "sequence": [ 91 | "Dreaming of the Crash", 92 | "Cornfield Chase", 93 | "Dust", 94 | "Day One", 95 | "Stay", 96 | "Message from Home", 97 | "The Wormhole", 98 | "Mountains", 99 | "Afraid of Time", 100 | "A Place Among the Stars", 101 | "Running Out", 102 | "I'm Going Home", 103 | "Coward", 104 | "Detach", 105 | "S.T.A.Y.", 106 | "Where We're Going" 107 | ] 108 | } 109 | } 110 | ``` 111 | 112 | We can convert it to its Plate representation and then validate it: 113 | ```haskell 114 | λ> Plate.validate mempty albumSchema interstellarSountrack 115 | Right () 116 | ``` 117 | 118 | # Special Thanks 119 | 120 | [TJ Weigel](http://tjweigel.com/) created the logo. 121 | -------------------------------------------------------------------------------- /docs/priorities.md: -------------------------------------------------------------------------------- 1 | # Priorities 2 | 3 | (In order of importance.) 4 | 5 | ### 1. Usefulness as a way of describing data 6 | 7 | Plate schemas should be expressive enough to describe all the data that passes through many applications. At the same they should be able to provide meaningful structure to that data. 8 | 9 | ### 2. Unchanging in a principled way 10 | 11 | This is different from simple backwards compatibility. The goal is to eventually reach a place where each decision made by Plate follows from principled reasons. If we end up doing something like adding new validators because they seem useful at the moment then something is wrong. 12 | 13 | Inspired by [the ECMA 404 introduction](https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf): "Because it is so simple, it is not expected that the JSON grammar will ever change." 14 | 15 | ### 3. Efficient data serialization 16 | 17 | This is a low priority for a reason. Tools like [Cap’n Proto](https://capnproto.org/) already exist to move data around in an extraordinarily efficient way. Plate exists so if you want to make a new meaningful-on-its-own format like [iCalendar](https://en.wikipedia.org/wiki/ICalendar) you can describe it well. 18 | 19 | These two approaches complement each other. For example you might use [Cap’n Proto](https://capnproto.org/) representations of your data in your APIs, but provide Plate representations on export. 20 | 21 | # Not priorities 22 | 23 | ### + Efficient schema serialization 24 | 25 | With regards to performance schemas get passed around a lot less than normal data. So it doesn't matter much how big they are. 26 | 27 | With regards to human-readability we'll eventually write a DSL for them (which may look a lot like Haskell source code). So the readability of JSON-encoded schemas won't matter much in the long run. 28 | 29 | ### + Ability to describe existing data types with Plate 30 | 31 | Not all (eg) JSON values can be converted to Plate values. 32 | 33 | Of those that can, not all Plate values can be described by Plate schemas. For instance, you can express untagged unions in Plate values, but not in Plate schemas. 34 | 35 | This is OK. There are an unlimited number of ways to contort values, a good type system can't cover all of them. Plate is meant to be used during the creation of new data types. It's not meant to describe existing ones retroactively. 36 | 37 | ### + Comprehensive UI descriptions 38 | 39 | Plate is a schema language, not a DSL for UIs. We want it to be useful for generating UIs, but it would be impossible for Plate to describe everything that goes into a UI: font choices, background color, horizontal vs. vertical positioning, etc. 40 | 41 | At some point a line has to be drawn. I think the cleanest place to do this is to say that Plate will only include information that's relevent to validating data. This is enough to auto-generate simple UIs. 42 | 43 | In the future when our UI-generation tools become more sophisticated we can consider various "UI-specification-formats" to be used alongside of Plate schemas. They can describe nuances of UIs that can't be expressed in the schemas themselves. 44 | -------------------------------------------------------------------------------- /docs/specification.md: -------------------------------------------------------------------------------- 1 | # Definition 2 | 3 | Plate is a few things: 4 | 5 | ### 1. Plate Values 6 | 7 | (Keep [Plate.Value](../src/Plate/Value.hs) in sync with this.) 8 | 9 | We'd like to use Plate to validate data serialized in different ways, so we avoid tying it into a specific serialization format like JSON. 10 | 11 | Instead we build the specification on our own concept of Plate values. 12 | 13 | How to define them? If we were really hardcore we'd just say `Value = Map String Value`. 14 | 15 | Then for instance we could represent the number 2 as: 16 | 17 | ``` 18 | Map.singleton 19 | "succ" 20 | (Map.singleton 21 | "succ" 22 | (Map.singleton 23 | "zero" 24 | mempty)) 25 | ``` 26 | 27 | Of course, we wouldn't want to serialize them this way, the payloads would be huge! Come to think of it we wouldn't want to represent them in memory this way either. 28 | 29 | OK, so why not just define them this way for simplicity, then let in-memory and serialization methods use custom representations that are more efficient? 30 | 31 | This could work, but makes for an awkward mappings between implementations and the spec. Each implementation would have to coordinate how (eg) integers are represented in the spec, because if one uses "succ" and "zero" and another "next" and "end" then they would inadvertently refer to different values. 32 | 33 | This could be solved by adding an adendum to the spec saying "integers are defined as 'succ' and 'zero'". If we're going that far why not just expand the definition of values to include commonly used data types? Then we don't have to make up silly names like "succ" that will always be optimized away anyway. 34 | 35 | And so we do. 36 | 37 | Plate values are made up of: 38 | 39 | 1. Primitives (the `Map String Value` mentioned earlier). 40 | 41 | 2. Integers 42 | 43 | 3. Sets of Plate values 44 | 45 | 4. Dictionaries mapping Plate values to Plate values 46 | 47 | 5. Sequences of Plate values 48 | 49 | 6. Strings of Unicode code points 50 | 51 | ### 2. Plate Schemas 52 | 53 | (Keep [Plate.Schema](../src/Plate/Value.hs) and [PlateExamples](../src/PlateExamples.hs) in sync with this.) 54 | 55 | This is what we use to describe Plate values. A Haskell implementation is shown, though it can be implemented in any language: 56 | 57 | ```haskell 58 | data Expression 59 | = Variable Text 60 | | Abstraction Text Expression 61 | | Application Expression Expression 62 | | Builtin Schema 63 | 64 | data Schema 65 | = SumType (HashMap Text Expression) 66 | | ProductType (HashMap Text Expression) 67 | | SInteger 68 | | SSet Expression 69 | | SDictionary Expression Expression 70 | | SSequence Expression 71 | | SString 72 | | SPrimitive Expression 73 | -- ^ Treat a sum/product type as a dictionary instead of as code. 74 | -- 75 | -- This is only recommended for special cases, such as when 76 | -- writing a schema for schemas. 77 | ``` 78 | 79 | We can also get recursive and describe Plate schemas using Plate schemas: 80 | ```haskell 81 | expression :: Schema 82 | expression = 83 | SumType (HM.fromList 84 | [ ("variable", Builtin SString) 85 | , ("abstraction", 86 | Builtin (ProductType (HM.fromList 87 | [ ("parameter", Builtin SString) 88 | , ("body", Variable expressionRef) 89 | ]))) 90 | , ("application", 91 | Builtin (ProductType (HM.fromList 92 | [ ("function", Variable expressionRef) 93 | , ("argument", Variable expressionRef) 94 | ]))) 95 | , ("type", Variable schemaRef) 96 | ]) 97 | 98 | schema :: Schema 99 | schema = 100 | SumType (HM.fromList 101 | [ ("schema.sum", sumOrProduct) 102 | , ("schema.product", sumOrProduct) 103 | , ("schema.integer", Builtin (ProductType mempty)) 104 | , ("schema.set", Variable expressionRef) 105 | , ("schema.dictionary", 106 | Builtin (ProductType (HM.fromList 107 | [ ("keys", Variable expressionRef) 108 | , ("values", Variable expressionRef) 109 | ]))) 110 | , ("schema.sequence", Variable expressionRef) 111 | , ("schema.string", Builtin (ProductType mempty)) 112 | , ("schema.primitive", Variable expressionRef) 113 | ]) 114 | where 115 | sumOrProduct :: Expression 116 | sumOrProduct = Builtin (SPrimitive (Variable expressionRef)) 117 | ``` 118 | 119 | ### 3. Validation 120 | 121 | (Keep [Plate](../src/Plate.hs) in sync with this.) 122 | 123 | Take a Plate schema and a Plate value and see if the schema allows the value. 124 | 125 | Currently defined by the `validate` function in [Plate](../src/Plate.hs) as well as common sense because there are probably mistakes in `validate`. This definition will improve in the future. 126 | 127 | ### 4. Mappings from Plate values to serialization formats 128 | 129 | (Keep [Plate.Value](../src/Plate/Value.hs) in sync with this.) 130 | 131 | This is the highest layer of the specification for a reason -- there will be multiple ways of mapping Plate values to data formats, and that's OK. You just have to keep track of which one was used for each document. 132 | 133 | That said, we hope to prevent fragmentation as much as possible by provided well-thought out mappings to most common data formats. 134 | 135 | At the moment though only one is provided: a mapping between Plate values and JSON. You can see how its implemented in the `ToJSON` and `FromJSON` instances of [Plate.Value](../src/Plate/Value.hs). 136 | 137 | Notably, it maps Plate primitives (`Map String Value`s) to JSON objects, and Plate dictionaries to JSON arrays. This because Plate dictionaries don't work as JSON objects since the latter requires keys to be JSON strings. 138 | 139 | This idea came from [Microsoft Bond](https://microsoft.github.io/bond/) which is a fantastic schema language itself (though it doesn't have sum types). 140 | 141 | So for example the following Plate value: 142 | ```haskell 143 | PPrimitive (HM.singleton 144 | "left" 145 | (PDictionary (HM.fromList 146 | [ (PInteger 12, PString "Invalid for reason foo") 147 | , (PInteger 20, PString "Invalid for reason bar") 148 | ])) 149 | ``` 150 | 151 | Serializes to the JSON: 152 | ```json 153 | { "left": 154 | { "dictionary": 155 | [ [ 12 156 | , "Invalid for reason foo" 157 | ] 158 | , [ 20 159 | , "Invalid for reason bar" 160 | ] 161 | ] 162 | } 163 | } 164 | ``` 165 | 166 | The reason "dictionary" is specified is to distinguish the result from a sequence or a set. This is required to let us roundtrip between the in-memory and serialized versions of the data without ambiguity. 167 | 168 | It has two downsides though in that it expands the size of the payload as well as making "dictionary", "set", etc. reserved keywords. The first problem is acceptable, the latter needs more consideration. 169 | -------------------------------------------------------------------------------- /misc/MIT-LICENSE.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | Copyright (c) 2017 Ian Grant Jeffries 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the "Software"), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in all 12 | copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 18 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 19 | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE 20 | OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /misc/editor.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seagreen/plate/572fd06ae1d08e9b012137d8b22a033950825a6e/misc/editor.png -------------------------------------------------------------------------------- /misc/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seagreen/plate/572fd06ae1d08e9b012137d8b22a033950825a6e/misc/logo.png -------------------------------------------------------------------------------- /plate.cabal: -------------------------------------------------------------------------------- 1 | name: plate 2 | version: 0.1.0 3 | synopsis: An experimental attempt at principled schemas 4 | homepage: https://github.com/plate/plate 5 | author: Ian Grant Jeffries 6 | maintainer: ian@housejeffries.com 7 | license: MIT 8 | license-file: ./misc/MIT-LICENSE.txt 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | library 13 | hs-source-dirs: 14 | src 15 | default-language: Haskell2010 16 | default-extensions: 17 | DeriveFunctor 18 | DeriveGeneric 19 | FlexibleContexts 20 | FlexibleInstances 21 | GeneralizedNewtypeDeriving 22 | NoImplicitPrelude 23 | OverloadedStrings 24 | ScopedTypeVariables 25 | StrictData 26 | TupleSections 27 | ghc-options: 28 | -Wall 29 | exposed-modules: 30 | Plate 31 | Plate.Schema 32 | Plate.Validation 33 | Plate.Value 34 | PlateExamples 35 | other-modules: 36 | Plate.Prelude 37 | build-depends: 38 | base 39 | , aeson 40 | , bytestring 41 | , containers 42 | , hashable 43 | , microlens 44 | , profunctors 45 | , protolude 46 | , QuickCheck 47 | , scientific 48 | , text 49 | , unordered-containers 50 | , vector 51 | 52 | test-suite test 53 | hs-source-dirs: 54 | test 55 | main-is: Test.hs 56 | other-modules: 57 | Test.ReadmeExamples 58 | Test.Prelude 59 | Test.SimplePlate 60 | Test.Validation 61 | default-language: Haskell2010 62 | default-extensions: 63 | DeriveFunctor 64 | DeriveGeneric 65 | FlexibleContexts 66 | FlexibleInstances 67 | GeneralizedNewtypeDeriving 68 | NoImplicitPrelude 69 | OverloadedStrings 70 | ScopedTypeVariables 71 | StrictData 72 | TupleSections 73 | type: exitcode-stdio-1.0 74 | ghc-options: 75 | -Wall 76 | build-depends: 77 | base 78 | , aeson 79 | , aeson-pretty 80 | , bytestring 81 | , plate 82 | , protolude 83 | , QuickCheck 84 | , tasty 85 | , tasty-hunit 86 | , tasty-quickcheck 87 | , text 88 | , unordered-containers 89 | , vector 90 | -------------------------------------------------------------------------------- /src/Plate.hs: -------------------------------------------------------------------------------- 1 | module Plate 2 | ( module Plate.Schema 3 | , module Plate.Validation 4 | , module Plate.Value 5 | ) where 6 | 7 | import Plate.Schema 8 | import Plate.Validation 9 | import Plate.Value 10 | -------------------------------------------------------------------------------- /src/Plate/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Plate.Prelude (module Export) where 2 | 3 | import Data.HashMap.Strict as Export (HashMap) 4 | import Data.Vector as Export (Vector) 5 | import Protolude as Export 6 | -------------------------------------------------------------------------------- /src/Plate/Schema.hs: -------------------------------------------------------------------------------- 1 | module Plate.Schema where 2 | 3 | import Control.Monad (fail) 4 | import Data.Aeson 5 | import Data.Aeson.Types (Parser) 6 | import Plate.Prelude hiding (evaluate, exp) 7 | import Plate.Value 8 | import Test.QuickCheck 9 | 10 | import qualified Data.HashMap.Strict as HM 11 | import qualified Data.Text as T 12 | 13 | data Expression 14 | = Variable Text 15 | | Abstraction Text Expression 16 | | Application Expression Expression 17 | | Builtin Schema 18 | deriving (Eq, Show) 19 | 20 | data Schema 21 | = SumType (HashMap Text Expression) 22 | | ProductType (HashMap Text Expression) 23 | | SInteger 24 | | SSet Expression 25 | | SDictionary Expression Expression 26 | | SSequence Expression 27 | | SString 28 | | SPrimitive Expression 29 | -- ^ Treat a sum/product type as a dictionary instead of as code. 30 | -- 31 | -- This is only recommended for special cases, such as when 32 | -- writing a schema for schemas. 33 | deriving (Eq, Show) 34 | 35 | instance ToPlate Expression where 36 | toPlate a = 37 | PPrimitive $ case a of 38 | Variable t -> HM.singleton "variable" (PString t) 39 | 40 | Abstraction t exp -> 41 | HM.singleton 42 | "abstraction" 43 | (PPrimitive (HM.fromList [ ("parameter", PString t) 44 | , ("body", toPlate exp) 45 | ])) 46 | 47 | Application exp1 exp2 -> 48 | HM.singleton 49 | "application" 50 | (PPrimitive (HM.fromList [ ("function", toPlate exp1) 51 | , ("argument", toPlate exp2) 52 | ])) 53 | 54 | Builtin b -> HM.singleton "type" (toPlate b) 55 | 56 | instance FromPlate Expression where 57 | fromPlate plate = 58 | case plate of 59 | (PPrimitive hm) -> 60 | case HM.toList hm of 61 | [("variable", a)] -> Variable <$> fromPlate a 62 | [("abstraction", a)] -> parseAbstraction a 63 | [("application", a)] -> parseApplication a 64 | [("type", a)] -> Builtin <$> fromPlate a 65 | _ -> Left "FromPlate Expression: No value constructor match" 66 | _ -> Left "FromPlate Expression: Not a PPrimitive" 67 | where 68 | parseAbstraction (PPrimitive hm) = 69 | Abstraction 70 | <$> (fromPlate =<< lkup "parameter" hm) 71 | <*> (fromPlate =<< lkup "body" hm) 72 | parseAbstraction _ = 73 | Left "FromPlate Expression: abstraction is not a sequence" 74 | 75 | parseApplication (PPrimitive hm) = 76 | Application 77 | <$> (fromPlate =<< lkup "function" hm) 78 | <*> (fromPlate =<< lkup "argument" hm) 79 | parseApplication _ = 80 | Left "FromPlate Expression: application is not a sequence" 81 | 82 | lkup :: Text -> HashMap Text Plate -> Either Text Plate 83 | lkup t hm = 84 | maybeToRight ("FromPlate Expression: not found: " <> t) (HM.lookup t hm) 85 | 86 | instance ToJSON Expression where 87 | toJSON = toJSON . toPlate 88 | 89 | instance FromJSON Expression where 90 | parseJSON = parseJSONPlate 91 | 92 | instance Arbitrary Expression where 93 | arbitrary = Builtin <$> arbitrary 94 | 95 | instance ToPlate Schema where 96 | toPlate a = 97 | case a of 98 | SumType hm -> f (PPrimitive (toPlate <$> hm)) 99 | ProductType hm -> f (PPrimitive (toPlate <$> hm)) 100 | SInteger -> f (PPrimitive mempty) 101 | SSet exp -> f (toPlate exp) 102 | SDictionary exp1 exp2 -> f (PPrimitive (HM.fromList 103 | [ ("keys", toPlate exp1) 104 | , ("values", toPlate exp2) 105 | ])) 106 | SSequence exp -> f (toPlate exp) 107 | SString -> f (PPrimitive mempty) 108 | SPrimitive exp -> f (toPlate exp) 109 | where 110 | f :: Plate -> Plate 111 | f = PPrimitive . HM.singleton ("schema." <> textFromSchema a) 112 | 113 | instance FromPlate Schema where 114 | fromPlate plate = 115 | case plate of 116 | (PPrimitive hm) -> 117 | case HM.toList hm of 118 | -- New value constructors share the same namespace as the builtin 119 | -- value constructors like @dictionary@, @set@, etc, so to 120 | -- avoid conflicts we preface everything with @schema.@. 121 | [("schema.sum", a)] -> parseSumType a 122 | [("schema.product", a)] -> parseProductType a 123 | [("schema.integer", a)] -> parseSInteger a 124 | [("schema.set", a)] -> SSet <$> fromPlate a 125 | [("schema.dictionary", a)] -> parseSDictionary a 126 | [("schema.sequence", a)] -> SSequence <$> fromPlate a 127 | [("schema.string", a)] -> parseSString a 128 | [("schema.primitive", a)] -> SPrimitive <$> fromPlate a 129 | _ -> Left "FromPlate Schema: No value constructor match" 130 | _ -> Left "FromPlate Schema: Not a PPrimitive" 131 | where 132 | parseSumType (PPrimitive hm) = SumType <$> traverse fromPlate hm 133 | parseSumType _ = Left "FromPlate Schema: sum type not PPrimitive" 134 | 135 | parseProductType (PPrimitive hm) = ProductType <$> traverse fromPlate hm 136 | parseProductType _ = Left "FromPlate Schema: product type not PPrimitive" 137 | 138 | parseSDictionary (PPrimitive hm) = 139 | SDictionary 140 | <$> (fromPlate =<< lkup "keys" hm) 141 | <*> (fromPlate =<< lkup "values" hm) 142 | parseSDictionary _ = 143 | Left "FromPlate Schema: SDictionary description not a sequence" 144 | 145 | lkup :: Text -> HashMap Text Plate -> Either Text Plate 146 | lkup t hm = 147 | maybeToRight ("FromPlate Schema: not found: " <> t) (HM.lookup t hm) 148 | 149 | parseSInteger (PPrimitive hm) 150 | | null hm = pure SInteger 151 | | otherwise = fail "SInteger contents must be empty" 152 | parseSInteger _ = 153 | Left "FromPlate Schema: SInteger contents not PPrimitive" 154 | 155 | parseSString (PPrimitive hm) 156 | | null hm = pure SString 157 | | otherwise = fail "SString contents must be empty" 158 | parseSString _ = 159 | Left "FromPlate Schema: SString contents not PPrimitive" 160 | 161 | instance ToJSON Schema where 162 | toJSON = toJSON . toPlate 163 | 164 | instance FromJSON Schema where 165 | parseJSON = parseJSONPlate 166 | 167 | instance Arbitrary Schema where 168 | arbitrary = sized f 169 | where 170 | f :: Int -> Gen Schema 171 | f 0 = pure SInteger 172 | f n = do 173 | (Positive m) <- arbitrary 174 | let n' = n `div` (m + 1) 175 | oneof 176 | [ SumType . HM.fromList . fmap (first T.pack) 177 | <$> resize n' arbitrary 178 | , ProductType . HM.fromList . fmap (first T.pack) 179 | <$> resize n' arbitrary 180 | , pure SInteger 181 | , SSet 182 | <$> resize n' arbitrary 183 | , SDictionary 184 | <$> resize n' arbitrary <*> resize n' arbitrary 185 | , SSequence 186 | <$> resize n' arbitrary 187 | , pure SString 188 | , SPrimitive 189 | <$> resize n' arbitrary 190 | ] 191 | 192 | mapSchema :: (Expression -> Expression) -> Schema -> Schema 193 | mapSchema f s = 194 | case s of 195 | SumType hm -> SumType (f <$> hm) 196 | ProductType hm -> SumType (f <$> hm) 197 | SInteger -> s 198 | SSet exp -> SSet (f exp) 199 | SDictionary exp1 exp2 -> SDictionary (f exp1) (f exp2) 200 | SSequence exp -> SSequence (f exp) 201 | SString -> s 202 | SPrimitive exp -> SPrimitive (f exp) 203 | 204 | parseJSONPlate :: FromPlate a => Value -> Parser a 205 | parseJSONPlate a = do 206 | plate <- parseJSON a 207 | case fromPlate plate of 208 | Right exp -> pure exp 209 | Left e -> fail (T.unpack e) 210 | 211 | textFromSchema :: Schema -> Text 212 | textFromSchema p = 213 | case p of 214 | SumType _ -> "sum" 215 | ProductType _ -> "product" 216 | SInteger -> "integer" 217 | SSet _ -> "set" 218 | SDictionary _ _ -> "dictionary" 219 | SSequence _ -> "sequence" 220 | SString -> "string" 221 | SPrimitive _ -> "primitive" 222 | -------------------------------------------------------------------------------- /src/Plate/Validation.hs: -------------------------------------------------------------------------------- 1 | module Plate.Validation where 2 | 3 | import Plate.Prelude hiding (evaluate, exp, replace) 4 | import Plate.Schema 5 | import Plate.Value 6 | 7 | import qualified Data.HashMap.Strict as HM 8 | 9 | data Invalid 10 | = VariableNotFound Text 11 | | AbstractionUnapplied Text Expression 12 | | NonAbstractionApplied Expression Expression 13 | | SumTypeSizeNotOne (HashMap Text Expression) (HashMap Text Plate) 14 | | SumTypeNoMatch (HashMap Text Expression) (HashMap Text Plate) 15 | | MissingFields (HashMap Text Expression) (HashMap Text Plate) 16 | | BuiltinMismatch Schema Plate 17 | deriving (Eq, Show) 18 | 19 | validate :: HashMap Text Expression -> Expression -> Plate -> Either Invalid () 20 | validate bound expression plate = 21 | case expression of 22 | Variable t -> case evaluateVariable bound t of 23 | Nothing -> Left (VariableNotFound t) 24 | Just exp -> validate bound exp plate 25 | Abstraction t exp -> Left (AbstractionUnapplied t exp) 26 | Application exp1 exp2 -> 27 | case exp1 of 28 | Abstraction t abstractedExp -> validate (addBinding bound t exp2) 29 | abstractedExp plate 30 | _ -> Left (NonAbstractionApplied exp1 exp2) 31 | Builtin schema -> validateBuiltin bound schema plate 32 | 33 | -- | Internal. Used by 'validate'. 34 | addBinding 35 | :: HashMap Text Expression 36 | -> Text 37 | -> Expression 38 | -> HashMap Text Expression 39 | addBinding hm t exp = HM.insert t exp hm 40 | 41 | -- | Internal. Used by 'validate'. 42 | evaluateVariable 43 | :: HashMap Text Expression 44 | -> Text 45 | -> Maybe Expression 46 | evaluateVariable hm t = HM.lookup t hm 47 | 48 | -- | Internal. Used by 'validate'. 49 | validateBuiltin 50 | :: HashMap Text Expression 51 | -> Schema 52 | -> Plate 53 | -> Either Invalid () 54 | validateBuiltin bound schema plate = 55 | case (schema, plate) of 56 | (SumType st, PPrimitive hm) -> do 57 | when (HM.size hm /= 1) (Left (SumTypeSizeNotOne st hm)) 58 | case HM.elems (HM.intersectionWith (,) st hm) of 59 | [(exp, p2)] -> validate bound exp p2 60 | _ -> Left (SumTypeNoMatch st hm) 61 | (ProductType pt, PPrimitive hm) -> do 62 | let b = HM.intersectionWith (,) pt hm 63 | when (HM.size b < HM.size pt) (Left (MissingFields pt hm)) 64 | traverse_ 65 | (\(exp, p2) -> validate bound exp p2) 66 | (HM.elems b) 67 | (SPrimitive exp, PPrimitive hm) -> traverse_ (validate bound exp) hm 68 | (SInteger, PInteger _) -> pure () 69 | (SSet exp, PSet xs) -> traverse_ (validate bound exp) xs 70 | (SDictionary exp1 exp2, PDictionary hm) -> 71 | traverse_ 72 | (\(k, p2) -> validate bound exp1 k *> validate bound exp2 p2) 73 | (HM.toList hm) 74 | (SSequence exp, PSequence xs) -> traverse_ (validate bound exp) xs 75 | (SString, PString _) -> pure () 76 | _ -> Left (BuiltinMismatch schema plate) 77 | 78 | -- | 'Left' means an expression was applied to a non-abstraction. 79 | -- 80 | -- Not actually used in this library, just exposed in case other code needs it. 81 | whnf :: Expression -> Either (Expression, Expression) Expression 82 | whnf expression = 83 | case expression of 84 | Application exp1 exp2 -> handleApplication exp1 exp2 85 | _ -> Right expression 86 | where 87 | handleApplication 88 | :: Expression 89 | -> Expression 90 | -> Either (Expression, Expression) Expression 91 | handleApplication exp1 exp2 = 92 | case exp1 of 93 | Abstraction t abstractedExp -> whnf (replace t exp2 abstractedExp) 94 | Application e1 e2 -> (\a -> handleApplication a exp2) 95 | =<< handleApplication e1 e2 96 | _ -> Left (exp1, exp2) 97 | 98 | -- PERFORMANCE: Not efficient to replace variables one-by-one like this. 99 | replace :: Text -> Expression -> Expression -> Expression 100 | replace t bound target = 101 | case target of 102 | Variable v -> if t == v 103 | then bound 104 | else target 105 | Abstraction param abstractedExp -> 106 | if t == param 107 | then target 108 | else Abstraction param (replace t bound abstractedExp) 109 | Application e1 e2 -> Application (replace t bound e1) 110 | (replace t bound e2) 111 | Builtin schema -> Builtin (mapSchema (replace t bound) schema) 112 | -------------------------------------------------------------------------------- /src/Plate/Value.hs: -------------------------------------------------------------------------------- 1 | module Plate.Value where 2 | 3 | import Control.Monad (fail) 4 | import Data.Aeson 5 | import Data.Aeson.Types (Parser) 6 | import Data.HashSet (HashSet) 7 | import Plate.Prelude hiding (evaluate, exp) 8 | import Test.QuickCheck 9 | 10 | import qualified Data.HashMap.Strict as HM 11 | import qualified Data.HashSet as HashSet 12 | import qualified Data.Text as T 13 | import qualified Data.Vector as V 14 | 15 | class ToPlate a where 16 | toPlate :: a -> Plate 17 | 18 | class FromPlate a where 19 | fromPlate :: Plate -> Either Text a 20 | 21 | data Plate 22 | = PPrimitive (HashMap Text Plate) 23 | | PInteger Int 24 | | PSet (HashSet Plate) 25 | | PDictionary (HashMap Plate Plate) 26 | | PSequence (Vector Plate) 27 | | PString Text 28 | deriving (Eq, Show) 29 | 30 | instance ToPlate Plate where 31 | toPlate = identity 32 | 33 | instance FromPlate Plate where 34 | fromPlate = pure . identity 35 | 36 | instance ToJSON Plate where 37 | toJSON (PPrimitive hm) = 38 | case HM.toList hm of 39 | [("bool", PString "true")] -> Bool True 40 | [("bool", PString "false")] -> Bool False 41 | [("nothing", PDictionary x)] -> if HM.null x 42 | then Null 43 | else Object (toJSON <$> hm) 44 | _ -> Object (toJSON <$> hm) 45 | 46 | toJSON (PInteger n) = Number (fromInteger (toInteger n)) 47 | 48 | -- NOTE: Nondeterministic. 49 | toJSON (PSet xs) = object [ "set" .= toJSON xs ] 50 | 51 | -- NOTE: Nondeterministic. 52 | toJSON (PDictionary hm) = object [ "dictionary" .= HM.toList hm ] 53 | 54 | toJSON (PSequence xs) = object [ "sequence" .= xs ] 55 | 56 | toJSON (PString t) = String t 57 | 58 | instance FromJSON Plate where 59 | parseJSON v = 60 | case v of 61 | Null -> 62 | pure (PDictionary (HM.singleton (PString "nothing") 63 | (PDictionary mempty))) 64 | Bool b -> 65 | pure (PDictionary (HM.singleton (PString "bool") 66 | (if b 67 | then PString "true" 68 | else PString "false"))) 69 | String t -> pure (PString t) 70 | Number _ -> PInteger <$> parseJSON v 71 | Array _ -> 72 | fail "Arrays outside of a set/dictionary/etc tag aren't allowed" 73 | Object hm -> 74 | case HM.toList hm of 75 | [("set", b)] -> PSet <$> parseJSON b 76 | [("dictionary", b)] -> PDictionary <$> dictionaryFromArray b 77 | [("sequence", b)] -> PSequence <$> parseJSON b 78 | _ -> PPrimitive <$> parseJSON v 79 | 80 | -- | PERFORMANCE: This is just used until I get around to making 81 | -- a 'FromJSONKey' instance for plate. 82 | dictionaryFromArray :: Value -> Parser (HashMap Plate Plate) 83 | dictionaryFromArray = 84 | withArray "Array-encoded dictionary" 85 | $ fmap HM.fromList . parseJSON . Array 86 | 87 | instance Hashable Plate where 88 | hashWithSalt salt a = 89 | case a of 90 | PPrimitive b -> hashWithSalt salt b 91 | PInteger b -> hashWithSalt salt b 92 | PSet b -> hashWithSalt salt b 93 | PDictionary b -> hashWithSalt salt b 94 | PSequence b -> hashWithSalt salt (V.toList b) 95 | PString b -> hashWithSalt salt b 96 | 97 | instance Arbitrary Plate where 98 | arbitrary = sized arbPlate 99 | where 100 | arbPlate :: Int -> Gen Plate 101 | arbPlate 0 = PInteger <$> arbitrary 102 | arbPlate n = do 103 | (Positive m) <- arbitrary 104 | let n' = n `div` (m + 1) 105 | oneof 106 | [ PPrimitive . HM.fromList . fmap (first T.pack) 107 | <$> resize n' arbitrary 108 | , PInteger <$> arbitrary 109 | , PSet . HashSet.fromList <$> resize n' arbitrary 110 | , PDictionary . HM.fromList <$> resize n' arbitrary 111 | , PSequence . V.fromList <$> resize n' arbitrary 112 | , PString . T.pack <$> arbitrary 113 | ] 114 | 115 | -------------------------------------------------- 116 | -- General instances 117 | -------------------------------------------------- 118 | 119 | instance ToPlate Text where 120 | toPlate = PString 121 | 122 | instance FromPlate Text where 123 | fromPlate (PString t) = Right t 124 | fromPlate _ = Left "FromPlate Text: not a PString" 125 | -------------------------------------------------------------------------------- /src/PlateExamples.hs: -------------------------------------------------------------------------------- 1 | -- | The first Plate library. 2 | module PlateExamples where 3 | 4 | import Plate 5 | import Plate.Prelude hiding (bool, either, maybe, sequence) 6 | 7 | import qualified Data.HashMap.Strict as HM 8 | 9 | unit :: Expression 10 | unit = Builtin (ProductType mempty) 11 | 12 | string :: Schema 13 | string = 14 | SumType (HM.singleton "string" (Builtin (SSequence (Builtin SInteger)))) 15 | 16 | bool :: Schema 17 | bool = 18 | SumType (HM.fromList 19 | [ ("true", unit) 20 | , ("false", unit) 21 | ]) 22 | 23 | maybe :: Expression 24 | maybe = 25 | Abstraction "a" 26 | $ Builtin (SumType (HM.fromList 27 | [ ("just", Variable "a") 28 | , ("nothing", unit) 29 | ])) 30 | 31 | either :: Expression 32 | either = 33 | Abstraction "a" 34 | $ Abstraction "b" 35 | $ Builtin (SumType (HM.fromList 36 | [ ("left", Variable "a") 37 | , ("right", Variable "b") 38 | ])) 39 | 40 | sequence :: Expression 41 | sequence = 42 | Abstraction "a" 43 | $ Builtin (SumType (HM.fromList 44 | [ ("nil", unit) 45 | , ("cons", Variable "b") 46 | ])) 47 | 48 | dictionary :: Expression 49 | dictionary = 50 | Abstraction "k" 51 | $ Abstraction "v" 52 | $ Application (Variable sequenceRef) tup 53 | where 54 | tup :: Expression 55 | tup = 56 | Application 57 | (Application (Variable tuple2Ref) (Variable "k")) 58 | (Variable "v") 59 | 60 | tuple2 :: Expression 61 | tuple2 = 62 | Abstraction "a" 63 | $ Abstraction "b" 64 | $ Builtin (ProductType (HM.fromList 65 | [ ("1", Variable "a") 66 | , ("2", Variable "b") 67 | ])) 68 | 69 | expression :: Schema 70 | expression = 71 | SumType (HM.fromList 72 | [ ("variable", Builtin SString) 73 | , ("abstraction", 74 | Builtin (ProductType (HM.fromList 75 | [ ("parameter", Builtin SString) 76 | , ("body", Variable expressionRef) 77 | ]))) 78 | , ("application", 79 | Builtin (ProductType (HM.fromList 80 | [ ("function", Variable expressionRef) 81 | , ("argument", Variable expressionRef) 82 | ]))) 83 | , ("type", Variable schemaRef) 84 | ]) 85 | 86 | schema :: Schema 87 | schema = 88 | SumType (HM.fromList 89 | [ ("schema.sum", sumOrProduct) 90 | , ("schema.product", sumOrProduct) 91 | , ("schema.integer", Builtin (ProductType mempty)) 92 | , ("schema.set", Variable expressionRef) 93 | , ("schema.dictionary", 94 | Builtin (ProductType (HM.fromList 95 | [ ("keys", Variable expressionRef) 96 | , ("values", Variable expressionRef) 97 | ]))) 98 | , ("schema.sequence", Variable expressionRef) 99 | , ("schema.string", Builtin (ProductType mempty)) 100 | , ("schema.primitive", Variable expressionRef) 101 | ]) 102 | where 103 | sumOrProduct :: Expression 104 | sumOrProduct = Builtin (SPrimitive (Variable expressionRef)) 105 | 106 | exampleLibrary :: [(Text, Expression)] 107 | exampleLibrary = 108 | [ (stringRef , Builtin string) 109 | , (boolRef , Builtin bool) 110 | , (maybeRef , maybe) 111 | , (eitherRef , either) 112 | , (sequenceRef , sequence) 113 | , (dictionaryRef, dictionary) 114 | , (tuple2Ref , tuple2) 115 | , (expressionRef, Builtin expression) 116 | , (schemaRef , Builtin schema) 117 | ] 118 | 119 | stringRef :: Text 120 | stringRef = "string" 121 | 122 | boolRef :: Text 123 | boolRef = "bool" 124 | 125 | maybeRef :: Text 126 | maybeRef = "maybe" 127 | 128 | eitherRef :: Text 129 | eitherRef = "either" 130 | 131 | sequenceRef :: Text 132 | sequenceRef = "sequence" 133 | 134 | dictionaryRef :: Text 135 | dictionaryRef = "dictionary" 136 | 137 | tuple2Ref :: Text 138 | tuple2Ref = "tuple2" 139 | 140 | expressionRef :: Text 141 | expressionRef = "expression" 142 | 143 | schemaRef :: Text 144 | schemaRef = "schema" 145 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.18 2 | extra-deps: 3 | - aeson-1.4.6.0 # Important enough to lock down 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: aeson-1.4.6.0@sha256:560575b008a23960403a128331f0e59594786b5cd19a35be0cd74b9a7257958e,6980 9 | pantry-tree: 10 | size: 40193 11 | sha256: 5769473440ae594ae8679dde9fe12b6d00a49264a9dd8962a53ff3ae5740d7a5 12 | original: 13 | hackage: aeson-1.4.6.0 14 | snapshots: 15 | - completed: 16 | size: 524789 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/18.yaml 18 | sha256: 646be71223e08234131c6989912e6011e01b9767bc447b6d466a35e14360bdf2 19 | original: lts-14.18 20 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Aeson 4 | import Plate 5 | import Test.Prelude hiding (evaluate, exp) 6 | import Test.Tasty 7 | import Test.Tasty.HUnit hiding (assert) 8 | import Test.Tasty.QuickCheck 9 | import Test.Validation 10 | 11 | -- Just make sure it compiles: 12 | import Test.SimplePlate () 13 | 14 | import qualified Data.Aeson as Aeson 15 | import qualified Data.ByteString as BS 16 | import qualified Data.HashMap.Strict as HM 17 | import qualified Data.Text as T 18 | import qualified Data.Vector as V 19 | import qualified PlateExamples as PE 20 | import qualified Test.ReadmeExamples as ReadmeExamples 21 | 22 | main :: IO () 23 | main = do 24 | writeLibraryExamples 25 | ReadmeExamples.write 26 | writeTests "./test/generated/concrete.json" concreteTests 27 | writeTests "./test/generated/expressions.json" expressionTests 28 | defaultMain $ testGroup "Plate" 29 | [ testGroup "Plate representations" plateTests 30 | , testGroup "JSON representations" jsonTests 31 | , testGroup "Concrete" (treeFromCase <$> concreteTests) 32 | , testGroup "Expressions" (treeFromCase <$> expressionTests) 33 | , testGroup "The schema for schemas" (pure testSchema) 34 | ] 35 | 36 | plateTests :: [TestTree] 37 | plateTests = 38 | [ testProperty "Plate/Plate isomorphism" 39 | (isomorphicPlate :: Plate -> Bool) 40 | , testProperty "Schema/Plate isomorphism" 41 | (isomorphicPlate :: Schema -> Bool) 42 | , testProperty "Expression/Plate isomorphism" 43 | (isomorphicPlate :: Expression -> Bool) 44 | ] 45 | 46 | jsonTests :: [TestTree] 47 | jsonTests = 48 | [ testProperty "Plate/JSON isomorphism" 49 | (isomorphicJSON :: Plate -> Bool) 50 | , testProperty "Schema/JSON isomorphism" 51 | (isomorphicJSON :: Schema -> Bool) 52 | , testProperty "Expression/JSON isomorphism" 53 | (isomorphicJSON :: Expression -> Bool) 54 | , testCase "Special case for bool" 55 | (toJSON (PPrimitive (HM.singleton "bool" (PString "true"))) 56 | @?= Bool True) 57 | , testCase "Special case for maybe" 58 | (toJSON (PPrimitive (HM.singleton "nothing" (PDictionary mempty))) 59 | @?= Null) 60 | , testCase "Special case for dictionaries" 61 | (toJSON (PDictionary (HM.singleton (PInteger 1) (PString "foo"))) 62 | @?= Object (HM.singleton "dictionary" 63 | (Array (V.fromList 64 | [ Array (V.fromList [ Number 1 65 | , String "foo" 66 | ]) 67 | ])))) 68 | ] 69 | 70 | isomorphicPlate :: (Eq a, ToPlate a, FromPlate a) => a -> Bool 71 | isomorphicPlate a = fromPlate (toPlate a) == Right a 72 | 73 | isomorphicJSON :: (Eq a, ToJSON a, FromJSON a) => a -> Bool 74 | isomorphicJSON a = fromJSON (toJSON a) == Aeson.Success a 75 | 76 | treeFromCase :: TestCase Expression -> TestTree 77 | treeFromCase a = 78 | testGroup (show (_tgType a)) 79 | [ testCase 80 | "Valid assertions" 81 | (traverse_ (validCase (_tgType a)) (_tgValid a)) 82 | , testCase 83 | "Invalid assertions" 84 | (traverse_ (invalidCase (_tgType a)) (_tgInvalid a)) 85 | ] 86 | 87 | validCase :: Expression -> Value -> Assertion 88 | validCase a b = do 89 | let Aeson.Success plate = fromJSON b 90 | validate mempty a plate @?= Right () 91 | 92 | invalidCase :: Expression -> Value -> Assertion 93 | invalidCase a b = do 94 | let Aeson.Success plate = fromJSON b 95 | case validate mempty a plate of 96 | Left _ -> pure () 97 | Right () -> assertFailure "An invalid value slipped through" 98 | 99 | testSchema :: TestTree 100 | testSchema = 101 | testProperty "Validates generated expressions" f 102 | where 103 | f :: Expression -> Bool 104 | f exp = validate (HM.fromList PE.exampleLibrary) 105 | (Builtin PE.expression) 106 | (toPlate exp) == Right () 107 | 108 | writeLibraryExamples :: IO () 109 | writeLibraryExamples = 110 | BS.writeFile "./test/generated/examples.json" (encodePretty examples <> "\n") 111 | where 112 | examples :: [(Text, Value)] 113 | examples = fmap toJSON <$> PE.exampleLibrary 114 | 115 | writeTests :: Text -> [TestCase Expression] -> IO () 116 | writeTests name tests = 117 | BS.writeFile (T.unpack name) (encodePretty (toJSON <$> tests) <> "\n") 118 | -------------------------------------------------------------------------------- /test/Test/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Test.Prelude 2 | ( module Export 3 | , encodePretty 4 | ) where 5 | 6 | import Data.Aeson 7 | import Data.Aeson.Encode.Pretty hiding (encodePretty) 8 | import Data.HashMap.Strict as Export (HashMap) 9 | import Data.Vector as Export (Vector) 10 | import Protolude as Export 11 | 12 | import qualified Data.ByteString.Lazy as LBS 13 | 14 | encodePretty :: ToJSON a => a -> ByteString 15 | encodePretty = LBS.toStrict . encodePretty' defConfig { confIndent = Spaces 2 } 16 | -------------------------------------------------------------------------------- /test/Test/ReadmeExamples.hs: -------------------------------------------------------------------------------- 1 | module Test.ReadmeExamples where 2 | 3 | import Plate 4 | import Test.Prelude 5 | 6 | import qualified Data.ByteString as BS 7 | import qualified Data.HashMap.Strict as HM 8 | import qualified Data.Vector as V 9 | 10 | write :: IO () 11 | write = do 12 | BS.writeFile 13 | "test/generated/readme-schema.json" 14 | (encodePretty album) 15 | BS.writeFile 16 | "test/generated/readme-instance.json" 17 | (encodePretty interstellarSoundtrack) 18 | case validate mempty (Builtin album) interstellarSoundtrack of 19 | Left e -> panic (show e) 20 | Right _ -> pure () 21 | 22 | data Album = Album 23 | { title :: Text 24 | , artist :: Text 25 | , tracks :: [Text] 26 | } 27 | 28 | album :: Schema 29 | album = ProductType (HM.fromList 30 | [ ("title", Builtin SString) 31 | , ("artist", Builtin SString) 32 | , ("tracks", Builtin (SSequence (Builtin SString))) 33 | ]) 34 | 35 | interstellarSoundtrack :: Plate 36 | interstellarSoundtrack = PPrimitive (HM.fromList 37 | [ ("title", PString "Interstellar: Original Motion Picture Soundtrack") 38 | , ("artist", PString "Hans Zimmer") 39 | , ("tracks", PSequence (V.fromList 40 | [ PString "Dreaming of the Crash" 41 | , PString "Cornfield Chase" 42 | , PString "Dust" 43 | , PString "Day One" 44 | , PString "Stay" 45 | , PString "Message from Home" 46 | , PString "The Wormhole" 47 | , PString "Mountains" 48 | , PString "Afraid of Time" 49 | , PString "A Place Among the Stars" 50 | , PString "Running Out" 51 | , PString "I'm Going Home" 52 | , PString "Coward" 53 | , PString "Detach" 54 | , PString "S.T.A.Y." 55 | , PString "Where We're Going" 56 | ])) 57 | ]) 58 | -------------------------------------------------------------------------------- /test/Test/SimplePlate.hs: -------------------------------------------------------------------------------- 1 | -- | A minimal description of Plate. 2 | -- 3 | -- For a production implementation see the 'Plate' module. 4 | module Test.SimplePlate where 5 | 6 | import Protolude hiding (exp) 7 | 8 | -------------------------------------------------- 9 | -- * Plate Abstract Data Types 10 | -------------------------------------------------- 11 | 12 | data Plate 13 | = PDictionary (Map Plate Plate) 14 | | PSequence [Plate] 15 | | PInteger Integer 16 | deriving (Eq, Ord, Show) 17 | 18 | type PString = [Integer] 19 | 20 | -------------------------------------------------- 21 | -- * Plate Schemas 22 | -------------------------------------------------- 23 | 24 | data Expression 25 | = Variable Text 26 | | Abstraction Text Expression 27 | | Application Expression Expression 28 | | Builtin Schema 29 | deriving (Eq, Ord, Show) 30 | 31 | data Schema 32 | = SumType (Map Text Expression) 33 | | ProductType (Map Text Expression) 34 | | SDictionary Expression Expression 35 | | SSequence Expression 36 | | SInteger 37 | deriving (Eq, Ord, Show) 38 | -------------------------------------------------------------------------------- /test/Test/Validation.hs: -------------------------------------------------------------------------------- 1 | module Test.Validation where 2 | 3 | import Data.Aeson 4 | import Plate 5 | import Protolude 6 | 7 | import qualified Data.HashMap.Strict as HM 8 | 9 | data TestCase a = TestCase 10 | { _tgType :: a 11 | , _tgValid :: [Value] 12 | , _tgInvalid :: [Value] 13 | } deriving (Eq, Show, Functor) 14 | 15 | instance ToJSON a => ToJSON (TestCase a) where 16 | toJSON a = object 17 | [ "type" .= _tgType a 18 | , "valid" .= _tgValid a 19 | , "invalid" .= _tgInvalid a 20 | ] 21 | 22 | instance FromJSON a => FromJSON (TestCase a) where 23 | parseJSON = withObject "TestCase" $ \o -> TestCase 24 | <$> o .: "type" 25 | <*> o .: "valid" 26 | <*> o .: "invalid" 27 | 28 | concreteTests :: [TestCase Expression] 29 | concreteTests = 30 | [ Builtin <$> basicTest 31 | , Builtin <$> productTest 32 | , Builtin <$> productWithMultipleTest 33 | , Builtin <$> nestedProductTest 34 | ] 35 | 36 | expressionTests :: [TestCase Expression] 37 | expressionTests = 38 | [ applicationTest 39 | , recursiveTest 40 | ] 41 | 42 | basicTest :: TestCase Schema 43 | basicTest = TestCase 44 | { _tgType = SInteger 45 | , _tgValid = [Number (-1), Number 0, Number 1, Number 2] 46 | , _tgInvalid = [Bool True, String "foo"] 47 | } 48 | 49 | productTest :: TestCase Schema 50 | productTest = TestCase 51 | { _tgType = ProductType (HM.fromList 52 | [ ("foo", Builtin SInteger) 53 | ]) 54 | , _tgValid = 55 | [ object [ "foo" .= Number 123 ] 56 | , object [ "foo" .= Number 123, "bar" .= String "baz" ] 57 | ] 58 | , _tgInvalid = 59 | [ Bool True 60 | , object [ "foo" .= Null ] 61 | , object [ "foo" .= String "bar" ] 62 | , Object mempty 63 | ] 64 | } 65 | 66 | productWithMultipleTest :: TestCase Schema 67 | productWithMultipleTest = TestCase 68 | { _tgType = ProductType (HM.fromList 69 | [ ("foo", Builtin SInteger) 70 | , ("bar", Builtin SInteger) 71 | ]) 72 | , _tgValid = 73 | [ object [ "foo" .= Number 123, "bar" .= Number 123 ] 74 | ] 75 | , _tgInvalid = 76 | [ object [ "foo" .= Number 123 ] 77 | , object [ "foo" .= Number 123, "bar" .= String "baz" ] 78 | ] 79 | } 80 | 81 | nestedProductTest :: TestCase Schema 82 | nestedProductTest = TestCase 83 | { _tgType = ProductType (HM.fromList 84 | [ ("foo", Builtin (ProductType (HM.fromList 85 | [ ("bar", Builtin SInteger) 86 | ])) 87 | ) 88 | ]) 89 | , _tgValid = 90 | [ object [ "foo" .= object [ "bar" .= Number 123 ] ] 91 | ] 92 | , _tgInvalid = 93 | [ object [ "foo" .= Number 123 ] 94 | , object [ "foo" .= object [ "bar" .= String "baz" ] ] 95 | ] 96 | } 97 | 98 | -------------------------------------------------- 99 | -- Expression tests 100 | -------------------------------------------------- 101 | 102 | applicationTest :: TestCase Expression 103 | applicationTest = TestCase 104 | { _tgType = Application 105 | (Abstraction "a" (Variable "a")) 106 | (Builtin SInteger) 107 | , _tgValid = [Number 123] 108 | , _tgInvalid = [Bool True, String "abc"] 109 | } 110 | 111 | recursiveTest :: TestCase Expression 112 | recursiveTest = TestCase 113 | { _tgType = Application 114 | (Abstraction "list" (Variable "list")) 115 | (Application 116 | (Abstraction "a" (Builtin (SumType (HM.fromList 117 | [ ("nil", Builtin (ProductType mempty)) 118 | , ("cons", Builtin (ProductType (HM.fromList 119 | [ ("1", Variable "a") 120 | , ("2", Variable "list") 121 | ]))) 122 | ])))) 123 | (Builtin SInteger)) 124 | , _tgValid = 125 | [ object [ "nil" .= Object mempty ] 126 | , object [ "cons" .= object [ "1" .= Number 123 127 | , "2" .= object [ "nil" .= Object mempty ] ] 128 | ] 129 | ] 130 | , _tgInvalid = [Bool True] 131 | } 132 | -------------------------------------------------------------------------------- /test/generated/concrete.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "invalid": [ 4 | true, 5 | "foo" 6 | ], 7 | "type": { 8 | "type": { 9 | "schema.integer": {} 10 | } 11 | }, 12 | "valid": [ 13 | -1, 14 | 0, 15 | 1, 16 | 2 17 | ] 18 | }, 19 | { 20 | "invalid": [ 21 | true, 22 | { 23 | "foo": null 24 | }, 25 | { 26 | "foo": "bar" 27 | }, 28 | {} 29 | ], 30 | "type": { 31 | "type": { 32 | "schema.product": { 33 | "foo": { 34 | "type": { 35 | "schema.integer": {} 36 | } 37 | } 38 | } 39 | } 40 | }, 41 | "valid": [ 42 | { 43 | "foo": 123 44 | }, 45 | { 46 | "foo": 123, 47 | "bar": "baz" 48 | } 49 | ] 50 | }, 51 | { 52 | "invalid": [ 53 | { 54 | "foo": 123 55 | }, 56 | { 57 | "foo": 123, 58 | "bar": "baz" 59 | } 60 | ], 61 | "type": { 62 | "type": { 63 | "schema.product": { 64 | "foo": { 65 | "type": { 66 | "schema.integer": {} 67 | } 68 | }, 69 | "bar": { 70 | "type": { 71 | "schema.integer": {} 72 | } 73 | } 74 | } 75 | } 76 | }, 77 | "valid": [ 78 | { 79 | "foo": 123, 80 | "bar": 123 81 | } 82 | ] 83 | }, 84 | { 85 | "invalid": [ 86 | { 87 | "foo": 123 88 | }, 89 | { 90 | "foo": { 91 | "bar": "baz" 92 | } 93 | } 94 | ], 95 | "type": { 96 | "type": { 97 | "schema.product": { 98 | "foo": { 99 | "type": { 100 | "schema.product": { 101 | "bar": { 102 | "type": { 103 | "schema.integer": {} 104 | } 105 | } 106 | } 107 | } 108 | } 109 | } 110 | } 111 | }, 112 | "valid": [ 113 | { 114 | "foo": { 115 | "bar": 123 116 | } 117 | } 118 | ] 119 | } 120 | ] 121 | -------------------------------------------------------------------------------- /test/generated/examples.json: -------------------------------------------------------------------------------- 1 | [ 2 | [ 3 | "string", 4 | { 5 | "type": { 6 | "schema.sum": { 7 | "string": { 8 | "type": { 9 | "schema.sequence": { 10 | "type": { 11 | "schema.integer": {} 12 | } 13 | } 14 | } 15 | } 16 | } 17 | } 18 | } 19 | ], 20 | [ 21 | "bool", 22 | { 23 | "type": { 24 | "schema.sum": { 25 | "false": { 26 | "type": { 27 | "schema.product": {} 28 | } 29 | }, 30 | "true": { 31 | "type": { 32 | "schema.product": {} 33 | } 34 | } 35 | } 36 | } 37 | } 38 | ], 39 | [ 40 | "maybe", 41 | { 42 | "abstraction": { 43 | "body": { 44 | "type": { 45 | "schema.sum": { 46 | "just": { 47 | "variable": "a" 48 | }, 49 | "nothing": { 50 | "type": { 51 | "schema.product": {} 52 | } 53 | } 54 | } 55 | } 56 | }, 57 | "parameter": "a" 58 | } 59 | } 60 | ], 61 | [ 62 | "either", 63 | { 64 | "abstraction": { 65 | "body": { 66 | "abstraction": { 67 | "body": { 68 | "type": { 69 | "schema.sum": { 70 | "left": { 71 | "variable": "a" 72 | }, 73 | "right": { 74 | "variable": "b" 75 | } 76 | } 77 | } 78 | }, 79 | "parameter": "b" 80 | } 81 | }, 82 | "parameter": "a" 83 | } 84 | } 85 | ], 86 | [ 87 | "sequence", 88 | { 89 | "abstraction": { 90 | "body": { 91 | "type": { 92 | "schema.sum": { 93 | "nil": { 94 | "type": { 95 | "schema.product": {} 96 | } 97 | }, 98 | "cons": { 99 | "variable": "b" 100 | } 101 | } 102 | } 103 | }, 104 | "parameter": "a" 105 | } 106 | } 107 | ], 108 | [ 109 | "dictionary", 110 | { 111 | "abstraction": { 112 | "body": { 113 | "abstraction": { 114 | "body": { 115 | "application": { 116 | "function": { 117 | "variable": "sequence" 118 | }, 119 | "argument": { 120 | "application": { 121 | "function": { 122 | "application": { 123 | "function": { 124 | "variable": "tuple2" 125 | }, 126 | "argument": { 127 | "variable": "k" 128 | } 129 | } 130 | }, 131 | "argument": { 132 | "variable": "v" 133 | } 134 | } 135 | } 136 | } 137 | }, 138 | "parameter": "v" 139 | } 140 | }, 141 | "parameter": "k" 142 | } 143 | } 144 | ], 145 | [ 146 | "tuple2", 147 | { 148 | "abstraction": { 149 | "body": { 150 | "abstraction": { 151 | "body": { 152 | "type": { 153 | "schema.product": { 154 | "1": { 155 | "variable": "a" 156 | }, 157 | "2": { 158 | "variable": "b" 159 | } 160 | } 161 | } 162 | }, 163 | "parameter": "b" 164 | } 165 | }, 166 | "parameter": "a" 167 | } 168 | } 169 | ], 170 | [ 171 | "expression", 172 | { 173 | "type": { 174 | "schema.sum": { 175 | "application": { 176 | "type": { 177 | "schema.product": { 178 | "function": { 179 | "variable": "expression" 180 | }, 181 | "argument": { 182 | "variable": "expression" 183 | } 184 | } 185 | } 186 | }, 187 | "variable": { 188 | "type": { 189 | "schema.string": {} 190 | } 191 | }, 192 | "type": { 193 | "variable": "schema" 194 | }, 195 | "abstraction": { 196 | "type": { 197 | "schema.product": { 198 | "body": { 199 | "variable": "expression" 200 | }, 201 | "parameter": { 202 | "type": { 203 | "schema.string": {} 204 | } 205 | } 206 | } 207 | } 208 | } 209 | } 210 | } 211 | } 212 | ], 213 | [ 214 | "schema", 215 | { 216 | "type": { 217 | "schema.sum": { 218 | "schema.sum": { 219 | "type": { 220 | "schema.primitive": { 221 | "variable": "expression" 222 | } 223 | } 224 | }, 225 | "schema.product": { 226 | "type": { 227 | "schema.primitive": { 228 | "variable": "expression" 229 | } 230 | } 231 | }, 232 | "schema.string": { 233 | "type": { 234 | "schema.product": {} 235 | } 236 | }, 237 | "schema.dictionary": { 238 | "type": { 239 | "schema.product": { 240 | "values": { 241 | "variable": "expression" 242 | }, 243 | "keys": { 244 | "variable": "expression" 245 | } 246 | } 247 | } 248 | }, 249 | "schema.set": { 250 | "variable": "expression" 251 | }, 252 | "schema.sequence": { 253 | "variable": "expression" 254 | }, 255 | "schema.primitive": { 256 | "variable": "expression" 257 | }, 258 | "schema.integer": { 259 | "type": { 260 | "schema.product": {} 261 | } 262 | } 263 | } 264 | } 265 | } 266 | ] 267 | ] 268 | -------------------------------------------------------------------------------- /test/generated/expressions.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "invalid": [ 4 | true, 5 | "abc" 6 | ], 7 | "type": { 8 | "application": { 9 | "function": { 10 | "abstraction": { 11 | "body": { 12 | "variable": "a" 13 | }, 14 | "parameter": "a" 15 | } 16 | }, 17 | "argument": { 18 | "type": { 19 | "schema.integer": {} 20 | } 21 | } 22 | } 23 | }, 24 | "valid": [ 25 | 123 26 | ] 27 | }, 28 | { 29 | "invalid": [ 30 | true 31 | ], 32 | "type": { 33 | "application": { 34 | "function": { 35 | "abstraction": { 36 | "body": { 37 | "variable": "list" 38 | }, 39 | "parameter": "list" 40 | } 41 | }, 42 | "argument": { 43 | "application": { 44 | "function": { 45 | "abstraction": { 46 | "body": { 47 | "type": { 48 | "schema.sum": { 49 | "nil": { 50 | "type": { 51 | "schema.product": {} 52 | } 53 | }, 54 | "cons": { 55 | "type": { 56 | "schema.product": { 57 | "1": { 58 | "variable": "a" 59 | }, 60 | "2": { 61 | "variable": "list" 62 | } 63 | } 64 | } 65 | } 66 | } 67 | } 68 | }, 69 | "parameter": "a" 70 | } 71 | }, 72 | "argument": { 73 | "type": { 74 | "schema.integer": {} 75 | } 76 | } 77 | } 78 | } 79 | } 80 | }, 81 | "valid": [ 82 | { 83 | "nil": {} 84 | }, 85 | { 86 | "cons": { 87 | "1": 123, 88 | "2": { 89 | "nil": {} 90 | } 91 | } 92 | } 93 | ] 94 | } 95 | ] 96 | -------------------------------------------------------------------------------- /test/generated/readme-instance.json: -------------------------------------------------------------------------------- 1 | { 2 | "tracks": { 3 | "sequence": [ 4 | "Dreaming of the Crash", 5 | "Cornfield Chase", 6 | "Dust", 7 | "Day One", 8 | "Stay", 9 | "Message from Home", 10 | "The Wormhole", 11 | "Mountains", 12 | "Afraid of Time", 13 | "A Place Among the Stars", 14 | "Running Out", 15 | "I'm Going Home", 16 | "Coward", 17 | "Detach", 18 | "S.T.A.Y.", 19 | "Where We're Going" 20 | ] 21 | }, 22 | "title": "Interstellar: Original Motion Picture Soundtrack", 23 | "artist": "Hans Zimmer" 24 | } -------------------------------------------------------------------------------- /test/generated/readme-schema.json: -------------------------------------------------------------------------------- 1 | { 2 | "schema.product": { 3 | "tracks": { 4 | "type": { 5 | "schema.sequence": { 6 | "type": { 7 | "schema.string": {} 8 | } 9 | } 10 | } 11 | }, 12 | "title": { 13 | "type": { 14 | "schema.string": {} 15 | } 16 | }, 17 | "artist": { 18 | "type": { 19 | "schema.string": {} 20 | } 21 | } 22 | } 23 | } --------------------------------------------------------------------------------