├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── config-value.cabal ├── config-value.vim ├── demo.txt ├── src ├── Config.hs └── Config │ ├── Lens.hs │ ├── Lexer.x │ ├── LexerUtils.hs │ ├── Macro.hs │ ├── Number.hs │ ├── NumberParser.y │ ├── Parser.y │ ├── Pretty.hs │ ├── Tokens.hs │ └── Value.hs └── test └── Main.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'config-value.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20240708 12 | # 13 | # REGENDATA ("0.19.20240708",["github","config-value.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.10.1 32 | compilerKind: ghc 33 | compilerVersion: 9.10.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.8.2 37 | compilerKind: ghc 38 | compilerVersion: 9.8.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.6.6 42 | compilerKind: ghc 43 | compilerVersion: 9.6.6 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.4.8 47 | compilerKind: ghc 48 | compilerVersion: 9.4.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.2.8 52 | compilerKind: ghc 53 | compilerVersion: 9.2.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.0.2 57 | compilerKind: ghc 58 | compilerVersion: 9.0.2 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.10.7 62 | compilerKind: ghc 63 | compilerVersion: 8.10.7 64 | setup-method: ghcup 65 | allow-failure: false 66 | fail-fast: false 67 | steps: 68 | - name: apt 69 | run: | 70 | apt-get update 71 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 72 | mkdir -p "$HOME/.ghcup/bin" 73 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 74 | chmod a+x "$HOME/.ghcup/bin/ghcup" 75 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 76 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 77 | env: 78 | HCKIND: ${{ matrix.compilerKind }} 79 | HCNAME: ${{ matrix.compiler }} 80 | HCVER: ${{ matrix.compilerVersion }} 81 | - name: Set PATH and environment variables 82 | run: | 83 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 84 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 85 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 86 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 87 | HCDIR=/opt/$HCKIND/$HCVER 88 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 89 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 90 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 91 | echo "HC=$HC" >> "$GITHUB_ENV" 92 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 93 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 94 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 95 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 96 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 97 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 98 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 99 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 100 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 101 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 102 | env: 103 | HCKIND: ${{ matrix.compilerKind }} 104 | HCNAME: ${{ matrix.compiler }} 105 | HCVER: ${{ matrix.compilerVersion }} 106 | - name: env 107 | run: | 108 | env 109 | - name: write cabal config 110 | run: | 111 | mkdir -p $CABAL_DIR 112 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 145 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 146 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 147 | rm -f cabal-plan.xz 148 | chmod a+x $HOME/.cabal/bin/cabal-plan 149 | cabal-plan --version 150 | - name: checkout 151 | uses: actions/checkout@v4 152 | with: 153 | path: source 154 | - name: initial cabal.project for sdist 155 | run: | 156 | touch cabal.project 157 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 158 | cat cabal.project 159 | - name: sdist 160 | run: | 161 | mkdir -p sdist 162 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 163 | - name: unpack 164 | run: | 165 | mkdir -p unpacked 166 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 167 | - name: generate cabal.project 168 | run: | 169 | PKGDIR_config_value="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/config-value-[0-9.]*')" 170 | echo "PKGDIR_config_value=${PKGDIR_config_value}" >> "$GITHUB_ENV" 171 | rm -f cabal.project cabal.project.local 172 | touch cabal.project 173 | touch cabal.project.local 174 | echo "packages: ${PKGDIR_config_value}" >> cabal.project 175 | echo "package config-value" >> cabal.project 176 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 177 | cat >> cabal.project <> cabal.project.local 180 | cat cabal.project 181 | cat cabal.project.local 182 | - name: dump install plan 183 | run: | 184 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 185 | cabal-plan 186 | - name: restore cache 187 | uses: actions/cache/restore@v4 188 | with: 189 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 190 | path: ~/.cabal/store 191 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 192 | - name: install dependencies 193 | run: | 194 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 195 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 196 | - name: build w/o tests 197 | run: | 198 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 199 | - name: build 200 | run: | 201 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 202 | - name: tests 203 | run: | 204 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 205 | - name: cabal check 206 | run: | 207 | cd ${PKGDIR_config_value} || false 208 | ${CABAL} -vnormal check 209 | - name: haddock 210 | run: | 211 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 212 | - name: unconstrained build 213 | run: | 214 | rm -f cabal.project.local 215 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 216 | - name: save cache 217 | uses: actions/cache/save@v4 218 | if: always() 219 | with: 220 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 221 | path: ~/.cabal/store 222 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-*/ 3 | .HTF/ 4 | log/ 5 | .cabal-sandbox/ 6 | .stack-work/ 7 | cabal-dev 8 | *# 9 | *.aux 10 | *.chi 11 | *.chs.h 12 | *.dSYM 13 | *.dylib 14 | *.dyn_hi 15 | *.dyn_o 16 | *.eventlog 17 | *.hi 18 | *.hp 19 | *.o 20 | *.a 21 | *.prof 22 | *.so 23 | *~ 24 | .*.swo 25 | .*.swp 26 | .DS_Store 27 | .hpc 28 | .hsenv 29 | TAGS 30 | cabal.project.local 31 | cabal.sandbox.config 32 | codex.tags 33 | docs 34 | stack.yaml 35 | tags 36 | wiki 37 | wip 38 | .ghc.environment.* 39 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.8.3 2 | --- 3 | * Add `prettyInline` for layout-free pretty-printing 4 | 5 | 0.8.2.1 6 | --- 7 | * Fix pretty-printing bug with long string literals 8 | 9 | 0.8.2 10 | --- 11 | * Add `+` and `-` to the set of layout-based list syntax bullets. 12 | All elements of the list are checked to see that a consistent 13 | bullet is used. Different bullets might be used to help make 14 | nested lists more understandable. `-` might be used to make things 15 | look more like YAML 16 | 17 | 0.8.1 18 | --- 19 | * Allow underscores in number literals 20 | Copied from 21 | 22 | Underscores are allowed and ignored 23 | - in the *middle* of integer-parts of the literal syntax 24 | - between base-markers (0x, 0o, 0b) and number part 25 | - before the `eEpP` part of an exponent 26 | 27 | 0.8 28 | --- 29 | * Allow atoms and section names to start with `@` or `$` 30 | * Add `Config.Macro` module 31 | 32 | 0.7.0.1 33 | --- 34 | 35 | * Fix pretty-printing of fractional, hexadecimal numbers 36 | 37 | 0.7.0.0 38 | --- 39 | * Updated number representation to preserve fractional part 40 | and added new `Config.Number` module with operations on 41 | this new type. 42 | 43 | 0.6.3.1 44 | --- 45 | * Build on GHC 8.4.1 46 | 47 | 0.6.3 48 | --- 49 | * Add `valuePlate` 50 | 51 | 0.6.2.1 52 | --- 53 | * Fixed error output for unexpected floating point literal 54 | 55 | 0.6.2 56 | --- 57 | * Nicer errors on unterminated inline lists and sections. 58 | * Stop enforcing well-formed text files 59 | 60 | 0.6.1 61 | --- 62 | * Add vim syntax highlighting file 63 | * Fix string gaps, they shouldn't require a newline 64 | 65 | 0.6 66 | --- 67 | * Annotate `Value` with file positions 68 | * Derive `Generic1` instances for `Value` 69 | 70 | 0.5.1 71 | --- 72 | * Allow trailing commas in lists and section lists 73 | * Support inline section lists using `{}` 74 | * Add more documentation 75 | 76 | 0.5 77 | ---- 78 | * Add support for floating-point numbers 79 | 80 | 0.4.0.2 81 | ---- 82 | * Internal lexer and parser improvements 83 | * Added support for `\&` escape sequence 84 | 85 | 0.4.0.1 86 | ---- 87 | * Loosen version constraints to build back to GHC 7.4.2 88 | * Remove unused bytestring dependency 89 | 90 | 0.4 91 | ---- 92 | * Make `Atom` a newtype to help distinguish it from `Text` 93 | * Add `values` traversal for traversing individual elements of a list 94 | 95 | 0.3 96 | ----- 97 | * Replace `yes` and `no` with generalized atoms 98 | * Add character index to error position 99 | * Add human readable error messages 100 | 101 | 0.2 102 | ----- 103 | * Take `Text` as the input to `parse` 104 | 105 | 0.1.1 106 | ----- 107 | * Added `Config.Lens` module 108 | * Added aligned fields to pretty printer 109 | 110 | 0.1 111 | ----- 112 | * Initial release 113 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Eric Mertens 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED “AS IS” AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # config-value 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/config-value.svg)](https://hackage.haskell.org/package/config-value) 4 | 5 | This package implements a simple, layout-based value definition language 6 | used for supplying configuration values to various applications. 7 | 8 | Before starting to use config-value, you probably want to read the documentation for [config-schema](https://github.com/glguy/config-schema) to see the user-friendly way to wrap this library. 9 | 10 | Live Demo 11 | -------- 12 | 13 | The config-value and config-schema packages are available in a [live demo](https://glguy.net/config-demo/). 14 | 15 | Example 16 | ------- 17 | ``` 18 | -- Line comments until newline 19 | layout: 20 | based: 21 | configuration: 22 | {} -- empty section 23 | 24 | inline-maps: {key1: value1, key2: value2} 25 | 26 | sections: 27 | "glguy" 28 | 29 | {- Block comments 30 | {- nested comments -} 31 | "O'caml style {- strings in comments" 32 | so you can comment out otherwise valid 33 | portions of your config 34 | -} 35 | atoms: yes 36 | 37 | decimal: -1234 38 | hexadecimal: 0x1234 39 | octal: 0o1234 40 | binary: 0b1010 41 | 42 | floats: [1e2, 0x3p-5, 24.48] 43 | underscores: 1_000_000 44 | 45 | lists: 46 | * sections: in-lists 47 | next-section: still-in-list 48 | * [ "inline", "lists" ] 49 | * * "nestable" 50 | * "layout" 51 | * "lists" 52 | * 3 53 | 54 | unicode: "standard Haskell format strings (1 ≤ 2)x2228(2 ≤ 3)" 55 | 56 | multiline: "haskell style\ 57 | \string gaps" 58 | ``` 59 | 60 | Format 61 | ------ 62 | 63 | The language supports: Strings, Atoms, Integers, Lists, Nested Sections. 64 | 65 | Sections are layout based. The contents of a section must be indented further than the section heading. 66 | The whitespace between a section heading and its colon is not significant. Section names must start with 67 | a letter and may contain letters, numbers, dashes (`-`), underscores (`_`), and periods (`.`). 68 | 69 | Lists are either layout based with `*` prefixes or inline surrounded by `[` and `]` delimited by `,` 70 | 71 | Strings are surrounded by `"` and use Haskell-style escapes. 72 | 73 | Numbers support decimal, hexadecimal (`0x`), octal (`0o`), and binary (`0b`). 74 | 75 | Atoms follow the same lexical rule as section heading. 76 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /config-value.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: config-value 3 | version: 0.8.3 4 | synopsis: Simple, layout-based value language similar to YAML or JSON 5 | license: ISC 6 | license-file: LICENSE 7 | author: Eric Mertens 8 | maintainer: emertens@gmail.com 9 | copyright: 2015-2016,2019 Eric Mertens 10 | category: Language 11 | build-type: Simple 12 | homepage: https://github.com/glguy/config-value 13 | bug-reports: https://github.com/glguy/config-value/issues 14 | description: This package implements a language similar to YAML or JSON but 15 | with fewer special cases and fewer dependencies. It emphasizes 16 | layout structure for sections and lists, and requires quotes 17 | around strings. 18 | tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.2, 9.10.1} 19 | 20 | extra-doc-files: 21 | README.md 22 | CHANGELOG.md 23 | config-value.vim 24 | 25 | library 26 | 27 | exposed-modules: 28 | Config 29 | Config.Lens 30 | Config.Number 31 | Config.Macro 32 | 33 | other-modules: 34 | Config.Lexer 35 | Config.LexerUtils 36 | Config.Parser 37 | Config.NumberParser 38 | Config.Tokens 39 | Config.Pretty 40 | Config.Value 41 | 42 | build-depends: 43 | base >= 4.8 && < 4.22, 44 | array >= 0.4 && < 0.6, 45 | containers >= 0.5 && < 0.8, 46 | pretty >= 1.1.1.0 && < 1.2, 47 | text >= 1.2.0.4 && < 2.2, 48 | 49 | build-tool-depends: 50 | alex:alex >= 3.2, 51 | happy:happy >= 1.19 && <2.2, 52 | 53 | hs-source-dirs: src 54 | default-language: Haskell2010 55 | 56 | source-repository head 57 | type: git 58 | location: git://github.com/glguy/config-value.git 59 | 60 | test-suite unit-tests 61 | type: exitcode-stdio-1.0 62 | main-is: Main.hs 63 | hs-source-dirs: test 64 | build-depends: base, config-value, text 65 | default-language: Haskell2010 66 | ghc-options: -Wall 67 | -------------------------------------------------------------------------------- /config-value.vim: -------------------------------------------------------------------------------- 1 | " Config-value syntax file 2 | " Language: config-value 3 | " Author: Eric Mertens 4 | 5 | if exists("b:current_syntax") 6 | finish 7 | endif 8 | 9 | " Reserved symbols 10 | syn match cvDelimiter "*\|:\|\[\|\]\|,\|{\|}\|=" 11 | 12 | " Strings and constants -- copied from haskell.vim 13 | syn match cvSpecialChar contained "\\\([\n\t ]*\\\|[0-9]\+\|o[0-7]\+\|x[0-9a-fA-F]\+\|[\"'&\\abfnrtv]\|\^[@A-Z^_\[\\\]]\)" 14 | syn match cvSpecialChar contained "\\\(NUL\|SOH\|STX\|ETX\|EOT\|ENQ\|ACK\|BEL\|BS\|HT\|LF\|VT\|FF\|CR\|SO\|SI\|DLE\|DC1\|DC2\|DC3\|DC4\|NAK\|SYN\|ETB\|CAN\|EM\|SUB\|ESC\|FS\|GS\|RS\|US\|SP\|DEL\)" 15 | syn region cvString start=+"+ skip=+\\\\\|\\"+ end=+"\|\n+ contains=cvSpecialChar 16 | syn match cvNumber "-\=\([0-9]\+\|0[xX][0-9a-fA-F]\+\|0[oO][0-7]\+\|0[bB][0-1]\+\)\>" 17 | syn match cvFloat "-\=[0-9]\+\.[0-9]\+\([eE][-+]\=[0-9]\+\)\=\>" 18 | syn match cvFloat "-\=[0-9]\+[eE][-+]\=[0-9]\+\>" 19 | 20 | syn match cvVariable "$[a-zA-Z0-9\._\-]*\>" 21 | syn match cvDirective "@[a-zA-Z0-9\._\-]*\>" 22 | syn match cvAtom "\<[a-zA-Z][a-zA-Z0-9\._\-]*\>" 23 | 24 | syn match cvLineComment "--.*$" 25 | syn region cvBlockComment start="{-" end="-}" contains=cvString,cvBlockComment 26 | 27 | hi def link cvVariable Macro 28 | hi def link cvDirective Include 29 | hi def link cvAtom Identifier 30 | hi def link cvDelimiter Delimiter 31 | 32 | hi def link cvSpecialChar SpecialChar 33 | hi def link cvString String 34 | hi def link cvNumber Number 35 | hi def link cvFloat Float 36 | 37 | hi def link cvBlockComment cvComment 38 | hi def link cvLineComment cvComment 39 | hi def link cvComment Comment 40 | 41 | let b:current_syntax = "config-value" 42 | 43 | setlocal commentstring=--%s 44 | setlocal comments=:-- 45 | let b:undo_ftplugin = "setl com< commentstring<" 46 | -------------------------------------------------------------------------------- /demo.txt: -------------------------------------------------------------------------------- 1 | -- Line comments until newline 2 | layout: 3 | based: 4 | configuration: 5 | {} -- empty section 6 | 7 | inline-maps: {key1: value1, key2: value2} 8 | 9 | sections: 10 | "glguy" 11 | 12 | {- Block comments 13 | {- nested comments -} 14 | "O'caml style {- strings in comments" 15 | so you can comment out otherwise valid 16 | portions of your config 17 | -} 18 | atoms: yes 19 | 20 | decimal: -1234 21 | hexadecimal: 0x1234 22 | octal: 0o1234 23 | binary: 0b1010 24 | 25 | floats: [1e2, 0x3p-5, 24.48] 26 | underscores: 1_000_000 27 | 28 | lists: 29 | * sections: in-lists 30 | next-section: still-in-list 31 | * [ "inline", "lists" ] 32 | * * "nestable" 33 | * "layout" 34 | * "lists" 35 | * 3 36 | 37 | unicode: "standard Haskell format strings (1 ≤ 2)x2228(2 ≤ 3)" 38 | 39 | multiline: "haskell style\ 40 | \string gaps" 41 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-| 3 | Module : Config 4 | Description : Configuration file parser and abstract syntax 5 | Copyright : (c) Eric Mertens, 2017 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module parses files using the syntax demonstrated below. 10 | The full lexical syntax is available in the Alex source file. 11 | The full grammar is available in the Happy source file. 12 | 13 | Configuration file schemas can be specified using the 14 | 15 | package. This package helps extract application-specific meaning 16 | from a 'Value', and can also generate documentation for the supported 17 | format. 18 | 19 | The @config-value@ format offers a simple, layout-based syntax for 20 | specifying configuration information. In addition configuration 21 | values can be pretty-printed back into valid concrete syntax. 22 | 23 | = Example 24 | 25 | @ 26 | -- Line comments until newline 27 | layout: 28 | based: 29 | configuration: 30 | {} -- empty section 31 | 32 | sections: 33 | "glguy" 34 | 35 | {- Block comments 36 | {- nested comments -} 37 | "O'caml style {- strings in comments" 38 | so you can comment out otherwise valid 39 | portions of your config 40 | -} 41 | atoms : yes 42 | 43 | decimal : -1234 44 | hexadecimal: 0x1234 45 | octal : 0o1234 46 | binary : 0b1010 47 | 48 | lists: 49 | * sections: in-lists 50 | next-section: still-in-list 51 | * [ "inline", "lists" ] 52 | * * "nestable" 53 | * "layout" 54 | * "lists" 55 | * 3 56 | 57 | unicode : "standard Haskell format strings (1 ≤ 2)\\x2228(2 ≤ 3)" 58 | @ 59 | 60 | = Syntax 61 | 62 | A configuration file should contain a single /value/ at the top-level. 63 | Typically this value will be a list of sections (as seen in the example 64 | above). 65 | 66 | Unicode character classes are fully supported. The alpha and digit character 67 | classes use the full Unicode range, rather than merely the ASCII ranges. 68 | 69 | There are 5 distinct types of values possible in a configuration file: 70 | 71 | * Sections list (list of key-value pairs) 72 | 73 | * Lists 74 | 75 | * Text 76 | 77 | * Numbers 78 | 79 | * Atoms 80 | 81 | == Sections list 82 | 83 | @ 84 | KEY: VALUE 85 | KEY: VALUE 86 | KEY: VALUE 87 | @ 88 | 89 | Sections lists are lists of key-value pairs. Each key in the list should 90 | start on the same column in the file. The value of the pair should be 91 | indented to the right of the key. 92 | 93 | The lexical syntax for section names is identical to the lexical syntax 94 | of /atoms/. Section names are nonempty sequences starting with an /alpha/, 95 | @$@ or @\@@ character followed by zero or more /alpha/, /digit/, /period/ (.), 96 | underscore (_), or dash (-). 97 | 98 | Section lists can be nested. 99 | 100 | Section lists can be used inline, without layout, but surrounding them 101 | with @{@ and @}@ and separating the sections with @,@. The empty sections 102 | list is specified with @{}@. 103 | 104 | Examples: 105 | 106 | @ 107 | key-1 : -- spaces are allowed between the section name and the colon 108 | key-1.1: value-1.1 109 | key-1.2: [ value-1.2 ] 110 | key-2: value-2 111 | key-3: {} -- the value for key-3 is the empty sections list 112 | key-4: { red: 1, blue: 2} -- inline syntax for sublist 113 | @ 114 | 115 | == List 116 | 117 | @ 118 | * VALUE 119 | * VALUE 120 | * VALUE 121 | @ 122 | 123 | Lists can be specified using either layout or inline syntax. There is no distinction 124 | between the two syntaxes in the abstract syntax. 125 | 126 | Inline lists are surrounded by @[@ and @]@ with elements separated by @,@. The final 127 | list element may be terminated with a trailing comma. 128 | 129 | Example: @[1, 2, 3]@ 130 | 131 | Layout list entries are started with a leading @*@, @+@, or @-@. Each leading bullet 132 | must occur in the some column of the file. Lists can be nested by starting the new 133 | list on a column to the right of the current list. A single list must use the same 134 | bullet token for every element of the list. Nested lists can choose a different 135 | bullet. This can help visually distinguish nested lists. 136 | 137 | Layout based lists can not occur inside inline list syntax. Layout based section lists 138 | can occur inside layout based lists 139 | 140 | Example: 141 | 142 | @ 143 | -- One list element containing an atom 144 | * item-1 145 | 146 | -- One list element containing a two element list 147 | * * item-2.1 148 | * item-2.2 149 | 150 | -- One list element containing two key-value pairs 151 | * key-1: value-1 152 | key-2: value-2 153 | @ 154 | 155 | == Text 156 | 157 | @ 158 | "quoted string literals" 159 | @ 160 | 161 | Text values are specified using the Haskell string literal syntax. 162 | 163 | Text values are distinct from /atoms/ described below. This allows 164 | a configuration file to make a distinction between the atom @default@ 165 | and the text value @"default"@, for example. 166 | 167 | For a detailed description of Haskell string literal syntax, see 168 | 169 | 170 | == Number 171 | 172 | @ 173 | 123.456 174 | @ 175 | 176 | Numbers can be written with integer and floating-point literals. 177 | 178 | Numbers can optionally be prefixed with a sign: @+@ or @-@. 179 | 180 | Digits can be separated using @_@. 181 | 182 | Bases 183 | 184 | * No prefix for decimal (base 10) integer literals. Base 10 exponents 185 | are specified with @e@. 186 | 187 | * Prefix binary (base 2) integer literals with @0b@ or @0B@ 188 | 189 | * Prefix octal (base 8) integer literals with @0o@ or @0O@ 190 | 191 | * Prefix hexadecimal (base 16) integer literals with @0x@ or @0X@. Upper 192 | and lower-cased hex digits are supported. Base 2 exponents are 193 | specified with @p@. 194 | 195 | List of examples: 196 | 197 | @ 198 | [ 0, 42, -42, +123.45, 6E7, 1e+10, 3.4e-5, 0xfF, 0b1010_1000, -0o77, 0xap10 ] 199 | @ 200 | 201 | == Atom 202 | 203 | @ 204 | unquoted-string 205 | @ 206 | 207 | /Atoms/ are unquoted strings that are distinct from normal /text/ values. 208 | This type is intended to represent enumerations in a configuration file. 209 | 210 | Atoms are nonempty sequences starting with an /alpha/, @$@, or @\@@ character 211 | followed by zero or more /alpha/, /digit/, /period/ (.), underscore (_), or 212 | dash (-). 213 | 214 | Lexical syntax: @$alpha [$alpha $digit $unidigit \\. _ \\-]*@ 215 | 216 | List of examples: 217 | 218 | @ 219 | [ yes, no, default, MODE-61 ] 220 | @ 221 | 222 | == Comments 223 | 224 | Comments are valid white-space. 225 | 226 | An ordinary comment begins with @--@ and extends to the following newline. 227 | 228 | @ 229 | -- This is a comment 230 | @ 231 | 232 | Use pairs of @{-@ and @-}@ to create comments that can span multiple 233 | lines. These comments can be nested. 234 | 235 | @ 236 | {- this {- is -} 237 | a comment -} 238 | @ 239 | 240 | -} 241 | module Config 242 | ( 243 | -- * Parsing 244 | parse 245 | , Position(..) 246 | 247 | -- * Pretty-printing 248 | , pretty 249 | , prettyInline 250 | 251 | -- * Types 252 | , Section(..) 253 | , Value(..) 254 | , Atom(..) 255 | , valueAnn 256 | 257 | -- * Numbers 258 | , Number 259 | , numberToInteger 260 | , numberToRational 261 | , integerToNumber 262 | , rationalToNumber 263 | 264 | -- * Errors 265 | , ParseError(..) 266 | ) where 267 | 268 | import Config.Number (Number, numberToInteger, numberToRational, integerToNumber, rationalToNumber) 269 | import Config.Value (Atom(..), Value(..), Section(..), valueAnn) 270 | import Config.Parser (parseValue) 271 | import Config.Pretty (pretty, prettyInline) 272 | import Config.Lexer (scanTokens) 273 | import Config.Tokens (Error(..), Position(..), Located(..), layoutPass, Token) 274 | import qualified Config.Tokens as T 275 | 276 | import Control.Exception (Exception(..)) 277 | import Data.Text (Text) 278 | import qualified Data.Text as Text 279 | 280 | -- | Parse a configuration file and return the result on the 281 | -- right, or the position of an error on the left. 282 | -- 283 | -- The resulting value is annotated with source file locations. 284 | -- 285 | -- Note: Text file lines are terminated by new-lines. 286 | parse :: 287 | Text {- ^ source text -} -> 288 | Either ParseError (Value Position) {- ^ error message or parsed value -} 289 | parse txt = 290 | case parseValue (layoutPass (scanTokens txt)) of 291 | Right x -> Right x 292 | Left (Located posn token) -> Left (ParseError posn (explainToken token)) 293 | 294 | -- | Error messages that can occur during parsing annotated with a file position. 295 | data ParseError = ParseError Position String 296 | deriving (Read, Show, Eq, Ord) 297 | 298 | -- | 'displayException' implements a pretty format 299 | instance Exception ParseError where 300 | displayException (ParseError posn msg) = 301 | "line " ++ show (posLine posn) ++ 302 | " column " ++ show (posColumn posn) ++ 303 | ": " ++ msg 304 | 305 | explainToken :: Token -> String 306 | explainToken token = 307 | case token of 308 | T.Error e -> explainError e 309 | T.Atom atom -> "parse error: unexpected atom: `" ++ Text.unpack atom ++ "`" 310 | T.String str -> "parse error: unexpected string: " ++ show (Text.unpack str) 311 | T.Bullet s -> "parse error: unexpected bullet '" ++ Text.unpack s ++ "'" 312 | T.Comma -> "parse error: unexpected comma ','" 313 | T.Section s -> "parse error: unexpected section: `" ++ Text.unpack s ++ "`" 314 | T.Number{} -> "parse error: unexpected number" 315 | T.OpenList -> "parse error: unexpected start of list '['" 316 | T.CloseList -> "parse error: unexpected end of list ']'" 317 | T.OpenMap -> "parse error: unexpected start of section '{'" 318 | T.CloseMap -> "parse error: unexpected end of section '}'" 319 | T.LayoutSep -> "parse error: unexpected end of block" 320 | T.LayoutEnd -> "parse error: unexpected end of block" 321 | T.EOF -> "parse error: unexpected end of file" 322 | 323 | explainError :: Error -> String 324 | explainError e = 325 | case e of 326 | T.UntermComment -> "lexical error: unterminated comment" 327 | T.UntermString -> "lexical error: unterminated string literal" 328 | T.UntermSections -> "lexical error: unterminated sections" 329 | T.UntermList -> "lexical error: unterminated list" 330 | T.BadEscape c -> "lexical error: bad escape sequence: " ++ Text.unpack c 331 | T.NoMatch c -> "lexical error at character " ++ show c 332 | -------------------------------------------------------------------------------- /src/Config/Lens.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Config.Lens 3 | Description : Lenses and traversals for manipulating 'Value' values. 4 | Copyright : (c) Eric Mertens, 2017 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | Lenses and traversals for compatibility with the lens package 9 | -} 10 | module Config.Lens 11 | ( key 12 | , text 13 | , atom 14 | , number 15 | , list 16 | , values 17 | , sections 18 | , ann 19 | , valuePlate 20 | ) where 21 | 22 | import Config.Number 23 | import Config.Value 24 | import Data.Text 25 | 26 | -- | Traversal for the subsections of the given 'Value' when 27 | -- that value is a 'Sections' and the section name matches the 28 | -- given name. 29 | key :: 30 | Applicative f => 31 | Text {- ^ section name -} -> 32 | (Value a -> f (Value a)) -> Value a -> f (Value a) 33 | key i = sections . traverse . section i 34 | 35 | -- | Traversal for the 'Value' contained inside the given 36 | -- 'Section' when its section name matches the given name. 37 | section :: 38 | Applicative f => 39 | Text {- ^ section name -} -> 40 | (Value a -> f (Value a)) -> Section a -> f (Section a) 41 | section i f s@(Section a j v) | i == j = Section a j <$> f v 42 | | otherwise = pure s 43 | 44 | -- | Traversal for the ['Section'] contained inside the given 45 | -- 'Value' when it is a 'Sections'. 46 | sections :: Applicative f => ([Section a] -> f [Section a]) -> Value a -> f (Value a) 47 | sections f (Sections a xs) = Sections a <$> f xs 48 | sections _ v = pure v 49 | 50 | -- | Traversal for the 'Text' contained inside the given 'Value'. 51 | text :: Applicative f => (Text -> f Text) -> Value a -> f (Value a) 52 | text f (Text a t) = Text a <$> f t 53 | text _ v = pure v 54 | 55 | -- | Traversal for the 'Atom' contained inside the given 'Value'. 56 | atom :: Applicative f => (Atom -> f Atom) -> Value a -> f (Value a) 57 | atom f (Atom a t) = Atom a <$> f t 58 | atom _ v = pure v 59 | 60 | -- | Traversal for the 'Number' contained inside the given 'Value'. 61 | number :: Applicative f => (Number -> f Number) -> Value a -> f (Value a) 62 | number f (Number a n) = Number a <$> f n 63 | number _ v = pure v 64 | 65 | -- | Traversal for the ['Value'] contained inside the given 66 | -- 'Value' when it is a 'List'. 67 | list :: Applicative f => ([Value a] -> f [Value a]) -> Value a -> f (Value a) 68 | list f (List a xs) = List a <$> f xs 69 | list _ v = pure v 70 | 71 | -- | Traversal for the immediate values in a list or a sections list. 72 | -- 73 | -- This is intended to be used with "Control.Lens.Plated". 74 | valuePlate :: Applicative f => (Value a -> f (Value a)) -> Value a -> f (Value a) 75 | valuePlate f (List a xs) = List a <$> traverse f xs 76 | valuePlate f (Sections a xs) = Sections a <$> traverse (sectionVal f) xs 77 | valuePlate _ v = pure v 78 | 79 | sectionVal :: Functor f => (Value a -> f (Value a)) -> Section a -> f (Section a) 80 | sectionVal f (Section a k v) = Section a k <$> f v 81 | 82 | -- | Traversal for the 'Value' elements inside the given 83 | -- 'Value' when it is a 'List'. 84 | -- 85 | -- @ 86 | -- 'values' = 'list' . 'traverse' 87 | -- @ 88 | values :: Applicative f => (Value a -> f (Value a)) -> Value a -> f (Value a) 89 | values = list . traverse 90 | 91 | 92 | -- | Lens for the annotation component of a 'Value' 93 | ann :: Functor f => (a -> f a) -> Value a -> f (Value a) 94 | ann f v = 95 | case v of 96 | Sections a x -> (\a' -> Sections a' x) <$> f a 97 | Number a x -> (\a' -> Number a' x) <$> f a 98 | Text a x -> (\a' -> Text a' x) <$> f a 99 | Atom a x -> (\a' -> Atom a' x) <$> f a 100 | List a x -> (\a' -> List a' x) <$> f a 101 | -------------------------------------------------------------------------------- /src/Config/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# OPTIONS_GHC -Wnot #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | module Config.Lexer 5 | ( scanTokens 6 | ) where 7 | 8 | import Config.LexerUtils 9 | import Config.Tokens 10 | import Data.Text (Text) 11 | import qualified Data.Text as Text 12 | 13 | } 14 | 15 | $uniupper = \x1 16 | $unilower = \x2 17 | $unidigit = \x3 18 | $unisymbol = \x4 19 | $unispace = \x5 20 | $uniother = \x6 21 | 22 | $asciialpha = [A-Z a-z] 23 | $digit = [0-9] 24 | $octit = [0-7] 25 | $hexit = [0-9a-fA-F] 26 | $binit = [0-1] 27 | $white_no_nl = $white # \n 28 | $charesc = [abfnrtv\\\"'&] 29 | $cntrl = [A-Z@\[\\\]\^_] 30 | $alpha = [$unilower $uniupper $asciialpha] 31 | 32 | @spacer = _* 33 | 34 | @decimal = $digit (@spacer $digit)* 35 | @octal = $octit (@spacer $octit)* 36 | @binary = $binit (@spacer $binit)* 37 | @hexadecimal = $hexit (@spacer $hexit)* 38 | 39 | -- Copied from Haskell 2010 40 | @ascii = \^ $cntrl 41 | | NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL 42 | | BS | HT | LF | VT | FF | CR | SO | SI 43 | | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB 44 | | CAN | EM | SUB | ESC | FS | GS | RS | US 45 | | SP | DEL 46 | @escape = $charesc 47 | | @ascii 48 | | $digit+ 49 | | o $octit+ 50 | | x $hexit+ 51 | 52 | @atom = [$alpha \$ \@] [$alpha $digit $unidigit \. _ \-]* 53 | 54 | @sign = [\-\+]? 55 | @exponent = @spacer [Ee] @sign @decimal 56 | @hexexponent = @spacer [Pp] @sign @decimal 57 | 58 | config :- 59 | 60 | <0> { 61 | $white+ ; 62 | "--" .* ; 63 | 64 | "{" { token_ OpenMap } 65 | "}" { token_ CloseMap } 66 | "[" { token_ OpenList } 67 | "," { token_ Comma } 68 | "]" { token_ CloseList } 69 | "*" { token Bullet } 70 | "-" { token Bullet } 71 | "+" { token Bullet } 72 | 73 | @sign 0 [Xx] @spacer @hexadecimal ("." @hexadecimal?)? @hexexponent? { token number } 74 | @sign 0 [Oo] @spacer @octal ("." @octal ?)? { token number } 75 | @sign 0 [Bb] @spacer @binary ("." @binary ?)? { token number } 76 | @sign @decimal ("." @decimal ?)? @exponent? { token number } 77 | 78 | @atom { token Atom } 79 | @atom $white_no_nl* : { token section } 80 | \" { startString } 81 | } 82 | 83 | { 84 | \" { endMode } 85 | "\" @escape ; 86 | "\" $white+ "\" ; 87 | "\" . { token (Error . BadEscape) } 88 | . ; 89 | \n { untermString } 90 | } 91 | 92 | <0,comment> "{-" { nestMode InComment } 93 | 94 | { 95 | "-}" { endMode } 96 | \" { nestMode InCommentString } 97 | . ; 98 | \n ; 99 | } 100 | 101 | { 102 | \" { endMode } 103 | \n { endMode } 104 | \\ \" ; 105 | . ; 106 | } 107 | 108 | 109 | { 110 | -- | Attempt to produce a token stream from an input file. 111 | -- In the case of an error the line and column of the error 112 | -- are returned instead. 113 | scanTokens :: 114 | Text {- ^ Source text -} -> 115 | [Located Token] {- ^ Tokens with position -} 116 | scanTokens str = go (Located startPos str) InNormal 117 | where 118 | go inp st = 119 | case alexScan inp (stateToInt st) of 120 | AlexEOF -> eofAction (locPosition inp) st 121 | AlexError inp' -> errorAction inp' 122 | AlexSkip inp' _ -> go inp' st 123 | AlexToken inp' len act -> case act len inp st of 124 | (st', xs) -> xs ++ go inp' st' 125 | 126 | -- | Compute the Alex state corresponding to a particular 'LexerMode' 127 | stateToInt :: LexerMode -> Int 128 | stateToInt InNormal{} = 0 129 | stateToInt InComment{} = comment 130 | stateToInt InCommentString{} = commentstring 131 | stateToInt InString{} = stringlit 132 | 133 | } 134 | -------------------------------------------------------------------------------- /src/Config/LexerUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- | This module is separate from the Lexer.x input to Alex 3 | -- to segregate the automatically generated code from the 4 | -- hand written code. The automatically generated code 5 | -- causes lots of warnings which mask the interesting warnings. 6 | module Config.LexerUtils 7 | ( 8 | -- * Alex wrapper 9 | AlexInput 10 | , alexGetByte 11 | 12 | -- * Lexer modes 13 | , LexerMode(..) 14 | , startString 15 | , nestMode 16 | , endMode 17 | 18 | -- * Token builders 19 | , token 20 | , token_ 21 | , section 22 | , number 23 | 24 | -- * Final actions 25 | , untermString 26 | , eofAction 27 | , errorAction 28 | ) where 29 | 30 | import Data.Char (GeneralCategory(..), generalCategory, isAscii, isSpace, ord) 31 | import Data.Text (Text) 32 | import Data.Word (Word8) 33 | import qualified Data.Text as Text 34 | 35 | import Config.Tokens 36 | import qualified Config.NumberParser 37 | 38 | ------------------------------------------------------------------------ 39 | -- Custom Alex wrapper - these functions are used by generated code 40 | ------------------------------------------------------------------------ 41 | 42 | -- | The generated code expects the lexer input type to be named 'AlexInput' 43 | type AlexInput = Located Text 44 | 45 | -- | Get the next characteristic byte from the input source. 46 | alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) 47 | alexGetByte (Located p cs) 48 | = do (c,cs') <- Text.uncons cs 49 | let !b = byteForChar c 50 | !inp = Located (move p c) cs' 51 | return (b, inp) 52 | 53 | ------------------------------------------------------------------------ 54 | 55 | -- | Advance the position according to the kind of character lexed. 56 | move :: Position -> Char -> Position 57 | move (Position ix line column) c = 58 | case c of 59 | '\t' -> Position (ix + 1) line (((column + 7) `div` 8) * 8 + 1) 60 | '\n' -> Position (ix + 1) (line + 1) 1 61 | _ -> Position (ix + 1) line (column + 1) 62 | 63 | -- | Action to perform upon end of file. Produce errors if EOF was unexpected. 64 | eofAction :: Position -> LexerMode -> [Located Token] 65 | eofAction eofPosn st = 66 | case st of 67 | InComment posn _ -> [Located posn (Error UntermComment)] 68 | InCommentString posn _ -> [Located posn (Error UntermComment)] 69 | InString posn _ -> [Located posn (Error UntermString)] 70 | InNormal -> [Located (park eofPosn) EOF] 71 | 72 | -- | Terminate the line if needed and move the cursor to column 0 to ensure 73 | -- that it terminates any top-level block. 74 | park :: Position -> Position 75 | park pos 76 | | posColumn pos == 1 = pos { posColumn = 0 } 77 | | otherwise = pos { posColumn = 0, posLine = posLine pos + 1 } 78 | 79 | -- | Action to perform when lexer gets stuck. Emits an error. 80 | errorAction :: AlexInput -> [Located Token] 81 | errorAction inp = [fmap (Error . NoMatch . Text.head) inp] 82 | 83 | ------------------------------------------------------------------------ 84 | -- Lexer Modes 85 | ------------------------------------------------------------------------ 86 | 87 | -- | The lexer can be in any of four modes which determine which rules 88 | -- are active. 89 | data LexerMode 90 | = InNormal 91 | | InComment !Position !LexerMode -- ^ Start of comment and return mode 92 | | InCommentString !Position !LexerMode -- ^ Start of string and return mode 93 | | InString !Position !Text -- ^ Start of string and input text 94 | 95 | -- | Type of actions used by lexer upon matching a rule 96 | type Action = 97 | Int {- ^ match length -} -> 98 | Located Text {- ^ current input -} -> 99 | LexerMode {- ^ lexer mode -} -> 100 | (LexerMode, [Located Token]) {- ^ updated lexer mode, emitted tokens -} 101 | 102 | -- | Helper function for building an 'Action' using the lexeme 103 | token :: (Text -> Token) -> Action 104 | token f len match st = (st, [fmap (f . Text.take len) match]) 105 | 106 | -- | Helper function for building an 'Action' where the lexeme is unused. 107 | token_ :: Token -> Action 108 | token_ = token . const 109 | 110 | ------------------------------------------------------------------------ 111 | -- Alternative modes 112 | ------------------------------------------------------------------------ 113 | 114 | -- | Used to enter one of the nested modes 115 | nestMode :: (Position -> LexerMode -> LexerMode) -> Action 116 | nestMode f _ match st = (f (locPosition match) st, []) 117 | 118 | -- | Enter the string literal lexer 119 | startString :: Action 120 | startString _ (Located posn text) _ = (InString posn text, []) 121 | 122 | -- | Successfully terminate the current mode and emit tokens as needed 123 | endMode :: Action 124 | endMode len (Located endPosn _) mode = 125 | case mode of 126 | InNormal -> (InNormal, []) 127 | InCommentString _ st -> (st, []) 128 | InComment _ st -> (st, []) 129 | InString startPosn input -> 130 | let n = posIndex endPosn - posIndex startPosn + len 131 | badEscape = BadEscape (Text.pack "out of range") 132 | in case reads (Text.unpack (Text.take n input)) of 133 | [(s,"")] -> (InNormal, [Located startPosn (String (Text.pack s))]) 134 | _ -> (InNormal, [Located startPosn (Error badEscape)]) 135 | 136 | -- | Action for unterminated string constant 137 | untermString :: Action 138 | untermString _ _ = \(InString posn _) -> 139 | (InNormal, [Located posn (Error UntermString)]) 140 | 141 | ------------------------------------------------------------------------ 142 | -- Token builders 143 | ------------------------------------------------------------------------ 144 | 145 | -- | Construct a 'Number' token from a token using a 146 | -- given base. This function expect the token to be 147 | -- legal for the given base. This is checked by Alex. 148 | number :: 149 | Text {- ^ sign-prefix-digits -} -> 150 | Token 151 | number = Number . Config.NumberParser.number 152 | . Text.unpack . Text.toUpper . Text.filter ('_' /=) 153 | 154 | -- | Process a section heading token 155 | section :: Text -> Token 156 | section = Section . Text.dropWhileEnd isSpace . Text.init 157 | 158 | ------------------------------------------------------------------------ 159 | -- Embed all of unicode, kind of, in a single byte! 160 | ------------------------------------------------------------------------ 161 | 162 | -- | Alex is driven by looking up elements in a 128 element array. 163 | -- This function maps each ASCII character to its ASCII encoding 164 | -- and it maps non-ASCII code-points to a character class (0-6) 165 | byteForChar :: Char -> Word8 166 | byteForChar c 167 | | c <= '\6' = non_graphic 168 | | isAscii c = fromIntegral (ord c) 169 | | otherwise = case generalCategory c of 170 | LowercaseLetter -> lower 171 | OtherLetter -> lower 172 | UppercaseLetter -> upper 173 | TitlecaseLetter -> upper 174 | DecimalNumber -> digit 175 | OtherNumber -> digit 176 | ConnectorPunctuation -> symbol 177 | DashPunctuation -> symbol 178 | OtherPunctuation -> symbol 179 | MathSymbol -> symbol 180 | CurrencySymbol -> symbol 181 | ModifierSymbol -> symbol 182 | OtherSymbol -> symbol 183 | Space -> space 184 | ModifierLetter -> other 185 | NonSpacingMark -> other 186 | SpacingCombiningMark -> other 187 | EnclosingMark -> other 188 | LetterNumber -> other 189 | OpenPunctuation -> other 190 | ClosePunctuation -> other 191 | InitialQuote -> other 192 | FinalQuote -> other 193 | _ -> non_graphic 194 | where 195 | non_graphic = 0 196 | upper = 1 197 | lower = 2 198 | digit = 3 199 | symbol = 4 200 | space = 5 201 | other = 6 202 | -------------------------------------------------------------------------------- /src/Config/Macro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe, OverloadedStrings, DeriveTraversable, RankNTypes #-} 2 | {-| 3 | Module : Config.Macro 4 | Description : Configuration pre-processor adding support for aliases and common sections 5 | Copyright : (c) Eric Mertens, 2020 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module provides assigns meaning to atoms and section names that start with @\@@ 10 | and @$@. It provides processing pass for configuration to use local variables and 11 | inclusion to better structure configuration. 12 | 13 | = Sigils 14 | 15 | * @$@ starts a variable. 16 | * @\@@ starts a directive. 17 | 18 | Merge key-value mappings using @\@splice@. 19 | 20 | Load external configuration with @\@load@. 21 | 22 | = Variables 23 | 24 | Variables are atoms that start with a @$@ sigil. Variables are defined by 25 | setting a variable as a section name. This variable will remain in 26 | scope for the remainder of the sections being defined. 27 | 28 | Variables used in a value position will be replaced with their previously 29 | defined values. 30 | 31 | @ 32 | $example: 42 33 | field1: $example 34 | field2: [0, $example] 35 | @ 36 | 37 | expands to 38 | 39 | @ 40 | field1: 42 41 | field2: [0, 42] 42 | @ 43 | 44 | Later variable definitions will shadow earlier definitions. 45 | 46 | @ 47 | { $x: 1, $x: 2, k: $x } 48 | @ 49 | 50 | expands to 51 | 52 | @ 53 | { k: 2 } 54 | @ 55 | 56 | Scoping examples: 57 | 58 | @ 59 | top1: 60 | a: $x -- BAD: $x not defined yet 61 | $x: 42 -- $x is now defined to be 42 62 | b: $x -- OK: $x was defined above 63 | c: {sub1: $x, sub2: [$x]} -- OK: $x in scope in subsections 64 | -- note: $x now goes out of scope 65 | top2: $x -- BAD: $x no longer in scope 66 | @ 67 | 68 | Macros are expanded at their definition site. All variables are resolved before 69 | adding the new variable into the environment. Variables are lexically scoped 70 | rather than dynamically scoped. 71 | 72 | Allowed: 73 | 74 | @ 75 | $x: 1 76 | $y: $x -- OK, y is now 1 77 | @ 78 | 79 | Not allowed: 80 | 81 | @ 82 | $y: $x -- BAD: $x was not in scope 83 | $x: 1 84 | z: $y 85 | @ 86 | 87 | = Sections splicing 88 | 89 | One sections value can be spliced into another sections value using the @\@splice@ 90 | directive. It is an error to splice a value that is not a key-value sections. 91 | 92 | @ 93 | $xy: { x: 0, y: 1 } 94 | example: 95 | \@splice: $xy 96 | z: 2 97 | @ 98 | 99 | expands to 100 | 101 | @ 102 | example: 103 | x: 0 104 | y: 1 105 | z: 2 106 | @ 107 | 108 | = File loading 109 | 110 | The @\@load@ directive is intended including configuration from other sources. 111 | 'loadFileWithMacros' provides an interpretation of this directive that loads 112 | other files. An arbitrary interpretation can be defined with 'expandMacros'' 113 | 114 | To load a value define a key-value mapping with a single @\@load@ key with a 115 | value specifying the location to load from. 116 | 117 | @ 118 | x: @load: "fourty-two.cfg" 119 | @ 120 | 121 | could expand to 122 | 123 | @ 124 | x: 42 125 | @ 126 | 127 | -} 128 | module Config.Macro ( 129 | -- * Macro expansion primitives 130 | MacroError(..), 131 | expandMacros, 132 | expandMacros', 133 | 134 | -- * File loader with inclusion 135 | LoadFileError(..), 136 | FilePosition(..), 137 | loadFileWithMacros 138 | ) where 139 | 140 | import Data.Text (Text) 141 | import qualified Data.Text as Text 142 | import qualified Data.Text.IO as Text 143 | import Control.Exception 144 | import Config 145 | import Data.Map (Map) 146 | import Data.Typeable (Typeable) 147 | import qualified Data.Map as Map 148 | 149 | -- | Errors from macro expansion annotated with the 'valueAnn' from 150 | -- the 'Value' nearest to the problem (typically a file position). 151 | data MacroError a 152 | = UndeclaredVariable a Text -- ^ Variable used before its defintion 153 | | UnknownDirective a Text -- ^ Unknown directive 154 | | BadSplice a -- ^ Incorrect use of @\@splice@ 155 | | BadLoad a -- ^ Incorrect use of @\@load@ 156 | deriving 157 | (Eq, Read, Show, Functor, Foldable, Traversable) 158 | 159 | instance (Typeable a, Show a) => Exception (MacroError a) 160 | 161 | data Special = Plain | Variable Text | Splice | Load 162 | 163 | processAtom :: a -> Text -> Either (MacroError a) Special 164 | processAtom a txt = 165 | case Text.uncons txt of 166 | Just ('@',"splice") -> Right Splice 167 | Just ('@',"load" ) -> Right Load 168 | Just ('@',t ) -> Left (UnknownDirective a t) 169 | Just ('$',t ) -> Right (Variable t) 170 | _ -> Right Plain 171 | 172 | -- | Expand macros in a configuration value. 173 | -- 174 | -- @\@load@ not supported and results in a 'BadLoad' error. 175 | expandMacros :: Value a -> Either (MacroError a) (Value a) 176 | expandMacros = expandMacros' Left (Left . BadLoad . valueAnn) Map.empty 177 | 178 | -- | Expand macros in a configuration value using a pre-populated environment. 179 | expandMacros' :: 180 | Monad m => 181 | (forall b. MacroError a -> m b) {- ^ failure -} -> 182 | (Value a -> m (Value a)) {- ^ @\@load@ implementation -} -> 183 | Map Text (Value a) {- ^ variable environment -} -> 184 | Value a {- ^ value to expand -} -> 185 | m (Value a) {- ^ expanded value -} 186 | expandMacros' failure load = go 187 | where 188 | proc a txt = either failure pure (processAtom a txt) 189 | 190 | go env v = 191 | case v of 192 | Number a x -> pure (Number a x) 193 | Text a x -> pure (Text a x) 194 | List a x -> List a <$> traverse (go env) x 195 | 196 | Sections _ [Section _ "@load" arg] -> load =<< go env arg 197 | Sections a x -> Sections a <$> elaborateSections env x 198 | 199 | Atom a x -> 200 | do x' <- proc a (atomName x) 201 | case x' of 202 | Plain -> pure (Atom a x) 203 | Splice -> failure (BadSplice a) 204 | Load -> failure (BadLoad a) 205 | Variable var -> 206 | case Map.lookup var env of 207 | Nothing -> failure (UndeclaredVariable a var) 208 | Just y -> pure y 209 | 210 | elaborateSections _ [] = pure [] 211 | elaborateSections env (Section a k v : xs) = 212 | do special <- proc a k 213 | v' <- go env v 214 | case special of 215 | Load -> failure (BadLoad a) 216 | Variable var -> elaborateSections (Map.insert var v' env) xs 217 | Plain -> (Section a k v' :) <$> elaborateSections env xs 218 | Splice -> 219 | case v' of 220 | Sections _ ys -> (ys++) <$> elaborateSections env xs 221 | _ -> failure (BadSplice a) 222 | 223 | -- | A pair of filepath and position 224 | data FilePosition = FilePosition FilePath Position 225 | deriving (Read, Show, Ord, Eq) 226 | 227 | -- | Errors thrown by 'loadFileWithMacros' 228 | data LoadFileError 229 | = LoadFileParseError FilePath ParseError -- ^ failure to parse a file 230 | | LoadFileMacroError (MacroError FilePosition) -- ^ failure to expand macros 231 | deriving (Eq, Read, Show) 232 | 233 | instance Exception LoadFileError 234 | 235 | -- | Load a configuration value from a given file path. 236 | -- 237 | -- @\@load@ will compute included file path from the given function given the 238 | -- load argument and current configuration file path. 239 | -- 240 | -- Valid @\@load@ arguments are string literals use as arguments to 241 | -- the path resolution function. 242 | -- 243 | -- Throws `IOError` from file loads and `LoadFileError` 244 | loadFileWithMacros :: 245 | (Text -> FilePath -> IO FilePath) {- ^ inclusion path resolution -} -> 246 | FilePath {- ^ starting file path -} -> 247 | IO (Value FilePosition) {- ^ macro-expanded config value -} 248 | loadFileWithMacros findPath = go 249 | where 250 | go path = 251 | do txt <- Text.readFile path 252 | v1 <- case parse txt of 253 | Left e -> throwIO (LoadFileParseError path e) 254 | Right v -> pure v 255 | let v2 = FilePosition path <$> v1 256 | let loadImpl pathVal = 257 | case pathVal of 258 | Text _ str -> go =<< findPath str path 259 | _ -> throwIO (LoadFileMacroError (BadLoad (valueAnn pathVal))) 260 | expandMacros' (throwIO . LoadFileMacroError) loadImpl Map.empty v2 261 | -------------------------------------------------------------------------------- /src/Config/Number.hs: -------------------------------------------------------------------------------- 1 | {-# Language DeriveDataTypeable, DeriveGeneric, Safe #-} 2 | {-| 3 | Module : Config.Number 4 | Description : Scientific-notation numbers with explicit radix 5 | Copyright : (c) Eric Mertens, 2019 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module provides a representation of numbers in scientific 10 | notation. 11 | -} 12 | module Config.Number 13 | ( Number(..) 14 | , Radix(..) 15 | , radixToInt 16 | , numberToRational 17 | , numberToInteger 18 | , integerToNumber 19 | , rationalToNumber 20 | ) where 21 | 22 | import Data.Ratio (numerator, denominator) 23 | import Data.Data (Data) 24 | import GHC.Generics (Generic) 25 | 26 | -- | Numbers are represented as base, coefficient, and exponent. 27 | -- 28 | -- The most convenient way to get numbers into and out of this form 29 | -- is to use one of: 'numberToRational', 'numberToInteger', 30 | -- 'rationalToNumber', or 'integerToNumber'. 31 | -- 32 | -- This representation is explicit about the radix and exponent 33 | -- used to facilitate better pretty-printing. By using explicit 34 | -- exponents extremely large numbers can be represented compactly. 35 | -- Consider that it is easy to write `1e100000000` which would use 36 | -- a significant amount of memory if realized as an 'Integer'. This 37 | -- representation allows concerned programs to check bounds before 38 | -- converting to a representation like 'Integer'. 39 | data Number = MkNumber 40 | { numberRadix :: !Radix 41 | , numberCoefficient :: !Rational 42 | } 43 | deriving (Eq, Ord, Read, Show, Data, Generic) 44 | 45 | -- | Radix used for a number. Some radix modes support an exponent. 46 | data Radix 47 | = Radix2 -- ^ binary, base 2 48 | | Radix8 -- ^ octal, base 8 49 | | Radix10 !Integer -- ^ decimal, base 10, exponent base 10 50 | | Radix16 !Integer -- ^ hexdecimal, base 16, exponent base 2 51 | deriving (Eq, Ord, Read, Show, Data, Generic) 52 | 53 | -- | Returns the radix as an integer ignoring any exponent. 54 | radixToInt :: Radix -> Int 55 | radixToInt r = 56 | case r of 57 | Radix2 {} -> 2 58 | Radix8 {} -> 8 59 | Radix10{} -> 10 60 | Radix16{} -> 16 61 | 62 | -- | Convert a number to a 'Rational'. Warning: This can use a 63 | -- lot of memory in the case of very large exponent parts. 64 | numberToRational :: Number -> Rational 65 | numberToRational (MkNumber r c) = 66 | case r of 67 | Radix2 -> c 68 | Radix8 -> c 69 | Radix10 e -> c * 10 ^^ e 70 | Radix16 e -> c * 2 ^^ e 71 | 72 | -- | Convert a number to a 'Integer'. Warning: This can use a 73 | -- lot of memory in the case of very large exponent parts. 74 | numberToInteger :: Number -> Maybe Integer 75 | numberToInteger n 76 | | denominator r == 1 = Just $! numerator r 77 | | otherwise = Nothing 78 | where 79 | r = numberToRational n 80 | 81 | -- | 'Integer' to a radix 10 'Number' with no exponent 82 | integerToNumber :: Integer -> Number 83 | integerToNumber = rationalToNumber . fromInteger 84 | 85 | -- | 'Rational' to a radix 10 'Number' with no exponent 86 | rationalToNumber :: Rational -> Number 87 | rationalToNumber = MkNumber (Radix10 0) 88 | -------------------------------------------------------------------------------- /src/Config/NumberParser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | module Config.NumberParser where 5 | 6 | import Data.List (foldl') 7 | import Config.Number 8 | 9 | } 10 | 11 | %tokentype 12 | { Char} 13 | %token 14 | '+' { '+' } 15 | '-' { '-' } 16 | '.' { '.' } 17 | '0' { '0' } 18 | '1' { '1' } 19 | '2' { '2' } 20 | '3' { '3' } 21 | '4' { '4' } 22 | '5' { '5' } 23 | '6' { '6' } 24 | '7' { '7' } 25 | '8' { '8' } 26 | '9' { '9' } 27 | 'A' { 'A' } 28 | 'B' { 'B' } 29 | 'C' { 'C' } 30 | 'D' { 'D' } 31 | 'E' { 'E' } 32 | 'F' { 'F' } 33 | 'O' { 'O' } 34 | 'P' { 'P' } 35 | 'X' { 'X' } 36 | 37 | %name number 38 | 39 | %% 40 | 41 | number :: { Number } 42 | : '-' unsigned_number { negNum $2 } 43 | | '+' unsigned_number { $2 } 44 | | unsigned_number { $1 } 45 | 46 | unsigned_number 47 | : '0' 'X' hexadecimal fracpart(hexadecimal) exppart('P') 48 | { mkNum (Radix16 $5) $3 $4 } 49 | | decimal fracpart(decimal ) exppart('E') 50 | { mkNum (Radix10 $3) $1 $2 } 51 | | '0' 'O' octal fracpart(octal ) 52 | { mkNum Radix8 $3 $4 } 53 | | '0' 'B' binary fracpart(binary ) 54 | { mkNum Radix2 $3 $4 } 55 | 56 | fracpart(p) :: { [Int] } 57 | : { [] } 58 | | '.' { [] } 59 | | '.' p { $2 } 60 | 61 | exppart(p) :: { Integer } 62 | : { 0 } 63 | | p expnum { $2 } 64 | 65 | 66 | expnum :: { Integer } 67 | : '+' decimal { toInt 10 $2 } 68 | | '-' decimal { - toInt 10 $2 } 69 | | decimal { toInt 10 $1 } 70 | 71 | hexadecimal :: { [Int] } 72 | : hexdigit { [$1] } 73 | | hexadecimal hexdigit { $2 : $1 } 74 | 75 | decimal :: { [Int] } 76 | : decdigit { [$1] } 77 | | decimal decdigit { $2 : $1 } 78 | 79 | octal :: { [Int] } 80 | : octdigit { [$1] } 81 | | octal octdigit { $2 : $1 } 82 | 83 | binary :: { [Int] } 84 | : bindigit { [$1] } 85 | | binary bindigit { $2 : $1 } 86 | 87 | hexdigit :: { Int } 88 | : decdigit { $1 } 89 | | 'A' {10} | 'B' {11} | 'C' {12} 90 | | 'D' {13} | 'E' {14} | 'F' {15} 91 | 92 | decdigit :: { Int } 93 | : octdigit {$1} 94 | | '8' { 8} | '9' { 9} 95 | 96 | octdigit :: { Int } 97 | : bindigit { $1 } 98 | | '2' { 2} | '3' { 3} | '4' { 4} 99 | | '5' { 5} | '6' { 6} | '7' { 7} 100 | 101 | bindigit :: { Int } 102 | : '0' { 0} | '1' { 1} 103 | 104 | { 105 | 106 | mkNum :: Radix -> [Int] -> [Int] -> Number 107 | mkNum radix coef frac = 108 | MkNumber radix (fromInteger (toInt base coef) + toFrac base frac) 109 | where 110 | base = radixToInt radix 111 | 112 | negNum :: Number -> Number 113 | negNum n = n { numberCoefficient = - numberCoefficient n } 114 | 115 | toInt :: Int -> [Int] -> Integer 116 | toInt base = foldl' (\acc i -> acc*base' + fromIntegral i) 0 . reverse 117 | where base' = fromIntegral base 118 | 119 | toFrac :: Int -> [Int] -> Rational 120 | toFrac base = foldl' (\acc i -> (fromIntegral i+acc)/base') 0 121 | where base' = fromIntegral base 122 | 123 | happyError [] = error "Unexpected EOF" 124 | happyError (c:_) = error ("Unexpected: "++[c]) 125 | } 126 | -------------------------------------------------------------------------------- /src/Config/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE Trustworthy, OverloadedStrings #-} 3 | 4 | module Config.Parser (parseValue) where 5 | 6 | import Config.Value (Section(..), Value(..), Atom(..)) 7 | import Config.Tokens (Located(..), Token, Position) 8 | import qualified Config.Tokens as T 9 | 10 | } 11 | 12 | %tokentype { Located Token } 13 | %token 14 | SECTION { Located _ T.Section{} } 15 | STRING { Located _ T.String{} } 16 | ATOM { Located _ T.Atom{} } 17 | NUMBER { Located _ T.Number{} } 18 | '*' { Located $$ (T.Bullet "*") } 19 | '+' { Located $$ (T.Bullet "+") } 20 | '-' { Located $$ (T.Bullet "-") } 21 | '[' { Located $$ T.OpenList } 22 | ',' { Located _ T.Comma } 23 | ']' { Located _ T.CloseList } 24 | '{' { Located $$ T.OpenMap } 25 | '}' { Located _ T.CloseMap } 26 | SEP { Located _ T.LayoutSep } 27 | END { Located _ T.LayoutEnd } 28 | EOF { Located _ T.EOF } 29 | 30 | %monad { Either (Located Token) } 31 | %error { errorP } 32 | 33 | %name config 34 | 35 | %% 36 | 37 | config :: { Value Position } 38 | : value EOF { $1 } 39 | 40 | value :: { Value Position } 41 | : sections END { sections $1 } 42 | | '*' list('*') END { List $1 (reverse $2) } 43 | | '-' list('-') END { List $1 (reverse $2) } 44 | | '+' list('+') END { List $1 (reverse $2) } 45 | | simple { $1 } 46 | 47 | simple :: { Value Position } 48 | : NUMBER { number $1 } 49 | | STRING { text $1 } 50 | | ATOM { atom $1 } 51 | | '{' inlinesections '}' { Sections $1 (reverse $2) } 52 | | '[' inlinelist ']' { List $1 (reverse $2) } 53 | | '{' inlinesections term {% untermSections $1 } 54 | | '[' inlinelist term {% untermList $1 } 55 | 56 | term :: { () } 57 | term : EOF { () } 58 | | END { () } 59 | | SEP { () } 60 | 61 | sections :: { [Section Position] } 62 | : section { [$1] } 63 | | sections SEP section { $3 : $1 } 64 | 65 | inlinesections :: { [Section Position] } 66 | : { [] } 67 | | inlinesections1 { $1 } 68 | | inlinesections1 ',' { $1 } 69 | 70 | inlinesections1 :: { [Section Position] } 71 | : section { [$1] } 72 | | inlinesections1 ',' section { $3 : $1 } 73 | 74 | section :: { Section Position } 75 | : SECTION value { section $1 $2 } 76 | 77 | list(blt) :: { [Value Position] } 78 | : value { [$1] } 79 | | list(blt) SEP blt value { $4 : $1 } 80 | 81 | inlinelist :: { [Value Position] } 82 | : { [] } 83 | | inlinelist1 { $1 } 84 | | inlinelist1 ',' { $1 } 85 | 86 | inlinelist1 :: { [Value Position] } 87 | : simple { [$1] } 88 | | inlinelist1 ',' simple { $3 : $1 } 89 | 90 | { 91 | 92 | -- | Convert number token to number value. This needs a custom 93 | -- function like this because there are multiple values matched from 94 | -- the constructor. 95 | number :: Located Token -> Value Position 96 | number = \(Located a (T.Number n)) -> Number a n 97 | 98 | section :: Located Token -> Value Position -> Section Position 99 | section = \(Located a (T.Section k)) v -> Section a k v 100 | 101 | sections :: [Section Position] -> Value Position 102 | sections xxs = Sections (sectionAnn x) (x:xs) 103 | where x:xs = reverse xxs 104 | 105 | text :: Located Token -> Value Position 106 | text = \(Located a (T.String x)) -> Text a x 107 | 108 | atom :: Located Token -> Value Position 109 | atom = \(Located a (T.Atom x)) -> Atom a (MkAtom x) 110 | 111 | errorP :: [Located Token] -> Either (Located Token) a 112 | errorP xs = Left (head xs) 113 | 114 | untermSections :: Position -> Either (Located Token) a 115 | untermSections p = Left (Located p (T.Error T.UntermSections)) 116 | 117 | untermList :: Position -> Either (Located Token) a 118 | untermList p = Left (Located p (T.Error T.UntermList)) 119 | 120 | -- | Attempt to parse a layout annotated token stream or 121 | -- the token that caused the parse to fail. 122 | parseValue :: 123 | [Located Token] {- ^ layout annotated token stream -} -> 124 | Either (Located Token) (Value Position) {- ^ token at failure or result -} 125 | parseValue = config 126 | 127 | } 128 | -------------------------------------------------------------------------------- /src/Config/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language Safe #-} 2 | -- | Pretty-printing implementation for 'Value' 3 | module Config.Pretty (pretty, prettyInline) where 4 | 5 | import Data.Char (isPrint, isDigit,intToDigit) 6 | import Data.List (mapAccumL) 7 | import Data.Ratio (denominator) 8 | import qualified Data.Text as Text 9 | import Text.PrettyPrint 10 | import Numeric(showIntAtBase) 11 | import Prelude hiding ((<>)) 12 | 13 | import Config.Value 14 | import Config.Number 15 | 16 | -- | Pretty-print a 'Value' as shown in the example. 17 | -- Sections will nest complex values underneath with 18 | -- indentation and simple values will be rendered on 19 | -- the same line as their section. 20 | pretty :: Value a -> Doc 21 | pretty value = 22 | case value of 23 | Sections _ [] -> text "{}" 24 | Sections _ xs -> prettySections xs 25 | Number _ n -> prettyNumber n 26 | Text _ t -> prettyText (Text.unpack t) 27 | Atom _ t -> text (Text.unpack (atomName t)) 28 | List _ [] -> text "[]" 29 | List _ xs -> vcat [ char '*' <+> pretty x | x <- xs ] 30 | 31 | prettyNumber :: Number -> Doc 32 | prettyNumber (MkNumber r c) = 33 | case r of 34 | Radix16 e -> pref <> text "0x" <> num <> expPart 'p' e 35 | Radix10 e -> pref <> num <> expPart 'e' e 36 | Radix8 -> pref <> text "0o" <> num 37 | Radix2 -> pref <> text "0b" <> num 38 | where 39 | radix = radixToInt r 40 | pref = if c < 0 then char '-' else empty 41 | num = text (showIntAtBase (fromIntegral radix) intToDigit whole "") 42 | <> fracPart 43 | (whole,frac) = properFraction (abs c) :: (Integer, Rational) 44 | expPart _ 0 = text "" 45 | expPart p i = text (p : show i) 46 | fracPart 47 | | 0 == frac = text "" 48 | | otherwise = text ('.' : showFrac radix frac) 49 | 50 | showFrac :: Int -> Rational -> String 51 | showFrac _ 0 = "" 52 | showFrac radix x = intToDigit w : rest 53 | where 54 | (w,f) = properFraction (x * fromIntegral radix) 55 | rest 56 | | denominator f < denominator x = showFrac radix f 57 | | otherwise = "" 58 | 59 | prettyText :: String -> Doc 60 | prettyText = doubleQuotes . hcat . snd . mapAccumL ppChar True 61 | 62 | where ppChar s x 63 | | isDigit x = (True, if not s then text "\\&" <> char x else char x) 64 | | isPrint x = (True, char x) 65 | | otherwise = (False, char '\\' <> int (fromEnum x)) 66 | 67 | 68 | prettySections :: [Section a] -> Doc 69 | prettySections ss = prettySmallSections small $$ rest 70 | where 71 | (small,big) = break (isBig . sectionValue) ss 72 | rest = case big of 73 | [] -> empty 74 | b : bs -> prettyBigSection b $$ prettySections bs 75 | 76 | prettyBigSection :: Section a -> Doc 77 | prettyBigSection s = 78 | text (Text.unpack (sectionName s)) <> colon 79 | $$ nest 2 (pretty (sectionValue s)) 80 | 81 | prettySmallSections :: [Section a] -> Doc 82 | prettySmallSections ss = vcat (map pp annotated) 83 | where 84 | annotate s = (Text.length (sectionName s), s) 85 | annotated = map annotate ss 86 | indent = 1 + maximum (0 : map fst annotated) 87 | pp (l,s) = prettySmallSection (indent - l) s 88 | 89 | prettySmallSection :: Int -> Section a -> Doc 90 | prettySmallSection n s = 91 | text (Text.unpack (sectionName s)) <> colon <> 92 | text (replicate n ' ') <> pretty (sectionValue s) 93 | 94 | isBig :: Value a -> Bool 95 | isBig (Sections _ (_:_)) = True 96 | isBig (List _ (_:_)) = True 97 | isBig _ = False 98 | 99 | -- | Pretty-printer that uses no layout for sections or lists. 100 | prettyInline :: Value a -> Doc 101 | prettyInline value = 102 | case value of 103 | Number _ n -> prettyNumber n 104 | Text _ t -> prettyText (Text.unpack t) 105 | Atom _ t -> text (Text.unpack (atomName t)) 106 | List _ xs -> brackets (list (map prettyInline xs)) 107 | Sections _ xs -> braces (list [text (Text.unpack k) <> colon <> prettyInline v | Section _ k v <- xs]) 108 | where 109 | list = hcat . punctuate comma 110 | -------------------------------------------------------------------------------- /src/Config/Tokens.hs: -------------------------------------------------------------------------------- 1 | {-# Language Safe #-} 2 | -- | This module provides the token type used in the lexer and 3 | -- parser and provides the extra pass to insert layout tokens. 4 | module Config.Tokens 5 | ( Token(..) 6 | , Located(..) 7 | , Position(..) 8 | , startPos 9 | , Error(..) 10 | , layoutPass 11 | ) where 12 | 13 | import Data.Text (Text) 14 | import Config.Number (Number) 15 | 16 | -- | A position in a text file 17 | data Position = Position 18 | { posIndex, posLine, posColumn :: {-# UNPACK #-} !Int } 19 | deriving (Read, Show, Ord, Eq) 20 | 21 | -- | The initial 'Position' for the start of a file 22 | startPos :: Position 23 | startPos = Position { posIndex = 0, posLine = 1, posColumn = 1 } 24 | 25 | -- | A value annotated with its text file position 26 | data Located a = Located 27 | { locPosition :: {-# UNPACK #-} !Position 28 | , locThing :: !a 29 | } 30 | deriving (Read, Show) 31 | 32 | instance Functor Located where 33 | fmap f (Located p x) = Located p (f x) 34 | 35 | -- | The token type used by "Config.Lexer" and "Config.Parser" 36 | data Token 37 | = Section Text 38 | | String Text 39 | | Atom Text 40 | | Bullet Text 41 | | Comma 42 | | Number Number 43 | | OpenList 44 | | CloseList 45 | | OpenMap 46 | | CloseMap 47 | 48 | | Error Error 49 | 50 | -- "Virtual" tokens used by the subsequent layout processor 51 | | LayoutSep 52 | | LayoutEnd 53 | | EOF 54 | deriving (Show) 55 | 56 | -- | Types of lexical errors 57 | data Error 58 | = UntermComment 59 | | UntermString 60 | | UntermList 61 | | UntermSections 62 | | BadEscape Text 63 | | NoMatch Char 64 | deriving (Show) 65 | 66 | -- | Process a list of position-annotated tokens inserting 67 | -- layout end tokens as appropriate. 68 | layoutPass :: 69 | [Located Token] {- ^ tokens without layout markers -} -> 70 | [Located Token] {- ^ tokens with layout markers -} 71 | layoutPass toks = foldr step (\_ -> []) toks [Layout (-1)] 72 | 73 | data Layout = NoLayout | Layout Int 74 | 75 | -- | Single step of the layout pass 76 | step :: 77 | Located Token {- ^ current token -} -> 78 | ([Layout] -> [Located Token]) {- ^ continuation -} -> 79 | [Layout] {- ^ stack of layout scopes -} -> 80 | [Located Token] {- ^ token stream with layout -} 81 | 82 | -- start blocks must be indented 83 | -- tokens before the current layout end the current layout 84 | -- note that EOF occurs on column 1 for properly formatted text files 85 | step t next cols = 86 | case cols of 87 | NoLayout:cols' | CloseMap <- locThing t -> t : next cols' 88 | _ | OpenMap <- locThing t -> t : next (NoLayout : cols) 89 | Layout col:_ | toCol t == col -> t{locThing=LayoutSep} : t : next cols 90 | Layout col:cols' | toCol t < col -> t{locThing=LayoutEnd} : step t next cols' 91 | Layout{}:_ | usesLayout t -> t : next (Layout (toCol t) : cols) 92 | _ -> t : next cols 93 | 94 | -- | Extract the column number from a located thing. 95 | toCol :: Located a -> Int 96 | toCol = posColumn . locPosition 97 | 98 | 99 | -- | Return True when a token starts a layout scope. 100 | usesLayout :: Located Token -> Bool 101 | usesLayout t 102 | | Section{} <- locThing t = True 103 | | Bullet{} <- locThing t = True 104 | | otherwise = False 105 | -------------------------------------------------------------------------------- /src/Config/Value.hs: -------------------------------------------------------------------------------- 1 | {-# Language DeriveGeneric, DeriveTraversable, DeriveDataTypeable, Safe #-} 2 | 3 | -- | This module provides the types used in this package for configuration. 4 | -- Visit "Config.Parser" to parse values of this type in a convenient 5 | -- layout based notation. 6 | module Config.Value 7 | ( Section(..) 8 | , Value(..) 9 | , Atom(..) 10 | , valueAnn 11 | ) where 12 | 13 | import Data.Text (Text) 14 | import Data.Data (Data, Typeable) 15 | import Data.String (IsString(..)) 16 | import GHC.Generics (Generic, Generic1) 17 | 18 | import Config.Number (Number) 19 | 20 | -- | A single section of a 'Value' 21 | -- 22 | -- Example: 23 | -- 24 | -- * @my-key: my-value@ is @'Section' _ "my-key" ('Atom' _ "my-value")@ 25 | data Section a = Section 26 | { sectionAnn :: a 27 | , sectionName :: Text 28 | , sectionValue :: Value a 29 | } 30 | deriving ( Eq, Read, Show, Typeable, Data 31 | , Functor, Foldable, Traversable 32 | , Generic, Generic1 33 | ) 34 | 35 | -- | Wrapper to distinguish 'Atom' from 'Text' by 36 | -- type in a configuration. Atoms can be constructed 37 | -- using the @OverloadedStrings@ extension. 38 | newtype Atom = MkAtom { atomName :: Text } 39 | deriving ( Eq, Ord, Show, Read, Typeable, Data 40 | , Generic 41 | ) 42 | 43 | instance IsString Atom where 44 | fromString = MkAtom . fromString 45 | 46 | -- | Sum type of the values supported by this language. 47 | -- 48 | -- 'Value' is parameterized over an annotation type indented to be used for 49 | -- file position or other application specific information. When no 50 | -- annotations are needed, '()' is a fine choice. 51 | data Value a 52 | = Sections a [Section a] -- ^ lists of key-value pairs 53 | | Number a Number -- ^ numbers 54 | | Text a Text -- ^ quoted strings 55 | | Atom a Atom -- ^ unquoted strings 56 | | List a [Value a] -- ^ lists 57 | deriving ( Eq, Read, Show, Typeable, Data 58 | , Functor, Foldable, Traversable 59 | , Generic, Generic1 60 | ) 61 | 62 | -- | Returns the annotation for a value. 63 | valueAnn :: Value a -> a 64 | valueAnn v = 65 | case v of 66 | Sections a _ -> a 67 | Number a _ -> a 68 | Text a _ -> a 69 | Atom a _ -> a 70 | List a _ -> a 71 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | {-| 3 | Module : Main 4 | Description : Unit tests for config-schema 5 | Copyright : (c) Eric Mertens, 2017 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | -} 9 | module Main (main) where 10 | 11 | import Config 12 | import Config.Number 13 | import Control.Monad (unless) 14 | import Data.Foldable 15 | import Data.Text (Text) 16 | import qualified Data.Text as Text 17 | 18 | parseTest :: 19 | Value () {- ^ expected value -} -> 20 | [Text] {- ^ input lines -} -> 21 | IO () 22 | parseTest expected txts = 23 | case parse (Text.unlines txts) of 24 | Left e -> fail (show e) 25 | Right v -> 26 | unless ((() <$ v) == expected) (fail (show (expected, () <$ v))) 27 | 28 | number :: Number -> Value () 29 | number = Number () 30 | 31 | atom :: Atom -> Value () 32 | atom = Atom () 33 | 34 | list :: [Value ()] -> Value () 35 | list = List () 36 | 37 | text :: Text -> Value () 38 | text = Text () 39 | 40 | sections :: [(Text, Value ())] -> Value () 41 | sections xs = Sections () [Section () k v | (k,v) <- xs] 42 | 43 | main :: IO () 44 | main = sequenceA_ 45 | 46 | [ parseTest (number (MkNumber (Radix10 0) 42)) ["42"] 47 | , parseTest (number (MkNumber (Radix10 56) 42)) ["42e56"] 48 | , parseTest (number (MkNumber (Radix10 56) 42.34)) ["42.34e56"] 49 | , parseTest (number (MkNumber (Radix10 0) 42.34)) ["42.34"] 50 | , parseTest (number (MkNumber (Radix10 0) 42)) ["42."] 51 | , parseTest (number (MkNumber (Radix10 0) 42)) ["042"] 52 | 53 | , parseTest (number (MkNumber (Radix16 0) 42)) ["0x2a"] 54 | , parseTest (number (MkNumber (Radix16 56) 42)) ["0x2ap56"] 55 | , parseTest (number (MkNumber (Radix16 56) (0x2a + (0x34 / 16^(2::Int))))) ["0x2a.34p56"] 56 | , parseTest (number (MkNumber (Radix16 0) (0x2a + (0x3f / 16^(2::Int))))) ["0x2a.3f"] 57 | , parseTest (number (MkNumber (Radix16 0) 42)) ["0x2a."] 58 | , parseTest (number (MkNumber (Radix16 0) 42)) ["0x02a"] 59 | 60 | , parseTest (number (MkNumber Radix2 42)) ["0b101010"] 61 | , parseTest (number (MkNumber Radix2 4)) ["0b0100"] 62 | , parseTest (number (MkNumber Radix2 4)) ["0b0100."] 63 | , parseTest (number (MkNumber Radix2 (4 + (22 / 2^(6::Int))))) ["0b100.010110"] 64 | 65 | , parseTest (number (MkNumber Radix8 55)) ["0o67"] 66 | , parseTest (number (MkNumber Radix8 55)) ["0o67."] 67 | , parseTest (number (MkNumber Radix8 55)) ["0o067"] 68 | , parseTest (number (MkNumber Radix8 (55 + (10 / 64)))) ["0o67.12"] 69 | 70 | , parseTest (atom "example") ["example"] 71 | , parseTest (atom "one-two") ["one-two"] 72 | , parseTest (atom "one-1") ["one-1"] 73 | 74 | , parseTest (list []) ["[ ]"] 75 | , parseTest (list []) ["[]"] 76 | , parseTest (list [atom "x"]) ["[x]"] 77 | , parseTest (list [atom "x"]) ["* x"] 78 | , parseTest (list [atom "x", atom "y", atom "z"]) ["[x, y, z]"] 79 | , parseTest (list [atom "x", atom "y", atom "z"]) 80 | ["* x", "* y", "* z"] 81 | , parseTest (list [atom "x", list [atom "y", atom "z"]]) ["[x,[y,z]]"] 82 | , parseTest (list [atom "x", list [atom "y", atom "z"]]) ["* x", "* [y,z]"] 83 | , parseTest (list [atom "x", list [atom "y", atom "z"]]) ["* x", "* * y", " * z"] 84 | 85 | , parseTest (text "string") ["\"string\""] 86 | , parseTest (text "\10string\1\2") ["\"\\x0ast\\&r\\ \\ing\\SOH\\^B\""] 87 | , parseTest (text "string") ["\"str\\", " \\ing\""] 88 | 89 | , parseTest (sections []) ["{}"] 90 | , parseTest (sections [("x", atom "y")]) ["{x:y}"] 91 | , parseTest (sections [("x", atom "y")]) ["x:y"] 92 | , parseTest (sections [("x", atom "y"), ("z", atom "w")]) ["{x:y,z:w}"] 93 | , parseTest (sections [("x", sections [("y", atom "z")])]) ["x:y:z"] 94 | , parseTest (sections [("x", sections [("y", atom "z")])]) 95 | ["x:" 96 | ," y:" 97 | ," z"] 98 | , parseTest (sections [("x", list [atom "y", atom "z"])]) 99 | ["x: * y" 100 | ," * z"] 101 | , parseTest (list [sections [("x", atom "y")], sections [("z", atom "w")]]) 102 | ["* x: y" 103 | ,"* z: w"] 104 | ] 105 | --------------------------------------------------------------------------------