├── .dockerignore ├── .gitignore ├── .stylish-haskell.yaml ├── ChangeLog.md ├── Dockerfile ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── example-config.yaml ├── example-schema-diesel-2.rs ├── example-schema.rs ├── rust-reason.cabal ├── src ├── ConfigurationParser.hs ├── Helpers.hs ├── SchemaParser.hs ├── SchemaPrinter.hs ├── Types.hs └── Yaml.hs ├── stack.yaml ├── stack.yaml.lock ├── test.sh ├── test └── Spec.hs └── tests ├── example-config-reason-snapshot.txt ├── example-config-reason.yaml ├── example-config-rescript-snapshot.txt ├── example-config-rescript.yaml └── example-schema.rs /.dockerignore: -------------------------------------------------------------------------------- 1 | # docker 2 | .dockerignore 3 | Dockerfile 4 | 5 | # git 6 | .git/ 7 | .gitignore 8 | 9 | # cabal-install 10 | dist-newstyle/ 11 | cabal.project.local 12 | 13 | # my editor(s) 14 | *.swp 15 | *.swo 16 | *.swn 17 | *~ 18 | 19 | # documentation 20 | README.md 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | schema.rs 2 | config.yaml 3 | .stack-work/ 4 | *~ 5 | *.re 6 | dist 7 | dist-* 8 | cabal-dev 9 | *.o 10 | *.hi 11 | *.hie 12 | *.chi 13 | *.chs.h 14 | *.dyn_o 15 | *.dyn_hi 16 | .hpc 17 | .hsenv 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | *.prof 21 | *.aux 22 | *.hp 23 | *.eventlog 24 | .stack-work/ 25 | cabal.project.local 26 | cabal.project.local~ 27 | .HTF/ 28 | .ghc.environment.* 29 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Format module header 19 | # 20 | # Currently, this option is not configurable and will format all exports and 21 | # module declarations to minimize diffs 22 | # 23 | # - module_header: 24 | # # How many spaces use for indentation in the module header. 25 | # indent: 4 26 | # 27 | # # Should export lists be sorted? Sorting is only performed within the 28 | # # export section, as delineated by Haddock comments. 29 | # sort: true 30 | # 31 | # # See `separate_lists` for the `imports` step. 32 | # separate_lists: true 33 | # 34 | # # When to break the "where". 35 | # # Possible values: 36 | # # - exports: only break when there is an explicit export list. 37 | # # - single: only break when the export list counts more than one export. 38 | # # - inline: only break when the export list is too long. This is 39 | # # determined by the `columns` setting. Not applicable when the export 40 | # # list contains comments as newlines will be required. 41 | # # - always: always break before the "where". 42 | # break_where: exports 43 | # 44 | # # Where to put open bracket 45 | # # Possible values: 46 | # # - same_line: put open bracket on the same line as the module name, before the 47 | # # comment of the module 48 | # # - next_line: put open bracket on the next line, after module comment 49 | # open_bracket: next_line 50 | 51 | # Format record definitions. This is disabled by default. 52 | # 53 | # You can control the layout of record fields. The only rules that can't be configured 54 | # are these: 55 | # 56 | # - "|" is always aligned with "=" 57 | # - "," in fields is always aligned with "{" 58 | # - "}" is likewise always aligned with "{" 59 | # 60 | # - records: 61 | # # How to format equals sign between type constructor and data constructor. 62 | # # Possible values: 63 | # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. 64 | # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. 65 | # equals: "indent 2" 66 | # 67 | # # How to format first field of each record constructor. 68 | # # Possible values: 69 | # # - "same_line" -- "{" and first field goes on the same line as the data constructor. 70 | # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor 71 | # first_field: "indent 2" 72 | # 73 | # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. 74 | # field_comment: 2 75 | # 76 | # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. 77 | # deriving: 2 78 | # 79 | # # How many spaces to insert before "via" clause counted from indentation of deriving clause 80 | # # Possible values: 81 | # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. 82 | # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. 83 | # via: "indent 2" 84 | # 85 | # # Sort typeclass names in the "deriving" list alphabetically. 86 | # sort_deriving: true 87 | # 88 | # # Wheter or not to break enums onto several lines 89 | # # 90 | # # Default: false 91 | # break_enums: false 92 | # 93 | # # Whether or not to break single constructor data types before `=` sign 94 | # # 95 | # # Default: true 96 | # break_single_constructors: true 97 | # 98 | # # Whether or not to curry constraints on function. 99 | # # 100 | # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ 101 | # # 102 | # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ 103 | # # 104 | # # Default: false 105 | # curried_context: false 106 | 107 | # Align the right hand side of some elements. This is quite conservative 108 | # and only applies to statements where each element occupies a single 109 | # line. 110 | # Possible values: 111 | # - always - Always align statements. 112 | # - adjacent - Align statements that are on adjacent lines in groups. 113 | # - never - Never align statements. 114 | # All default to always. 115 | - simple_align: 116 | cases: always 117 | top_level_patterns: always 118 | records: always 119 | multi_way_if: always 120 | 121 | # Import cleanup 122 | - imports: 123 | # There are different ways we can align names and lists. 124 | # 125 | # - global: Align the import names and import list throughout the entire 126 | # file. 127 | # 128 | # - file: Like global, but don't add padding when there are no qualified 129 | # imports in the file. 130 | # 131 | # - group: Only align the imports per group (a group is formed by adjacent 132 | # import lines). 133 | # 134 | # - none: Do not perform any alignment. 135 | # 136 | # Default: global. 137 | align: global 138 | 139 | # The following options affect only import list alignment. 140 | # 141 | # List align has following options: 142 | # 143 | # - after_alias: Import list is aligned with end of import including 144 | # 'as' and 'hiding' keywords. 145 | # 146 | # > import qualified Data.List as List (concat, foldl, foldr, head, 147 | # > init, last, length) 148 | # 149 | # - with_alias: Import list is aligned with start of alias or hiding. 150 | # 151 | # > import qualified Data.List as List (concat, foldl, foldr, head, 152 | # > init, last, length) 153 | # 154 | # - with_module_name: Import list is aligned `list_padding` spaces after 155 | # the module name. 156 | # 157 | # > import qualified Data.List as List (concat, foldl, foldr, head, 158 | # init, last, length) 159 | # 160 | # This is mainly intended for use with `pad_module_names: false`. 161 | # 162 | # > import qualified Data.List as List (concat, foldl, foldr, head, 163 | # init, last, length, scanl, scanr, take, drop, 164 | # sort, nub) 165 | # 166 | # - new_line: Import list starts always on new line. 167 | # 168 | # > import qualified Data.List as List 169 | # > (concat, foldl, foldr, head, init, last, length) 170 | # 171 | # - repeat: Repeat the module name to align the import list. 172 | # 173 | # > import qualified Data.List as List (concat, foldl, foldr, head) 174 | # > import qualified Data.List as List (init, last, length) 175 | # 176 | # Default: after_alias 177 | list_align: after_alias 178 | 179 | # Right-pad the module names to align imports in a group: 180 | # 181 | # - true: a little more readable 182 | # 183 | # > import qualified Data.List as List (concat, foldl, foldr, 184 | # > init, last, length) 185 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 186 | # > init, last, length) 187 | # 188 | # - false: diff-safe 189 | # 190 | # > import qualified Data.List as List (concat, foldl, foldr, init, 191 | # > last, length) 192 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 193 | # > init, last, length) 194 | # 195 | # Default: true 196 | pad_module_names: true 197 | 198 | # Long list align style takes effect when import is too long. This is 199 | # determined by 'columns' setting. 200 | # 201 | # - inline: This option will put as much specs on same line as possible. 202 | # 203 | # - new_line: Import list will start on new line. 204 | # 205 | # - new_line_multiline: Import list will start on new line when it's 206 | # short enough to fit to single line. Otherwise it'll be multiline. 207 | # 208 | # - multiline: One line per import list entry. 209 | # Type with constructor list acts like single import. 210 | # 211 | # > import qualified Data.Map as M 212 | # > ( empty 213 | # > , singleton 214 | # > , ... 215 | # > , delete 216 | # > ) 217 | # 218 | # Default: inline 219 | long_list_align: inline 220 | 221 | # Align empty list (importing instances) 222 | # 223 | # Empty list align has following options 224 | # 225 | # - inherit: inherit list_align setting 226 | # 227 | # - right_after: () is right after the module name: 228 | # 229 | # > import Vector.Instances () 230 | # 231 | # Default: inherit 232 | empty_list_align: inherit 233 | 234 | # List padding determines indentation of import list on lines after import. 235 | # This option affects 'long_list_align'. 236 | # 237 | # - : constant value 238 | # 239 | # - module_name: align under start of module name. 240 | # Useful for 'file' and 'group' align settings. 241 | # 242 | # Default: 4 243 | list_padding: 4 244 | 245 | # Separate lists option affects formatting of import list for type 246 | # or class. The only difference is single space between type and list 247 | # of constructors, selectors and class functions. 248 | # 249 | # - true: There is single space between Foldable type and list of it's 250 | # functions. 251 | # 252 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 253 | # 254 | # - false: There is no space between Foldable type and list of it's 255 | # functions. 256 | # 257 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 258 | # 259 | # Default: true 260 | separate_lists: true 261 | 262 | # Space surround option affects formatting of import lists on a single 263 | # line. The only difference is single space after the initial 264 | # parenthesis and a single space before the terminal parenthesis. 265 | # 266 | # - true: There is single space associated with the enclosing 267 | # parenthesis. 268 | # 269 | # > import Data.Foo ( foo ) 270 | # 271 | # - false: There is no space associated with the enclosing parenthesis 272 | # 273 | # > import Data.Foo (foo) 274 | # 275 | # Default: false 276 | space_surround: false 277 | 278 | # Post qualify option moves any qualifies found in import declarations 279 | # to the end of the declaration. This also adjust padding for any 280 | # unqualified import declarations. 281 | # 282 | # - true: Qualified as is moved to the end of the 283 | # declaration. 284 | # 285 | # > import Data.Bar 286 | # > import Data.Foo qualified as F 287 | # 288 | # - false: Qualified remains in the default location and unqualified 289 | # imports are padded to align with qualified imports. 290 | # 291 | # > import Data.Bar 292 | # > import qualified Data.Foo as F 293 | # 294 | # Default: false 295 | post_qualify: false 296 | 297 | 298 | # Language pragmas 299 | - language_pragmas: 300 | # We can generate different styles of language pragma lists. 301 | # 302 | # - vertical: Vertical-spaced language pragmas, one per line. 303 | # 304 | # - compact: A more compact style. 305 | # 306 | # - compact_line: Similar to compact, but wrap each line with 307 | # `{-# LANGUAGE #-}'. 308 | # 309 | # - vertical_compact: Similar to vertical, but use only one language pragma. 310 | # 311 | # Default: vertical. 312 | style: vertical 313 | 314 | # Align affects alignment of closing pragma brackets. 315 | # 316 | # - true: Brackets are aligned in same column. 317 | # 318 | # - false: Brackets are not aligned together. There is only one space 319 | # between actual import and closing bracket. 320 | # 321 | # Default: true 322 | align: true 323 | 324 | # stylish-haskell can detect redundancy of some language pragmas. If this 325 | # is set to true, it will remove those redundant pragmas. Default: true. 326 | remove_redundant: true 327 | 328 | # Language prefix to be used for pragma declaration, this allows you to 329 | # use other options non case-sensitive like "language" or "Language". 330 | # If a non correct String is provided, it will default to: LANGUAGE. 331 | language_prefix: LANGUAGE 332 | 333 | # Replace tabs by spaces. This is disabled by default. 334 | # - tabs: 335 | # # Number of spaces to use for each tab. Default: 8, as specified by the 336 | # # Haskell report. 337 | # spaces: 8 338 | 339 | # Remove trailing whitespace 340 | - trailing_whitespace: {} 341 | 342 | # Squash multiple spaces between the left and right hand sides of some 343 | # elements into single spaces. Basically, this undoes the effect of 344 | # simple_align but is a bit less conservative. 345 | # - squash: {} 346 | 347 | # A common setting is the number of columns (parts of) code will be wrapped 348 | # to. Different steps take this into account. 349 | # 350 | # Set this to null to disable all line wrapping. 351 | # 352 | # Default: 80. 353 | columns: 80 354 | 355 | # By default, line endings are converted according to the OS. You can override 356 | # preferred format here. 357 | # 358 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 359 | # 360 | # - lf: Convert to LF ("\n"). 361 | # 362 | # - crlf: Convert to CRLF ("\r\n"). 363 | # 364 | # Default: native. 365 | newline: native 366 | 367 | # Sometimes, language extensions are specified in a cabal file or from the 368 | # command line instead of using language pragmas in the file. stylish-haskell 369 | # needs to be aware of these, so it can parse the file correctly. 370 | # 371 | # No language extensions are enabled by default. 372 | # language_extensions: 373 | # - TemplateHaskell 374 | # - QuasiQuotes 375 | 376 | # Attempt to find the cabal file in ancestors of the current directory, and 377 | # parse options (currently only language extensions) from that. 378 | # 379 | # Default: true 380 | cabal: true 381 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for rust-reason 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:9.4.8 2 | 3 | WORKDIR /opt/app 4 | 5 | COPY app ./app 6 | COPY src ./src 7 | COPY Setup.hs rust-reason.cabal stack.yaml stack.yaml.lock ./ 8 | 9 | RUN stack install --system-ghc 10 | 11 | ENTRYPOINT ["rust-reason-exe"] 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Konfig (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | * Neither the name of Konfig nor the names of other contributors may be 16 | used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Rust Diesel -> ReasonML 2 | 3 | ## Rationale 4 | For more simple CRUD apps, there is often a near 1-1 mapping of types from DB, 5 | to API, to FE. This packages tries to take advantage of this fact, and create 6 | this mapping. Specifically from a Diesel / Rust `schema.rs` file, to a single 7 | file, that outputs ReasonML types in the conventional `Module.t` notation. 8 | It does so with reasonable flexibilty, allowing for: 9 | - Specifiying alias types 10 | - Specifiying mappings based on types and fieldnames (`table.field`) 11 | - Specifiying mappings for nested types 12 | - Add annotations (ppx's) for aliases and for types 13 | - Hide: 14 | - Modules (tables) 15 | - Fieldnames 16 | - Qualified types (`table.field`) 17 | 18 | 19 | ## Usage 20 | ### Using Docker 21 | We provide a docker image that's synced with latest master, to make the process 22 | of diffing / generating these files easier. Given a project with the following 23 | folder structure: 24 | 25 | ``` 26 | xyz 27 | - app 28 | -- src 29 | ---- schema.rs 30 | - config.yaml 31 | ``` 32 | 33 | One should be able to run the following command: 34 | ``` 35 | docker run -v $(pwd):/mnt/xyz konfigxyz/rust-reason-parser /mnt/xyz/config.yaml /mnt/xyz/app/src/schema.rs 36 | ``` 37 | It works by mounting the entire project into the container, and subsequently 38 | running the parser on with the provided input. 39 | 40 | ### Building from scratch 41 | 42 | Pre-requisites: 43 | - [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) 44 | 45 | Pass in a filename and config file to the `stack run` command and get Reason 46 | parsed output. See `example-config.yaml` for an example config file. 47 | 48 | ``` 49 | stack run {example-config.yaml} {example-schema.rs} 50 | ``` 51 | 52 | ### Input 53 | `example-config.yaml` 54 | ```yaml 55 | language: reason 56 | types: 57 | aliases: 58 | - uuid->string 59 | containerized: 60 | - arrayT->array 61 | - listT->list 62 | - optionT->option 63 | base: 64 | - Uuid->uuid 65 | - Text->string 66 | - Bool->bool 67 | - Int4->int 68 | - Float4->float 69 | nested: 70 | - Array->array 71 | - Nullable->option 72 | qualified: 73 | - test.some_string->someRandomTypeName 74 | annotations: 75 | key-ppx: "@decco.key(\"{}\")" 76 | alias-ppx: 77 | - decco 78 | type-ppx: 79 | - decco 80 | - bs.deriving jsConverter 81 | hiding: 82 | tables: 83 | - hide_me 84 | keys: 85 | - hidden_id 86 | qualified: 87 | qualified_hide: 88 | - qualified_field 89 | - another_qualified_field 90 | ``` 91 | 92 | `example-schema.rs` 93 | ```rust 94 | table! { 95 | use diesel::sql_types::*; 96 | 97 | hide_me (hide_me_id) { 98 | hide_me_id -> Uuid, 99 | } 100 | } 101 | 102 | table! { 103 | use diesel::sql_types::*; 104 | 105 | qualified_shown (test_id) { 106 | qualified_field -> Text, 107 | } 108 | } 109 | 110 | table! { 111 | use diesel::sql_types::*; 112 | 113 | qualified_hide (test_id) { 114 | qualified_field -> Text, 115 | another_qualified_field -> Text, 116 | } 117 | } 118 | 119 | table! { 120 | use diesel::sql_types::*; 121 | 122 | test (test_id) { 123 | test_id -> Uuid, 124 | hidden_id -> Uuid, 125 | some_string -> Text, 126 | some_bool -> Bool, 127 | some_int -> Int4, 128 | some_float -> Float4, 129 | some_array -> Array, 130 | some_option -> Nullable, 131 | } 132 | } 133 | ``` 134 | #### Output 135 | ```reason 136 | [@decco] 137 | type uuid = string; 138 | 139 | // module HideMe = { }; 140 | 141 | module QualifiedShown = { 142 | [@decco] 143 | [@bs.deriving jsConverter] 144 | type t = { 145 | @decco.key("qualified_field") qualifiedField: string, 146 | }; 147 | 148 | [@decco] 149 | type arrayT = array(t); 150 | 151 | [@decco] 152 | type listT = list(t); 153 | 154 | [@decco] 155 | type optionT = option(t); 156 | }; 157 | 158 | module QualifiedHide = { 159 | [@decco] 160 | [@bs.deriving jsConverter] 161 | type t = { 162 | // @decco.key("qualified_field") qualifiedField: string, 163 | // @decco.key("another_qualified_field") anotherQualifiedField: string, 164 | }; 165 | 166 | [@decco] 167 | type arrayT = array(t); 168 | 169 | [@decco] 170 | type listT = list(t); 171 | 172 | [@decco] 173 | type optionT = option(t); 174 | }; 175 | 176 | module Test = { 177 | [@decco] 178 | [@bs.deriving jsConverter] 179 | type t = { 180 | @decco.key("test_id") testId: uuid, 181 | // @decco.key("hidden_id") hiddenId: uuid, 182 | @decco.key("some_string") someString: someRandomTypeName, 183 | @decco.key("some_bool") someBool: bool, 184 | @decco.key("some_int") someInt: int, 185 | @decco.key("some_float") someFloat: float, 186 | @decco.key("some_array") someArray: array(string), 187 | @decco.key("some_option") someOption: option(string), 188 | }; 189 | 190 | [@decco] 191 | type arrayT = array(t); 192 | 193 | [@decco] 194 | type listT = list(t); 195 | 196 | [@decco] 197 | type optionT = option(t); 198 | }; 199 | 200 | ``` 201 | 202 | ## Development 203 | 204 | - Build 205 | ```bash 206 | stack build 207 | ``` 208 | - Build & Run 209 | ```bash 210 | stack run {config.yaml} {filename.rs} 211 | ``` 212 | 213 | ## Configuration Keys (-vv) 214 | 215 | #### Language 216 | Either `reason` or `rescript`. 217 | 218 | #### Types.Aliases 219 | 220 | To keep the output self-contained, we allow for the specification of alias 221 | types, that get printed at the top of the output. 222 | 223 | #### Types.Containerized 224 | 225 | We found quite often we would need array types next to the regular ones, and 226 | those would need to be annotated with our PPX's. This is messy and clutters 227 | this approach where this file is / stays auto-generated. 228 | 229 | #### Types.Base 230 | 231 | These are the base mappings. Based on the `value` of the type in the 232 | `schema.rs`, we map the `value` of the type over. The name of the type get's 233 | passed as-is, only converted to camel-case. 234 | 235 | #### Types.Nested 236 | 237 | Whenever we encounter something like `Nullable` we need to know what to 238 | map it too. These mappings can be specified here. Note that **they recurse**. 239 | So given the configuration above, and the input type 240 | `Nullable>`, we would generate 241 | `option(array(option(int)))`. 242 | 243 | #### Types.Nested 244 | 245 | There may be cases where you don't want to switch based on the type's `value`, 246 | but rather on its `name`. For instance, when you want to save an convert a 247 | `string` to a `variant` type only relevant to the FE. This is where you would 248 | do that. 249 | 250 | #### Annotations.(Alias-PPX | Type-PPX | Containerized-PPX) 251 | 252 | PPX annotations can be used to annotate types so that they automatically get 253 | some extra nice-ties. Such as using 254 | [decco](https://github.com/reasonml-labs/decco) for automatic JSON conversion, 255 | or [bs-pancake](https://github.com/rolandpeelen/bs-pancake) to automatically 256 | generate lenses for each record entry. There are respectively intended for 257 | either aliases (which are printed at the top), or for the types themselves. 258 | Some PPX's, like [decco](https://github.com/reasonml-labs/decco) require a sort 259 | of bottom-up approach, where every type in a record is also annotated itself. 260 | Hence the `alias-ppx` field. The `containerized-ppx` is the latest addition for 261 | more flexibility. 262 | 263 | There is one additional annotation that has some special syntax. I've found that when using things like Decco, or Spice, while we want to use camelCased things locally, it could be that the database tables are named with something that is more used in your backend language (snake_case, PascalCase, whichever - I think the PG default is snake_case). You can use this key to still parse into camelCase, by annotating the original key with: `"@decco.key(\"{}\")"`. Note a few things: 264 | - The entire string is escaped, because yaml doesn't allow `@`. 265 | - The content within `{}` will be replaced with the original type-name. 266 | - You can enter anything there - so `"@spice.key(\"{}\")"` will also work. 267 | - Default Yaml escaping will apply 268 | 269 | #### Hiding.Tables 270 | 271 | If the API you're building has some tables that are not to be exposed to the 272 | FE, here's where you would specify them. They'll be commented out in the 273 | output. Given that Reason will try to convert as-little as possible, the 274 | comments will automatically dissapear. However, for the more full-stack 275 | oriented, it might be nice to keep it in there, hence commented as opposed to 276 | deleted. 277 | 278 | #### Hiding.Keys 279 | 280 | Sometimes one doesn't want to hide a full `table`, but instead a `key` that 281 | occurs on a bunch of tables. For instance a `userId` or `companyId`. 282 | 283 | #### Hiding.Qualified 284 | 285 | This is the more specific variant to `tables` / `keys`. It allows for the full 286 | specification of hiding (`user.password`) for instance. 287 | 288 | **NOTE** - There is a difference in qualified notation between `types` and 289 | `hiding`. Reasoning here is that hiding multiple elements from a type is more 290 | common than having multiple `convert-by-typename` elements. 291 | 292 | 293 | ## TODO 294 | - [ ] - Build 'the' definitive mapping as a good default 295 | - [ ] - Build this in CI 296 | - [ ] - Tests... 297 | - [ ] - Homebrew / ... ? 298 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import ConfigurationParser 6 | import qualified Data.Text as T 7 | import SchemaParser 8 | import SchemaPrinter 9 | import System.Environment (getArgs) 10 | import Types 11 | 12 | main :: IO () 13 | main = do 14 | [configFile, schemaFile] <- getArgs 15 | 16 | configuration <- makeConfig configFile 17 | contents <- readFile schemaFile 18 | 19 | putStrLn $ 20 | T.unpack $ 21 | case parseSchema (T.pack contents) of 22 | Left err -> T.pack $ show err 23 | Right schema -> printTypeAliases configuration <> printSchema configuration schema 24 | -------------------------------------------------------------------------------- /example-config.yaml: -------------------------------------------------------------------------------- 1 | language: reason 2 | types: 3 | aliases: 4 | - uuid->string 5 | containerized: 6 | - arrayT->array 7 | - listT->list 8 | - optionT->option 9 | base: 10 | - Uuid->uuid 11 | - Text->string 12 | - Bool->bool 13 | - Int4->int 14 | - Float4->float 15 | nested: 16 | - Array->array 17 | - Nullable->option 18 | qualified: 19 | - test.some_string->someRandomTypeName 20 | annotations: 21 | key-ppx: "@decco.key(\"{}\")" 22 | alias-ppx: 23 | - decco 24 | type-ppx: 25 | - decco 26 | - bs.deriving jsConverter 27 | containerized-ppx: 28 | - decco 29 | hiding: 30 | tables: 31 | - hide_me 32 | keys: 33 | - hidden_id 34 | qualified: 35 | qualified_hide: 36 | - qualified_field 37 | - another_qualified_field 38 | -------------------------------------------------------------------------------- /example-schema-diesel-2.rs: -------------------------------------------------------------------------------- 1 | // @generated automatically by Diesel CLI. 2 | 3 | diesel::table! { 4 | use diesel::sql_types::*; 5 | 6 | hide_me (hide_me_id) { 7 | hide_me_id -> Uuid, 8 | } 9 | } 10 | 11 | diesel::table! { 12 | use diesel::sql_types::*; 13 | 14 | qualified_shown (test_id) { 15 | qualified_field -> Text, 16 | } 17 | } 18 | 19 | diesel::table! { 20 | use diesel::sql_types::*; 21 | 22 | qualified_hide (test_id) { 23 | qualified_field -> Text, 24 | another_qualified_field -> Text, 25 | } 26 | } 27 | 28 | diesel::table! { 29 | use diesel::sql_types::*; 30 | 31 | test (test_id) { 32 | test_id -> Uuid, 33 | hidden_id -> Uuid, 34 | some_string -> Text, 35 | some_bool -> Bool, 36 | some_int -> Int4, 37 | some_float -> Float4, 38 | some_array -> Array, 39 | some_option -> Nullable, 40 | } 41 | } 42 | 43 | diesel::joinable!(foo -> bar (bar_id)); 44 | 45 | diesel::allow_tables_to_appear_in_same_query!( 46 | bar, 47 | ); 48 | -------------------------------------------------------------------------------- /example-schema.rs: -------------------------------------------------------------------------------- 1 | table! { 2 | use diesel::sql_types::*; 3 | 4 | hide_me (hide_me_id) { 5 | hide_me_id -> Uuid, 6 | } 7 | } 8 | 9 | table! { 10 | use diesel::sql_types::*; 11 | 12 | qualified_shown (test_id) { 13 | qualified_field -> Text, 14 | } 15 | } 16 | 17 | table! { 18 | use diesel::sql_types::*; 19 | 20 | qualified_hide (test_id) { 21 | qualified_field -> Text, 22 | another_qualified_field -> Text, 23 | } 24 | } 25 | 26 | table! { 27 | use diesel::sql_types::*; 28 | 29 | test (test_id) { 30 | test_id -> Uuid, 31 | hidden_id -> Uuid, 32 | some_string -> Text, 33 | some_bool -> Bool, 34 | some_int -> Int4, 35 | some_float -> Float4, 36 | some_array -> Array, 37 | some_option -> Nullable, 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /rust-reason.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: d638651666de833bab61ad9a173ef67bf5aabd3290dd88338fa71adc5cd880b5 8 | 9 | name: rust-reason 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/rust-reason#readme 13 | bug-reports: https://github.com/githubuser/rust-reason/issues 14 | author: Roland Peelen 15 | maintainer: roland@konfig.xyz 16 | copyright: 2021 Roland Peelen 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/githubuser/rust-reason 27 | 28 | library 29 | exposed-modules: 30 | ConfigurationParser 31 | Helpers 32 | SchemaParser 33 | SchemaPrinter 34 | Types 35 | Yaml 36 | other-modules: 37 | Paths_rust_reason 38 | hs-source-dirs: 39 | src 40 | build-depends: 41 | base >=4.7 && <5 42 | , casing 43 | , containers 44 | , parsec 45 | , split 46 | , text 47 | , yaml 48 | , unordered-containers 49 | , deepseq 50 | , aeson 51 | default-language: Haskell2010 52 | 53 | executable rust-reason-exe 54 | main-is: Main.hs 55 | other-modules: 56 | Paths_rust_reason 57 | hs-source-dirs: 58 | app 59 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 60 | build-depends: 61 | base >=4.7 && <5 62 | , casing 63 | , containers 64 | , parsec 65 | , rust-reason 66 | , split 67 | , text 68 | , yaml 69 | , unordered-containers 70 | , deepseq 71 | , aeson 72 | default-language: Haskell2010 73 | 74 | test-suite rust-reason-test 75 | type: exitcode-stdio-1.0 76 | main-is: Spec.hs 77 | other-modules: 78 | Paths_rust_reason 79 | hs-source-dirs: 80 | test 81 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 82 | build-depends: 83 | base >=4.7 && <5 84 | , casing 85 | , containers 86 | , parsec 87 | , rust-reason 88 | , split 89 | , text 90 | , yaml 91 | , unordered-containers 92 | , deepseq 93 | , aeson 94 | default-language: Haskell2010 95 | -------------------------------------------------------------------------------- /src/ConfigurationParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module ConfigurationParser (makeConfig) where 5 | 6 | import Data.Bifunctor (first) 7 | import qualified Data.Map as M 8 | import Data.Maybe (mapMaybe) 9 | import qualified Data.Set as S 10 | import qualified Data.Text as T 11 | import Helpers (parseTypeSplitBy) 12 | import qualified Types as T 13 | import Yaml 14 | ( Config, 15 | keys, 16 | load, 17 | lookupDefault, 18 | subconfig, 19 | ) 20 | 21 | parseTypeMapConfiguration :: T.Text -> Maybe (T.Text, T.Text) 22 | parseTypeMapConfiguration = parseTypeSplitBy "->" 23 | 24 | toTypeMap :: [T.Text] -> T.Mapping 25 | toTypeMap = M.fromList . mapMaybe parseTypeMapConfiguration 26 | 27 | toQualified :: Config -> T.HiddenQualified 28 | toQualified xs = M.fromList $ map (\k -> (k, S.fromList $ lookupDefault k [] xs)) (keys xs) 29 | 30 | toLanguage :: T.Text -> T.Language 31 | toLanguage "reason" = T.Reason 32 | toLanguage "rescript" = T.Rescript 33 | toLanguage _ = T.Reason 34 | 35 | makeConfig :: String -> IO T.Configuration 36 | makeConfig path = do 37 | config <- load path 38 | types <- subconfig "types" config 39 | hiding <- subconfig "hiding" config 40 | annotations <- subconfig "annotations" config 41 | qualified <- subconfig "qualified" hiding 42 | 43 | pure $ 44 | T.Configuration 45 | (toLanguage $ lookupDefault "language" "reason" config) 46 | (lookupDefault "key-ppx" Nothing annotations) 47 | (lookupDefault "alias-ppx" [] annotations) 48 | (lookupDefault "type-ppx" [] annotations) 49 | (lookupDefault "containerized-ppx" [] annotations) 50 | (toTypeMap $ lookupDefault "aliases" [] types) 51 | (toTypeMap $ lookupDefault "containerized" [] types) 52 | (toTypeMap $ lookupDefault "base" [] types) 53 | (toTypeMap $ lookupDefault "nested" [] types) 54 | (toTypeMap $ lookupDefault "qualified" [] types) 55 | (S.fromList $ lookupDefault "tables" [] hiding) 56 | (S.fromList $ lookupDefault "keys" [] hiding) 57 | (toQualified qualified) 58 | -------------------------------------------------------------------------------- /src/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Helpers where 2 | 3 | import qualified Data.Map as M 4 | import qualified Data.Set as S 5 | import qualified Data.Text as T 6 | import qualified Text.Casing as C 7 | import Types 8 | import Prelude hiding (repeat) 9 | 10 | mergeQualified :: Configuration -> T.Text -> Hidden 11 | mergeQualified configuration typeName = case M.lookup typeName (qualified configuration) of 12 | Just xs -> S.union xs (keys configuration) 13 | Nothing -> keys configuration 14 | 15 | snakeToCamel :: T.Text -> T.Text 16 | snakeToCamel = T.pack . C.toCamel . C.fromSnake . T.unpack 17 | 18 | snakeToPascal :: T.Text -> T.Text 19 | snakeToPascal = T.pack . C.toPascal . C.fromSnake . T.unpack 20 | 21 | parseTypeSplitBy :: T.Text -> T.Text -> Maybe (T.Text, T.Text) 22 | parseTypeSplitBy c xs = case T.splitOn c xs of 23 | [x, y] -> Just (x, y) -- TODO - trim whitespace 24 | _ -> Nothing 25 | 26 | repeat :: Int -> T.Text -> T.Text 27 | repeat 0 c = T.pack "" 28 | repeat 1 c = c 29 | repeat i c = c <> repeat (i - 1) c 30 | -------------------------------------------------------------------------------- /src/SchemaParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module SchemaParser (parseTypeContainer, parseSchema) where 4 | 5 | import Control.Monad 6 | import Data.Set (member) 7 | import qualified Data.Text as T 8 | import Debug.Trace 9 | import Text.Parsec 10 | import Type.Reflection.Unsafe 11 | import Types 12 | 13 | data TypeName = Simple T.Text | Qualified (T.Text, T.Text) 14 | deriving (Eq, Ord) 15 | 16 | parseQualifiedType :: Parsec T.Text () (T.Text, T.Text) 17 | parseQualifiedType = do 18 | spaces 19 | base <- manyTill anyChar $ string "." 20 | nesting <- manyTill anyChar eof 21 | pure (T.pack base, T.pack nesting) 22 | 23 | parseTypeContainer :: Parsec T.Text () (T.Text, T.Text) 24 | parseTypeContainer = do 25 | containerType <- manyTill anyChar $ try $ string "<" 26 | valueType <- manyTill anyChar $ try $ string ">" <* (eof >> pure "") 27 | pure (T.pack containerType, T.pack valueType) 28 | 29 | parseType :: Parsec T.Text () (T.Text, T.Text) 30 | parseType = do 31 | spaces 32 | try $ optional (string "#[" <* manyTill anyChar (try $ string "]" <* spaces)) 33 | typeName <- manyTill anyChar $ spaces *> string "->" <* spaces 34 | typeVar <- manyTill anyChar $ string "," 35 | optional eof 36 | pure (T.pack typeName, T.pack typeVar) 37 | 38 | parseTable :: Parsec T.Text () (T.Text, [(T.Text, T.Text)]) 39 | parseTable = do 40 | optional $ string "diesel::" -- Diesel v2 41 | string "table! {" 42 | optional (spaces *> string "use" <* manyTill anyChar (try $ newline <* newline)) 43 | 44 | spaces 45 | typeName <- manyTill anyChar $ try space 46 | spaces 47 | 48 | try $ manyTill anyChar (try $ string "{") 49 | contents <- manyTill (try parseType) (try $ spaces *> string "}") 50 | spaces 51 | 52 | string "}" 53 | pure (T.pack typeName, contents) 54 | 55 | sqlTypes = do 56 | string "pub mod sql_types {" <* try spaces 57 | manyTill anyChar (try (string "}")) 58 | 59 | parseSchema :: T.Text -> Either ParseError [(T.Text, [(T.Text, T.Text)])] 60 | parseSchema = runParser schemaParser () "Error Parsing" 61 | where 62 | schemaParser = do 63 | optional $ string "// @generated automatically by Diesel CLI." <* spaces 64 | optional sqlTypes <* spaces 65 | manyTill (try parseTable <* spaces) $ try (optional $ string "diesel::" <* string "joinable" <|> (eof >> pure "")) 66 | -------------------------------------------------------------------------------- /src/SchemaPrinter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module SchemaPrinter (printTypeAliases, printSchema) where 4 | 5 | import qualified Data.List as L 6 | import qualified Data.Map as M 7 | import Data.Maybe (fromJust, isJust) 8 | import qualified Data.Set as S 9 | import qualified Data.Text as T 10 | import Helpers 11 | import SchemaParser 12 | import Text.Parsec 13 | import Types 14 | 15 | printTypeAlias :: Configuration -> (T.Text, T.Text) -> T.Text 16 | printTypeAlias configuration (x, y) = 17 | printPPXs 0 configuration (aliasPPX configuration) <> "type " <> x <> " = " <> y <> semi 18 | where 19 | semi = case language configuration of 20 | Rescript -> "" 21 | Reason -> ";" 22 | 23 | printTypeAliases :: Configuration -> T.Text 24 | printTypeAliases configuration = 25 | T.intercalate 26 | "\n" 27 | ( map (printTypeAlias configuration) $ 28 | M.toList $ 29 | aliases configuration 30 | ) 31 | <> "\n\n" 32 | 33 | printTypeContainer :: Configuration -> Either ParseError (T.Text, T.Text) -> T.Text 34 | printTypeContainer configuration (Left y) = T.pack $ "Parse error: " <> show y 35 | printTypeContainer configuration (Right (x, value)) 36 | | isJust key = fromJust key <> nesting 37 | | otherwise = x <> nesting 38 | where 39 | key = M.lookup x $ nested configuration 40 | nesting = lBrack <> printTypeValue configuration value <> rBrack 41 | (lBrack, rBrack) = case language configuration of 42 | Rescript -> ("<", ">") 43 | Reason -> ("(", ")") 44 | 45 | printTypeValue :: Configuration -> T.Text -> T.Text 46 | printTypeValue configuration typeName 47 | | isJust key = fromJust key 48 | | otherwise = printTypeContainer configuration (runParser parseTypeContainer () "Error" typeName) 49 | where 50 | key = M.lookup typeName $ base configuration 51 | 52 | adaptKeyPPX :: Configuration -> T.Text -> T.Text 53 | adaptKeyPPX configuration typeName = case keyPPX configuration of 54 | Just keyPPX -> T.replace (T.pack "{}") typeName keyPPX <> " " <> snakeCaseTypename 55 | Nothing -> snakeCaseTypename 56 | where 57 | snakeCaseTypename = snakeToCamel typeName 58 | 59 | printType :: Configuration -> T.Text -> TypePair -> T.Text 60 | printType configuration tableName (typeName, typeValue) 61 | | S.member typeName mergedQualifiedKeys = "// " <> typeString 62 | | isJust qualifiedTypeString = fromJust qualifiedTypeString 63 | | otherwise = typeString 64 | where 65 | mergedQualifiedKeys = mergeQualified configuration tableName 66 | typeStringLHS = typeNameWithKeyPPX <> ": " 67 | typeNameWithKeyPPX = adaptKeyPPX configuration typeName 68 | qualifiedTypeString = 69 | fmap (typeStringLHS <>) $ 70 | M.lookup (tableName <> "." <> typeName) $ 71 | qualifiedTypes configuration 72 | typeString = typeStringLHS <> printTypeValue configuration typeValue 73 | 74 | printModuleName :: T.Text -> T.Text 75 | printModuleName xs = "module " <> snakeToPascal xs <> " = " 76 | 77 | printTableName :: Configuration -> T.Text -> Visibility T.Text -> T.Text 78 | printTableName configuration tableName (Visible types) = printModuleName tableName <> "{\n" <> types <> "\n}" <> semi 79 | where 80 | semi = case language configuration of 81 | Rescript -> "" 82 | Reason -> ";" 83 | printTableName configuration tableName Hidden = "// " <> printModuleName tableName <> "{ }" <> semi 84 | where 85 | semi = case language configuration of 86 | Rescript -> "" 87 | Reason -> ";" 88 | 89 | printPPXs :: Int -> Configuration -> [T.Text] -> T.Text 90 | printPPXs i configuration = T.concat . map (\x -> Helpers.repeat i " " <> before <> x <> after <> "\n") 91 | where 92 | (before, after) = case language configuration of 93 | Rescript -> ("@", "") 94 | Reason -> ("[@", "]") 95 | 96 | printTypePPXs :: Configuration -> T.Text 97 | printTypePPXs configuration = printPPXs 2 configuration $ typePPX configuration 98 | 99 | printContainerizedPPXs :: Configuration -> T.Text 100 | printContainerizedPPXs configuration = printPPXs 2 configuration $ containerizedPPX configuration 101 | 102 | printContainerTypeAliases :: Configuration -> T.Text 103 | printContainerTypeAliases configuration = case p of 104 | [] -> T.pack "" 105 | xs -> "\n\n" <> T.intercalate "\n\n" p 106 | where 107 | p = 108 | ( \(x, y) -> 109 | printContainerizedPPXs configuration 110 | <> " type " 111 | <> x 112 | <> " = " 113 | <> y 114 | <> lBrack 115 | <> "t" 116 | <> rBrack 117 | <> semi 118 | ) 119 | <$> M.toList (containerized configuration) 120 | (lBrack, rBrack, semi) = case language configuration of 121 | Rescript -> ("<", ">", "") 122 | Reason -> ("(", ")", ";") 123 | 124 | printTableTypes :: Configuration -> T.Text -> [TypePair] -> T.Text 125 | printTableTypes configuration tableName xs = 126 | printTypePPXs configuration 127 | <> " type t = {\n " 128 | <> T.intercalate ",\n " (fmap (printType configuration tableName) xs) 129 | <> ",\n }" 130 | <> semi 131 | <> printContainerTypeAliases configuration 132 | where 133 | semi = case language configuration of 134 | Rescript -> "" 135 | Reason -> ";" 136 | 137 | printTable :: Configuration -> Table -> T.Text 138 | printTable configuration (tableName, types) 139 | | S.member tableName (tables configuration) = printTableName configuration tableName Hidden 140 | | otherwise = printTableName configuration tableName (Visible $ printTableTypes configuration tableName types) 141 | 142 | printSchema :: Configuration -> Schema -> T.Text 143 | printSchema configuration = T.intercalate "\n\n" . map (printTable configuration) 144 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import qualified Data.Map as M 4 | import qualified Data.Set as S 5 | import qualified Data.Text as T 6 | 7 | ------------------ 8 | -- Schema Types 9 | ------------------ 10 | type TypePair = (T.Text, T.Text) 11 | 12 | type Table = (T.Text, [TypePair]) 13 | 14 | type Schema = [Table] 15 | 16 | data Visibility a = Visible a | Hidden 17 | deriving (Eq, Ord) 18 | 19 | ------------------ 20 | -- Configuration Types 21 | ------------------ 22 | type Mapping = M.Map T.Text T.Text 23 | 24 | type Hidden = S.Set T.Text 25 | 26 | type HiddenQualified = M.Map T.Text (S.Set T.Text) 27 | 28 | data Language = Reason | Rescript deriving (Show) 29 | 30 | data Configuration = Configuration 31 | { language :: Language, 32 | keyPPX :: Maybe T.Text, 33 | aliasPPX :: [T.Text], 34 | typePPX :: [T.Text], 35 | containerizedPPX :: [T.Text], 36 | aliases :: Mapping, 37 | containerized :: Mapping, 38 | base :: Mapping, 39 | nested :: Mapping, 40 | qualifiedTypes :: Mapping, 41 | tables :: Hidden, 42 | keys :: Hidden, 43 | qualified :: HiddenQualified 44 | } 45 | deriving (Show) 46 | -------------------------------------------------------------------------------- /src/Yaml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Yaml 6 | ( -- * Types 7 | Config (..), 8 | KeyError (..), 9 | Key, 10 | 11 | -- * Loading 12 | load, 13 | 14 | -- * Access functions 15 | keys, 16 | subconfig, 17 | lookup, 18 | lookupDefault, 19 | fullpath, 20 | ) 21 | where 22 | 23 | import Control.DeepSeq (NFData (rnf)) 24 | import Control.Exception (Exception, throw) 25 | import Control.Monad (foldM) 26 | import qualified Data.Aeson as Aeson 27 | import Data.Aeson.Key (fromText, toText) 28 | import qualified Data.Aeson.KeyMap as KeyMap 29 | import Data.Maybe (fromMaybe) 30 | import Data.Monoid ((<>)) 31 | import qualified Data.Text as ST 32 | import Data.Typeable (Typeable) 33 | import Data.Yaml (FromJSON (parseJSON), Object, parseMaybe) 34 | import qualified Data.Yaml as Yaml 35 | import Prelude hiding (lookup) 36 | 37 | -- | Config or field name 38 | type Key = Aeson.Key 39 | 40 | type QueryKey = ST.Text 41 | 42 | -- | This error can be raised if config has not target path. 43 | newtype KeyError = KeyError Key 44 | deriving (Show, Typeable) 45 | 46 | instance Exception KeyError 47 | 48 | -- | Type contains config section and path from root. 49 | data Config = Config [Key] Object 50 | deriving (Eq, Show) 51 | 52 | instance NFData Config where 53 | rnf (Config p o) = rnf p `seq` rnf o 54 | 55 | ke :: (Monad m) => Key -> m a 56 | ke = throw . KeyError 57 | 58 | -- | Returns full path from the root to the given key. 59 | -- Levels are separated by dots. 60 | -- 61 | -- >>> fullpath sub "field1" 62 | -- "section1.field1" 63 | fullpath :: Config -> Key -> Key 64 | fullpath (Config parents _) path = 65 | fromText $ ST.intercalate "." $ reverse $ map toText (path : parents) 66 | 67 | newtype YamlException = Error String 68 | deriving (Show, Typeable) 69 | 70 | instance Exception YamlException 71 | 72 | validate f (Right object) = Config [] object 73 | validate f (Left err) = throw $ Error $ show err 74 | 75 | -- | Attempts to load a config from a given YAML file. 76 | -- Fails with @InvalidYaml@ if the file does not exist. 77 | -- 78 | -- >>> config <- load "example.yaml" 79 | load :: FilePath -> IO Config 80 | load f = do 81 | parse <- Yaml.decodeFileEither f 82 | return $ validate f parse 83 | 84 | -- | Returns all toplevel keys in a config. 85 | -- 86 | -- >>> keys config 87 | -- ["section1","section2"] 88 | keys :: Config -> [QueryKey] 89 | keys (Config _ o) = map toText $ KeyMap.keys o 90 | 91 | -- | Returns a value for a given key. 92 | -- Fails with a @KeyError@ if the key doesn't exist. 93 | -- 94 | -- >>> keys sub 95 | -- ["field1","field2"] 96 | -- >>> putStrLn =<< lookup "field1" sub 97 | -- value1 98 | lookup :: 99 | (Monad m, FromJSON a) => 100 | -- | Field name 101 | QueryKey -> 102 | -- | Config to query 103 | Config -> 104 | -- | Looked up value 105 | m a 106 | lookup path c = maybe err return $ lookupMaybe path c 107 | where 108 | err = ke $ "Field " <> fullpath c (fromText path) <> " not found or has wrong type." 109 | 110 | -- | An exception-free alternative to @lookup@. 111 | -- 112 | -- >>> keys sub 113 | -- ["field1","field2"] 114 | -- >>> lookupMaybe "field1" sub 115 | -- Just "value1" 116 | lookupMaybe :: (FromJSON a) => QueryKey -> Config -> Maybe a 117 | lookupMaybe path conf = 118 | foldM (flip subconfig) conf (init $ map fromText pathes) 119 | >>= look (last $ map fromText pathes) 120 | where 121 | look k (Config _ o) = KeyMap.lookup k o >>= parseMaybe parseJSON 122 | pathes = ST.splitOn "." path 123 | 124 | -- | Returns a value for a given key or a default value if a key doesn't exist. 125 | -- 126 | -- >>> lookupDefault "field3" "def" sub 127 | -- "def" 128 | lookupDefault :: 129 | (FromJSON a) => 130 | -- | Field name 131 | QueryKey -> 132 | -- | Default value 133 | a -> 134 | -- | Config to query 135 | Config -> 136 | -- | Looked up or default value 137 | a 138 | lookupDefault p d = fromMaybe d . lookupMaybe p 139 | 140 | -- | Narrows into a config section corresponding to a given key. 141 | -- Fails with a @KeyError@ if a key doesn't exist at the current level. 142 | -- 143 | -- >>> :set -XOverloadedStrings 144 | -- >>> sub <- subconfig "section1" config 145 | subconfig :: 146 | (Monad m) => 147 | -- | Subconfig name 148 | Key -> 149 | -- | (Sub)Config to narrow into 150 | Config -> 151 | -- | Subconfig 152 | m Config 153 | subconfig path c@(Config parents o) = case KeyMap.lookup path o of 154 | Just (Yaml.Object so) -> return $ Config (path : parents) so 155 | Just Yaml.Null -> return $ Config (path : parents) KeyMap.empty 156 | Nothing -> err 157 | where 158 | err = ke $ "Subconfig " <> fullpath c path <> " not found." 159 | -------------------------------------------------------------------------------- /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 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/23.yaml 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 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | extra-deps: 44 | - yaml-config-0.4.0@sha256:575103d9fa1ef074a2b419256babaae7be5f5257f37adf3ed2601052415b2d83,1814 45 | 46 | # Override default flag values for local packages and extra-deps 47 | # flags: {} 48 | 49 | # Extra package databases containing global packages 50 | # extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=2.5" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor 69 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: yaml-config-0.4.0@sha256:575103d9fa1ef074a2b419256babaae7be5f5257f37adf3ed2601052415b2d83,1814 9 | pantry-tree: 10 | sha256: 504d63293d50f9949a1130abcaf1885f10df61a658cba854fb704521ba797c91 11 | size: 347 12 | original: 13 | hackage: yaml-config-0.4.0@sha256:575103d9fa1ef074a2b419256babaae7be5f5257f37adf3ed2601052415b2d83,1814 14 | snapshots: 15 | - completed: 16 | sha256: 8809197159ce65ec2d66f91982e4844ad0c2cbd1126df42146dd103c0ea6cac0 17 | size: 640063 18 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/23.yaml 19 | original: 20 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/23.yaml 21 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | stack run tests/example-config-reason.yaml tests/example-schema.rs > tests/example-config-reason-snapshot.txt 2 | stack run tests/example-config-rescript.yaml tests/example-schema.rs > tests/example-config-rescript-snapshot.txt 3 | 4 | git diff --exit-code tests 5 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /tests/example-config-reason-snapshot.txt: -------------------------------------------------------------------------------- 1 | [@decco] 2 | type uuid = string; 3 | 4 | module Companies = { 5 | [@decco] 6 | [@bs.deriving jsConverter] 7 | type t = { 8 | id: uuid, 9 | companyName: string, 10 | createdAt: Js.Date.t, 11 | updatedAt: Js.Date.t, 12 | archivedAt: option(Js.Date.t), 13 | }; 14 | 15 | [@decco] 16 | type arrayT = array(t); 17 | 18 | [@decco] 19 | type listT = list(t); 20 | 21 | [@decco] 22 | type optionT = option(t); 23 | }; 24 | 25 | module Members = { 26 | [@decco] 27 | [@bs.deriving jsConverter] 28 | type t = { 29 | id: uuid, 30 | userId: uuid, 31 | companyId: uuid, 32 | role: Api.Types.Role.t, 33 | createdAt: Js.Date.t, 34 | updatedAt: Js.Date.t, 35 | archivedAt: option(Js.Date.t), 36 | }; 37 | 38 | [@decco] 39 | type arrayT = array(t); 40 | 41 | [@decco] 42 | type listT = list(t); 43 | 44 | [@decco] 45 | type optionT = option(t); 46 | }; 47 | 48 | module Users = { 49 | [@decco] 50 | [@bs.deriving jsConverter] 51 | type t = { 52 | id: uuid, 53 | email: string, 54 | password: string, 55 | blocked: bool, 56 | isSuperUser: bool, 57 | verified: bool, 58 | createdAt: Js.Date.t, 59 | updatedAt: Js.Date.t, 60 | archivedAt: option(Js.Date.t), 61 | }; 62 | 63 | [@decco] 64 | type arrayT = array(t); 65 | 66 | [@decco] 67 | type listT = list(t); 68 | 69 | [@decco] 70 | type optionT = option(t); 71 | }; 72 | -------------------------------------------------------------------------------- /tests/example-config-reason.yaml: -------------------------------------------------------------------------------- 1 | language: reason 2 | types: 3 | aliases: 4 | - uuid->string 5 | containerized: 6 | - arrayT->array 7 | - listT->list 8 | - optionT->option 9 | base: 10 | - Uuid->uuid 11 | - Text->string 12 | - Bool->bool 13 | - Int4->int 14 | - Float4->float 15 | - Timestamp->Js.Date.t 16 | nested: 17 | - Array->array 18 | - Nullable->option 19 | qualified: 20 | - members.role->Api.Types.Role.t 21 | annotations: 22 | alias-ppx: 23 | - decco 24 | type-ppx: 25 | - decco 26 | - bs.deriving jsConverter 27 | containerized-ppx: 28 | - decco 29 | hiding: 30 | tables: 31 | - hide_me 32 | keys: 33 | - hidden_id 34 | qualified: 35 | qualified_hide: 36 | - qualified_field 37 | - another_qualified_field 38 | -------------------------------------------------------------------------------- /tests/example-config-rescript-snapshot.txt: -------------------------------------------------------------------------------- 1 | @spice 2 | type uuid = string 3 | 4 | module Companies = { 5 | @spice 6 | type t = { 7 | id: uuid, 8 | companyName: string, 9 | createdAt: string, 10 | updatedAt: string, 11 | archivedAt: option, 12 | } 13 | 14 | @spice 15 | type arrayT = array 16 | }; 17 | 18 | module Members = { 19 | @spice 20 | type t = { 21 | id: uuid, 22 | userId: uuid, 23 | companyId: uuid, 24 | role: Api.Types.Role.t, 25 | createdAt: string, 26 | updatedAt: string, 27 | archivedAt: option, 28 | } 29 | 30 | @spice 31 | type arrayT = array 32 | }; 33 | 34 | module Users = { 35 | @spice 36 | type t = { 37 | id: uuid, 38 | email: string, 39 | password: string, 40 | blocked: bool, 41 | isSuperUser: bool, 42 | verified: bool, 43 | createdAt: string, 44 | updatedAt: string, 45 | archivedAt: option, 46 | } 47 | 48 | @spice 49 | type arrayT = array 50 | }; 51 | -------------------------------------------------------------------------------- /tests/example-config-rescript.yaml: -------------------------------------------------------------------------------- 1 | language: rescript 2 | types: 3 | aliases: 4 | - uuid->string 5 | base: 6 | - Uuid->uuid 7 | - Text->string 8 | - Bool->bool 9 | - Int2->int 10 | - Int4->int 11 | - Float8->float 12 | - Timestamp->string 13 | - Role->Api.Types.Role.t 14 | containerized: 15 | - arrayT->array 16 | nested: 17 | - Array->array 18 | - Nullable->option 19 | qualified: null 20 | annotations: 21 | alias-ppx: 22 | - spice 23 | type-ppx: 24 | - spice 25 | containerized-ppx: 26 | - spice 27 | hiding: 28 | tables: null 29 | keys: null 30 | qualified: null 31 | 32 | -------------------------------------------------------------------------------- /tests/example-schema.rs: -------------------------------------------------------------------------------- 1 | // @generated automatically by Diesel CLI. 2 | 3 | pub mod sql_types { 4 | #[derive(diesel::sql_types::SqlType)] 5 | #[diesel(postgres_type(name = "role"))] 6 | pub struct Role; 7 | } 8 | 9 | diesel::table! { 10 | use diesel::sql_types::*; 11 | 12 | companies (id) { 13 | id -> Uuid, 14 | company_name -> Text, 15 | created_at -> Timestamp, 16 | updated_at -> Timestamp, 17 | archived_at -> Nullable, 18 | } 19 | } 20 | 21 | diesel::table! { 22 | use diesel::sql_types::*; 23 | use super::sql_types::Role; 24 | 25 | members (id) { 26 | id -> Uuid, 27 | user_id -> Uuid, 28 | company_id -> Uuid, 29 | role -> Role, 30 | created_at -> Timestamp, 31 | updated_at -> Timestamp, 32 | archived_at -> Nullable, 33 | } 34 | } 35 | 36 | diesel::table! { 37 | use diesel::sql_types::*; 38 | 39 | users (id) { 40 | id -> Uuid, 41 | email -> Text, 42 | password -> Text, 43 | blocked -> Bool, 44 | is_super_user -> Bool, 45 | verified -> Bool, 46 | created_at -> Timestamp, 47 | updated_at -> Timestamp, 48 | archived_at -> Nullable, 49 | } 50 | } 51 | 52 | diesel::joinable!(members -> companies (company_id)); 53 | diesel::joinable!(members -> users (user_id)); 54 | 55 | diesel::allow_tables_to_appear_in_same_query!(companies, members, users,); 56 | 57 | --------------------------------------------------------------------------------