├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── .mergify.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── hschema-aeson ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml ├── src │ └── Data │ │ └── Schema │ │ ├── JSON.hs │ │ └── JSON │ │ ├── Internal │ │ ├── Serializer.hs │ │ └── Types.hs │ │ └── Simple.hs └── test │ ├── Spec.hs │ ├── Test │ └── Schema │ │ ├── JSON.hs │ │ ├── Model.hs │ │ └── Utils.hs │ └── expected-model.json ├── hschema-prettyprinter ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml └── src │ └── Data │ └── Schema │ ├── PrettyPrint.hs │ └── PrettyPrint │ └── Internal │ ├── Algebra.hs │ └── Types.hs ├── hschema-quickcheck ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml └── src │ └── Test │ └── Schema │ ├── QuickCheck.hs │ └── QuickCheck │ └── Internal │ └── Gen.hs ├── hschema ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml └── src │ ├── Control │ └── Functor │ │ └── HigherOrder.hs │ └── Data │ ├── Schema.hs │ └── Schema │ └── Internal │ └── Types.hs ├── stack.yaml ├── stack.yaml.lock └── stylize.sh /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | 3 | name: build 4 | 5 | jobs: 6 | build: 7 | name: Build 8 | strategy: 9 | matrix: 10 | ghc: ['8.10'] 11 | stack: ['latest'] 12 | os: [ubuntu-latest, macOS-latest, windows-latest] 13 | runs-on: ${{ matrix.os }} 14 | steps: 15 | - uses: actions/checkout@v2 16 | 17 | - uses: haskell/actions/setup@v1 18 | name: Setup Haskell ${{ matrix.ghc }} with Stack ${{ matrix.stack }} 19 | with: 20 | ghc-version: ${{ matrix.ghc }} 21 | # cabal-version: 'latest'. Omitted, but defalts to 'latest' 22 | enable-stack: true 23 | stack-version: ${{ matrix.stack }} 24 | stack-setup-ghc: true 25 | 26 | - run: stack test 27 | name: Test -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.cabal 3 | *~ -------------------------------------------------------------------------------- /.mergify.yml: -------------------------------------------------------------------------------- 1 | pull_request_rules: 2 | - name: automatic merge when CI passes 3 | conditions: 4 | - status-success=continuous-integration/travis-ci/pr 5 | - base=master 6 | actions: 7 | merge: 8 | method: squash 9 | delete_head_branch: {} -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hexomorph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell Schema 2 | 3 | [![Build Status](https://travis-ci.org/alonsodomin/haskell-schema.svg?branch=master)](https://travis-ci.org/alonsodomin/haskell-schema) 4 | [![License: LGPL v3](https://img.shields.io/badge/License-LGPL%20v3-blue.svg)](https://www.gnu.org/licenses/lgpl-3.0) 5 | ![Hackage](https://img.shields.io/hackage/v/hschema.svg) 6 | 7 | 8 | Haskell Schema (or `hschema`) is a library with the purpose of describing data (or domains) and use that information to automatically 9 | derive serialization codecs (JSON, binary, etc.), arbitrary generators, pretty printers and much more. It is heavily inspired by 10 | the Scala library [xenomorph](https://github.com/nuttycom/xenomorph) (in fact, it is a port of the same ideas), which was introduced 11 | in the following talk at Scala World 2017: 12 | 13 | Describing Data...with free applicative functors (and more)—Kris Nuttycombe 15 | 16 | ## Motivation 17 | 18 | The idea behind it is that, given a domain model you want to work with, you can use this library to build a description of it (or _schema_) 19 | that is totally independent of the actual code representation of the given domain model. After that, you can leverage the mechanics 20 | behind this library to generate QuickCheck generators, JSON parsers, binary codecs, etc. 21 | 22 | ### Isn't that much work? What about deriving `Generic`? 23 | 24 | Deriving `Generic` from your data and deriving your encoders from there seems pretty reasonable, and it's usually very concise, isn't it? 25 | But there is a problem with that, usually the data that you are going to be serializing over the wire (that's why you need your JSON, 26 | binary, etc. codecs) forms part of your public protocol. That means that every time you modify one of those data items, you are in danger 27 | of breaking your compatibility. 28 | 29 | On top of that, what about supporting two versions of your protocol? That will get hairy quite quickly. By defining the schema separated 30 | from the actual data types, you can evolve your domain model without modifying the actual schema, add a new schema version and even 31 | define migrations between them. 32 | 33 | ## How to use it? 34 | 35 | Haskell Schema is distributed as a set of packages that together provide a cohesive set of features: 36 | 37 | * `hschema`: This is the core package, defining the base building pieces 38 | * `hschema-aeson`: This is a package that provides JSON encoding and decoding using Aeson. 39 | * `hschema-quickcheck`: This package will provide with QuickCheck generators based on our schema. 40 | * `hschema-prettyprinter`: This package brings pretty priting utilities. 41 | 42 | In the following example we are going to make use of all those packages. 43 | 44 | ### Example 45 | 46 | Let's start by defining a some data types alongside some lenses: 47 | 48 | ```haskell 49 | {-# LANGUAGE LambdaCase #-} 50 | {-# LANGUAGE OverloadedStrings #-} 51 | {-# LANGUAGE TypeFamilies #-} 52 | 53 | import Control.Lens 54 | import Data.Time (UTCTime) 55 | 56 | data Role = 57 | UserRole UserRole 58 | | AdminRole AdminRole 59 | deriving (Eq, Show) 60 | 61 | data UserRole = UserRole' 62 | deriving (Eq, Show) 63 | 64 | data AdminRole = AdminRole' { department :: String, subordinateCount :: Int } 65 | deriving (Eq, Show) 66 | 67 | _UserRole :: Prism' Role UserRole 68 | _UserRole = prism' UserRole $ \case 69 | UserRole x -> Just x 70 | _ -> Nothing 71 | 72 | _AdminRole :: Prism' Role AdminRole 73 | _AdminRole = prism' AdminRole $ \case 74 | AdminRole x -> Just x 75 | _ -> Nothing 76 | 77 | data Person = Person { personName :: String, birthDate :: Maybe UTCTime, roles :: [Role] } 78 | deriving (Eq, Show) 79 | ``` 80 | 81 | Now, defining the schema for the `Person` data type, you define each of the fields individually (name, type and getter) and combine them using 82 | an applicative: 83 | 84 | ```haskell 85 | import Data.Convertible 86 | import qualified Data.Schema as S 87 | import Data.Schema.JSON 88 | import qualified Data.Schema.JSON.Simple as JSON 89 | 90 | utcTimeSchema :: JsonSchema UTCTime 91 | utcTimeSchema = S.alias (iso convert convert) (JSON.int :: JsonSchema Integer) 92 | 93 | personSchema :: JsonSchema Person 94 | personSchema = S.record 95 | ( Person 96 | <$> S.field "name" JSON.string (to personName) 97 | <*> S.optional "birthDate" utcTimeSchema (to birthDate) 98 | <*> S.field "roles" (S.list roleSchema) (to roles) 99 | ) 100 | ``` 101 | 102 | The schema for the `Role` data type is defined as a list of alternatives alongside a prism as an accessor: 103 | 104 | ```haskell 105 | adminRole :: JsonSchema AdminRole 106 | adminRole = S.record 107 | ( AdminRole' 108 | <$> S.field "department" JSON.string (to department) 109 | <*> S.field "subordinateCount" JSON.int (to subordinateCount) 110 | ) 111 | 112 | roleSchema :: JsonSchema Role 113 | roleSchema = S.oneOf 114 | [ S.alt "user" (S.const UserRole') _UserRole 115 | , S.alt "admin" adminRole _AdminRole 116 | ] 117 | ``` 118 | 119 | Once you have defined the schema, by proving an instance for the `HasSchema` typeclass, 120 | you'll get JSON decoders, encoders, generators, etc. for free right away. 121 | 122 | ```haskell 123 | import Data.Schema (HasSchema(..)) 124 | 125 | instance HasSchema Person where 126 | type PrimitivesOf Person = JsonType 127 | 128 | getSchema = personSchema 129 | ``` 130 | 131 | ### Pretty Printer 132 | 133 | There is also built-in support for pretty printing schemas: 134 | 135 | ```haskell 136 | import Data.Schema.PrettyPrint 137 | 138 | putSchema' personSchema 139 | ``` 140 | 141 | That will produce an output similar to the following: 142 | 143 | ``` 144 | * roles :: [ 145 | - user 146 | - admin 147 | * subordinateCount :: Number 148 | * department :: Text 149 | ] 150 | * birthDate ?:: Number 151 | * name :: Text 152 | ``` 153 | 154 | Not happy with that? What about a pretty printer based on the given schema? Just use the `prettyPrinter` function, which will 155 | return you a `a -> IO ()` function that you can use to print your data types: 156 | 157 | ```haskell 158 | pprintPerson :: Person -> IO () 159 | pprintPerson = prettyPrinter' personSchema 160 | ``` 161 | 162 | ## Credits 163 | 164 | All thanks to [Kris Nuttycombe](https://github.com/nuttycom) for his excellent work in `xenomorph`, this project would be have 165 | been impossible without his work. 166 | -------------------------------------------------------------------------------- /hschema-aeson/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hexomorph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /hschema-aeson/LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /hschema-aeson/README.md: -------------------------------------------------------------------------------- 1 | # Haskell Schema Aeson 2 | 3 | This a companion package for the `hschema` package providing JSON encoder and decoders for your data types. 4 | Find more information on how to use this in the `hschema` package. -------------------------------------------------------------------------------- /hschema-aeson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hschema-aeson/package.yaml: -------------------------------------------------------------------------------- 1 | name: hschema-aeson 2 | version: 0.0.1.1 3 | category: Data,Schema,JSON 4 | github: "alonsodomin/haskell-schema" 5 | license: LGPL-3 6 | license-file: LICENSE 7 | author: "Antonio Alonso Dominguez" 8 | maintainer: "alonso.domin@gmail.com" 9 | copyright: "2018 Antonio Alonso Dominguez" 10 | 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | - test/*.json 15 | 16 | # Metadata used when publishing your package 17 | synopsis: Describe schemas for your Haskell data types. 18 | 19 | # To avoid duplicated efforts in documentation and dealing with the 20 | # complications of embedding Haddock markup inside cabal files, it is 21 | # common to point users to the README.md file. 22 | description: Please see the README on GitHub at 23 | 24 | dependencies: 25 | - aeson 26 | - contravariant 27 | - hschema >= 0.0.1.0 && < 0.0.2.0 28 | - hschema-prettyprinter >= 0.0.1.0 && < 0.0.2.0 29 | - hschema-quickcheck >= 0.0.1.0 && < 0.0.2.0 30 | - base >= 4.7 && < 5 31 | - comonad >= 5.0 && < 5.1 32 | - mtl 33 | - natural-transformation 34 | - lens 35 | - free 36 | - QuickCheck 37 | - quickcheck-instances 38 | - prettyprinter 39 | - prettyprinter-ansi-terminal 40 | - scientific 41 | - text 42 | - time 43 | - unordered-containers 44 | - vector 45 | 46 | library: 47 | source-dirs: src 48 | 49 | tests: 50 | hschema-aeson-test: 51 | main: Spec.hs 52 | source-dirs: test 53 | ghc-options: 54 | - -threaded 55 | - -rtsopts 56 | - -with-rtsopts=-N 57 | dependencies: 58 | - bytestring 59 | - convertible 60 | - directory 61 | - hschema 62 | - hschema-aeson 63 | - hspec 64 | -------------------------------------------------------------------------------- /hschema-aeson/src/Data/Schema/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Data.Schema.JSON 6 | ( JsonType 7 | , JsonSchema 8 | , JsonField 9 | , JsonSerializer(..) 10 | , JsonDeserializer(..) 11 | , ToJsonSerializer(..) 12 | , ToJsonDeserializer(..) 13 | , JsonPrimitive(..) 14 | ) where 15 | 16 | import Data.Aeson (FromJSON (parseJSON), 17 | ToJSON (toJSON)) 18 | import Data.Schema 19 | import Data.Schema.JSON.Internal.Serializer 20 | import Data.Schema.JSON.Internal.Types 21 | 22 | instance (HasSchema a, ToJsonSerializer (PrimitivesOf a)) => ToJSON a where 23 | toJSON = runJsonSerializer . toJsonSerializer $ getSchema 24 | 25 | instance (HasSchema a, ToJsonDeserializer (PrimitivesOf a)) => FromJSON a where 26 | parseJSON = runJsonDeserializer . toJsonDeserializer $ getSchema 27 | -------------------------------------------------------------------------------- /hschema-aeson/src/Data/Schema/JSON/Internal/Serializer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Data.Schema.JSON.Internal.Serializer where 9 | 10 | import Control.Applicative.Free 11 | import Control.Functor.HigherOrder 12 | import Control.Lens hiding (iso) 13 | import Control.Monad.State (State) 14 | import qualified Control.Monad.State as ST 15 | import Control.Natural 16 | import qualified Data.Aeson.Types as JSON 17 | import Data.Functor.Contravariant 18 | import Data.Functor.Sum 19 | import Data.HashMap.Strict (HashMap) 20 | import qualified Data.HashMap.Strict as Map 21 | import Data.List.NonEmpty (NonEmpty) 22 | import qualified Data.List.NonEmpty as NEL 23 | import Data.Maybe 24 | import Data.Schema.Internal.Types 25 | import Data.Text (Text) 26 | 27 | newtype JsonSerializer a = JsonSerializer { runJsonSerializer :: a -> JSON.Value } 28 | 29 | instance Contravariant JsonSerializer where 30 | contramap f (JsonSerializer g) = JsonSerializer $ g . f 31 | 32 | newtype JsonDeserializer a = JsonDeserializer { runJsonDeserializer :: JSON.Value -> JSON.Parser a } 33 | 34 | instance Functor JsonDeserializer where 35 | fmap f (JsonDeserializer g) = JsonDeserializer $ \x -> fmap f (g x) 36 | 37 | instance Applicative JsonDeserializer where 38 | pure x = JsonDeserializer $ \_ -> pure x 39 | (JsonDeserializer l) <*> (JsonDeserializer r) = JsonDeserializer $ \x -> l x <*> r x 40 | 41 | class ToJsonSerializer s where 42 | toJsonSerializer :: s ~> JsonSerializer 43 | 44 | class ToJsonDeserializer s where 45 | toJsonDeserializer :: s ~> JsonDeserializer 46 | 47 | instance (ToJsonSerializer p, ToJsonSerializer q) => ToJsonSerializer (Sum p q) where 48 | toJsonSerializer (InL l) = toJsonSerializer l 49 | toJsonSerializer (InR r) = toJsonSerializer r 50 | 51 | toJsonSerializerAlg :: ToJsonSerializer p => HAlgebra (SchemaF p) JsonSerializer 52 | toJsonSerializerAlg = wrapNT $ \case 53 | PrimitiveSchema p -> toJsonSerializer p 54 | 55 | RecordSchema fields -> JsonSerializer $ \obj -> JSON.Object $ ST.execState (runAp (encodeFieldOf obj) (unwrapField fields)) Map.empty 56 | where encodeFieldOf :: o -> FieldDef o JsonSerializer v -> State (HashMap Text JSON.Value) v 57 | encodeFieldOf o (RequiredField name (JsonSerializer serialize) getter) = do 58 | let el = view getter o 59 | ST.modify $ Map.insert name (serialize el) 60 | return el 61 | encodeFieldOf o (OptionalField name (JsonSerializer serialize) getter) = do 62 | let el = view getter o 63 | ST.modify $ Map.insert name (maybe JSON.Null serialize el) 64 | return el 65 | 66 | UnionSchema alts -> JsonSerializer $ \value -> head . catMaybes . NEL.toList $ fmap (encodeAlt value) alts 67 | where singleAttrObj :: Text -> JSON.Value -> JSON.Value 68 | singleAttrObj n v = JSON.Object $ Map.insert n v Map.empty 69 | 70 | encodeAlt :: o -> AltDef JsonSerializer o -> Maybe JSON.Value 71 | encodeAlt o (AltDef name (JsonSerializer serialize) pr) = do 72 | json <- serialize <$> o ^? pr 73 | return $ singleAttrObj name json 74 | 75 | AliasSchema (JsonSerializer base) iso -> JsonSerializer $ \value -> base (view (re iso) value) 76 | 77 | instance ToJsonSerializer p => ToJsonSerializer (Schema p) where 78 | toJsonSerializer schema = cataNT toJsonSerializerAlg (unwrapSchema schema) 79 | 80 | instance (ToJsonDeserializer p, ToJsonDeserializer q) => ToJsonDeserializer (Sum p q) where 81 | toJsonDeserializer (InL l) = toJsonDeserializer l 82 | toJsonDeserializer (InR r) = toJsonDeserializer r 83 | 84 | toJsonDeserializerAlg :: ToJsonDeserializer p => HAlgebra (SchemaF p) JsonDeserializer 85 | toJsonDeserializerAlg = wrapNT $ \case 86 | PrimitiveSchema p -> toJsonDeserializer p 87 | 88 | RecordSchema fields -> JsonDeserializer $ \case 89 | JSON.Object obj -> runAp decodeField $ unwrapField fields 90 | where decodeField :: FieldDef o JsonDeserializer v -> JSON.Parser v 91 | decodeField (RequiredField name (JsonDeserializer deserial) _) = JSON.explicitParseField deserial obj name 92 | decodeField (OptionalField name (JsonDeserializer deserial) _) = JSON.explicitParseFieldMaybe deserial obj name 93 | other -> fail $ "Expected JSON Object but got: " ++ show other 94 | 95 | UnionSchema alts -> JsonDeserializer $ \case 96 | JSON.Object obj -> head . catMaybes . NEL.toList $ fmap lookupParser alts 97 | where lookupParser :: AltDef JsonDeserializer a -> Maybe (JSON.Parser a) 98 | lookupParser (AltDef name (JsonDeserializer deserial) pr) = do 99 | altParser <- deserial <$> Map.lookup name obj 100 | return $ view (re pr) <$> altParser 101 | other -> fail $ "Expected JSON Object but got: " ++ show other 102 | 103 | AliasSchema (JsonDeserializer base) iso -> JsonDeserializer (fmap (view iso) . base) 104 | 105 | instance ToJsonDeserializer p => ToJsonDeserializer (Schema p) where 106 | toJsonDeserializer schema = cataNT toJsonDeserializerAlg (unwrapSchema schema) 107 | -------------------------------------------------------------------------------- /hschema-aeson/src/Data/Schema/JSON/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Data.Schema.JSON.Internal.Types where 7 | 8 | import Control.Applicative (liftA2) 9 | import Control.Functor.HigherOrder 10 | import Data.Aeson (parseJSON) 11 | import qualified Data.Aeson.Types as JSON 12 | import Data.HashMap.Strict (HashMap) 13 | import qualified Data.HashMap.Strict as Map 14 | import Data.Schema.Internal.Types 15 | import Data.Schema.JSON.Internal.Serializer 16 | import Data.Schema.PrettyPrint 17 | import Data.Scientific 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | import Data.Vector (Vector) 21 | import qualified Data.Vector as Vector 22 | import Prettyprinter ((<+>)) 23 | import qualified Prettyprinter as PP 24 | import qualified Test.QuickCheck as QC 25 | import qualified Test.QuickCheck.Gen as QC 26 | import Test.QuickCheck.Instances.Scientific () 27 | import Test.Schema.QuickCheck.Internal.Gen 28 | 29 | data JsonPrimitive (f :: (* -> *)) (a :: *) where 30 | JsonNumber :: JsonPrimitive f Scientific 31 | JsonText :: JsonPrimitive f Text 32 | JsonBool :: JsonPrimitive f Bool 33 | JsonArray :: f a -> JsonPrimitive f (Vector a) 34 | JsonMap :: f a -> JsonPrimitive f (HashMap Text a) 35 | 36 | type JsonType = HMutu JsonPrimitive Schema 37 | 38 | -- | Simple JSON schema type 39 | type JsonSchema = Schema JsonType 40 | 41 | -- | Simple JSON field type 42 | type JsonField o a = Field JsonSchema o a 43 | 44 | instance ToJsonSerializer JsonType where 45 | toJsonSerializer jType = JsonSerializer $ case unmutu jType of 46 | JsonNumber -> JSON.Number 47 | JsonText -> JSON.String 48 | JsonBool -> JSON.Bool 49 | JsonArray value -> JSON.Array . fmap (runJsonSerializer . toJsonSerializer $ value) 50 | JsonMap value -> JSON.Object . Map.map (runJsonSerializer . toJsonSerializer $ value) 51 | 52 | instance ToJsonDeserializer JsonType where 53 | toJsonDeserializer jType = JsonDeserializer $ case unmutu jType of 54 | JsonNumber -> parseJSON 55 | JsonText -> parseJSON 56 | JsonBool -> parseJSON 57 | JsonArray value -> \case 58 | JSON.Array arr -> traverse (runJsonDeserializer . toJsonDeserializer $ value) arr 59 | other -> fail $ "Expected a JSON array but got: " ++ show other 60 | JsonMap value -> \case 61 | JSON.Object obj -> Map.foldrWithKey Map.insert Map.empty <$> traverse (runJsonDeserializer . toJsonDeserializer $ value) obj 62 | other -> fail $ "Expected a JSON object but got: " ++ show other 63 | 64 | instance ToGen JsonType where 65 | toGen jType = case unmutu jType of 66 | JsonNumber -> QC.arbitrary 67 | JsonText -> T.pack <$> QC.listOf QC.chooseAny 68 | JsonBool -> QC.arbitrary :: (QC.Gen Bool) 69 | JsonArray value -> Vector.fromList <$> QC.listOf (toGen value) 70 | JsonMap value -> Map.fromList <$> QC.listOf (liftA2 (,) (T.pack <$> QC.listOf QC.chooseAny) (toGen value)) 71 | 72 | instance ToSchemaDoc JsonType where 73 | toSchemaDoc settings jType = SchemaDoc $ case unmutu jType of 74 | JsonNumber -> PP.pretty "Number" 75 | JsonText -> PP.pretty "Text" 76 | JsonBool -> PP.pretty "Bool" 77 | JsonArray value -> PP.pretty "[" <> (getDoc . toSchemaDoc settings $ value) <> PP.pretty "]" 78 | JsonMap value -> PP.pretty "Map { Text ->" <+> (getDoc . toSchemaDoc settings $ value) <+> PP.pretty "}" 79 | 80 | instance ToSchemaLayout JsonType where 81 | toSchemaLayout settings jType = SchemaLayout $ case unmutu jType of 82 | JsonNumber -> PP.unsafeViaShow 83 | JsonText -> PP.unsafeViaShow 84 | JsonBool -> PP.unsafeViaShow 85 | JsonArray value -> PP.vsep . fmap (renderSchemaLayout (toSchemaLayout settings value)) . Vector.toList 86 | JsonMap value -> PP.vsep . fmap (\(k,v) -> PP.pretty k <+> PP.pretty "->" <+> renderSchemaLayout (toSchemaLayout settings value) v) . Map.toList 87 | -------------------------------------------------------------------------------- /hschema-aeson/src/Data/Schema/JSON/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE LiberalTypeSynonyms #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module Data.Schema.JSON.Simple where 7 | 8 | import Control.Functor.HigherOrder 9 | import Control.Lens 10 | import Data.HashMap.Strict (HashMap) 11 | import Data.Schema 12 | import Data.Schema.Internal.Types 13 | import Data.Schema.JSON.Internal.Types 14 | import Data.Scientific 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | import Data.Vector (Vector) 18 | 19 | -- | Define a text primitive 20 | text :: JsonSchema Text 21 | text = prim $ HMutu JsonText 22 | 23 | -- | Define a string primitive 24 | string :: JsonSchema String 25 | string = alias (iso T.unpack T.pack) text 26 | 27 | -- | Define a scientific number primitive 28 | number :: JsonSchema Scientific 29 | number = prim $ HMutu JsonNumber 30 | 31 | -- | Define an integral primitive 32 | int :: Integral a => JsonSchema a 33 | int = alias (iso (\x -> either truncate id $ floatingOrInteger x) fromIntegral) number 34 | 35 | -- | Define a floating point primitive 36 | real :: RealFloat a => JsonSchema a 37 | real = alias (iso (\x -> either id fromIntegral $ floatingOrInteger x) fromFloatDigits) number 38 | 39 | array :: JsonSchema a -> JsonSchema (Vector a) 40 | array elemSchema = prim $ HMutu (JsonArray elemSchema) 41 | 42 | list :: JsonSchema a -> JsonSchema [a] 43 | list = toList . array 44 | 45 | hash :: JsonSchema a -> JsonSchema (HashMap Text a) 46 | hash elemSchema = prim $ HMutu (JsonMap elemSchema) 47 | -------------------------------------------------------------------------------- /hschema-aeson/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Schema.JSON 2 | 3 | main :: IO () 4 | main = verifyJsonSchema 5 | -------------------------------------------------------------------------------- /hschema-aeson/test/Test/Schema/JSON.hs: -------------------------------------------------------------------------------- 1 | module Test.Schema.JSON 2 | ( verifyJsonSchema 3 | ) where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Text 7 | import Data.Convertible 8 | import Data.Schema.JSON 9 | import qualified Data.Text.Lazy as T 10 | import Test.Hspec 11 | import Test.QuickCheck 12 | import Test.Schema.Model 13 | import Test.Schema.Utils 14 | 15 | samplePerson :: Person 16 | samplePerson = Person "foo" (Just $ convert (12 :: Int)) [ 17 | mkUserRole 18 | , mkAdminRole "bar" 4 19 | ] 20 | 21 | samplePersonJSONFileName :: String 22 | samplePersonJSONFileName = "expected-model.json" 23 | 24 | samplePersonJSON :: IO String 25 | samplePersonJSON = loadTestFile samplePersonJSONFileName 26 | 27 | prop_reverse :: Person -> Bool 28 | prop_reverse person = decode (encode person) == (Just person) 29 | 30 | describeJsonSerialization :: IO () 31 | describeJsonSerialization = hspec $ do 32 | describe "toJsonSerializer" $ do 33 | it "should generate valid JSON" $ do 34 | expectedJSON <- samplePersonJSON 35 | (T.unpack $ encodeToLazyText samplePerson) `shouldBe` expectedJSON 36 | 37 | it "should parse the given JSON" $ do 38 | givenJSON <- samplePersonJSON 39 | decodedPerson <- decodeFileStrict =<< testFilePath samplePersonJSONFileName 40 | decodedPerson `shouldBe` (Just samplePerson) 41 | 42 | verifyJsonSchema :: IO () 43 | verifyJsonSchema = do 44 | quickCheck prop_reverse 45 | describeJsonSerialization 46 | -------------------------------------------------------------------------------- /hschema-aeson/test/Test/Schema/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Test.Schema.Model where 6 | 7 | import Control.Lens 8 | import Data.Aeson 9 | import Data.Convertible 10 | import Data.Schema (HasSchema (..)) 11 | import qualified Data.Schema as S 12 | import Data.Schema.JSON 13 | import qualified Data.Schema.JSON.Simple as JSON 14 | import Data.Time (UTCTime) 15 | import Test.QuickCheck 16 | import Test.Schema.QuickCheck 17 | 18 | utcTimeSchema :: JsonSchema UTCTime 19 | utcTimeSchema = S.alias (iso convert convert) (JSON.int :: JsonSchema Integer) 20 | 21 | data Role = 22 | UserRole UserRole 23 | | AdminRole AdminRole 24 | deriving (Eq, Show) 25 | 26 | data UserRole = UserRole' 27 | deriving (Eq, Show) 28 | 29 | data AdminRole = AdminRole' { department :: String, subordinateCount :: Int } 30 | deriving (Eq, Show) 31 | 32 | mkUserRole :: Role 33 | mkUserRole = UserRole $ UserRole' 34 | 35 | mkAdminRole :: String -> Int -> Role 36 | mkAdminRole dpt subs = AdminRole $ AdminRole' dpt subs 37 | 38 | _UserRole :: Prism' Role UserRole 39 | _UserRole = prism' UserRole $ \case 40 | UserRole x -> Just x 41 | _ -> Nothing 42 | 43 | _AdminRole :: Prism' Role AdminRole 44 | _AdminRole = prism' AdminRole $ \case 45 | AdminRole x -> Just x 46 | _ -> Nothing 47 | 48 | adminRole :: JsonSchema AdminRole 49 | adminRole = S.record 50 | ( AdminRole' 51 | <$> S.field "department" JSON.string (to department) 52 | <*> S.field "subordinateCount" JSON.int (to subordinateCount) 53 | ) 54 | 55 | roleSchema :: JsonSchema Role 56 | roleSchema = S.oneOf 57 | [ S.alt "user" (S.const UserRole') _UserRole 58 | , S.alt "admin" adminRole _AdminRole 59 | ] 60 | 61 | data Person = Person { personName :: String, birthDate :: Maybe UTCTime, roles :: [Role] } 62 | deriving (Eq, Show) 63 | 64 | personSchema :: JsonSchema Person 65 | personSchema = S.record 66 | ( Person 67 | <$> S.field "name" JSON.string (to personName) 68 | <*> S.optional "birthDate" utcTimeSchema (to birthDate) 69 | <*> S.field "roles" (JSON.list roleSchema) (to roles) 70 | ) 71 | 72 | instance HasSchema Person where 73 | type PrimitivesOf Person = JsonType 74 | 75 | getSchema = personSchema 76 | -------------------------------------------------------------------------------- /hschema-aeson/test/Test/Schema/Utils.hs: -------------------------------------------------------------------------------- 1 | module Test.Schema.Utils where 2 | 3 | import System.Directory 4 | import System.IO 5 | 6 | getTestFolder :: IO FilePath 7 | getTestFolder = do 8 | baseDir <- getCurrentDirectory 9 | return $ baseDir ++ "/test/" 10 | 11 | testFilePath :: String -> IO String 12 | testFilePath f = do 13 | testDir <- getTestFolder 14 | return $ testDir ++ f 15 | 16 | loadTestFile :: String -> IO String 17 | loadTestFile f = testFilePath f >>= readFile 18 | -------------------------------------------------------------------------------- /hschema-aeson/test/expected-model.json: -------------------------------------------------------------------------------- 1 | {"roles":[{"user":{}},{"admin":{"subordinateCount":4,"department":"bar"}}],"name":"foo","birthDate":12} -------------------------------------------------------------------------------- /hschema-prettyprinter/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hexomorph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /hschema-prettyprinter/LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /hschema-prettyprinter/README.md: -------------------------------------------------------------------------------- 1 | # Haskell Schema Pretty Printer 2 | 3 | This a companion package for the `hschema` package providing utilities to pretty print schemas or to layout data 4 | according to a given schema. Find more information on how to use this in the `hschema` package. -------------------------------------------------------------------------------- /hschema-prettyprinter/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hschema-prettyprinter/package.yaml: -------------------------------------------------------------------------------- 1 | name: hschema-prettyprinter 2 | version: 0.0.1.1 3 | category: Data,Schema,Text 4 | github: "alonsodomin/haskell-schema" 5 | license: LGPL-3 6 | license-file: LICENSE 7 | author: "Antonio Alonso Dominguez" 8 | maintainer: "alonso.domin@gmail.com" 9 | copyright: "2018 Antonio Alonso Dominguez" 10 | 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | # Metadata used when publishing your package 16 | synopsis: Describe schemas for your Haskell data types. 17 | 18 | # To avoid duplicated efforts in documentation and dealing with the 19 | # complications of embedding Haddock markup inside cabal files, it is 20 | # common to point users to the README.md file. 21 | description: Please see the README on GitHub at 22 | 23 | dependencies: 24 | - base >= 4.7 && < 5 25 | - contravariant 26 | - hschema >= 0.0.1.0 && < 0.0.2.0 27 | - mtl 28 | - natural-transformation 29 | - lens 30 | - free 31 | - prettyprinter >= 1.7.0 && < 1.8.0 32 | - prettyprinter-ansi-terminal 33 | - text 34 | - unordered-containers 35 | - vector 36 | 37 | library: 38 | source-dirs: src 39 | 40 | exposed-modules: 41 | - Data.Schema.PrettyPrint.Internal.Algebra 42 | - Data.Schema.PrettyPrint.Internal.Types -------------------------------------------------------------------------------- /hschema-prettyprinter/src/Data/Schema/PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Data.Schema.PrettyPrint 7 | ( module Data.Schema.PrettyPrint.Internal.Algebra 8 | , module Data.Schema.PrettyPrint.Internal.Types 9 | , putSchema 10 | , putSchema' 11 | , prettyPrinter 12 | , prettyPrinter' 13 | ) where 14 | 15 | 16 | import Data.Schema.PrettyPrint.Internal.Algebra 17 | import Data.Schema.PrettyPrint.Internal.Types 18 | import qualified Prettyprinter.Render.Terminal as PP 19 | 20 | 21 | -- | Renders the given schema to the standard out 22 | putSchema :: ToSchemaDoc s => LayoutSettings -> s a -> IO () 23 | putSchema settings schema = do 24 | PP.putDoc . getDoc $ toSchemaDoc settings schema 25 | putStrLn "" 26 | 27 | putSchema' :: ToSchemaDoc s => s a -> IO () 28 | putSchema' = putSchema defaultLayoutSettings 29 | 30 | -- | Generates a renderer of data types based on the given schema 31 | prettyPrinter :: ToSchemaLayout s => LayoutSettings -> s a -> (a -> IO ()) 32 | prettyPrinter settings schema x = do 33 | PP.putDoc $ renderSchemaLayout (toSchemaLayout settings schema) x 34 | putStrLn "" 35 | 36 | prettyPrinter' :: ToSchemaLayout s => s a -> (a -> IO ()) 37 | prettyPrinter' = prettyPrinter defaultLayoutSettings 38 | -------------------------------------------------------------------------------- /hschema-prettyprinter/src/Data/Schema/PrettyPrint/Internal/Algebra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Data.Schema.PrettyPrint.Internal.Algebra ( 9 | SchemaDoc (..) 10 | , ToSchemaDoc (..) 11 | , toSchemaDoc' 12 | , SchemaLayout (..) 13 | , ToSchemaLayout (..) 14 | , toSchemaLayout' 15 | ) where 16 | 17 | import Control.Applicative.Free 18 | import Control.Functor.HigherOrder 19 | import Control.Lens hiding (iso) 20 | import Control.Monad.State (State) 21 | import qualified Control.Monad.State as ST 22 | import Control.Natural 23 | import Data.Functor.Contravariant 24 | import Data.Functor.Contravariant.Divisible 25 | import Data.Functor.Sum 26 | import Data.List.NonEmpty (NonEmpty) 27 | import qualified Data.List.NonEmpty as NEL 28 | import Data.Maybe 29 | import Data.Schema.Internal.Types 30 | import Data.Schema.PrettyPrint.Internal.Types 31 | import Prettyprinter ((<+>), (<>)) 32 | import qualified Prettyprinter as PP 33 | 34 | renderFields :: forall o s. LayoutSettings -> (forall v. FieldDef o s v -> AnsiDoc) -> Fields s o -> AnsiDoc 35 | renderFields settings f fields = packFields $ ST.execState (runAp fieldDoc $ unwrapField fields) [] 36 | where fieldDoc :: FieldDef o s v -> State [AnsiDoc] v 37 | fieldDoc fld = do 38 | let fieldDesc = PP.pretty (layoutProductItem settings) <+> PP.pretty (fieldName fld) <+> f fld 39 | ST.modify $ \xs -> fieldDesc:xs 40 | return undefined 41 | 42 | packFields :: [AnsiDoc] -> AnsiDoc 43 | packFields [] = PP.emptyDoc 44 | packFields xs = PP.nest (layoutIndent settings) $ PP.line <> PP.vsep xs 45 | 46 | renderAlts :: forall s o. LayoutSettings -> (AltDef s o -> Maybe AnsiDoc) -> NonEmpty (AltDef s o) -> [AnsiDoc] 47 | renderAlts settings f alts = catMaybes . NEL.toList $ altDoc <$> alts 48 | where altDoc :: AltDef s o -> Maybe AnsiDoc 49 | altDoc a = (\x -> PP.indent (layoutIndent settings) $ PP.pretty (layoutSumItem settings) <+> PP.pretty (altName a) <> x) <$> f a 50 | 51 | -- | Defines the transformation of schema `s a` into a `SchemaDoc a` 52 | class ToSchemaDoc s where 53 | toSchemaDoc :: LayoutSettings -> s ~> SchemaDoc 54 | 55 | toSchemaDoc' :: ToSchemaDoc s => s ~> SchemaDoc 56 | toSchemaDoc' = toSchemaDoc defaultLayoutSettings 57 | 58 | instance (ToSchemaDoc p, ToSchemaDoc q) => ToSchemaDoc (Sum p q) where 59 | toSchemaDoc settings (InL l) = toSchemaDoc settings l 60 | toSchemaDoc settings (InR r) = toSchemaDoc settings r 61 | 62 | toSchemaDocAlg :: ToSchemaDoc s => LayoutSettings -> HAlgebra (SchemaF s) SchemaDoc 63 | toSchemaDocAlg settings = wrapNT $ \case 64 | PrimitiveSchema p -> SchemaDoc $ PP.pretty (layoutTypeAssignment settings) <+> getDoc (toSchemaDoc settings p) 65 | RecordSchema fields -> SchemaDoc $ renderFields settings fieldDoc' fields 66 | where fieldDoc' :: FieldDef o SchemaDoc v -> AnsiDoc 67 | fieldDoc' (RequiredField _ schemaDoc _) = getDoc schemaDoc 68 | fieldDoc' (OptionalField _ schemaDoc _) = PP.pretty (layoutOptional settings) <> getDoc schemaDoc 69 | UnionSchema alts -> SchemaDoc $ PP.vsep $ renderAlts settings altDoc' alts 70 | where altDoc' :: AltDef SchemaDoc a -> Maybe AnsiDoc 71 | altDoc' (AltDef _ (SchemaDoc doc) _) = Just doc 72 | AliasSchema baseDoc _ -> SchemaDoc $ getDoc baseDoc 73 | 74 | instance ToSchemaDoc s => ToSchemaDoc (Schema s) where 75 | toSchemaDoc settings schema = cataNT (toSchemaDocAlg settings) (unwrapSchema schema) 76 | 77 | newtype SchemaLayout a = SchemaLayout { 78 | renderSchemaLayout :: a -> AnsiDoc 79 | } 80 | 81 | instance Contravariant SchemaLayout where 82 | contramap f (SchemaLayout g) = SchemaLayout $ g . f 83 | 84 | instance Divisible SchemaLayout where 85 | conquer = SchemaLayout $ const PP.emptyDoc 86 | divide split leftLayout rightLayout = SchemaLayout $ \x -> 87 | let (left, right) = split x 88 | leftDoc = renderSchemaLayout leftLayout left 89 | rightDoc = renderSchemaLayout rightLayout right 90 | in leftDoc <+> PP.pretty "," <+> rightDoc 91 | 92 | class ToSchemaLayout s where 93 | toSchemaLayout :: LayoutSettings -> s ~> SchemaLayout 94 | 95 | toSchemaLayout' :: ToSchemaLayout s => s ~> SchemaLayout 96 | toSchemaLayout' = toSchemaLayout defaultLayoutSettings 97 | 98 | instance (ToSchemaLayout p, ToSchemaLayout q) => ToSchemaLayout (Sum p q) where 99 | toSchemaLayout settings (InL l) = toSchemaLayout settings l 100 | toSchemaLayout settings (InR r) = toSchemaLayout settings r 101 | 102 | toSchemaLayoutAlg :: ToSchemaLayout s => LayoutSettings -> HAlgebra (SchemaF s) SchemaLayout 103 | toSchemaLayoutAlg settings = wrapNT $ \case 104 | PrimitiveSchema p -> SchemaLayout $ \x -> PP.colon <+> renderSchemaLayout (toSchemaLayout settings p) x 105 | RecordSchema fields -> SchemaLayout $ \rc -> renderFields settings (fieldDocOf rc) fields 106 | where fieldDocOf :: o -> FieldDef o SchemaLayout v -> AnsiDoc 107 | fieldDocOf obj (RequiredField _ (SchemaLayout layout) getter) = 108 | let el = view getter obj 109 | in layout el 110 | fieldDocOf obj (OptionalField _ (SchemaLayout layout) getter) = 111 | let el = view getter obj 112 | in maybe (PP.pretty $ layoutNothing settings) layout el 113 | UnionSchema alts -> SchemaLayout $ \value -> head $ renderAlts settings (layoutAlt' value) alts 114 | where layoutAlt' :: o -> AltDef SchemaLayout o -> Maybe AnsiDoc 115 | layoutAlt' obj (AltDef _ (SchemaLayout layout) getter) = layout <$> obj ^? getter 116 | AliasSchema (SchemaLayout baseLayout) getter -> SchemaLayout $ \value -> baseLayout (view (re getter) value) 117 | 118 | instance ToSchemaLayout s => ToSchemaLayout (Schema s) where 119 | toSchemaLayout settings schema = cataNT (toSchemaLayoutAlg settings) (unwrapSchema schema) 120 | -------------------------------------------------------------------------------- /hschema-prettyprinter/src/Data/Schema/PrettyPrint/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Data.Schema.PrettyPrint.Internal.Types where 10 | 11 | import Control.Natural 12 | import Data.Functor.Sum 13 | import Data.Text 14 | import qualified Prettyprinter as PP 15 | import qualified Prettyprinter.Render.Terminal as PP 16 | 17 | type AnsiDoc = PP.Doc PP.AnsiStyle 18 | 19 | -- | General settings to be used when rendering documents 20 | data LayoutSettings = LayoutSettings { 21 | layoutIndent :: !Int 22 | , layoutTypeAssignment :: !Text 23 | , layoutOptional :: !Text 24 | , layoutSumItem :: !Text 25 | , layoutProductItem :: !Text 26 | , layoutNothing :: !Text 27 | } 28 | 29 | -- | Default layout settings 30 | defaultLayoutSettings :: LayoutSettings 31 | defaultLayoutSettings = LayoutSettings { 32 | layoutIndent = 2 33 | , layoutTypeAssignment = pack "::" 34 | , layoutOptional = pack "?" 35 | , layoutSumItem = pack "+" 36 | , layoutProductItem = pack "*" 37 | , layoutNothing = pack "Nothing" 38 | } 39 | 40 | -- | Functor-like structure holding a document for a schema 41 | newtype SchemaDoc a = SchemaDoc { getDoc :: AnsiDoc } deriving Functor 42 | 43 | instance Applicative SchemaDoc where 44 | pure _ = SchemaDoc PP.emptyDoc 45 | (SchemaDoc l) <*> (SchemaDoc r) = SchemaDoc $ l <> r 46 | -------------------------------------------------------------------------------- /hschema-quickcheck/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hexomorph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /hschema-quickcheck/LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /hschema-quickcheck/README.md: -------------------------------------------------------------------------------- 1 | # Haskell Schema QuickCheck 2 | 3 | This a companion package for the `hschema` package providing utilities for automatically generating 4 | QuickCheck generators for your data types. Find more information on how to use this in the `hschema` package. -------------------------------------------------------------------------------- /hschema-quickcheck/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hschema-quickcheck/package.yaml: -------------------------------------------------------------------------------- 1 | name: hschema-quickcheck 2 | version: 0.0.1.1 3 | category: Data,Schema,Testing 4 | github: "alonsodomin/haskell-schema" 5 | license: LGPL-3 6 | license-file: LICENSE 7 | author: "Antonio Alonso Dominguez" 8 | maintainer: "alonso.domin@gmail.com" 9 | copyright: "2018 Antonio Alonso Dominguez" 10 | 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | # Metadata used when publishing your package 16 | synopsis: Describe schemas for your Haskell data types. 17 | 18 | # To avoid duplicated efforts in documentation and dealing with the 19 | # complications of embedding Haddock markup inside cabal files, it is 20 | # common to point users to the README.md file. 21 | description: Please see the README on GitHub at 22 | 23 | dependencies: 24 | - base >= 4.7 && < 5 25 | - hschema >= 0.0.1.0 && < 0.0.2.0 26 | - mtl 27 | - natural-transformation 28 | - lens 29 | - free 30 | - QuickCheck 31 | - quickcheck-instances 32 | - text 33 | - unordered-containers 34 | - vector 35 | 36 | library: 37 | source-dirs: src 38 | -------------------------------------------------------------------------------- /hschema-quickcheck/src/Test/Schema/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Test.Schema.QuickCheck 6 | ( module Test.Schema.QuickCheck.Internal.Gen 7 | ) where 8 | 9 | import Data.Schema 10 | import Test.QuickCheck 11 | import Test.Schema.QuickCheck.Internal.Gen 12 | 13 | instance (HasSchema a, ToGen (PrimitivesOf a)) => Arbitrary a where 14 | arbitrary = toGen getSchema 15 | -------------------------------------------------------------------------------- /hschema-quickcheck/src/Test/Schema/QuickCheck/Internal/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Test.Schema.QuickCheck.Internal.Gen 9 | ( ToGen (..) 10 | ) where 11 | 12 | import Control.Applicative (liftA2) 13 | import Control.Applicative.Free 14 | import Control.Functor.HigherOrder 15 | import Control.Lens 16 | import Control.Monad (liftM) 17 | import Control.Natural 18 | import Data.Functor.Sum 19 | import qualified Data.HashMap.Strict as Map 20 | import qualified Data.List.NonEmpty as NEL 21 | import Data.Schema.Internal.Types 22 | import qualified Data.Vector as Vector 23 | import Test.QuickCheck (Gen) 24 | import qualified Test.QuickCheck as Gen 25 | 26 | optGen :: Gen a -> Gen (Maybe a) 27 | optGen base = Gen.frequency [(1, return Nothing), (3, fmap Just base)] 28 | 29 | class ToGen a where 30 | toGen :: a ~> Gen 31 | 32 | instance (ToGen p, ToGen q) => ToGen (Sum p q) where 33 | toGen (InL l) = toGen l 34 | toGen (InR r) = toGen r 35 | 36 | genAlg :: ToGen p => HAlgebra (SchemaF p) Gen 37 | genAlg = wrapNT $ \case 38 | PrimitiveSchema p -> toGen p 39 | RecordSchema (Field flds) -> runAp genField flds 40 | where genField :: FieldDef o Gen a -> Gen a 41 | genField (RequiredField _ g _) = g 42 | genField (OptionalField _ g _) = optGen g 43 | UnionSchema alts -> Gen.oneof . NEL.toList $ fmap genAlt alts 44 | where genAlt :: AltDef Gen a -> Gen a 45 | genAlt (AltDef _ genSingle pr) = view (re pr) <$> genSingle 46 | AliasSchema base iso -> view iso <$> base 47 | 48 | instance ToGen s => ToGen (Schema s) where 49 | toGen schema = cataNT genAlg (unwrapSchema schema) 50 | -------------------------------------------------------------------------------- /hschema/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for hexomorph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /hschema/LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /hschema/README.md: -------------------------------------------------------------------------------- 1 | # Haskell Schema Core 2 | 3 | This is the core module of the the Haskell Schema set of libraries and provides with the basic elements needed to define your own schemas. 4 | To be able to use this library you will need to combine it with one or more of the additional companion packages. 5 | -------------------------------------------------------------------------------- /hschema/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hschema/package.yaml: -------------------------------------------------------------------------------- 1 | name: hschema 2 | version: 0.0.1.1 3 | category: Data,Schema 4 | github: "alonsodomin/haskell-schema" 5 | license: LGPL-3 6 | license-file: LICENSE 7 | author: "Antonio Alonso Dominguez" 8 | maintainer: "alonso.domin@gmail.com" 9 | copyright: "2018 Antonio Alonso Dominguez" 10 | 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | # Metadata used when publishing your package 16 | synopsis: Describe schemas for your Haskell data types. 17 | 18 | # To avoid duplicated efforts in documentation and dealing with the 19 | # complications of embedding Haddock markup inside cabal files, it is 20 | # common to point users to the README.md file. 21 | description: Please see the README on GitHub at 22 | 23 | dependencies: 24 | - base >= 4.7 && < 5 25 | - comonad >= 5.0 && < 5.1 26 | - contravariant 27 | - hashable 28 | - invariant 29 | - mtl 30 | - natural-transformation 31 | - lens 32 | - free 33 | - profunctors 34 | - text 35 | - unordered-containers 36 | - vector 37 | 38 | library: 39 | source-dirs: src 40 | 41 | -------------------------------------------------------------------------------- /hschema/src/Control/Functor/HigherOrder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Control.Functor.HigherOrder where 8 | 9 | import Control.Natural 10 | 11 | type HAlgebra f g = f g :~> g 12 | type HCoalgebra f g = g :~> f g 13 | 14 | class HFunctor (f :: ((* -> *) -> * -> *)) where 15 | hfmap :: (m ~> n) -> f m ~> f n 16 | 17 | class HFunctor f => HPointed f where 18 | hreturn :: Functor g => g a -> f g a 19 | 20 | class HFunctor f => HCopointed f where 21 | hextract :: Functor g => f g a -> g a 22 | 23 | newtype HFix f a = HFix { unfix :: f (HFix f) a } 24 | 25 | data HEnvT 26 | (f :: ((* -> *) -> * -> *)) 27 | (e :: *) 28 | (g :: (* -> *)) 29 | (i :: *) = HEnvT { hask :: !e, hlocal :: f g i } 30 | 31 | newtype HMutu 32 | (f :: ((* -> *) -> * -> *)) 33 | (g :: ((* -> *) -> * -> *)) 34 | (a :: *) = HMutu { unmutu :: f (g (HMutu f g)) a } 35 | 36 | instance HFunctor f => HFunctor (HEnvT f a) where 37 | hfmap nt = \fa -> HEnvT (hask fa) (hfmap nt (hlocal fa)) 38 | 39 | instance Functor (f g) => Functor (HEnvT f e g) where 40 | fmap f env = HEnvT (hask env) (fmap f (hlocal env)) 41 | 42 | type HCofree 43 | (f :: ((* -> *) -> * -> *)) 44 | (a :: *) = HFix (HEnvT f a) 45 | 46 | hcofree :: a -> f (HCofree f a) b -> HCofree f a b 47 | hcofree a fhc = HFix (HEnvT a fhc) 48 | 49 | cataNT :: HFunctor f => HAlgebra f g -> HFix f ~> g 50 | cataNT alg = unwrapNT alg . nt 51 | where nt hf = hfmap (cataNT alg) (unfix hf) 52 | 53 | anaNT :: HFunctor f => HCoalgebra f g -> g ~> HFix f 54 | anaNT coalg g = HFix $ hfmap (anaNT coalg) $ unwrapNT coalg g 55 | 56 | --hyloNT :: HFunctor f => HAlgebra f g -> HCoalgebra g f -> HFix f ~> HFix g 57 | 58 | hforgetAlg :: HAlgebra (HEnvT f a) (HFix f) 59 | hforgetAlg = wrapNT $ \env -> HFix $ hlocal env 60 | 61 | hforget :: HFunctor f => HCofree f a ~> HFix f 62 | hforget = cataNT hforgetAlg 63 | 64 | htagCoalg :: HFunctor f => a -> HCoalgebra (HEnvT f a) (HFix f) 65 | htagCoalg tag = wrapNT $ \hfix -> HEnvT tag (unfix hfix) 66 | 67 | htag :: HFunctor f => a -> HFix f ~> HCofree f a 68 | htag tag = anaNT (htagCoalg tag) 69 | -------------------------------------------------------------------------------- /hschema/src/Data/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Data.Schema 4 | ( Field 5 | , Fields 6 | , field 7 | , optional 8 | , alt 9 | , Schema 10 | , HasSchema (..) 11 | , prim 12 | , const 13 | , record 14 | , asList 15 | , toList 16 | , oneOf 17 | , alias 18 | ) where 19 | 20 | import Control.Functor.HigherOrder 21 | import Control.Lens 22 | import Data.Functor.Invariant 23 | import Data.HashMap.Strict (HashMap) 24 | import Data.Hashable (Hashable) 25 | import qualified Data.List.NonEmpty as NEL 26 | import Data.Schema.Internal.Types 27 | import Data.Text (Text) 28 | import Data.Vector (Vector) 29 | import qualified Data.Vector as Vector 30 | import Prelude hiding (const, seq) 31 | 32 | -- | Define an alternative 33 | alt :: Text -> s b -> Prism' a b -> AltDef s a 34 | alt = AltDef 35 | 36 | -- | Define an annotated schema for primitives of type `p` 37 | prim :: p a -> Schema p a 38 | prim primAlg = Schema (HFix $ PrimitiveSchema primAlg) 39 | 40 | -- | Define a schema for a type that is always constant 41 | const :: a -> Schema p a 42 | const a = Schema (HFix (RecordSchema $ pure a)) 43 | 44 | -- | Define the schema of record using the given fields 45 | record :: Fields (Schema p) a -> Schema p a 46 | record ps = Schema (HFix (RecordSchema $ hoistField unwrapSchema ps)) 47 | 48 | -- | Define the schema of a list based on the element type 49 | asList :: Iso' (Vector a) [a] 50 | asList = iso Vector.toList Vector.fromList 51 | 52 | toList :: Schema p (Vector a) -> Schema p [a] 53 | toList = invmap Vector.toList Vector.fromList 54 | 55 | -- | Define the schema of an union (coproduct) type based on the given alternatives 56 | oneOf :: [AltDef (Schema p) a] -> Schema p a 57 | oneOf alts = Schema (HFix (UnionSchema $ hfmap unwrapSchema <$> NEL.fromList alts)) 58 | 59 | -- | Define an schema alias that is isomorphic to another one using the given ISO transformation 60 | alias :: Iso' a b -> Schema p a -> Schema p b 61 | alias i = invmap (view i) (view . from $ i) 62 | -------------------------------------------------------------------------------- /hschema/src/Data/Schema/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Data.Schema.Internal.Types where 13 | 14 | import Control.Applicative.Free 15 | import Control.Functor.HigherOrder 16 | import Control.Lens hiding (iso) 17 | import qualified Control.Lens as Lens 18 | import Control.Natural 19 | import Data.Functor.Invariant 20 | import Data.List.NonEmpty (NonEmpty) 21 | import Data.Profunctor 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import Data.Vector (Vector) 25 | import Prelude hiding (const, seq) 26 | 27 | -- | Metadata for a field of type `a`, belonging to the data type `o` and based on schema `s` 28 | data FieldDef o s a where 29 | RequiredField :: Text -> s a -> Getter o a -> FieldDef o s a 30 | OptionalField :: Text -> s a -> Getter o (Maybe a) -> FieldDef o s (Maybe a) 31 | 32 | -- | Read the field name from a field definition 33 | fieldName :: FieldDef o s a -> Text 34 | fieldName (RequiredField name _ _) = name 35 | fieldName (OptionalField name _ _) = name 36 | 37 | instance HFunctor (FieldDef o) where 38 | hfmap nt = \case 39 | RequiredField name s acc -> RequiredField name (nt s) acc 40 | OptionalField name s acc -> OptionalField name (nt s) acc 41 | 42 | -- | The type of a field of type `a`, belonging to the data type `o` and based on schema `s` 43 | newtype Field s o a = Field { unwrapField :: Ap (FieldDef o s) a } 44 | 45 | -- | Applies a Natural Transformation to the schema of a Field 46 | hoistField :: (m ~> n) -> Field m o a -> Field n o a 47 | hoistField nt (Field ap) = Field $ hoistAp (hfmap nt) ap 48 | 49 | -- | The set of fields for the data type `o` based on schema `s` 50 | type Fields s o = Field s o o 51 | 52 | instance Functor (Field s o) where 53 | fmap f (Field x) = Field $ fmap f x 54 | 55 | instance Applicative (Field s o) where 56 | pure x = Field $ Pure x 57 | (Field x) <*> (Field y) = Field (x <*> y) 58 | 59 | instance Profunctor (Field s) where 60 | lmap f (Field ap) = Field $ hoistAp (contraNT f) ap 61 | where contraNT :: (n -> o) -> FieldDef o s ~> FieldDef n s 62 | contraNT f = \case 63 | RequiredField n s g -> RequiredField n s (to f . g) 64 | OptionalField n s g -> OptionalField n s (to f . g) 65 | rmap = fmap 66 | 67 | -- | Define a required field 68 | field :: Text -> s a -> Getter o a -> Field s o a 69 | field name schema getter = Field $ liftAp (RequiredField name schema getter) 70 | 71 | -- | Define an optional field 72 | optional :: Text -> s a -> Getter o (Maybe a) -> Field s o (Maybe a) 73 | optional name schema getter = Field $ liftAp (OptionalField name schema getter) 74 | 75 | -- | Metadata for an alternative of type `a` based on schema `s` 76 | data AltDef s a = forall b. AltDef 77 | { altName :: Text 78 | , altSchema :: s b 79 | , altPrism :: Prism' a b 80 | } 81 | 82 | instance HFunctor AltDef where 83 | hfmap nt = \(AltDef name schema pr) -> AltDef name (nt schema) pr 84 | 85 | -- | Metadata for a schema `s` based on primitives `p` and representing type `a` 86 | data SchemaF p s a where 87 | PrimitiveSchema :: p a -> SchemaF p s a 88 | RecordSchema :: Fields s a -> SchemaF p s a 89 | UnionSchema :: NonEmpty (AltDef s a) -> SchemaF p s a 90 | AliasSchema :: s a -> Iso' a b -> SchemaF p s b 91 | 92 | instance HFunctor (SchemaF p) where 93 | hfmap nt = \case 94 | PrimitiveSchema p -> PrimitiveSchema p 95 | RecordSchema (Field flds) -> RecordSchema . Field $ hoistAp (hfmap nt) flds 96 | UnionSchema alts -> UnionSchema $ fmap (hfmap nt) alts 97 | AliasSchema base iso -> AliasSchema (nt base) iso 98 | 99 | -- | The Schema type itself for a set of primitives `p` 100 | newtype Schema p a = Schema { unwrapSchema :: HFix (SchemaF p) a } 101 | 102 | instance Invariant (Schema p) where 103 | invmap f g sch = case unfix . unwrapSchema $ sch of 104 | AliasSchema base iso -> Schema . HFix $ AliasSchema base (iso . Lens.iso f g) 105 | _ -> Schema . HFix $ AliasSchema (unwrapSchema sch) (Lens.iso f g) 106 | 107 | -- | An Schema has a HFunctor that performs a natural transformation of the primitive algebra of the Schema 108 | instance HFunctor Schema where 109 | hfmap nt (Schema fsch) = Schema $ cataNT pfmapAlg fsch 110 | where pfmapAlg = wrapNT $ \sch -> HFix $ pfmap nt sch 111 | 112 | pfmap :: (p ~> q) -> SchemaF p s ~> SchemaF q s 113 | pfmap nt = \case 114 | PrimitiveSchema p -> PrimitiveSchema (nt p) 115 | RecordSchema fields -> RecordSchema fields 116 | UnionSchema alts -> UnionSchema alts 117 | AliasSchema base iso -> AliasSchema base iso 118 | 119 | class HasSchema a where 120 | type PrimitivesOf a :: * -> * 121 | 122 | getSchema :: Schema (PrimitivesOf a) a 123 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-18.27 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - hschema 38 | - hschema-quickcheck 39 | - hschema-prettyprinter 40 | - hschema-aeson 41 | 42 | # Dependency packages to be pulled from upstream that are not in the resolver 43 | # using the same syntax as the packages field. 44 | # (e.g., acme-missiles-0.3) 45 | extra-deps: 46 | 47 | # Override default flag values for local packages and extra-deps 48 | # flags: {} 49 | 50 | # Extra package databases containing global packages 51 | # extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.7" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | -------------------------------------------------------------------------------- /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 | snapshots: 8 | - completed: 9 | sha256: 79a786674930a89301b0e908fad2822a48882f3d01486117693c377b8edffdbe 10 | size: 590102 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml 12 | original: lts-18.27 13 | -------------------------------------------------------------------------------- /stylize.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | command -v stylish-haskell >/dev/null 2>&1 || { echo "Could not find stylish-haskell. Aborting." >&2; exit 1; } 4 | 5 | find . -name \*.hs -and \( -not \( -name Setup.hs -or -path ./.stack-work/\* -or -path ./dist/\* \) \) | xargs stylish-haskell -i > stylish-out 2>&1 6 | 7 | # It doesn't do exit codes properly, so we just check if it outputted anything. 8 | if [ -s stylish-out ]; 9 | then 10 | echo "Stylish-haskell reported an error :(" 11 | cat stylish-out 12 | exit 1 13 | fi 14 | 15 | rm stylish-out 16 | 17 | if git status --porcelain|grep .; # true if there was any output 18 | then 19 | echo "Git tree is dirty after stylizing."; 20 | if [ -n "$TRAVIS" ]; 21 | then 22 | echo "Since we're on Travis, this is a build failure." 23 | echo "Run ./stylize.sh to stylize your tree and push the changes." 24 | exit 1 25 | fi 26 | else 27 | echo "Stylish didn't change anything :)" 28 | exit 0; 29 | fi --------------------------------------------------------------------------------