├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.lhs ├── README.md ├── benchmarker └── benchmarker.hs ├── cabal.project ├── hie.yaml ├── src ├── Toml.hs └── Toml │ ├── Pretty.hs │ ├── Schema.hs │ ├── Schema │ ├── FromValue.hs │ ├── Generic.hs │ ├── Generic │ │ ├── FromValue.hs │ │ └── ToValue.hs │ ├── Matcher.hs │ ├── ParseTable.hs │ └── ToValue.hs │ ├── Semantics.hs │ ├── Semantics │ ├── Ordered.hs │ └── Types.hs │ ├── Syntax.hs │ └── Syntax │ ├── Lexer.x │ ├── LexerUtils.hs │ ├── Parser.y │ ├── ParserUtils.hs │ ├── Position.hs │ ├── Token.hs │ └── Types.hs ├── test-drivers ├── LICENSE ├── decoder │ └── Main.hs ├── encoder │ └── Main.hs ├── highlighter │ └── Main.hs └── toml-test-drivers.cabal ├── test ├── DecodeSpec.hs ├── DerivingViaSpec.hs ├── FromValueSpec.hs ├── HieDemoSpec.hs ├── LexerSpec.hs ├── Main.hs ├── PrettySpec.hs ├── QuoteStr.hs ├── ToValueSpec.hs └── TomlSpec.hs ├── toml-parser.cabal └── weeder.toml /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 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.20250330 12 | # 13 | # REGENDATA ("0.19.20250330",["github","cabal.project"]) 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-24.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.12.2 32 | compilerKind: ghc 33 | compilerVersion: 9.12.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.2 42 | compilerKind: ghc 43 | compilerVersion: 9.8.2 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | fail-fast: false 72 | steps: 73 | - name: apt-get install 74 | run: | 75 | apt-get update 76 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 77 | - name: Install GHCup 78 | run: | 79 | mkdir -p "$HOME/.ghcup/bin" 80 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 81 | chmod a+x "$HOME/.ghcup/bin/ghcup" 82 | - name: Install cabal-install 83 | run: | 84 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) 85 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" 86 | - name: Install GHC (GHCup) 87 | if: matrix.setup-method == 'ghcup' 88 | run: | 89 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 90 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 91 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 92 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 93 | echo "HC=$HC" >> "$GITHUB_ENV" 94 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 95 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 96 | env: 97 | HCKIND: ${{ matrix.compilerKind }} 98 | HCNAME: ${{ matrix.compiler }} 99 | HCVER: ${{ matrix.compilerVersion }} 100 | - name: Set PATH and environment variables 101 | run: | 102 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 103 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 104 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 105 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 106 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 107 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 108 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 109 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 110 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 111 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 112 | env: 113 | HCKIND: ${{ matrix.compilerKind }} 114 | HCNAME: ${{ matrix.compiler }} 115 | HCVER: ${{ matrix.compilerVersion }} 116 | - name: env 117 | run: | 118 | env 119 | - name: write cabal config 120 | run: | 121 | mkdir -p $CABAL_DIR 122 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 155 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 156 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 157 | rm -f cabal-plan.xz 158 | chmod a+x $HOME/.cabal/bin/cabal-plan 159 | cabal-plan --version 160 | - name: checkout 161 | uses: actions/checkout@v4 162 | with: 163 | path: source 164 | - name: initial cabal.project for sdist 165 | run: | 166 | touch cabal.project 167 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 168 | echo "packages: $GITHUB_WORKSPACE/source/test-drivers" >> cabal.project 169 | cat cabal.project 170 | - name: sdist 171 | run: | 172 | mkdir -p sdist 173 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 174 | - name: unpack 175 | run: | 176 | mkdir -p unpacked 177 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 178 | - name: generate cabal.project 179 | run: | 180 | PKGDIR_toml_parser="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/toml-parser-[0-9.]*')" 181 | echo "PKGDIR_toml_parser=${PKGDIR_toml_parser}" >> "$GITHUB_ENV" 182 | PKGDIR_toml_test_drivers="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/toml-test-drivers-[0-9.]*')" 183 | echo "PKGDIR_toml_test_drivers=${PKGDIR_toml_test_drivers}" >> "$GITHUB_ENV" 184 | rm -f cabal.project cabal.project.local 185 | touch cabal.project 186 | touch cabal.project.local 187 | echo "packages: ${PKGDIR_toml_parser}" >> cabal.project 188 | echo "packages: ${PKGDIR_toml_test_drivers}" >> cabal.project 189 | echo "package toml-parser" >> cabal.project 190 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 191 | echo "package toml-test-drivers" >> cabal.project 192 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 193 | cat >> cabal.project <> cabal.project.local 196 | cat cabal.project 197 | cat cabal.project.local 198 | - name: dump install plan 199 | run: | 200 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 201 | cabal-plan 202 | - name: restore cache 203 | uses: actions/cache/restore@v4 204 | with: 205 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 206 | path: ~/.cabal/store 207 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 208 | - name: install dependencies 209 | run: | 210 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 211 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 212 | - name: build w/o tests 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 215 | - name: build 216 | run: | 217 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 218 | - name: tests 219 | run: | 220 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 221 | - name: cabal check 222 | run: | 223 | cd ${PKGDIR_toml_parser} || false 224 | ${CABAL} -vnormal check 225 | cd ${PKGDIR_toml_test_drivers} || false 226 | ${CABAL} -vnormal check 227 | - name: haddock 228 | run: | 229 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 230 | - name: unconstrained build 231 | run: | 232 | rm -f cabal.project.local 233 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 234 | - name: save cache 235 | if: always() 236 | uses: actions/cache/save@v4 237 | with: 238 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 239 | path: ~/.cabal/store 240 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-*/ 3 | .HTF/ 4 | log/ 5 | .cabal-sandbox/ 6 | .stack-work/ 7 | cabal-dev 8 | *# 9 | *.aux 10 | *.bundle 11 | *.chi 12 | *.chs.h 13 | *.dSYM 14 | *.dylib 15 | *.dyn_hi 16 | *.dyn_o 17 | *.eventlog 18 | *.hi 19 | *.hp 20 | *.o 21 | *.a 22 | *.prof 23 | *.so 24 | *~ 25 | .*.swo 26 | .*.swp 27 | .DS_Store 28 | .hpc 29 | .hsenv 30 | TAGS 31 | cabal.project.local 32 | cabal.sandbox.config 33 | codex.tags 34 | docs 35 | stack.yaml 36 | stack.yaml.lock 37 | tags 38 | wiki 39 | wip 40 | .ghc.environment.* 41 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for toml-parser 2 | 3 | ## 2.0.1.2 4 | 5 | * Reject inputs with out-of-bounds time zone offsets in accordance 6 | with the toml-tests test suite. 7 | 8 | ## 2.0.1.1 9 | 10 | * Fixes bug that prohibited non-ASCII characters in `'''` strings. 11 | 12 | ## 2.0.1.0 13 | 14 | * Added `ToValue UTCTime` and `FromValue UTCTime`. These correspond 15 | to offset data-times with the timezone translated to UTC. 16 | 17 | ## 2.0.0.0 18 | 19 | * Pervasive annotations on the values added to allow for detailed 20 | positional error reporting throughout parsing and validation. 21 | * Replace uses of String with Text in the Value type and throughout 22 | the API 23 | * Reorganized almost all of the modules to minimize imports that upstream 24 | packages will actually need. 25 | 26 | ## 1.3.3.0 27 | 28 | * Added `IsString Value` instance. 29 | * Addded helpers for `runMatcher` for ignoring and failing on warning 30 | `runMatcherIgnoreWarn` and `runMatcherFatalWarn` 31 | 32 | ## 1.3.2.0 33 | 34 | * Added `Toml.Generic` to make instances easily derivable via DerivingVia. 35 | * Added GHC.Generics support for switching between product types and TOML arrays. 36 | 37 | ## 1.3.1.3 38 | 39 | * Bugfix: Previous fix admitted some invalid inline tables - these are now rejected 40 | 41 | ## 1.3.1.2 42 | 43 | * Bugfix: In some cases overlapping keys in inline tables could throw an exception 44 | instead instead of returning the proper semantic error value. 45 | 46 | ## 1.3.1.1 47 | 48 | * Ensure years are rendered zero-padded 49 | 50 | ## 1.3.1.0 51 | 52 | * Added `Toml.Semantics.Ordered` for preserving input TOML orderings 53 | * Added support for pretty-printing multi-line strings 54 | 55 | ## 1.3.0.0 -- 2023-07-16 56 | 57 | * Make more structured error messages available in the low-level modules. 58 | Consumers of the `Toml` module can keep getting simple error strings 59 | and users interested in structured errors can run the different layers 60 | independently to get more detailed error reporting. 61 | * `FromValue` and `ToValue` instances for: `Ratio`, `NonEmpty`, `Seq` 62 | * Add `FromKey` and `ToKey` for allowing codecs for `Map` to use various key types. 63 | 64 | ## 1.2.1.0 -- 2023-07-12 65 | 66 | * Added `Toml.Pretty.prettyTomlOrdered` to allow user-specified section ordering. 67 | * Added `FromValue` and `ToValue` instances for `Text` 68 | * Added `reqKeyOf` and `optKeyOf` for easier custom matching without `FromValue` instances. 69 | 70 | ## 1.2.0.0 -- 2023-07-09 71 | 72 | * Remove `FromTable` class. This class existed for things that could be 73 | matched specifically from tables, which is what the top-level values 74 | always are. However `FromValue` already handles this, and both classes 75 | can fail, so having the extra level of checking doesn't avoid failure. 76 | It does, however, create a lot of noise generating instances. Note that 77 | `ToTable` continues to exist because `toTable` isn't allowed to fail, 78 | and when serializing to TOML syntax you can only serialize top-level 79 | tables. 80 | * Extracted `Toml.FromValue.Matcher` and `Toml.FromValue.ParseTable` into 81 | their own modules. 82 | * Add `pickKey`, `liftMatcher`, `inKey`, `inIndex`, `parseTableFromValue` to `Toml.FromValue` 83 | * Replace `genericFromTable` with `genericParseTable`. The intended way to 84 | derive a `FromValue` instance is now to write: 85 | 86 | ```haskell 87 | instance FromValue T where fromValue = parseTableFromValue genericParseTable 88 | ``` 89 | 90 | ## 1.1.1.0 -- 2023-07-03 91 | 92 | * Add support for GHC 8.10.7 and 9.0.2 93 | 94 | ## 1.1.0.0 -- 2023-07-03 95 | 96 | * Add Toml.FromValue.Generic and Toml.ToValue.Generic 97 | * Add Alternative instance to Matcher and support multiple error messages in Result 98 | * Add Data and Generic instances for Value 99 | 100 | ## 1.0.1.0 -- 2023-07-01 101 | 102 | * Add ToTable and ToValue instances for Map 103 | * Refine error messages 104 | * More test coverage 105 | 106 | ## 1.0.0.0 -- 2023-06-29 107 | 108 | * Complete rewrite including 1.0.0 compliance and pretty-printing. 109 | 110 | ## 0.1.0.0 -- 2017-05-04 111 | 112 | * First version. 113 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 Eric Mertens 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.lhs: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # TOML Parser 2 | 3 | This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.0). 4 | 5 | This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated 6 | lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser. 7 | 8 | It also provides a pair of classes for serializing into and out of TOML. 9 | 10 | ## Package Structure 11 | 12 | ```mermaid 13 | --- 14 | title: Package Structure 15 | --- 16 | stateDiagram-v2 17 | classDef important font-weight:bold; 18 | 19 | TOML:::important --> ApplicationTypes:::important : decode 20 | ApplicationTypes --> TOML : encode 21 | TOML --> [Token]: Lexer 22 | [Token] --> [Expr]: Parser 23 | [Expr] --> Table : Semantics 24 | Table --> ApplicationTypes : FromValue 25 | ApplicationTypes --> Table : ToValue 26 | Table --> TOML : Pretty 27 | ``` 28 | 29 | Most users will only need to import **Toml** or **Toml.Schema**. Other top-level 30 | modules are for low-level hacking on the TOML format itself. All modules below 31 | these top-level modules are exposed to provide direct access to library implementation 32 | details. 33 | 34 | - **Toml** - Basic encoding and decoding TOML 35 | - **Toml.Schema** - TOML schemas for application types 36 | - **Toml.Semantics** - Low-level semantic operations on TOML syntax 37 | - **Toml.Syntax** - Low-level parsing of text into TOML raw syntax 38 | 39 | ## Examples 40 | 41 | This file uses [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) 42 | to ensure that its code typechecks and stays in sync with the rest of the package. 43 | 44 | ```haskell 45 | {-# Language OverloadedStrings #-} 46 | import Data.Text (Text) 47 | import GHC.Generics (Generic) 48 | import QuoteStr (quoteStr) 49 | import Test.Hspec (Spec, hspec, it, shouldBe) 50 | import Toml 51 | import Toml.Schema 52 | 53 | main :: IO () 54 | main = hspec (parses >> decodes >> encodes >> warns >> errors) 55 | ``` 56 | 57 | ### Using the raw parser 58 | 59 | Consider this sample TOML text from the TOML specification. 60 | 61 | ```haskell 62 | fruitStr :: Text 63 | fruitStr = [quoteStr| 64 | ``` 65 | 66 | ```toml 67 | [[fruits]] 68 | name = "apple" 69 | 70 | [fruits.physical] # subtable 71 | color = "red" 72 | shape = "round" 73 | 74 | [[fruits.varieties]] # nested array of tables 75 | name = "red delicious" 76 | 77 | [[fruits.varieties]] 78 | name = "granny smith" 79 | 80 | 81 | [[fruits]] 82 | name = "banana" 83 | 84 | [[fruits.varieties]] 85 | name = "plantain" 86 | ``` 87 | 88 | ```haskell 89 | |] 90 | ``` 91 | 92 | Parsing using this package generates the following unstructured value 93 | 94 | ```haskell 95 | parses :: Spec 96 | parses = it "parses" $ 97 | forgetTableAnns <$> parse fruitStr 98 | `shouldBe` 99 | Right (table [ 100 | ("fruits", List [ 101 | Table (table [ 102 | ("name", Text "apple"), 103 | ("physical", Table (table [ 104 | ("color", Text "red"), 105 | ("shape", Text "round")])), 106 | ("varieties", List [ 107 | Table (table [("name", Text "red delicious")]), 108 | Table (table [("name", Text "granny smith")])])]), 109 | Table (table [ 110 | ("name", Text "banana"), 111 | ("varieties", List [ 112 | Table (table [("name", Text "plantain")])])])])]) 113 | ``` 114 | 115 | ### Defining a schema 116 | 117 | We can define a schema for our TOML format in the form of instances of 118 | `FromValue`, `ToValue`, and `ToTable` in order to read TOML directly 119 | into structured data form. This example manually derives some of the 120 | instances as a demonstration. 121 | 122 | ```haskell 123 | newtype Fruits = Fruits { fruits :: [Fruit] } 124 | deriving (Eq, Show, Generic) 125 | deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruits 126 | 127 | data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } 128 | deriving (Eq, Show, Generic) 129 | deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit 130 | 131 | data Physical = Physical { color :: String, shape :: String } 132 | deriving (Eq, Show, Generic) 133 | deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical 134 | 135 | newtype Variety = Variety String 136 | deriving (Eq, Show) 137 | 138 | instance FromValue Variety where 139 | fromValue = parseTableFromValue (Variety <$> reqKey "name") 140 | instance ToValue Variety where 141 | toValue = defaultTableToValue 142 | instance ToTable Variety where 143 | toTable (Variety x) = table ["name" .= x] 144 | 145 | ``` 146 | 147 | We can run this example on the original value to deserialize it into domain-specific datatypes. 148 | 149 | ```haskell 150 | decodes :: Spec 151 | decodes = it "decodes" $ 152 | decode fruitStr 153 | `shouldBe` 154 | Success [] (Fruits [ 155 | Fruit 156 | "apple" 157 | (Just (Physical "red" "round")) 158 | [Variety "red delicious", Variety "granny smith"], 159 | Fruit "banana" Nothing [Variety "plantain"]]) 160 | 161 | encodes :: Spec 162 | encodes = it "encodes" $ 163 | show (encode (Fruits [Fruit 164 | "apple" 165 | (Just (Physical "red" "round")) 166 | [Variety "red delicious", Variety "granny smith"]])) 167 | `shouldBe` [quoteStr| 168 | [[fruits]] 169 | name = "apple" 170 | 171 | [fruits.physical] 172 | color = "red" 173 | shape = "round" 174 | 175 | [[fruits.varieties]] 176 | name = "red delicious" 177 | 178 | [[fruits.varieties]] 179 | name = "granny smith"|] 180 | ``` 181 | 182 | ### Useful errors and warnings 183 | 184 | This package takes care to preserve source information as much as possible 185 | in order to provide useful feedback to users. These examples show a couple 186 | of the message that can be generated when things don't go perfectly. 187 | 188 | ```haskell 189 | warns :: Spec 190 | warns = it "warns" $ 191 | decode [quoteStr| 192 | name = "simulated" 193 | typo = 10|] 194 | `shouldBe` 195 | Success 196 | ["2:1: unexpected key: typo in "] -- warnings 197 | (Variety "simulated") 198 | 199 | errors :: Spec 200 | errors = it "errors" $ 201 | decode [quoteStr| 202 | # Physical characteristics table 203 | color = "blue" 204 | shape = []|] 205 | `shouldBe` 206 | (Failure 207 | ["3:9: expected string but got array in shape"] 208 | :: Result String Physical) 209 | ``` 210 | 211 | ## More Examples 212 | 213 | A demonstration of using this package at a more realistic scale 214 | can be found in [HieDemoSpec](test/HieDemoSpec.hs). The various unit 215 | test files demonstrate what you can do with this library and what 216 | outputs you can expect. 217 | 218 | See the low-level operations used to build a TOML syntax highlighter 219 | in [TomlHighlighter](test-drivers/highlighter/Main.hs). 220 | -------------------------------------------------------------------------------- /benchmarker/benchmarker.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | import Control.Exception (evaluate) 4 | import qualified Data.Text.IO 5 | import Data.Time (diffUTCTime, getCurrentTime) 6 | import System.Environment (getArgs) 7 | import Toml (parse) 8 | 9 | main :: IO () 10 | main = 11 | do args <- getArgs 12 | filename <- case args of 13 | [filename] -> pure filename 14 | _ -> fail "Usage: benchmarker " 15 | txt <- Data.Text.IO.readFile filename 16 | start <- getCurrentTime 17 | evaluate (parse txt) 18 | stop <- getCurrentTime 19 | print (stop `diffUTCTime` start) 20 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./toml-parser.cabal 3 | test-drivers/toml-test-drivers.cabal -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | components: 4 | - path: "./src" 5 | component: "toml-parser:lib:toml-parser" 6 | - path: "./test" 7 | component: "toml-parser:test:unittests" 8 | - path: "./test-drivers/encoder" 9 | component: "toml-test-drivers:exe:TomlEncoder" 10 | - path: "./test-drivers/decoder" 11 | component: "toml-test-drivers:exe:TomlDecoder" 12 | - path: "./test-drivers/highlighter" 13 | component: "toml-test-drivers:exe:TomlHighlighter" 14 | - path: "./benchmarker" 15 | component: "toml-parser:exe:benchmarker" 16 | dependencies: 17 | - src/Toml/Lexer.x 18 | - src/Toml/Parser.y 19 | -------------------------------------------------------------------------------- /src/Toml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-| 3 | Module : Toml 4 | Description : TOML parsing, printing, and codecs 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This is the high-level interface to the toml-parser library. 10 | It enables parsing, printing, and conversion into and out of 11 | application-specific representations. 12 | 13 | This parser implements TOML 1.0.0 14 | as carefully as possible. 15 | 16 | Use "Toml.Schema" to implement functions mapping between TOML 17 | values and your application types. 18 | 19 | Use "Toml.Syntax" and "Toml.Semantics" for low-level TOML syntax 20 | processing and semantic validation. Most applications will not 21 | need to use these modules directly unless the application is 22 | about TOML itself. 23 | 24 | The types and functions of this package are parameterized over 25 | an annotation type in order to allow applications to provide 26 | detailed feedback messages tracked back to specific source 27 | locations in an original TOML file. While the default annotation 28 | is a simple file position, some applications might upgrade this 29 | annotation to track multiple file names or synthetically generated 30 | sources. Other applications won't need source location and can 31 | replace annotations with a simple unit type. 32 | 33 | -} 34 | module Toml ( 35 | 36 | -- * Types 37 | Table, 38 | Value, 39 | 40 | -- * Located types 41 | Located(..), 42 | Position(..), 43 | Table'(..), 44 | Value'(..), 45 | valueAnn, 46 | valueType, 47 | forgetTableAnns, 48 | forgetValueAnns, 49 | 50 | -- * Parsing 51 | decode', 52 | decode, 53 | parse, 54 | DecodeError, 55 | Result(..), 56 | 57 | -- * Printing 58 | encode, 59 | prettyToml, 60 | DocClass(..), 61 | 62 | -- * Error rendering 63 | prettyDecodeError, 64 | prettyLocated, 65 | prettyMatchMessage, 66 | prettySemanticError, 67 | ) where 68 | 69 | import Data.Text (Text) 70 | import Text.Printf (printf) 71 | import Toml.Pretty 72 | import Toml.Schema 73 | import Toml.Semantics 74 | import Toml.Syntax 75 | 76 | -- | Parse a TOML formatted 'String' or report a structured error message. 77 | parse' :: Text -> Either DecodeError (Table' Position) 78 | parse' str = 79 | case parseRawToml str of 80 | Left e -> Left (ErrSyntax e) 81 | Right exprs -> 82 | case semantics exprs of 83 | Left e -> Left (ErrSemantics e) 84 | Right tab -> Right tab 85 | 86 | -- | Parse a TOML formatted 'String' or report a human-readable error message. 87 | parse :: Text -> Either String (Table' Position) 88 | parse str = 89 | case parse' str of 90 | Left e -> Left (prettyDecodeError e) 91 | Right x -> Right x 92 | 93 | -- | Sum of errors that can occur during TOML decoding 94 | data DecodeError 95 | = ErrSyntax (Located String) -- ^ Error during the lexer/parser phase 96 | | ErrSemantics (SemanticError Position) -- ^ Error during TOML validation 97 | | ErrSchema (MatchMessage Position) -- ^ Error during schema matching 98 | 99 | -- | Decode TOML syntax into an application value. 100 | decode' :: FromValue a => Text -> Result DecodeError a 101 | decode' str = 102 | case parse' str of 103 | Left e -> Failure [e] 104 | Right tab -> 105 | case runMatcher (fromValue (Table' startPos tab)) of 106 | Failure es -> Failure (ErrSchema <$> es) 107 | Success ws x -> Success (ErrSchema <$> ws) x 108 | 109 | -- | Wrapper rending error and warning messages into human-readable strings. 110 | decode :: FromValue a => Text -> Result String a 111 | decode str = 112 | case decode' str of 113 | Failure e -> Failure (map prettyDecodeError e) 114 | Success w x -> Success (map prettyDecodeError w) x 115 | 116 | -- | Use the 'ToTable' instance to encode a value to a TOML string. 117 | encode :: ToTable a => a -> TomlDoc 118 | encode = prettyToml . toTable 119 | 120 | -- | Human-readable representation of a 'DecodeError' 121 | prettyDecodeError :: DecodeError -> String 122 | prettyDecodeError = \case 123 | ErrSyntax e -> prettyLocated e 124 | ErrSemantics e -> prettySemanticError e 125 | ErrSchema e -> prettyMatchMessage e 126 | 127 | -- | Render a TOML decoding error as a human-readable string. 128 | prettyMatchMessage :: MatchMessage Position -> String 129 | prettyMatchMessage (MatchMessage loc scope msg) = prefix ++ msg ++ " in " ++ path 130 | where 131 | prefix = 132 | case loc of 133 | Nothing -> "" 134 | Just l -> prettyPosition l ++ ": " 135 | path = 136 | case scope of 137 | [] -> "" 138 | ScopeKey key : scope' -> shows (prettySimpleKey key) (foldr f "" scope') 139 | ScopeIndex i : scope' -> foldr f "" (ScopeIndex i : scope') -- should be impossible 140 | 141 | f (ScopeIndex i) = showChar '[' . shows i . showChar ']' 142 | f (ScopeKey key) = showChar '.' . shows (prettySimpleKey key) 143 | 144 | -- | Render a semantic TOML error in a human-readable string. 145 | prettySemanticError :: SemanticError Position -> String 146 | prettySemanticError (SemanticError a key kind) = 147 | printf "%s: key error: %s %s" (prettyPosition a) (show (prettySimpleKey key)) 148 | case kind of 149 | AlreadyAssigned -> "is already assigned" :: String 150 | ClosedTable -> "is a closed table" 151 | ImplicitlyTable -> "is already implicitly defined to be a table" 152 | -------------------------------------------------------------------------------- /src/Toml/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings, GADTs #-} 2 | {-| 3 | Module : Toml.Pretty 4 | Description : Human-readable representations for error messages 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module provides human-readable renderers for types used 10 | in this package to assist error message production. 11 | 12 | The generated 'Doc' values are annotated with 'DocClass' values 13 | to assist in producing syntax-highlighted outputs. 14 | 15 | To extract a plain String representation, use 'show'. 16 | 17 | -} 18 | module Toml.Pretty ( 19 | -- * Types 20 | TomlDoc, 21 | DocClass(..), 22 | 23 | -- * Printing semantic values 24 | prettyToml, 25 | prettyTomlOrdered, 26 | prettyValue, 27 | 28 | -- * Printing syntactic components 29 | prettyToken, 30 | prettySectionKind, 31 | 32 | -- * Printing keys 33 | prettySimpleKey, 34 | prettyKey, 35 | 36 | -- * Locations 37 | prettyLocated, 38 | prettyPosition, 39 | ) where 40 | 41 | import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) 42 | import Data.Foldable (fold) 43 | import Data.List (partition, sortOn) 44 | import Data.List.NonEmpty (NonEmpty) 45 | import Data.List.NonEmpty qualified as NonEmpty 46 | import Data.Map qualified as Map 47 | import Data.String (fromString) 48 | import Data.Text (Text) 49 | import Data.Text qualified as Text 50 | import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes)) 51 | import Data.Time.Format (formatTime, defaultTimeLocale) 52 | import Prettyprinter 53 | import Text.Printf (printf) 54 | import Toml.Semantics 55 | import Toml.Syntax.Lexer (Token(..)) 56 | import Toml.Syntax.Position (Located(..), Position(..)) 57 | import Toml.Syntax.Types (SectionKind(..)) 58 | 59 | -- | Annotation used to enable styling pretty-printed TOML 60 | data DocClass 61 | = TableClass -- ^ top-level @[key]@ and @[[key]]@ 62 | | KeyClass -- ^ dotted keys, left-hand side of assignments 63 | | StringClass -- ^ string literals 64 | | NumberClass -- ^ number literals 65 | | DateClass -- ^ date and time literals 66 | | BoolClass -- ^ boolean literals 67 | deriving (Read, Show, Eq, Ord) 68 | 69 | -- | Pretty-printer document with TOML class attributes to aid 70 | -- in syntax-highlighting. 71 | type TomlDoc = Doc DocClass 72 | 73 | -- | Renders a dotted-key using quotes where necessary and annotated 74 | -- as a 'KeyClass'. 75 | prettyKey :: NonEmpty Text -> TomlDoc 76 | prettyKey = annotate KeyClass . fold . NonEmpty.intersperse dot . fmap prettySimpleKey 77 | 78 | -- | Renders a simple-key using quotes where necessary. 79 | prettySimpleKey :: Text -> Doc a 80 | prettySimpleKey str 81 | | not (Text.null str), Text.all isBareKey str = pretty str 82 | | otherwise = fromString (quoteString (Text.unpack str)) 83 | 84 | -- | Predicate for the character-class that is allowed in bare keys 85 | isBareKey :: Char -> Bool 86 | isBareKey x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '-' || x == '_' 87 | 88 | -- | Quote a string using basic string literal syntax. 89 | quoteString :: String -> String 90 | quoteString = ('"':) . go 91 | where 92 | go = \case 93 | "" -> "\"" -- terminator 94 | '"' : xs -> '\\' : '"' : go xs 95 | '\\' : xs -> '\\' : '\\' : go xs 96 | '\b' : xs -> '\\' : 'b' : go xs 97 | '\f' : xs -> '\\' : 'f' : go xs 98 | '\n' : xs -> '\\' : 'n' : go xs 99 | '\r' : xs -> '\\' : 'r' : go xs 100 | '\t' : xs -> '\\' : 't' : go xs 101 | x : xs 102 | | isPrint x -> x : go xs 103 | | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) 104 | | otherwise -> printf "\\U%08X%s" (ord x) (go xs) 105 | 106 | -- | Quote a string using basic string literal syntax. 107 | quoteMlString :: String -> String 108 | quoteMlString = ("\"\"\"\n"++) . go 109 | where 110 | go = \case 111 | "" -> "\"\"\"" -- terminator 112 | '"' : '"' : '"' : xs -> "\"\"\\\"" ++ go xs 113 | '\\' : xs -> '\\' : '\\' : go xs 114 | '\b' : xs -> '\\' : 'b' : go xs 115 | '\f' : xs -> '\\' : 'f' : go xs 116 | '\t' : xs -> '\\' : 't' : go xs 117 | '\n' : xs -> '\n' : go xs 118 | '\r' : '\n' : xs -> '\r' : '\n' : go xs 119 | '\r' : xs -> '\\' : 'r' : go xs 120 | x : xs 121 | | isPrint x -> x : go xs 122 | | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) 123 | | otherwise -> printf "\\U%08X%s" (ord x) (go xs) 124 | 125 | -- | Pretty-print a section heading. The result is annotated as a 'TableClass'. 126 | prettySectionKind :: SectionKind -> NonEmpty Text -> TomlDoc 127 | prettySectionKind TableKind key = 128 | annotate TableClass (unAnnotate (lbracket <> prettyKey key <> rbracket)) 129 | prettySectionKind ArrayTableKind key = 130 | annotate TableClass (unAnnotate (lbracket <> lbracket <> prettyKey key <> rbracket <> rbracket)) 131 | 132 | -- | Render token for human-readable error messages. 133 | prettyToken :: Token -> String 134 | prettyToken = \case 135 | TokComma -> "','" 136 | TokEquals -> "'='" 137 | TokPeriod -> "'.'" 138 | TokSquareO -> "'['" 139 | TokSquareC -> "']'" 140 | Tok2SquareO -> "'[['" 141 | Tok2SquareC -> "']]'" 142 | TokCurlyO -> "'{'" 143 | TokCurlyC -> "'}'" 144 | TokNewline -> "end-of-line" 145 | TokBareKey _ -> "bare key" 146 | TokTrue -> "true literal" 147 | TokFalse -> "false literal" 148 | TokString _ -> "string" 149 | TokMlString _ -> "multi-line string" 150 | TokInteger _ -> "integer" 151 | TokFloat _ -> "float" 152 | TokOffsetDateTime _ -> "offset date-time" 153 | TokLocalDateTime _ -> "local date-time" 154 | TokLocalDate _ -> "local date" 155 | TokLocalTime _ -> "local time" 156 | TokEOF -> "end-of-input" 157 | 158 | prettyAssignment :: Text -> Value' l -> TomlDoc 159 | prettyAssignment = go . pure 160 | where 161 | go ks (Table' _ (MkTable (Map.assocs -> [(k,(_, v))]))) = go (NonEmpty.cons k ks) v 162 | go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v 163 | 164 | -- | Render a value suitable for assignment on the right-hand side 165 | -- of an equals sign. This value will always use inline table and list 166 | -- syntax. 167 | prettyValue :: Value' l -> TomlDoc 168 | prettyValue = \case 169 | Integer' _ i -> annotate NumberClass (pretty i) 170 | Double' _ f 171 | | isNaN f -> annotate NumberClass "nan" 172 | | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") 173 | | otherwise -> annotate NumberClass (pretty f) 174 | List' _ a -> align (list [prettyValue v | v <- a]) 175 | Table' _ (MkTable t) -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,(_, v)) <- Map.assocs t] <> rbrace 176 | Bool' _ True -> annotate BoolClass "true" 177 | Bool' _ False -> annotate BoolClass "false" 178 | Text' _ str -> prettySmartString str 179 | TimeOfDay' _ tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) 180 | ZonedTime' _ zt 181 | | timeZoneMinutes (zonedTimeZone zt) == 0 -> 182 | annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ" zt)) 183 | | otherwise -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%Ez" zt)) 184 | LocalTime' _ lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q" lt)) 185 | Day' _ d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%d" d)) 186 | 187 | prettySmartString :: Text -> TomlDoc 188 | prettySmartString str 189 | | '\n' `elem` Text.unpack str = -- Text.elem isn't in text-1.2 190 | column \i -> 191 | pageWidth \case 192 | AvailablePerLine n _ | Text.length str > n - i -> 193 | prettyMlString str 194 | _ -> prettyString str 195 | | otherwise = prettyString str 196 | 197 | prettyMlString :: Text -> TomlDoc 198 | prettyMlString str = annotate StringClass (column \i -> hang (-i) (fromString (quoteMlString (Text.unpack str)))) 199 | 200 | prettyString :: Text -> TomlDoc 201 | prettyString str = annotate StringClass (fromString (quoteString (Text.unpack str))) 202 | 203 | -- | Predicate for values that CAN rendered on the 204 | -- right-hand side of an @=@. 205 | isSimple :: Value' l -> Bool 206 | isSimple = \case 207 | Integer' {} -> True 208 | Double' {} -> True 209 | Bool' {} -> True 210 | Text' {} -> True 211 | TimeOfDay' {} -> True 212 | ZonedTime' {} -> True 213 | LocalTime' {} -> True 214 | Day' {} -> True 215 | Table' _ x -> isSingularTable x -- differs from isAlwaysSimple 216 | List' _ x -> null x || not (all isTable x) 217 | 218 | -- | Predicate for values that can be MUST rendered on the 219 | -- right-hand side of an @=@. 220 | isAlwaysSimple :: Value' l -> Bool 221 | isAlwaysSimple = \case 222 | Integer' {} -> True 223 | Double' {} -> True 224 | Bool' {} -> True 225 | Text' {} -> True 226 | TimeOfDay' {} -> True 227 | ZonedTime' {} -> True 228 | LocalTime' {} -> True 229 | Day' {} -> True 230 | Table' {} -> False -- differs from isSimple 231 | List' _ x -> null x || not (all isTable x) 232 | 233 | -- | Predicate for table values. 234 | isTable :: Value' l -> Bool 235 | isTable Table'{} = True 236 | isTable _ = False 237 | 238 | -- | Predicate for tables that can be rendered with a single assignment. 239 | -- These can be collapsed using dotted-key notation on the left-hand side 240 | -- of a @=@. 241 | isSingularTable :: Table' l -> Bool 242 | isSingularTable (MkTable (Map.elems -> [(_, v)])) = isSimple v 243 | isSingularTable _ = False 244 | 245 | -- | Render a complete TOML document using top-level table and array of 246 | -- table sections where possible. 247 | -- 248 | -- Keys are sorted alphabetically. To provide a custom ordering, see 249 | -- 'prettyTomlOrdered'. 250 | prettyToml :: 251 | Table' a {- ^ table to print -} -> 252 | TomlDoc {- ^ TOML syntax -} 253 | prettyToml = prettyToml_ NoProjection TableKind [] 254 | 255 | -- | Render a complete TOML document like 'prettyToml' but use a 256 | -- custom key ordering. The comparison function has access to the 257 | -- complete key path. Note that only keys in the same table will 258 | -- every be compared. 259 | -- 260 | -- This operation allows you to render your TOML files with the 261 | -- most important sections first. A TOML file describing a package 262 | -- might desire to have the @[package]@ section first before any 263 | -- of the ancillary configuration sections. 264 | -- 265 | -- The /table path/ is the name of the table being sorted. This allows 266 | -- the projection to be aware of which table is being sorted. 267 | -- 268 | -- The /key/ is the key in the table being sorted. These are the 269 | -- keys that will be compared to each other. 270 | -- 271 | -- Here's a projection that puts the @package@ section first, the 272 | -- @secondary@ section second, and then all remaining cases are 273 | -- sorted alphabetically afterward. 274 | -- 275 | -- @ 276 | -- example :: [String] -> String -> Either Int String 277 | -- example [] "package" = Left 1 278 | -- example [] "second" = Left 2 279 | -- example _ other = Right other 280 | -- @ 281 | -- 282 | -- We could also put the tables in reverse-alphabetical order 283 | -- by leveraging an existing newtype. 284 | -- 285 | -- @ 286 | -- reverseOrderProj :: [String] -> String -> Down String 287 | -- reverseOrderProj _ = Down 288 | -- @ 289 | prettyTomlOrdered :: 290 | Ord a => 291 | ([Text] -> Text -> a) {- ^ table path -> key -> projection -} -> 292 | Table' l {- ^ table to print -} -> 293 | TomlDoc {- ^ TOML syntax -} 294 | prettyTomlOrdered proj = prettyToml_ (KeyProjection proj) TableKind [] 295 | 296 | -- | Optional projection used to order rendered tables 297 | data KeyProjection where 298 | -- | No projection provided; alphabetical order used 299 | NoProjection :: KeyProjection 300 | -- | Projection provided: table name and current key are available 301 | KeyProjection :: Ord a => ([Text] -> Text -> a) -> KeyProjection 302 | 303 | prettyToml_ :: KeyProjection -> SectionKind -> [Text] -> Table' l -> TomlDoc 304 | prettyToml_ mbKeyProj kind prefix (MkTable t) = vcat (topLines ++ subtables) 305 | where 306 | order = 307 | case mbKeyProj of 308 | NoProjection -> id 309 | KeyProjection f -> sortOn (f prefix . fst) 310 | 311 | kvs = order (Map.assocs t) 312 | 313 | -- this table will require no subsequent tables to be defined 314 | simpleToml = all (isSimple . snd) t 315 | 316 | (simple, sections) = partition (isAlwaysSimple . snd . snd) kvs 317 | 318 | topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] 319 | 320 | headers = 321 | case NonEmpty.nonEmpty prefix of 322 | Just key | simpleToml || not (null simple) || null sections || kind == ArrayTableKind -> 323 | [prettySectionKind kind key <> hardline] 324 | _ -> [] 325 | 326 | assignments = [prettyAssignment k v <> hardline | (k,(_, v)) <- if simpleToml then kvs else simple] 327 | 328 | subtables = [prettySection (prefix ++ [k]) v | not simpleToml, (k,(_, v)) <- sections] 329 | 330 | prettySection key (Table' _ tab) = 331 | prettyToml_ mbKeyProj TableKind key tab 332 | prettySection key (List' _ a) = 333 | vcat [prettyToml_ mbKeyProj ArrayTableKind key tab | Table' _ tab <- a] 334 | prettySection _ _ = error "prettySection applied to simple value" 335 | 336 | -- | Pretty-print as @line:col: message@ 337 | prettyLocated :: Located String -> String 338 | prettyLocated (Located p s) = printf "%s: %s" (prettyPosition p) s 339 | 340 | -- | Pretty-print as @line:col@ 341 | prettyPosition :: Position -> String 342 | prettyPosition p = printf "%d:%d" (posLine p) (posColumn p) 343 | -------------------------------------------------------------------------------- /src/Toml/Schema.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Schema 3 | Description : Infrastructure for converting between TOML and application values 4 | Copyright : (c) Eric Mertens, 2024 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | -} 9 | module Toml.Schema ( 10 | -- * FromValue 11 | FromValue(..), 12 | mapOf, 13 | listOf, 14 | 15 | -- ** Matcher 16 | Matcher, 17 | runMatcher, 18 | runMatcherFatalWarn, 19 | runMatcherIgnoreWarn, 20 | Result(..), 21 | MatchMessage(..), 22 | Scope(..), 23 | parseTableFromValue, 24 | parseTable, 25 | getScope, 26 | warn, 27 | warnAt, 28 | failAt, 29 | getTable, 30 | setTable, 31 | 32 | -- ** Tables 33 | ParseTable, 34 | reqKey, 35 | optKey, 36 | reqKeyOf, 37 | optKeyOf, 38 | pickKey, 39 | KeyAlt(..), 40 | warnTable, 41 | warnTableAt, 42 | failTableAt, 43 | liftMatcher, 44 | 45 | -- * ToValue 46 | ToValue(..), 47 | ToTable(..), 48 | 49 | table, 50 | (.=), 51 | defaultTableToValue, 52 | 53 | -- * Types 54 | Value, Value'(..), 55 | Table, Table'(..), 56 | 57 | -- * Generics 58 | GenericTomlArray(..), 59 | GenericTomlTable(..), 60 | genericFromTable, 61 | genericFromArray, 62 | genericToArray, 63 | genericToTable, 64 | 65 | ) where 66 | 67 | import Toml.Schema.FromValue 68 | import Toml.Schema.Generic 69 | import Toml.Schema.ParseTable 70 | import Toml.Schema.Matcher 71 | import Toml.Schema.ToValue 72 | import Toml.Semantics 73 | -------------------------------------------------------------------------------- /src/Toml/Schema/FromValue.hs: -------------------------------------------------------------------------------- 1 | {-# Language TypeFamilies #-} 2 | {-| 3 | Module : Toml.Schema.FromValue 4 | Description : Automation for converting TOML values to application values. 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | Use 'FromValue' to define a transformation from some 'Value' to an application 10 | domain type. 11 | 12 | Use 'ParseTable' to help build 'FromValue' instances that match tables. It 13 | will make it easy to track which table keys have been used and which are left 14 | over. 15 | 16 | Warnings can be emitted using 'warn' and 'warnTable' (depending on what) 17 | context you're in. These warnings can provide useful feedback about 18 | problematic values or keys that might be unused now but were perhaps 19 | meaningful in an old version of a configuration file. 20 | 21 | "Toml.Schema.FromValue.Generic" can be used to derive instances of 'FromValue' 22 | automatically for record types. 23 | 24 | -} 25 | module Toml.Schema.FromValue ( 26 | -- * Deserialization classes 27 | FromValue(..), 28 | FromKey(..), 29 | 30 | -- * Containers 31 | mapOf, 32 | listOf, 33 | 34 | -- * Tables 35 | parseTableFromValue, 36 | reqKey, 37 | reqKeyOf, 38 | optKey, 39 | optKeyOf, 40 | 41 | -- * Errors 42 | typeError, 43 | 44 | ) where 45 | 46 | import Control.Monad (zipWithM, liftM2) 47 | import Data.Int (Int8, Int16, Int32, Int64) 48 | import Data.List.NonEmpty (NonEmpty) 49 | import Data.List.NonEmpty qualified as NonEmpty 50 | import Data.Map (Map) 51 | import Data.Map qualified as Map 52 | import Data.Ratio (Ratio) 53 | import Data.Sequence (Seq) 54 | import Data.Sequence qualified as Seq 55 | import Data.Text (Text) 56 | import Data.Text qualified as Text 57 | import Data.Text.Lazy qualified 58 | import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay, UTCTime, zonedTimeToUTC) 59 | import Data.Word (Word8, Word16, Word32, Word64) 60 | import Numeric.Natural (Natural) 61 | import Toml.Schema.Matcher 62 | import Toml.Schema.ParseTable 63 | import Toml.Semantics 64 | 65 | -- | Table matching function used to help implement 'fromValue' for tables. 66 | -- Key matching function is given the annotation of the key for error reporting. 67 | -- Value matching function is given the key in case values can depend on their keys. 68 | mapOf :: 69 | Ord k => 70 | (l -> Text -> Matcher l k) {- ^ key matcher -} -> 71 | (Text -> Value' l -> Matcher l v) {- ^ value matcher -} -> 72 | Value' l -> Matcher l (Map k v) 73 | mapOf matchKey matchVal = 74 | \case 75 | Table' _ (MkTable t) -> Map.fromList <$> sequence kvs 76 | where 77 | kvs = [liftM2 (,) (matchKey l k) (inKey k (matchVal k v)) | (k, (l, v)) <- Map.assocs t] 78 | v -> typeError "table" v 79 | 80 | -- | List matching function used to help implemented 'fromValue' for arrays. 81 | -- The element matching function is given the list index in case values can 82 | -- depend on their index. 83 | listOf :: 84 | (Int -> Value' l -> Matcher l a) -> 85 | Value' l -> Matcher l [a] 86 | listOf matchElt = 87 | \case 88 | List' _ xs -> zipWithM (\i -> inIndex i . matchElt i) [0..] xs 89 | v -> typeError "array" v 90 | 91 | -- | Class for types that can be decoded from a TOML value. 92 | class FromValue a where 93 | -- | Convert a 'Value' or report an error message 94 | fromValue :: Value' l -> Matcher l a 95 | 96 | -- | Used to implement instance for @[]@. Most implementations rely on the default implementation. 97 | listFromValue :: Value' l -> Matcher l [a] 98 | listFromValue = listOf (const fromValue) 99 | 100 | instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where 101 | fromValue = mapOf fromKey (const fromValue) 102 | 103 | instance FromValue Table where 104 | fromValue (Table' _ t) = pure (forgetTableAnns t) 105 | fromValue v = typeError "table" v 106 | 107 | -- | Convert from a table key 108 | class FromKey a where 109 | fromKey :: l -> Text -> Matcher l a 110 | 111 | -- | Matches all strings 112 | instance a ~ Char => FromKey [a] where 113 | fromKey _ = pure . Text.unpack 114 | 115 | -- | Matches all strings 116 | instance FromKey Text where 117 | fromKey _ = pure 118 | 119 | -- | Matches all strings 120 | instance FromKey Data.Text.Lazy.Text where 121 | fromKey _ = pure . Data.Text.Lazy.fromStrict 122 | 123 | -- | Report a type error 124 | typeError :: String {- ^ expected type -} -> Value' l {- ^ actual value -} -> Matcher l a 125 | typeError wanted got = failAt (valueAnn got) ("expected " ++ wanted ++ " but got " ++ valueType got) 126 | 127 | -- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher. 128 | parseTableFromValue :: ParseTable l a -> Value' l -> Matcher l a 129 | parseTableFromValue p (Table' l t) = parseTable p l t 130 | parseTableFromValue _ v = typeError "table" v 131 | 132 | -- | Matches integer values 133 | instance FromValue Integer where 134 | fromValue (Integer' _ x) = pure x 135 | fromValue v = typeError "integer" v 136 | 137 | -- | Matches non-negative integer values 138 | instance FromValue Natural where 139 | fromValue v = 140 | do i <- fromValue v 141 | if 0 <= i then 142 | pure (fromInteger i) 143 | else 144 | failAt (valueAnn v) "integer out of range for Natural" 145 | 146 | fromValueSized :: forall l a. (Bounded a, Integral a) => String -> Value' l -> Matcher l a 147 | fromValueSized name v = 148 | do i <- fromValue v 149 | if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) then 150 | pure (fromInteger i) 151 | else 152 | failAt (valueAnn v) ("integer out of range for " ++ name) 153 | 154 | instance FromValue Int where fromValue = fromValueSized "Int" 155 | instance FromValue Int8 where fromValue = fromValueSized "Int8" 156 | instance FromValue Int16 where fromValue = fromValueSized "Int16" 157 | instance FromValue Int32 where fromValue = fromValueSized "Int32" 158 | instance FromValue Int64 where fromValue = fromValueSized "Int64" 159 | instance FromValue Word where fromValue = fromValueSized "Word" 160 | instance FromValue Word8 where fromValue = fromValueSized "Word8" 161 | instance FromValue Word16 where fromValue = fromValueSized "Word16" 162 | instance FromValue Word32 where fromValue = fromValueSized "Word32" 163 | instance FromValue Word64 where fromValue = fromValueSized "Word64" 164 | 165 | -- | Matches single-character strings with 'fromValue' and arbitrary 166 | -- strings with 'listFromValue' to support 'Prelude.String' 167 | instance FromValue Char where 168 | fromValue (Text' l t) = 169 | case Text.uncons t of 170 | Just (c, t') 171 | | Text.null t' -> pure c 172 | _ -> failAt l "expected single character" 173 | fromValue v = typeError "string" v 174 | 175 | listFromValue (Text' _ t) = pure (Text.unpack t) 176 | listFromValue v = typeError "string" v 177 | 178 | -- | Matches string literals 179 | instance FromValue Text where 180 | fromValue (Text' _ t) = pure t 181 | fromValue v = typeError "string" v 182 | 183 | -- | Matches string literals 184 | instance FromValue Data.Text.Lazy.Text where 185 | fromValue v = Data.Text.Lazy.fromStrict <$> fromValue v 186 | 187 | -- | Matches floating-point and integer values 188 | instance FromValue Double where 189 | fromValue (Double' _ x) = pure x 190 | fromValue (Integer' _ x) = pure (fromInteger x) 191 | fromValue v = typeError "float" v 192 | 193 | -- | Matches floating-point and integer values 194 | instance FromValue Float where 195 | fromValue (Double' _ x) = pure (realToFrac x) 196 | fromValue (Integer' _ x) = pure (fromInteger x) 197 | fromValue v = typeError "float" v 198 | 199 | -- | Matches floating-point and integer values. 200 | -- 201 | -- TOML specifies @Floats should be implemented as IEEE 754 binary64 values.@ 202 | -- so note that the given 'Rational' will be converted from a double 203 | -- representation and will often be an approximation rather than the exact 204 | -- value. 205 | instance Integral a => FromValue (Ratio a) where 206 | fromValue (Double' a x) 207 | | isNaN x || isInfinite x = failAt a "finite float required" 208 | | otherwise = pure (realToFrac x) 209 | fromValue (Integer' _ x) = pure (fromInteger x) 210 | fromValue v = typeError "float" v 211 | 212 | -- | Matches non-empty arrays or reports an error. 213 | instance FromValue a => FromValue (NonEmpty a) where 214 | fromValue v = 215 | do xs <- fromValue v 216 | case NonEmpty.nonEmpty xs of 217 | Nothing -> failAt (valueAnn v) "non-empty list required" 218 | Just ne -> pure ne 219 | 220 | -- | Matches arrays 221 | instance FromValue a => FromValue (Seq a) where 222 | fromValue v = Seq.fromList <$> fromValue v 223 | 224 | -- | Matches @true@ and @false@ 225 | instance FromValue Bool where 226 | fromValue (Bool' _ x) = pure x 227 | fromValue v = typeError "boolean" v 228 | 229 | -- | Implemented in terms of 'listFromValue' 230 | instance FromValue a => FromValue [a] where 231 | fromValue = listFromValue 232 | 233 | -- | Matches local date literals 234 | instance FromValue Day where 235 | fromValue (Day' _ x) = pure x 236 | fromValue v = typeError "local date" v 237 | 238 | -- | Matches local time literals 239 | instance FromValue TimeOfDay where 240 | fromValue (TimeOfDay' _ x) = pure x 241 | fromValue v = typeError "local time" v 242 | 243 | -- | Matches offset date-time literals 244 | instance FromValue ZonedTime where 245 | fromValue (ZonedTime' _ x) = pure x 246 | fromValue v = typeError "offset date-time" v 247 | 248 | -- | Matches offset date-time literals and converts to UTC 249 | instance FromValue UTCTime where 250 | fromValue (ZonedTime' _ x) = pure (zonedTimeToUTC x) 251 | fromValue v = typeError "offset date-time" v 252 | 253 | -- | Matches local date-time literals 254 | instance FromValue LocalTime where 255 | fromValue (LocalTime' _ x) = pure x 256 | fromValue v = typeError "local date-time" v 257 | 258 | -- | Matches all values, used for pass-through 259 | instance FromValue Value where 260 | fromValue = pure . forgetValueAnns 261 | 262 | -- | Convenience function for matching an optional key with a 'FromValue' 263 | -- instance. 264 | -- 265 | -- @optKey key = 'optKeyOf' key 'fromValue'@ 266 | optKey :: FromValue a => Text -> ParseTable l (Maybe a) 267 | optKey key = optKeyOf key fromValue 268 | 269 | -- | Convenience function for matching a required key with a 'FromValue' 270 | -- instance. 271 | -- 272 | -- @reqKey key = 'reqKeyOf' key 'fromValue'@ 273 | reqKey :: FromValue a => Text -> ParseTable l a 274 | reqKey key = reqKeyOf key fromValue 275 | 276 | -- | Match a table entry by key if it exists or return 'Nothing' if not. 277 | -- If the key is defined, it is matched by the given function. 278 | -- 279 | -- See 'pickKey' for more complex cases. 280 | optKeyOf :: 281 | Text {- ^ key -} -> 282 | (Value' l -> Matcher l a) {- ^ value matcher -} -> 283 | ParseTable l (Maybe a) 284 | optKeyOf key k = pickKey [Key key (fmap Just . k), Else (pure Nothing)] 285 | 286 | -- | Match a table entry by key or report an error if missing. 287 | -- 288 | -- See 'pickKey' for more complex cases. 289 | reqKeyOf :: 290 | Text {- ^ key -} -> 291 | (Value' l -> Matcher l a) {- ^ value matcher -} -> 292 | ParseTable l a 293 | reqKeyOf key k = pickKey [Key key k] 294 | -------------------------------------------------------------------------------- /src/Toml/Schema/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables, InstanceSigs #-} 2 | {-| 3 | Module : Toml.Schema.Generic 4 | Description : Integration with DerivingVia extension 5 | Copyright : (c) Eric Mertens, 2024 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module makes it possible to easily derive the TOML classes 10 | using the @DerivingVia@ extension. 11 | 12 | For example: 13 | 14 | @ 15 | data Physical = Physical { 16 | color :: String, 17 | shape :: String 18 | } 19 | deriving (Eq, Show, Generic) 20 | deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical 21 | @ 22 | 23 | These derived instances would allow you to match TOML 24 | @{color="red", shape="round"}@ to value @Physical "red" "round"@. 25 | 26 | @ 27 | data Coord = Coord Int Int 28 | deriving (Eq, Show, Generic) 29 | deriving (ToValue, FromValue) via GenericTomlArray Physical 30 | @ 31 | 32 | These derived instances would allow you to match TOML @[1,2]@ to value @Coord 1 2@. 33 | 34 | -} 35 | module Toml.Schema.Generic ( 36 | -- * DerivingVia 37 | GenericTomlTable(GenericTomlTable), 38 | GenericTomlArray(GenericTomlArray), 39 | 40 | -- * FromValue 41 | genericFromArray, 42 | genericFromTable, 43 | GFromArray, 44 | GParseTable, 45 | 46 | -- * ToValue 47 | genericToArray, 48 | genericToTable, 49 | GToArray, 50 | GToTable, 51 | ) where 52 | 53 | import Data.Coerce (coerce) 54 | import GHC.Generics (Generic(Rep)) 55 | import Toml.Schema.FromValue 56 | import Toml.Schema.Matcher 57 | import Toml.Schema.Generic.FromValue 58 | import Toml.Schema.Generic.ToValue (GToTable, GToArray, genericToTable, genericToArray) 59 | import Toml.Schema.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue) 60 | import Toml.Semantics (Value, Value', Table) 61 | 62 | -- | Helper type to use GHC's DerivingVia extension to derive 63 | -- 'ToValue', 'ToTable', 'FromValue' for records. 64 | newtype GenericTomlTable a = GenericTomlTable a 65 | 66 | -- | Instance derived from 'ToTable' instance using 'defaultTableToValue' 67 | instance (Generic a, GToTable (Rep a)) => ToValue (GenericTomlTable a) where 68 | toValue = defaultTableToValue 69 | {-# INLINE toValue #-} 70 | 71 | -- | Instance derived using 'genericToTable' 72 | instance (Generic a, GToTable (Rep a)) => ToTable (GenericTomlTable a) where 73 | toTable = coerce (genericToTable :: a -> Table) 74 | {-# INLINE toTable #-} 75 | 76 | -- | Instance derived using 'genericParseTable' 77 | instance (Generic a, GParseTable (Rep a)) => FromValue (GenericTomlTable a) where 78 | fromValue :: forall l. Value' l -> Matcher l (GenericTomlTable a) 79 | fromValue = coerce (parseTableFromValue genericParseTable :: Value' l -> Matcher l a) 80 | {-# INLINE fromValue #-} 81 | 82 | -- | Helper type to use GHC's DerivingVia extension to derive 83 | -- 'ToValue', 'ToTable', 'FromValue' for any product type. 84 | newtype GenericTomlArray a = GenericTomlArray a 85 | 86 | -- | Instance derived using 'genericToArray' 87 | instance (Generic a, GToArray (Rep a)) => ToValue (GenericTomlArray a) where 88 | toValue = coerce (genericToArray :: a -> Value) 89 | {-# INLINE toValue #-} 90 | 91 | -- | Instance derived using 'genericFromArray' 92 | instance (Generic a, GFromArray (Rep a)) => FromValue (GenericTomlArray a) where 93 | fromValue :: forall l. Value' l -> Matcher l (GenericTomlArray a) 94 | fromValue = coerce (genericFromArray :: Value' l -> Matcher l a) 95 | {-# INLINE fromValue #-} 96 | -------------------------------------------------------------------------------- /src/Toml/Schema/Generic/FromValue.hs: -------------------------------------------------------------------------------- 1 | {-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-} 2 | {-| 3 | Module : Toml.Schema.Generic.FromValue 4 | Description : GHC.Generics derived table parsing 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | Generic implementations of matching tables and arrays. 10 | 11 | -} 12 | module Toml.Schema.Generic.FromValue ( 13 | -- * Record from table 14 | GParseTable(..), 15 | genericParseTable, 16 | genericFromTable, 17 | 18 | -- * Product type from array 19 | GFromArray(..), 20 | genericFromArray, 21 | ) where 22 | 23 | import Control.Monad.Trans.State (StateT(..)) 24 | import Data.Coerce (coerce) 25 | import Data.Text qualified as Text 26 | import GHC.Generics 27 | import Toml.Schema.FromValue (FromValue, fromValue, optKey, reqKey, parseTableFromValue, typeError) 28 | import Toml.Schema.Matcher (Matcher, failAt) 29 | import Toml.Schema.ParseTable (ParseTable) 30 | import Toml.Semantics (Value'(List')) 31 | 32 | -- | Match a 'Toml.Semantics.Table'' using the field names in a record. 33 | genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable l a 34 | genericParseTable = to <$> gParseTable 35 | {-# INLINE genericParseTable #-} 36 | 37 | -- | Implementation of 'fromValue' using 'genericParseTable' to derive 38 | -- a match from the record field names of the target type. 39 | genericFromTable :: (Generic a, GParseTable (Rep a)) => Value' l -> Matcher l a 40 | genericFromTable = parseTableFromValue genericParseTable 41 | {-# INLINE genericFromTable #-} 42 | 43 | -- | Match a 'Toml.Semantics.Value'' as an array positionally matching field fields 44 | -- of a constructor to the elements of the array. 45 | genericFromArray :: (Generic a, GFromArray (Rep a)) => Value' l -> Matcher l a 46 | genericFromArray (List' a xs) = 47 | do (gen, xs') <- runStateT gFromArray xs 48 | if null xs' then 49 | pure (to gen) 50 | else 51 | failAt a ("array " ++ show (length xs') ++ " elements too long") 52 | genericFromArray v = typeError "array" v 53 | 54 | {-# INLINE genericFromArray #-} 55 | 56 | -- 'gParseTable' is written in continuation passing style because 57 | -- it allows all the "GHC.Generics" constructors to inline into 58 | -- a single location which allows the optimizer to optimize them 59 | -- complete away. 60 | 61 | -- | Supports conversion of TOML tables into record values using 62 | -- field selector names as TOML keys. 63 | class GParseTable f where 64 | -- | Convert a value and apply the continuation to the result. 65 | gParseTable :: ParseTable l (f a) 66 | 67 | -- | Ignores type constructor name 68 | instance GParseTable f => GParseTable (D1 c f) where 69 | gParseTable = M1 <$> gParseTable 70 | {-# INLINE gParseTable #-} 71 | 72 | -- | Ignores value constructor name - only supports record constructors 73 | instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where 74 | gParseTable = M1 <$> gParseTable 75 | {-# INLINE gParseTable #-} 76 | 77 | -- | Matches left then right component 78 | instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where 79 | gParseTable = 80 | do x <- gParseTable 81 | y <- gParseTable 82 | pure (x :*: y) 83 | {-# INLINE gParseTable #-} 84 | 85 | -- | Omits the key from the table on nothing, includes it on just 86 | instance {-# OVERLAPS #-} (Selector s, FromValue a) => GParseTable (S1 s (K1 i (Maybe a))) where 87 | gParseTable = 88 | do x <- optKey (Text.pack (selName (M1 [] :: S1 s [] ()))) 89 | pure (M1 (K1 x)) 90 | {-# INLINE gParseTable #-} 91 | 92 | -- | Uses record selector name as table key 93 | instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where 94 | gParseTable = 95 | do x <- reqKey (Text.pack (selName (M1 [] :: S1 s [] ()))) 96 | pure (M1 (K1 x)) 97 | {-# INLINE gParseTable #-} 98 | 99 | -- | Emits empty table 100 | instance GParseTable U1 where 101 | gParseTable = pure U1 102 | {-# INLINE gParseTable #-} 103 | 104 | -- | Supports conversion of TOML arrays into product-type values. 105 | class GFromArray f where 106 | gFromArray :: StateT [Value' l] (Matcher l) (f a) 107 | 108 | instance GFromArray f => GFromArray (M1 i c f) where 109 | gFromArray :: forall a l. StateT [Value' l] (Matcher l) (M1 i c f a) 110 | gFromArray = coerce (gFromArray :: StateT [Value' l] (Matcher l) (f a)) 111 | {-# INLINE gFromArray #-} 112 | 113 | instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where 114 | gFromArray = 115 | do x <- gFromArray 116 | y <- gFromArray 117 | pure (x :*: y) 118 | {-# INLINE gFromArray #-} 119 | 120 | instance FromValue a => GFromArray (K1 i a) where 121 | gFromArray = StateT \case 122 | [] -> fail "array too short" 123 | x:xs -> (\v -> (K1 v, xs)) <$> fromValue x 124 | {-# INLINE gFromArray #-} 125 | 126 | -- | Uses no array elements 127 | instance GFromArray U1 where 128 | gFromArray = pure U1 129 | {-# INLINE gFromArray #-} 130 | -------------------------------------------------------------------------------- /src/Toml/Schema/Generic/ToValue.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Schema.Generic.ToValue 3 | Description : GHC.Generics derived table generation 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | Use 'genericToTable' to derive an instance of 'Toml.ToValue.ToTable' 9 | using the field names of a record. 10 | 11 | Use 'genericToArray' to derive an instance of 'Toml.ToValue.ToValue' 12 | using the positions of data in a constructor. 13 | 14 | -} 15 | module Toml.Schema.Generic.ToValue ( 16 | 17 | -- * Records to Tables 18 | GToTable(..), 19 | genericToTable, 20 | 21 | -- * Product types to Arrays 22 | GToArray(..), 23 | genericToArray, 24 | ) where 25 | 26 | import Data.Text (Text) 27 | import Data.Text qualified as Text 28 | import GHC.Generics 29 | import Toml.Semantics 30 | import Toml.Schema.ToValue (ToValue(..), table) 31 | 32 | -- | Use a record's field names to generate a 'Table' 33 | genericToTable :: (Generic a, GToTable (Rep a)) => a -> Table 34 | genericToTable x = table (gToTable (from x) []) 35 | {-# INLINE genericToTable #-} 36 | 37 | -- | Use a record's field names to generate a 'Table' 38 | genericToArray :: (Generic a, GToArray (Rep a)) => a -> Value 39 | genericToArray a = List (gToArray (from a) []) 40 | {-# INLINE genericToArray #-} 41 | 42 | -- | Supports conversion of product types with field selector names 43 | -- to TOML values. 44 | class GToTable f where 45 | gToTable :: f a -> [(Text, Value)] -> [(Text, Value)] 46 | 47 | -- | Ignores type constructor names 48 | instance GToTable f => GToTable (D1 c f) where 49 | gToTable (M1 x) = gToTable x 50 | {-# INLINE gToTable #-} 51 | 52 | -- | Ignores value constructor names 53 | instance GToTable f => GToTable (C1 c f) where 54 | gToTable (M1 x) = gToTable x 55 | {-# INLINE gToTable #-} 56 | 57 | instance (GToTable f, GToTable g) => GToTable (f :*: g) where 58 | gToTable (x :*: y) = gToTable x <> gToTable y 59 | {-# INLINE gToTable #-} 60 | 61 | -- | Omits the key from the table on nothing, includes it on just 62 | instance {-# OVERLAPS #-} (Selector s, ToValue a) => GToTable (S1 s (K1 i (Maybe a))) where 63 | gToTable (M1 (K1 Nothing)) = id 64 | gToTable s@(M1 (K1 (Just x))) = ((Text.pack (selName s), toValue x):) 65 | {-# INLINE gToTable #-} 66 | 67 | -- | Uses record selector name as table key 68 | instance (Selector s, ToValue a) => GToTable (S1 s (K1 i a)) where 69 | gToTable s@(M1 (K1 x)) = ((Text.pack (selName s), toValue x):) 70 | {-# INLINE gToTable #-} 71 | 72 | -- | Emits empty table 73 | instance GToTable U1 where 74 | gToTable _ = id 75 | {-# INLINE gToTable #-} 76 | 77 | instance GToTable V1 where 78 | gToTable v = case v of {} 79 | {-# INLINE gToTable #-} 80 | 81 | -- | Convert product types to arrays positionally. 82 | class GToArray f where 83 | gToArray :: f a -> [Value] -> [Value] 84 | 85 | -- | Ignore metadata 86 | instance GToArray f => GToArray (M1 i c f) where 87 | gToArray (M1 x) = gToArray x 88 | {-# INLINE gToArray #-} 89 | 90 | -- | Convert left and then right 91 | instance (GToArray f, GToArray g) => GToArray (f :*: g) where 92 | gToArray (x :*: y) = gToArray x . gToArray y 93 | {-# INLINE gToArray #-} 94 | 95 | -- | Convert fields using 'ToValue' instances 96 | instance ToValue a => GToArray (K1 i a) where 97 | gToArray (K1 x) = (toValue x :) 98 | {-# INLINE gToArray #-} 99 | -------------------------------------------------------------------------------- /src/Toml/Schema/Matcher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-| 3 | Module : Toml.Schema.Matcher 4 | Description : A type for building results while tracking scopes 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This type helps to build up computations that can validate a TOML 10 | value and compute some application-specific representation. 11 | 12 | It supports warning messages which can be used to deprecate old 13 | configuration options and to detect unused table keys. 14 | 15 | It supports tracking multiple error messages when you have more 16 | than one decoding option and all of them have failed. 17 | 18 | Use 'Toml.Pretty.prettyMatchMessage' for an easy way to make human 19 | readable strings from matcher outputs. 20 | 21 | -} 22 | module Toml.Schema.Matcher ( 23 | -- * Types 24 | Matcher, 25 | Result(..), 26 | MatchMessage(..), 27 | 28 | -- * Operations 29 | runMatcher, 30 | withScope, 31 | getScope, 32 | warn, 33 | warnAt, 34 | failAt, 35 | 36 | -- * Run helpers 37 | runMatcherIgnoreWarn, 38 | runMatcherFatalWarn, 39 | 40 | -- * Scope helpers 41 | Scope(..), 42 | inKey, 43 | inIndex, 44 | ) where 45 | 46 | import Control.Applicative (Alternative(..)) 47 | import Control.Monad (MonadPlus, ap, liftM) 48 | import Data.Monoid (Endo(..)) 49 | import Data.Text (Text) 50 | 51 | -- | Computations that result in a 'Result' and which track a list 52 | -- of nested contexts to assist in generating warnings and error 53 | -- messages. 54 | -- 55 | -- Use 'withScope' to run a 'Matcher' in a new, nested scope. 56 | newtype Matcher l a = Matcher { 57 | unMatcher :: 58 | forall r. 59 | [Scope] -> 60 | DList (MatchMessage l) -> 61 | (DList (MatchMessage l) -> r) -> 62 | (DList (MatchMessage l) -> a -> r) -> 63 | r 64 | } 65 | 66 | instance Functor (Matcher a) where 67 | fmap = liftM 68 | 69 | instance Applicative (Matcher a) where 70 | pure x = Matcher (\_env ws _err ok -> ok ws x) 71 | (<*>) = ap 72 | 73 | instance Monad (Matcher a) where 74 | m >>= f = Matcher (\env ws err ok -> unMatcher m env ws err (\warn' x -> unMatcher (f x) env warn' err ok)) 75 | {-# INLINE (>>=) #-} 76 | 77 | instance Alternative (Matcher a) where 78 | empty = Matcher (\_env _warn err _ok -> err mempty) 79 | Matcher x <|> Matcher y = Matcher (\env ws err ok -> x env ws (\errs1 -> y env ws (\errs2 -> err (errs1 <> errs2)) ok) ok) 80 | 81 | instance MonadPlus (Matcher a) 82 | 83 | -- | Scopes for TOML message. 84 | data Scope 85 | = ScopeIndex Int -- ^ zero-based array index 86 | | ScopeKey Text -- ^ key in a table 87 | deriving ( 88 | Read {- ^ Default instance -}, 89 | Show {- ^ Default instance -}, 90 | Eq {- ^ Default instance -}, 91 | Ord {- ^ Default instance -}) 92 | 93 | -- | A message emitted while matching a TOML value. The message is paired 94 | -- with the path to the value that was in focus when the message was 95 | -- generated. These message get used for both warnings and errors. 96 | -- 97 | -- For a convenient way to render these to a string, see 'Toml.Pretty.prettyMatchMessage'. 98 | data MatchMessage a = MatchMessage { 99 | matchAnn :: Maybe a, 100 | matchPath :: [Scope], -- ^ path to message location 101 | matchMessage :: String -- ^ error and warning message body 102 | } deriving ( 103 | Read {- ^ Default instance -}, 104 | Show {- ^ Default instance -}, 105 | Eq {- ^ Default instance -}, 106 | Ord {- ^ Default instance -}, 107 | Functor, Foldable, Traversable) 108 | 109 | -- | List of strings that supports efficient left- and right-biased append 110 | newtype DList a = DList (Endo [a]) 111 | deriving (Semigroup, Monoid) 112 | 113 | -- | Create a singleton list of strings 114 | one :: a -> DList a 115 | one x = DList (Endo (x:)) 116 | 117 | -- | Extract the list of strings 118 | runDList :: DList a -> [a] 119 | runDList (DList x) = x `appEndo` [] 120 | 121 | -- | Computation outcome with error and warning messages. Multiple error 122 | -- messages can occur when multiple alternatives all fail. Resolving any 123 | -- one of the error messages could allow the computation to succeed. 124 | data Result e a 125 | = Failure [e] -- ^ error messages 126 | | Success [e] a -- ^ warning messages and result 127 | deriving ( 128 | Read {- ^ Default instance -}, 129 | Show {- ^ Default instance -}, 130 | Eq {- ^ Default instance -}, 131 | Ord {- ^ Default instance -}) 132 | 133 | -- | Run a 'Matcher' with an empty scope. 134 | runMatcher :: Matcher l a -> Result (MatchMessage l) a 135 | runMatcher (Matcher m) = m [] mempty (Failure . runDList) (Success . runDList) 136 | 137 | -- | Run 'Matcher' and ignore warnings. 138 | runMatcherIgnoreWarn :: Matcher l a -> Either [MatchMessage l] a 139 | runMatcherIgnoreWarn m = 140 | case runMatcher m of 141 | Failure err -> Left err 142 | Success _ x -> Right x 143 | 144 | -- | Run 'Matcher' and treat warnings as errors. 145 | runMatcherFatalWarn :: Matcher l a -> Either [MatchMessage l] a 146 | runMatcherFatalWarn m = 147 | case runMatcher m of 148 | Success [] x -> Right x 149 | Success ws _ -> Left ws 150 | Failure err -> Left err 151 | 152 | -- | Run a 'Matcher' with a locally extended scope. 153 | withScope :: Scope -> Matcher l a -> Matcher l a 154 | withScope scope (Matcher m) = Matcher (\scopes -> m (scope : scopes)) 155 | 156 | -- | Get the current list of scopes. 157 | getScope :: Matcher a [Scope] 158 | getScope = Matcher (\env ws _err ok -> ok ws (reverse env)) 159 | 160 | -- | Emit a warning without an annotation. 161 | warn :: String -> Matcher a () 162 | warn w = 163 | Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage Nothing (reverse scopes) w)) ()) 164 | 165 | -- | Emit a warning mentioning the given annotation. 166 | warnAt :: l -> String -> Matcher l () 167 | warnAt loc w = 168 | Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage (Just loc) (reverse scopes) w)) ()) 169 | 170 | -- | Fail with an error message without an annotation. 171 | instance MonadFail (Matcher a) where 172 | fail e = 173 | Matcher (\scopes _warn err _ok -> err (one (MatchMessage Nothing (reverse scopes) e))) 174 | 175 | -- | Terminate the match with an error mentioning the given annotation. 176 | failAt :: l -> String -> Matcher l a 177 | failAt l e = 178 | Matcher (\scopes _warn err _ok -> err (one (MatchMessage (Just l) (reverse scopes) e))) 179 | 180 | -- | Update the scope with the message corresponding to a table key 181 | inKey :: Text -> Matcher l a -> Matcher l a 182 | inKey = withScope . ScopeKey 183 | 184 | -- | Update the scope with the message corresponding to an array index 185 | inIndex :: Int -> Matcher l a -> Matcher l a 186 | inIndex = withScope . ScopeIndex 187 | -------------------------------------------------------------------------------- /src/Toml/Schema/ParseTable.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Schema.ParseTable 3 | Description : A type for matching keys out of a table 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module provides utilities for matching key-value pairs 9 | out of tables while building up application-specific values. 10 | 11 | It will help generate warnings for unused keys, help select 12 | between multiple possible keys, and emit location-specific 13 | error messages when keys are unavailable. 14 | 15 | -} 16 | module Toml.Schema.ParseTable ( 17 | -- * Base interface 18 | ParseTable, 19 | KeyAlt(..), 20 | pickKey, 21 | parseTable, 22 | 23 | -- * Primitives 24 | liftMatcher, 25 | warnTable, 26 | warnTableAt, 27 | failTableAt, 28 | setTable, 29 | getTable, 30 | ) where 31 | 32 | import Control.Applicative (Alternative, empty) 33 | import Control.Monad (MonadPlus) 34 | import Control.Monad.Trans.Class (lift) 35 | import Control.Monad.Trans.Reader (ReaderT(..), ask) 36 | import Control.Monad.Trans.State.Strict (StateT(..), get, put) 37 | import Data.Foldable (for_) 38 | import Data.List (intercalate) 39 | import Data.Map qualified as Map 40 | import Data.Text (Text) 41 | import Toml.Schema.Matcher (Matcher, inKey, failAt, warn, warnAt) 42 | import Toml.Semantics (Table'(..), Value') 43 | import Toml.Pretty 44 | 45 | -- | Parser that tracks a current set of unmatched key-value 46 | -- pairs from a table. 47 | -- 48 | -- Use 'Toml.Schema.optKey' and 'Toml.Schema.reqKey' to extract keys. 49 | -- 50 | -- Use 'getTable' and 'setTable' to override the table and implement 51 | -- other primitives. 52 | newtype ParseTable l a = ParseTable (ReaderT l (StateT (Table' l) (Matcher l)) a) 53 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus) 54 | 55 | -- | Implemented in terms of 'fail' on 'Matcher' 56 | instance MonadFail (ParseTable l) where 57 | fail = ParseTable . fail 58 | 59 | -- | Lift a matcher into the current table parsing context. 60 | liftMatcher :: Matcher l a -> ParseTable l a 61 | liftMatcher = ParseTable . lift . lift 62 | 63 | -- | Run a 'ParseTable' computation with a given starting 'Table''. 64 | -- Unused tables will generate a warning. To change this behavior 65 | -- 'getTable' and 'setTable' can be used to discard or generate 66 | -- error messages. 67 | parseTable :: ParseTable l a -> l -> Table' l -> Matcher l a 68 | parseTable (ParseTable p) l t = 69 | do (x, MkTable t') <- runStateT (runReaderT p l) t 70 | for_ (Map.assocs t') \(k, (a, _)) -> 71 | warnAt a ("unexpected key: " ++ show (prettySimpleKey k)) 72 | pure x 73 | 74 | -- | Return the remaining portion of the table being matched. 75 | getTable :: ParseTable l (Table' l) 76 | getTable = ParseTable (lift get) 77 | 78 | -- | Replace the remaining portion of the table being matched. 79 | setTable :: Table' l -> ParseTable l () 80 | setTable = ParseTable . lift . put 81 | 82 | -- | Emit a warning without an annotation. 83 | warnTable :: String -> ParseTable l () 84 | warnTable = liftMatcher . warn 85 | 86 | -- | Emit a warning with the given annotation. 87 | warnTableAt :: l -> String -> ParseTable l () 88 | warnTableAt l = liftMatcher . warnAt l 89 | 90 | -- | Abort the current table matching with an error message at the given annotation. 91 | failTableAt :: l -> String -> ParseTable l a 92 | failTableAt l = liftMatcher . failAt l 93 | 94 | -- | Key and value matching function 95 | data KeyAlt l a 96 | = Key Text (Value' l -> Matcher l a) -- ^ pick alternative based on key match 97 | | Else (Matcher l a) -- ^ default case when no previous cases matched 98 | 99 | -- | Take the first option from a list of table keys and matcher functions. 100 | -- This operation will commit to the first table key that matches. If the 101 | -- associated matcher fails, only that error will be propagated and the 102 | -- other alternatives will not be matched. 103 | -- 104 | -- If no keys match, an error message is generated explaining which keys 105 | -- would have been accepted. 106 | -- 107 | -- This is provided as an alternative to chaining multiple 108 | -- 'Toml.Schema.reqKey' cases together with 'Control.Applicative.Alternative' 109 | -- which will fall-through as a result of any failure to the next case. 110 | pickKey :: [KeyAlt l a] -> ParseTable l a 111 | pickKey xs = 112 | do MkTable t <- getTable 113 | foldr (f t) errCase xs 114 | where 115 | f _ (Else m) _ = liftMatcher m 116 | f t (Key k c) continue = 117 | case Map.lookup k t of 118 | Nothing -> continue 119 | Just (_, v) -> 120 | do setTable $! MkTable (Map.delete k t) 121 | liftMatcher (inKey k (c v)) 122 | 123 | errCase = 124 | do l <- ParseTable ask 125 | case xs of 126 | [] -> empty -- there's nothing a user can do here 127 | [Key k _] -> failTableAt l ("missing key: " ++ show (prettySimpleKey k)) 128 | _ -> failTableAt l ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs]) 129 | -------------------------------------------------------------------------------- /src/Toml/Schema/ToValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} -- needed for type equality on old GHC 2 | {-| 3 | Module : Toml.Schema.ToValue 4 | Description : Automation for converting application values to TOML. 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | The 'ToValue' class provides a conversion function from 10 | application-specific to TOML values. 11 | 12 | Because the top-level TOML document is always a table, 13 | the 'ToTable' class is for types that specifically support 14 | conversion to a 'Table'. 15 | 16 | "Toml.Schema.Generic" can be used to derive instances of 'ToTable' 17 | automatically for record types and 'ToValue' for array types. 18 | 19 | -} 20 | module Toml.Schema.ToValue ( 21 | ToValue(..), 22 | 23 | -- * Table construction 24 | ToTable(..), 25 | ToKey(..), 26 | defaultTableToValue, 27 | table, 28 | (.=), 29 | ) where 30 | 31 | import Data.Foldable (toList) 32 | import Data.Int (Int8, Int16, Int32, Int64) 33 | import Data.List.NonEmpty (NonEmpty) 34 | import Data.List.NonEmpty qualified as NonEmpty 35 | import Data.Map (Map) 36 | import Data.Map qualified as Map 37 | import Data.Ratio (Ratio) 38 | import Data.Sequence (Seq) 39 | import Data.Text (Text) 40 | import Data.Text qualified as Text 41 | import Data.Text.Lazy qualified 42 | import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime, UTCTime, utcToZonedTime, utc) 43 | import Data.Word (Word8, Word16, Word32, Word64) 44 | import Numeric.Natural (Natural) 45 | import Toml.Semantics 46 | 47 | -- | Build a 'Table' from a list of key-value pairs. 48 | -- 49 | -- Use '.=' for a convenient way to build the pairs. 50 | table :: [(Text, Value)] -> Table 51 | table kvs = MkTable (Map.fromList [(k, ((), v)) | (k, v) <- kvs]) 52 | {-# INLINE table #-} 53 | 54 | -- | Convenience function for building key-value pairs while 55 | -- constructing a 'Table'. 56 | -- 57 | -- @'table' [a '.=' b, c '.=' d]@ 58 | (.=) :: ToValue a => Text -> a -> (Text, Value) 59 | k .= v = (k, toValue v) 60 | 61 | -- | Class for types that can be embedded into 'Value' 62 | class ToValue a where 63 | 64 | -- | Embed a single thing into a TOML value. 65 | toValue :: a -> Value 66 | 67 | -- | Helper for converting a list of things into a value. This is typically 68 | -- left to be defined by its default implementation and exists to help define 69 | -- the encoding for TOML arrays. 70 | toValueList :: [a] -> Value 71 | toValueList = List . map toValue 72 | 73 | -- | Class for things that can be embedded into a TOML table. 74 | -- 75 | -- Implement this for things that always embed into a 'Table' and then 76 | -- the 'ToValue' instance can be derived with 'defaultTableToValue'. 77 | -- 78 | -- @ 79 | -- instance ToValue Example where 80 | -- toValue = defaultTableToValue 81 | -- 82 | -- -- Option 1: Manual instance 83 | -- instance ToTable Example where 84 | -- toTable x = 'table' ["field1" '.=' field1 x, "field2" '.=' field2 x] 85 | -- 86 | -- -- Option 2: GHC.Generics derived instance using Toml.ToValue.Generic 87 | -- instance ToTable Example where 88 | -- toTable = genericToTable 89 | -- @ 90 | class ToValue a => ToTable a where 91 | 92 | -- | Convert a single value into a table 93 | toTable :: a -> Table 94 | 95 | instance (ToKey k, ToValue v) => ToTable (Map k v) where 96 | toTable m = table [(toKey k, toValue v) | (k,v) <- Map.assocs m] 97 | 98 | instance (ToKey k, ToValue v) => ToValue (Map k v) where 99 | toValue = defaultTableToValue 100 | 101 | instance ToTable (Table' a) where 102 | toTable = forgetTableAnns 103 | 104 | instance ToValue (Table' a) where 105 | toValue = defaultTableToValue 106 | 107 | -- | Convert to a table key. This class enables various string types to be 108 | -- used as the keys of a 'Map' when converting into TOML tables. 109 | class ToKey a where 110 | toKey :: a -> Text 111 | 112 | instance Char ~ a => ToKey [a] where 113 | toKey = Text.pack 114 | 115 | instance ToKey Text.Text where 116 | toKey = id 117 | 118 | instance ToKey Data.Text.Lazy.Text where 119 | toKey = Data.Text.Lazy.toStrict 120 | 121 | -- | Convenience function for building 'ToValue' instances. 122 | defaultTableToValue :: ToTable a => a -> Value 123 | defaultTableToValue = Table . toTable 124 | 125 | -- | Identity function 126 | instance ToValue Value where 127 | toValue = id 128 | 129 | -- | Single characters are encoded as singleton strings. Lists of characters 130 | -- are encoded as a single string value. 131 | instance ToValue Char where 132 | toValue x = Text (Text.singleton x) 133 | toValueList = Text . Text.pack 134 | 135 | -- | Encodes as string literal 136 | instance ToValue Text.Text where 137 | toValue = Text 138 | 139 | -- | Encodes as string literal 140 | instance ToValue Data.Text.Lazy.Text where 141 | toValue = Text . Data.Text.Lazy.toStrict 142 | 143 | -- | This instance defers to the list element's 'toValueList' implementation. 144 | instance ToValue a => ToValue [a] where 145 | toValue = toValueList 146 | 147 | -- | Converts to list and encodes that to value 148 | instance ToValue a => ToValue (NonEmpty a) where 149 | toValue = toValue . NonEmpty.toList 150 | 151 | -- | Converts to list and encodes that to value 152 | instance ToValue a => ToValue (Seq a) where 153 | toValue = toValue . toList 154 | 155 | -- | TOML represents floating point numbers with 'Prelude.Double'. 156 | -- This operation lose precision and can overflow to infinity. 157 | instance Integral a => ToValue (Ratio a) where 158 | toValue = Double . realToFrac 159 | 160 | instance ToValue Double where toValue = Double 161 | instance ToValue Float where toValue = Double . realToFrac 162 | instance ToValue Bool where toValue = Bool 163 | instance ToValue TimeOfDay where toValue = TimeOfDay 164 | instance ToValue LocalTime where toValue = LocalTime 165 | instance ToValue ZonedTime where toValue = ZonedTime 166 | instance ToValue UTCTime where toValue = ZonedTime . utcToZonedTime utc 167 | instance ToValue Day where toValue = Day 168 | instance ToValue Integer where toValue = Integer 169 | instance ToValue Natural where toValue = Integer . fromIntegral 170 | instance ToValue Int where toValue = Integer . fromIntegral 171 | instance ToValue Int8 where toValue = Integer . fromIntegral 172 | instance ToValue Int16 where toValue = Integer . fromIntegral 173 | instance ToValue Int32 where toValue = Integer . fromIntegral 174 | instance ToValue Int64 where toValue = Integer . fromIntegral 175 | instance ToValue Word where toValue = Integer . fromIntegral 176 | instance ToValue Word8 where toValue = Integer . fromIntegral 177 | instance ToValue Word16 where toValue = Integer . fromIntegral 178 | instance ToValue Word32 where toValue = Integer . fromIntegral 179 | instance ToValue Word64 where toValue = Integer . fromIntegral 180 | -------------------------------------------------------------------------------- /src/Toml/Semantics.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 2 | {-# HLINT ignore "Use section" #-} 3 | {-| 4 | Module : Toml.Semantics 5 | Description : Semantic interpretation of raw TOML expressions 6 | Copyright : (c) Eric Mertens, 2023 7 | License : ISC 8 | Maintainer : emertens@gmail.com 9 | 10 | This module extracts a nested Map representation of a TOML 11 | file. It detects invalid key assignments and resolves dotted 12 | key assignments. 13 | 14 | -} 15 | module Toml.Semantics ( 16 | 17 | -- * Types 18 | Value, Value'(..), 19 | Table, Table'(..), 20 | 21 | -- * Validation 22 | semantics, 23 | SemanticError(..), SemanticErrorKind(..), 24 | 25 | -- * Annotations 26 | forgetTableAnns, 27 | forgetValueAnns, 28 | valueAnn, 29 | valueType, 30 | 31 | ) where 32 | 33 | import Control.Monad (foldM) 34 | import Data.List.NonEmpty (NonEmpty((:|))) 35 | import Data.List.NonEmpty qualified as NonEmpty 36 | import Data.Map (Map) 37 | import Data.Map qualified as Map 38 | import Data.Text (Text) 39 | import Toml.Syntax.Types (SectionKind(..), Key, Val(..), Expr(..)) 40 | import Toml.Semantics.Types 41 | 42 | -- | This type represents errors generated when resolving keys in a TOML 43 | -- document. 44 | -- 45 | -- @since 1.3.0.0 46 | data SemanticError a = SemanticError { 47 | errorAnn :: a, -- ^ Annotation associated with offending key 48 | errorKey :: Text, 49 | errorKind :: SemanticErrorKind 50 | } deriving ( 51 | Read {- ^ Default instance -}, 52 | Show {- ^ Default instance -}, 53 | Eq {- ^ Default instance -}, 54 | Ord {- ^ Default instance -}, 55 | Functor, Foldable, Traversable) 56 | 57 | -- | Enumeration of the kinds of conflicts a key can generate. 58 | -- 59 | -- @since 1.3.0.0 60 | data SemanticErrorKind 61 | = AlreadyAssigned -- ^ Attempted to assign to a key that was already assigned 62 | | ClosedTable -- ^ Attempted to open a table already closed 63 | | ImplicitlyTable -- ^ Attempted to open a tables as an array of tables that was implicitly defined to be a table 64 | deriving ( 65 | Read {- ^ Default instance -}, 66 | Show {- ^ Default instance -}, 67 | Eq {- ^ Default instance -}, 68 | Ord {- ^ Default instance -}) 69 | 70 | -- | Extracts a semantic value from a sequence of raw TOML expressions, 71 | -- or reports a semantic error if one occurs. 72 | semantics :: [Expr a] -> Either (SemanticError a) (Table' a) 73 | semantics exprs = 74 | do f <- foldM processExpr (flip assignKeyVals Map.empty) exprs 75 | framesToTable <$> f [] 76 | where 77 | processExpr f = \case 78 | KeyValExpr k v -> Right (f . ((k,v):)) 79 | TableExpr k -> processSection TableKind k 80 | ArrayTableExpr k -> processSection ArrayTableKind k 81 | where 82 | processSection kind k = flip (addSection kind k) <$> f [] 83 | 84 | -- | A top-level table used to distinguish top-level defined arrays 85 | -- and tables from inline values. 86 | type FrameTable a = Map Text (a, Frame a) 87 | 88 | -- | M is the error-handling monad used through this module for 89 | -- propagating semantic errors through the 'semantics' function. 90 | type M a = Either (SemanticError a) 91 | 92 | -- | Frames are the top-level skeleton of the TOML file that mirror the 93 | -- subset of values that can be constructed with with top-level syntax. 94 | -- TOML syntax makes a distinction between tables and arrays that are 95 | -- defined at the top-level and those defined with inline syntax. This 96 | -- separate type keeps these syntactic differences separate while table 97 | -- and array resolution is still happening. Frames can keep track of which 98 | -- tables finished and which are eligible for extension. 99 | data Frame a 100 | = FrameTable a FrameKind (FrameTable a) 101 | | FrameArray (NonEmpty (a, FrameTable a)) -- stored in reverse order for easy "append" 102 | | FrameValue (Value' a) 103 | deriving Show 104 | 105 | -- | Top-level tables can be in various states of completeness. This type 106 | -- keeps track of the current state of a top-level defined table. 107 | data FrameKind 108 | = Open -- ^ table implicitly defined as super-table of [x.y.z] 109 | | Dotted -- ^ table implicitly defined using dotted key assignment 110 | | Closed -- ^ table closed to further extension 111 | deriving Show 112 | 113 | -- | Convert a top-level table "frame" representation into the plain Value 114 | -- representation once the distinction is no longer needed. 115 | framesToTable :: FrameTable a -> Table' a 116 | framesToTable = fmap MkTable $ fmap $ fmap 117 | \case 118 | FrameTable a _kind t -> Table' a (framesToTable t) 119 | FrameArray (NonEmpty.reverse -> t :| ts) -> 120 | -- the array itself is attributed to the first table defined 121 | List' (fst t) [Table' a (framesToTable x) | (a, x) <- t : ts] 122 | FrameValue v -> v 123 | 124 | -- | Attempts to insert the key-value pairs given into a new section 125 | -- located at the given key-path in a frame map. 126 | addSection :: 127 | SectionKind {- ^ section kind -} -> 128 | Key a {- ^ section key -} -> 129 | [(Key a, Val a)] {- ^ values to install -} -> 130 | FrameTable a {- ^ local frame map -} -> 131 | M a (FrameTable a) {- ^ error message or updated local frame table -} 132 | 133 | addSection kind (k :| []) kvs = 134 | alterFrame k 135 | -- defining a new table 136 | (case kind of 137 | TableKind -> FrameTable (fst k) Closed <$> go mempty 138 | ArrayTableKind -> FrameArray . (:| []) . (,) (fst k) <$> go mempty) 139 | 140 | \case 141 | -- defining a super table of a previously defined sub-table 142 | FrameTable _ Open t -> 143 | case kind of 144 | -- the annotation of the open table changes from the first mention closing key 145 | TableKind -> FrameTable (fst k) Closed <$> go t 146 | ArrayTableKind -> invalidKey k ImplicitlyTable 147 | 148 | -- Add a new array element to an existing table array 149 | FrameArray (t :| ts) -> 150 | case kind of 151 | TableKind -> invalidKey k ClosedTable 152 | ArrayTableKind -> FrameArray . (:| t : ts) . (,) (fst k) <$> go mempty 153 | 154 | -- failure cases 155 | FrameTable _ Closed _ -> invalidKey k ClosedTable 156 | FrameTable _ Dotted _ -> error "addSection: dotted table left unclosed" 157 | FrameValue {} -> invalidKey k AlreadyAssigned 158 | where 159 | go = assignKeyVals kvs 160 | 161 | addSection kind (k1 :| k2 : ks) kvs = 162 | alterFrame k1 163 | (FrameTable (fst k1) Open <$> go mempty) 164 | \case 165 | FrameTable a tk t -> FrameTable a tk <$> go t 166 | FrameArray (t :| ts) -> FrameArray . (:| ts) <$> traverse go t 167 | FrameValue _ -> invalidKey k1 AlreadyAssigned 168 | where 169 | go = addSection kind (k2 :| ks) kvs 170 | 171 | -- | Close all of the tables that were implicitly defined with 172 | -- dotted prefixes. These tables are only eligible for extension 173 | -- within the @[table]@ section in which they were introduced. 174 | closeDots :: FrameTable a -> FrameTable a 175 | closeDots = 176 | fmap $ fmap \case 177 | FrameTable a Dotted t -> FrameTable a Closed (closeDots t) 178 | frame -> frame 179 | 180 | -- | Extend the given frame table with a list of key-value pairs. 181 | -- Any tables created through dotted keys will be closed after 182 | -- all of the key-value pairs are processed. 183 | assignKeyVals :: [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a) 184 | assignKeyVals kvs t = closeDots <$> foldM f t kvs 185 | where 186 | f m (k,v) = assign k v m 187 | 188 | -- | Assign a single dotted key in a frame. Any open table traversed 189 | -- by a dotted key will be marked as dotted so that it will become 190 | -- closed at the end of the current call to 'assignKeyVals'. 191 | assign :: Key a -> Val a -> FrameTable a -> M a (FrameTable a) 192 | 193 | assign (key :| []) val = 194 | alterFrame key 195 | (FrameValue <$> valToValue val) 196 | (\_ -> invalidKey key AlreadyAssigned) 197 | 198 | assign (key :| k1 : keys) val = 199 | alterFrame key (go (fst key) mempty) 200 | \case 201 | FrameTable a Open t -> go a t 202 | FrameTable a Dotted t -> go a t 203 | FrameTable _ Closed _ -> invalidKey key ClosedTable 204 | FrameArray _ -> invalidKey key ClosedTable 205 | FrameValue _ -> invalidKey key AlreadyAssigned 206 | where 207 | go a t = FrameTable a Dotted <$> assign (k1 :| keys) val t 208 | 209 | -- | Convert 'Val' to 'Value' potentially raising an error if 210 | -- it contains inline tables with key-conflicts. 211 | valToValue :: Val a -> M a (Value' a) 212 | valToValue = 213 | \case 214 | ValInteger a x -> Right (Integer' a x) 215 | ValFloat a x -> Right (Double' a x) 216 | ValBool a x -> Right (Bool' a x) 217 | ValString a x -> Right (Text' a x) 218 | ValTimeOfDay a x -> Right (TimeOfDay' a x) 219 | ValZonedTime a x -> Right (ZonedTime' a x) 220 | ValLocalTime a x -> Right (LocalTime' a x) 221 | ValDay a x -> Right (Day' a x) 222 | ValArray a xs -> List' a <$> traverse valToValue xs 223 | ValTable a kvs -> Table' a . framesToTable <$> assignKeyVals kvs mempty 224 | 225 | -- | Abort validation by reporting an error about the given key. 226 | invalidKey :: 227 | (a, Text) {- ^ sub-key -} -> 228 | SemanticErrorKind {- ^ error kind -} -> 229 | M a b 230 | invalidKey (a, key) kind = Left (SemanticError a key kind) 231 | 232 | -- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable' 233 | alterFrame :: 234 | (a, Text) {- ^ annotated key -} -> 235 | M a (Frame a) {- ^ new value case -} -> 236 | (Frame a -> M a (Frame a)) {- ^ update value case -} -> 237 | FrameTable a -> M a (FrameTable a) 238 | alterFrame (a, k) create update = Map.alterF g k 239 | where 240 | -- insert a new value 241 | g Nothing = 242 | do lf <- create 243 | pure (Just (a, lf)) 244 | 245 | -- update an existing value and preserve its annotation 246 | g (Just (op, ov)) = 247 | do lf <- update ov 248 | pure (Just (op, lf)) 249 | -------------------------------------------------------------------------------- /src/Toml/Semantics/Ordered.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Semantics.Ordered 3 | Description : Tool for extracting an ordering from an existing TOML file 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module can help build a key ordering projection given an existing 9 | TOML file. This could be useful for applying a transformation to a TOML 10 | file before pretty-printing it back in something very close to the 11 | original order. 12 | 13 | When using the computed order, table keys will be remembered in the order 14 | they appeared in the source file. Any key additional keys added to the 15 | tables will be ordered alphabetically after all the known keys. 16 | 17 | @ 18 | demo = 19 | do txt <- 'readFile' \"demo.toml\" 20 | let Right exprs = 'Toml.Parser.parseRawToml' txt 21 | to = 'extractTableOrder' exprs 22 | Right toml = 'Toml.Semantics.semantics' exprs 23 | projection = 'projectKey' to 24 | 'print' ('Toml.Pretty.prettyTomlOrdered' projection toml) 25 | @ 26 | 27 | -} 28 | module Toml.Semantics.Ordered ( 29 | TableOrder, 30 | extractTableOrder, 31 | projectKey, 32 | ProjectedKey, 33 | debugTableOrder, 34 | ) where 35 | 36 | import Data.Foldable (foldl', toList) 37 | import Data.List (sortOn) 38 | import Data.Map (Map) 39 | import Data.Map qualified as Map 40 | import Data.Text (Text) 41 | import Data.Text qualified as Text 42 | import Toml.Syntax.Types (Expr(..), Key, Val(ValTable, ValArray)) 43 | 44 | -- | Summary of the order of the keys in a TOML document. 45 | newtype TableOrder = TO (Map Text KeyOrder) 46 | 47 | -- | Internal type used by 'TableOrder' 48 | -- 49 | -- The 'Int' field determines the order of the current key and the 50 | -- 'TableOrder' determines the order of the children of this key. 51 | data KeyOrder = KeyOrder !Int TableOrder 52 | 53 | -- | Opaque type used by 'projectKey' 54 | newtype ProjectedKey = PK (Either Int Text) 55 | deriving (Eq, Ord) 56 | 57 | -- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered' 58 | projectKey :: 59 | TableOrder {- ^ table order -} -> 60 | [Text] {- ^ table path -} -> 61 | Text {- ^ key -} -> 62 | ProjectedKey {- ^ type suitable for ordering table keys -} 63 | projectKey (TO to) [] = \k -> 64 | case Map.lookup k to of 65 | Just (KeyOrder i _) -> PK (Left i) 66 | Nothing -> PK (Right k) 67 | projectKey (TO to) (p:ps) = 68 | case Map.lookup p to of 69 | Just (KeyOrder _ to') -> projectKey to' ps 70 | Nothing -> PK . Right 71 | 72 | emptyOrder :: TableOrder 73 | emptyOrder = TO Map.empty 74 | 75 | -- | Extract a 'TableOrder' from the output of 'Toml.Parser.parseRawToml' 76 | -- to be later used with 'projectKey'. 77 | extractTableOrder :: [Expr a] -> TableOrder 78 | extractTableOrder = snd . foldl' addExpr ([], emptyOrder) 79 | 80 | addExpr :: ([Text], TableOrder) -> Expr a -> ([Text], TableOrder) 81 | addExpr (prefix, to) = \case 82 | TableExpr k -> let k' = keyPath k in (k', addKey to k') 83 | ArrayTableExpr k -> let k' = keyPath k in (k', addKey to k') 84 | KeyValExpr k v -> (prefix, addVal prefix (addKey to (prefix ++ keyPath k)) v) 85 | 86 | addVal :: [Text] -> TableOrder -> Val a -> TableOrder 87 | addVal prefix to lval = 88 | case lval of 89 | ValArray _ xs -> foldl' (addVal prefix) to xs 90 | ValTable _ kvs -> 91 | foldl' (\acc (k,v) -> 92 | let k' = prefix ++ keyPath k in 93 | addVal k' (addKey acc k') v) to kvs 94 | _ -> to 95 | 96 | addKey :: TableOrder -> [Text] -> TableOrder 97 | addKey to [] = to 98 | addKey (TO to) (x:xs) = TO (Map.alter f x to) 99 | where 100 | f Nothing = Just (KeyOrder (Map.size to) (addKey emptyOrder xs)) 101 | f (Just (KeyOrder i m)) = Just (KeyOrder i (addKey m xs)) 102 | 103 | keyPath :: Key a -> [Text] 104 | keyPath = map snd . toList 105 | 106 | -- | Render a white-space nested representation of the key ordering extracted 107 | -- by 'extractTableOrder'. This is provided for debugging and understandability. 108 | debugTableOrder :: TableOrder -> String 109 | debugTableOrder to = unlines (go 0 to []) 110 | where 111 | go i (TO m) z = 112 | foldr (go1 i) z 113 | (sortOn p (Map.assocs m)) 114 | 115 | go1 i (k, KeyOrder _ v) z = 116 | (replicate (4*i) ' ' ++ Text.unpack k) : 117 | go (i+1) v z 118 | 119 | p (_, KeyOrder i _) = i 120 | -------------------------------------------------------------------------------- /src/Toml/Semantics/Types.hs: -------------------------------------------------------------------------------- 1 | {-# Language PatternSynonyms, DeriveTraversable, TypeFamilies #-} 2 | {-| 3 | Module : Toml.Semantics.Types 4 | Description : Semantic TOML values 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module provides the type for the semantics of a TOML file. 10 | All dotted keys are resolved in this representation. Each table 11 | is a Map with a single level of keys. 12 | 13 | Values are parameterized over an annotation type to allow values 14 | to be attributed to a file location. When values are constructed 15 | programmatically, there might not be any interesting annotations. 16 | In this case a trivial @()@ unit annotation can be used. The 17 | 'Value' type-synonym and related pattern synonyms can make using 18 | this case more convenient. 19 | 20 | -} 21 | module Toml.Semantics.Types ( 22 | -- * Unlocated value synonyms 23 | Value, 24 | Table, 25 | 26 | -- * Annotated values 27 | Value'(.., 28 | Integer, Double, Text, Bool, 29 | ZonedTime, Day, LocalTime, TimeOfDay, 30 | List, Table), 31 | Table'(..), 32 | 33 | -- * Utilities 34 | forgetValueAnns, 35 | forgetTableAnns, 36 | valueAnn, 37 | valueType, 38 | ) where 39 | 40 | import Data.Map (Map) 41 | import Data.String (IsString(fromString)) 42 | import Data.Text (Text) 43 | import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime(zonedTimeToLocalTime, zonedTimeZone), timeZoneMinutes) 44 | 45 | pattern Integer :: Integer -> Value 46 | pattern Integer x <- Integer' _ x 47 | where Integer x = Integer' () x 48 | 49 | pattern Double :: Double -> Value 50 | pattern Double x <- Double' _ x 51 | where Double x = Double' () x 52 | 53 | pattern List :: [Value] -> Value 54 | pattern List x <- List' _ x 55 | where List x = List' () x 56 | 57 | pattern Table :: Table -> Value 58 | pattern Table x <- Table' _ x 59 | where Table x = Table' () x 60 | 61 | pattern Bool :: Bool -> Value 62 | pattern Bool x <- Bool' _ x 63 | where Bool x = Bool' () x 64 | 65 | pattern Text :: Text -> Value 66 | pattern Text x <- Text' _ x 67 | where Text x = Text' () x 68 | 69 | pattern TimeOfDay :: TimeOfDay -> Value 70 | pattern TimeOfDay x <- TimeOfDay' _ x 71 | where TimeOfDay x = TimeOfDay' () x 72 | 73 | pattern ZonedTime :: ZonedTime -> Value 74 | pattern ZonedTime x <- ZonedTime' _ x 75 | where ZonedTime x = ZonedTime' () x 76 | 77 | pattern LocalTime :: LocalTime -> Value 78 | pattern LocalTime x <- LocalTime' _ x 79 | where LocalTime x = LocalTime' () x 80 | 81 | pattern Day :: Day -> Value 82 | pattern Day x <- Day' _ x 83 | where Day x = Day' () x 84 | 85 | {-# Complete List, Table, Text, Bool, Integer, Double, Day, LocalTime, ZonedTime, TimeOfDay #-} 86 | 87 | -- | Semantic TOML value with all table assignments resolved. 88 | data Value' a 89 | = Integer' a Integer 90 | | Double' a Double 91 | | List' a [Value' a] 92 | | Table' a (Table' a) 93 | | Bool' a Bool 94 | | Text' a Text 95 | | TimeOfDay' a TimeOfDay 96 | | ZonedTime' a ZonedTime 97 | | LocalTime' a LocalTime 98 | | Day' a Day 99 | deriving ( 100 | Show {- ^ Default instance -}, 101 | Read {- ^ Default instance -}, 102 | Functor {- ^ Derived -}, 103 | Foldable {- ^ Derived -}, 104 | Traversable {- ^ Derived -}) 105 | 106 | -- | Extract the top-level annotation from a value. 107 | valueAnn :: Value' a -> a 108 | valueAnn = \case 109 | Integer' a _ -> a 110 | Double' a _ -> a 111 | List' a _ -> a 112 | Table' a _ -> a 113 | Bool' a _ -> a 114 | Text' a _ -> a 115 | TimeOfDay' a _ -> a 116 | ZonedTime' a _ -> a 117 | LocalTime' a _ -> a 118 | Day' a _ -> a 119 | 120 | -- | String representation of the kind of value using TOML vocabulary 121 | valueType :: Value' l -> String 122 | valueType = \case 123 | Integer' {} -> "integer" 124 | Double' {} -> "float" 125 | List' {} -> "array" 126 | Table' {} -> "table" 127 | Bool' {} -> "boolean" 128 | Text' {} -> "string" 129 | TimeOfDay' {} -> "local time" 130 | LocalTime' {} -> "local date-time" 131 | Day' {} -> "locate date" 132 | ZonedTime' {} -> "offset date-time" 133 | 134 | -- | A table with annotated keys and values. 135 | newtype Table' a = MkTable (Map Text (a, Value' a)) 136 | deriving ( 137 | Show {- ^ Default instance -}, 138 | Read {- ^ Default instance -}, 139 | Eq {- ^ Default instance -}, 140 | Functor {- ^ Derived -}, 141 | Foldable {- ^ Derived -}, 142 | Traversable {- ^ Derived -}) 143 | 144 | -- | A 'Table'' with trivial annotations 145 | type Table = Table' () 146 | 147 | -- | A 'Value'' with trivial annotations 148 | type Value = Value' () 149 | 150 | -- | Replaces annotations with a unit. 151 | forgetTableAnns :: Table' a -> Table 152 | forgetTableAnns (MkTable t) = MkTable (fmap (\(_, v) -> ((), forgetValueAnns v)) t) 153 | 154 | -- | Replaces annotations with a unit. 155 | forgetValueAnns :: Value' a -> Value 156 | forgetValueAnns = 157 | \case 158 | Integer' _ x -> Integer x 159 | Double' _ x -> Double x 160 | List' _ x -> List (map forgetValueAnns x) 161 | Table' _ x -> Table (forgetTableAnns x) 162 | Bool' _ x -> Bool x 163 | Text' _ x -> Text x 164 | TimeOfDay' _ x -> TimeOfDay x 165 | ZonedTime' _ x -> ZonedTime x 166 | LocalTime' _ x -> LocalTime x 167 | Day' _ x -> Day x 168 | 169 | -- | Nearly default instance except 'ZonedTime' doesn't have an 170 | -- 'Eq' instance. 'ZonedTime' values are equal if their times and 171 | -- time-zones are both equal. 172 | instance Eq a => Eq (Value' a) where 173 | Integer' a x == Integer' b y = a == b && x == y 174 | Double' a x == Double' b y = a == b && x == y 175 | List' a x == List' b y = a == b && x == y 176 | Table' a x == Table' b y = a == b && x == y 177 | Bool' a x == Bool' b y = a == b && x == y 178 | Text' a x == Text' b y = a == b && x == y 179 | TimeOfDay' a x == TimeOfDay' b y = a == b && x == y 180 | LocalTime' a x == LocalTime' b y = a == b && x == y 181 | Day' a x == Day' b y = a == b && x == y 182 | ZonedTime' a x == ZonedTime' b y = a == b && projectZT x == projectZT y 183 | _ == _ = False 184 | 185 | -- Extract the relevant parts to build an 'Eq' instance 186 | projectZT :: ZonedTime -> (LocalTime, Int) 187 | projectZT x = (zonedTimeToLocalTime x, timeZoneMinutes (zonedTimeZone x)) 188 | 189 | -- | Constructs a TOML string literal. 190 | -- 191 | -- @ 192 | -- fromString = String 193 | -- @ 194 | instance () ~ a => IsString (Value' a) where 195 | fromString = Text . fromString 196 | -------------------------------------------------------------------------------- /src/Toml/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax 3 | Description : Parsing and lexing for TOML syntax 4 | Copyright : (c) Eric Mertens, 2024 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | These are the low-level processing functions for transforming 9 | concrete TOML syntax into abstract TOML syntax. This module 10 | does not do any semantic validation of the parsed TOML. 11 | 12 | -} 13 | module Toml.Syntax ( 14 | -- * Parsing 15 | parseRawToml, 16 | Key, 17 | Expr(..), 18 | Val(..), 19 | 20 | -- * Lexing 21 | scanToken, 22 | Context(..), 23 | Token(..), 24 | 25 | -- * Locations 26 | Located(..), 27 | Position(..), 28 | startPos, 29 | ) where 30 | 31 | import Toml.Syntax.Lexer 32 | import Toml.Syntax.Parser 33 | import Toml.Syntax.Position 34 | -------------------------------------------------------------------------------- /src/Toml/Syntax/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | {-| 3 | Module : Toml.Syntax.Lexer 4 | Description : TOML lexical analyzer 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module parses a TOML file into a lazy sequence 10 | of tokens. The lexer is aware of nested brackets and 11 | equals signs in order to handle TOML's context-sensitive 12 | lexing requirements. This context enables the lexer to 13 | distinguish between bare keys and various values like: 14 | floating-point literals, integer literals, and date literals. 15 | 16 | This module uses actions and lexical hooks defined in 17 | "LexerUtils". 18 | 19 | -} 20 | module Toml.Syntax.Lexer (Context(..), scanToken, lexValue, Token(..)) where 21 | 22 | import Data.Text (Text) 23 | import Data.Text qualified as Text 24 | import Toml.Syntax.Token 25 | import Toml.Syntax.LexerUtils 26 | import Toml.Syntax.Position 27 | 28 | } 29 | $non_ascii = \x1 30 | $wschar = [\ \t] 31 | 32 | @ws = $wschar* 33 | @newline = \r? \n 34 | 35 | $bindig = [0-1] 36 | $octdig = [0-7] 37 | $digit = [0-9] 38 | $hexdig = [ $digit A-F a-f ] 39 | $basic_unescaped = [ $wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii ] 40 | $comment_start_symbol = \# 41 | $control = [\x00-\x1F \x7F] 42 | 43 | @barekey = [0-9 A-Z a-z \- _]+ 44 | 45 | @unsigned_dec_int = $digit | [1-9] ($digit | _ $digit)+ 46 | @dec_int = [\-\+]? @unsigned_dec_int 47 | @zero_prefixable_int = $digit ($digit | _ $digit)* 48 | @hex_int = "0x" $hexdig ($hexdig | _ $hexdig)* 49 | @oct_int = "0o" $octdig ($octdig | _ $octdig)* 50 | @bin_int = "0b" $bindig ($bindig | _ $bindig)* 51 | 52 | @frac = "." @zero_prefixable_int 53 | @float_exp_part = [\+\-]? @zero_prefixable_int 54 | @special_float = [\+\-]? ("inf" | "nan") 55 | @exp = [Ee] @float_exp_part 56 | @float_int_part = @dec_int 57 | @float = @float_int_part ( @exp | @frac @exp? ) | @special_float 58 | 59 | @bad_dec_int = [\-\+]? 0 ($digit | _ $digit)+ 60 | 61 | $non_eol = [\x09 \x20-\x7E $non_ascii] 62 | @comment = $comment_start_symbol $non_eol* 63 | 64 | $literal_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii] 65 | 66 | $mll_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii] 67 | @mll_content = $mll_char | @newline 68 | 69 | @mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)* 70 | $unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] 71 | 72 | @date_fullyear = $digit {4} 73 | @date_month = $digit {2} 74 | @date_mday = $digit {2} 75 | $time_delim = [Tt\ ] 76 | @time_hour = $digit {2} 77 | @time_minute = $digit {2} 78 | @time_second = $digit {2} 79 | @offset_hour = [01] $digit | 2 [0-3] 80 | @offset_minute = [0-5] $digit 81 | @time_secfrac = "." $digit+ 82 | @time_numoffset = [\+\-] @offset_hour ":" @offset_minute 83 | @time_offset = [Zz] | @time_numoffset 84 | 85 | @partial_time = @time_hour ":" @time_minute ":" @time_second @time_secfrac? 86 | @full_date = @date_fullyear "-" @date_month "-" @date_mday 87 | @full_time = @partial_time @time_offset 88 | 89 | @offset_date_time = @full_date $time_delim @full_time 90 | @local_date_time = @full_date $time_delim @partial_time 91 | @local_date = @full_date 92 | @local_time = @partial_time 93 | 94 | toml :- 95 | 96 | 97 | { 98 | 99 | @bad_dec_int { failure "leading zero prohibited" } 100 | @dec_int { token mkDecInteger } 101 | @hex_int { token mkHexInteger } 102 | @oct_int { token mkOctInteger } 103 | @bin_int { token mkBinInteger } 104 | @float { token mkFloat } 105 | "true" { token_ TokTrue } 106 | "false" { token_ TokFalse } 107 | 108 | @offset_date_time { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime } 109 | @local_date { timeValue "local date" localDatePatterns TokLocalDate } 110 | @local_date_time { timeValue "local date-time" localDateTimePatterns TokLocalDateTime } 111 | @local_time { timeValue "local time" localTimePatterns TokLocalTime } 112 | 113 | } 114 | 115 | <0> { 116 | "[[" { token_ Tok2SquareO } 117 | "]]" { token_ Tok2SquareC } 118 | } 119 | 120 | <0,val,tab> { 121 | @newline { token_ TokNewline } 122 | @comment; 123 | $wschar+; 124 | 125 | "=" { token_ TokEquals } 126 | "." { token_ TokPeriod } 127 | "," { token_ TokComma } 128 | 129 | "[" { token_ TokSquareO } 130 | "]" { token_ TokSquareC } 131 | "{" { token_ TokCurlyO } 132 | "}" { token_ TokCurlyC } 133 | 134 | @barekey { textToken TokBareKey } 135 | 136 | \"{3} @newline? { startMlBstr } 137 | \" { startBstr } 138 | "'''" @newline? { startMlLstr } 139 | "'" { startLstr } 140 | 141 | } 142 | 143 | { 144 | $literal_char+ { strFrag } 145 | "'" { endStr . fmap (Text.drop 1) } 146 | } 147 | 148 | { 149 | $unescaped+ { strFrag } 150 | \" { endStr . fmap (Text.drop 1) } 151 | } 152 | 153 | { 154 | @mll_content+ { strFrag } 155 | "'" {1,2} { strFrag } 156 | "'" {3,5} { endStr . fmap (Text.drop 3) } 157 | } 158 | 159 | { 160 | @mlb_escaped_nl; 161 | ($unescaped | @newline)+ { strFrag } 162 | \" {1,2} { strFrag } 163 | \" {3,5} { endStr . fmap (Text.drop 3) } 164 | } 165 | 166 | { 167 | \\ U $hexdig{8} { unicodeEscape } 168 | \\ U { failure "\\U requires exactly 8 hex digits"} 169 | \\ u $hexdig{4} { unicodeEscape } 170 | \\ u { failure "\\u requires exactly 4 hex digits"} 171 | \\ n { strFrag . (Text.singleton '\n' <$) } 172 | \\ t { strFrag . (Text.singleton '\t' <$) } 173 | \\ r { strFrag . (Text.singleton '\r' <$) } 174 | \\ f { strFrag . (Text.singleton '\f' <$) } 175 | \\ b { strFrag . (Text.singleton '\b' <$) } 176 | \\ \\ { strFrag . (Text.singleton '\\' <$) } 177 | \\ \" { strFrag . (Text.singleton '\"' <$) } 178 | \\ . { failure "unknown escape sequence" } 179 | \\ { failure "incomplete escape sequence" } 180 | $control # [\t\r\n] { recommendEscape } 181 | } 182 | 183 | { 184 | 185 | type AlexInput = Located Text 186 | 187 | alexGetByte :: AlexInput -> Maybe (Int, AlexInput) 188 | alexGetByte = locatedUncons 189 | 190 | -- | Get the next token from a located string or a located error message. 191 | scanToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text) 192 | scanToken st str = 193 | case alexScan str (stateInt st) of 194 | AlexEOF -> eofToken st str 195 | AlexError str' -> Left (mkError . Text.unpack <$> str') 196 | AlexSkip str' _ -> scanToken st str' 197 | AlexToken str' n action -> 198 | case action (Text.take n <$> str) st of 199 | Resume st' -> scanToken st' str' 200 | LexerError e -> Left e 201 | EmitToken t -> Right (t, str') 202 | 203 | -- Map the logical lexer state to an Alex state number 204 | stateInt :: Context -> Int 205 | stateInt = 206 | \case 207 | TopContext -> 0 208 | TableContext -> tab 209 | ValueContext -> val 210 | BstrContext {} -> bstr 211 | MlBstrContext{} -> mlbstr 212 | LstrContext {} -> lstr 213 | MlLstrContext{} -> mllstr 214 | 215 | -- | Lex a single token in a value context. This is mostly useful for testing. 216 | lexValue :: Text -> Either String Token 217 | lexValue str = 218 | case scanToken ValueContext Located{ locPosition = startPos, locThing = str } of 219 | Left e -> Left (locThing e) 220 | Right (t,_) -> Right (locThing t) 221 | 222 | } 223 | -------------------------------------------------------------------------------- /src/Toml/Syntax/LexerUtils.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax.LexerUtils 3 | Description : Wrapper and actions for generated lexer 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module provides a custom engine for the Alex generated 9 | lexer. This lexer drive provides nested states, unicode support, 10 | and file location tracking. 11 | 12 | The various states of this module are needed to deal with the varying 13 | lexing rules while lexing values, keys, and string-literals. 14 | 15 | -} 16 | module Toml.Syntax.LexerUtils ( 17 | 18 | -- * Types 19 | Action, 20 | Context(..), 21 | Outcome(..), 22 | 23 | -- * Input processing 24 | locatedUncons, 25 | 26 | -- * Actions 27 | token, 28 | token_, 29 | textToken, 30 | 31 | timeValue, 32 | eofToken, 33 | 34 | failure, 35 | 36 | -- * String literals 37 | strFrag, 38 | startMlBstr, 39 | startBstr, 40 | startMlLstr, 41 | startLstr, 42 | endStr, 43 | unicodeEscape, 44 | recommendEscape, 45 | 46 | mkError, 47 | ) where 48 | 49 | import Data.Char (ord, chr, isAscii, isControl) 50 | import Data.Foldable (asum) 51 | import Data.Text (Text) 52 | import Data.Text qualified as Text 53 | import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) 54 | import Numeric (readHex) 55 | import Text.Printf (printf) 56 | import Toml.Syntax.Token (Token(..)) 57 | import Toml.Syntax.Position (move, Located(..), Position) 58 | 59 | -- | Type of actions associated with lexer patterns 60 | type Action = Located Text -> Context -> Outcome 61 | 62 | data Outcome 63 | = Resume Context 64 | | LexerError (Located String) 65 | | EmitToken (Located Token) 66 | 67 | -- | Representation of the current lexer state. 68 | data Context 69 | = TopContext -- ^ top-level where @[[@ and @]]@ have special meaning 70 | | TableContext -- ^ inline table - lex key names 71 | | ValueContext -- ^ value lexer - lex number literals 72 | | MlBstrContext Position [Text] -- ^ multiline basic string: position of opening delimiter and list of fragments 73 | | BstrContext Position [Text] -- ^ basic string: position of opening delimiter and list of fragments 74 | | MlLstrContext Position [Text] -- ^ multiline literal string: position of opening delimiter and list of fragments 75 | | LstrContext Position [Text] -- ^ literal string: position of opening delimiter and list of fragments 76 | deriving Show 77 | 78 | -- | Add a literal fragment of a string to the current string state. 79 | strFrag :: Action 80 | strFrag (Located _ s) = \case 81 | BstrContext p acc -> Resume (BstrContext p (s : acc)) 82 | MlBstrContext p acc -> Resume (MlBstrContext p (s : acc)) 83 | LstrContext p acc -> Resume (LstrContext p (s : acc)) 84 | MlLstrContext p acc -> Resume (MlLstrContext p (s : acc)) 85 | _ -> error "strFrag: panic" 86 | 87 | -- | End the current string state and emit the string literal token. 88 | endStr :: Action 89 | endStr (Located _ x) = \case 90 | BstrContext p acc -> EmitToken (Located p (TokString (Text.concat (reverse (x : acc))))) 91 | MlBstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc))))) 92 | LstrContext p acc -> EmitToken (Located p (TokString (Text.concat (reverse (x : acc))))) 93 | MlLstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc))))) 94 | _ -> error "endStr: panic" 95 | 96 | -- | Start a basic string literal 97 | startBstr :: Action 98 | startBstr (Located p _) _ = Resume (BstrContext p []) 99 | 100 | -- | Start a literal string literal 101 | startLstr :: Action 102 | startLstr (Located p _) _ = Resume (LstrContext p []) 103 | 104 | -- | Start a multi-line basic string literal 105 | startMlBstr :: Action 106 | startMlBstr (Located p _) _ = Resume (MlBstrContext p []) 107 | 108 | -- | Start a multi-line literal string literal 109 | startMlLstr :: Action 110 | startMlLstr (Located p _) _ = Resume (MlLstrContext p []) 111 | 112 | -- | Resolve a unicode escape sequence and add it to the current string literal 113 | unicodeEscape :: Action 114 | unicodeEscape (Located p lexeme) ctx = 115 | case readHex (drop 2 (Text.unpack lexeme)) of 116 | [(n,_)] | 0xd800 <= n, n < 0xe000 -> LexerError (Located p "non-scalar unicode escape") 117 | | n >= 0x110000 -> LexerError (Located p "unicode escape too large") 118 | | otherwise -> strFrag (Located p (Text.singleton (chr n))) ctx 119 | _ -> error "unicodeEscape: panic" 120 | 121 | recommendEscape :: Action 122 | recommendEscape (Located p x) _ = 123 | LexerError (Located p (printf "control characters must be escaped, use: \\u%04X" (ord (Text.head x)))) 124 | 125 | -- | Emit a token ignoring the current lexeme 126 | token_ :: Token -> Action 127 | token_ t x _ = EmitToken (t <$ x) 128 | 129 | -- | Emit a token using the current lexeme 130 | token :: (String -> Token) -> Action 131 | token f x _ = EmitToken (f . Text.unpack <$> x) 132 | 133 | -- | Emit a token using the current lexeme 134 | textToken :: (Text -> Token) -> Action 135 | textToken f x _ = EmitToken (f <$> x) 136 | 137 | -- | Attempt to parse the current lexeme as a date-time token. 138 | timeValue :: 139 | ParseTime a => 140 | String {- ^ description for error messages -} -> 141 | [String] {- ^ possible valid patterns -} -> 142 | (a -> Token) {- ^ token constructor -} -> 143 | Action 144 | timeValue description patterns constructor (Located p str) _ = 145 | case asum [parseTimeM False defaultTimeLocale pat (Text.unpack str) | pat <- patterns] of 146 | Nothing -> LexerError (Located p ("malformed " ++ description)) 147 | Just t -> EmitToken (Located p (constructor t)) 148 | 149 | -- | Pop the first character off a located string if it's not empty. 150 | -- The resulting 'Int' will either be the ASCII value of the character 151 | -- or @1@ for non-ASCII Unicode values. To avoid a clash, @\x1@ is 152 | -- remapped to @0@. 153 | locatedUncons :: Located Text -> Maybe (Int, Located Text) 154 | locatedUncons Located { locPosition = p, locThing = str } = 155 | case Text.uncons str of 156 | Nothing -> Nothing 157 | Just (x, xs) 158 | | rest `seq` False -> undefined 159 | | x == '\1' -> Just (0, rest) 160 | | isAscii x -> Just (ord x, rest) 161 | | otherwise -> Just (1, rest) 162 | where 163 | rest = Located { locPosition = move x p, locThing = xs } 164 | 165 | -- | Generate the correct terminating token given the current lexer state. 166 | eofToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text) 167 | eofToken (MlBstrContext p _) _ = Left (Located p "unterminated multi-line basic string") 168 | eofToken (BstrContext p _) _ = Left (Located p "unterminated basic string") 169 | eofToken (MlLstrContext p _) _ = Left (Located p "unterminated multi-line literal string") 170 | eofToken (LstrContext p _) _ = Left (Located p "unterminated literal string") 171 | eofToken _ t = Right (TokEOF <$ t, t) 172 | 173 | failure :: String -> Action 174 | failure err t _ = LexerError (err <$ t) 175 | 176 | -- | Generate an error message given the current string being lexed. 177 | mkError :: String -> String 178 | mkError "" = "unexpected end-of-input" 179 | mkError ('\n':_) = "unexpected end-of-line" 180 | mkError ('\r':'\n':_) = "unexpected end-of-line" 181 | mkError (x:_) 182 | | isControl x = "control characters prohibited" 183 | | otherwise = "unexpected " ++ show x 184 | -------------------------------------------------------------------------------- /src/Toml/Syntax/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-| 3 | Module : Toml.Syntax.Parser 4 | Description : Raw TOML expression parser 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module parses TOML tokens into a list of raw, 10 | uninterpreted sections and assignments. 11 | 12 | -} 13 | module Toml.Syntax.Parser ( 14 | -- * Types 15 | Expr(..), 16 | SectionKind(..), 17 | Val(..), 18 | Key, 19 | 20 | -- * Parser 21 | parseRawToml, 22 | ) where 23 | 24 | import Data.List.NonEmpty (NonEmpty) 25 | import Data.List.NonEmpty qualified as NonEmpty 26 | import Data.Text (Text) 27 | import Toml.Syntax.Lexer (Context(..), Token(..)) 28 | import Toml.Syntax.ParserUtils 29 | import Toml.Syntax.Position (Located(Located, locThing), Position) 30 | import Toml.Syntax.Position (startPos) 31 | import Toml.Syntax.Types (Expr(..), Key, Val(..), SectionKind(..)) 32 | 33 | } 34 | 35 | %tokentype { Located Token } 36 | %token 37 | ',' { Located $$ TokComma } 38 | '=' { Located $$ TokEquals } 39 | NEWLINE { Located $$ TokNewline } 40 | '.' { Located $$ TokPeriod } 41 | '[' { Located $$ TokSquareO } 42 | ']' { Located $$ TokSquareC } 43 | '[[' { Located $$ Tok2SquareO } 44 | ']]' { Located $$ Tok2SquareC } 45 | '{' { Located $$ TokCurlyO } 46 | '}' { Located $$ TokCurlyC } 47 | BAREKEY { (traverse asBareKey -> Just $$) } 48 | STRING { (traverse asString -> Just $$) } 49 | MLSTRING { (traverse asMlString -> Just $$) } 50 | BOOL { (traverse asBool -> Just $$) } 51 | INTEGER { (traverse asInteger -> Just $$) } 52 | FLOAT { (traverse asFloat -> Just $$) } 53 | OFFSETDATETIME { (traverse asOffsetDateTime -> Just $$) } 54 | LOCALDATETIME { (traverse asLocalDateTime -> Just $$) } 55 | LOCALDATE { (traverse asLocalDate -> Just $$) } 56 | LOCALTIME { (traverse asLocalTime -> Just $$) } 57 | 58 | %monad { Parser r } { thenP } { pureP } 59 | %lexer { lexerP } { Located _ TokEOF } 60 | %error { errorP } 61 | 62 | %name parseRawToml_ toml 63 | 64 | %% 65 | 66 | toml :: { [Expr Position] } 67 | : sepBy1(expression, NEWLINE) 68 | { concat $1 } 69 | 70 | expression :: { [Expr Position] } 71 | : { [] } 72 | | keyval { [uncurry KeyValExpr $1] } 73 | | '[' key ']' { [TableExpr $2 ] } 74 | | '[[' key ']]' { [ArrayTableExpr $2 ] } 75 | 76 | keyval :: { (Key Position, Val Position) } 77 | : key rhs '=' pop val 78 | { ($1,$5) } 79 | 80 | key :: { Key Position } 81 | : sepBy1(simplekey, '.') 82 | { $1 } 83 | 84 | simplekey :: { (Position, Text) } 85 | : BAREKEY { locVal (,) $1 } 86 | | STRING { locVal (,) $1 } 87 | 88 | val :: { Val Position } 89 | : INTEGER { locVal ValInteger $1 } 90 | | FLOAT { locVal ValFloat $1 } 91 | | BOOL { locVal ValBool $1 } 92 | | STRING { locVal ValString $1 } 93 | | MLSTRING { locVal ValString $1 } 94 | | LOCALDATE { locVal ValDay $1 } 95 | | LOCALTIME { locVal ValTimeOfDay $1 } 96 | | OFFSETDATETIME { locVal ValZonedTime $1 } 97 | | LOCALDATETIME { locVal ValLocalTime $1 } 98 | | array { locVal ValArray $1 } 99 | | inlinetable { locVal ValTable $1 } 100 | 101 | inlinetable :: { Located [(Key Position, Val Position)] } 102 | : lhs '{' sepBy(keyval, ',') pop '}' 103 | { Located $2 $3 } 104 | 105 | array :: { Located [Val Position] } 106 | : rhs '[' newlines pop ']' 107 | { Located $2 [] } 108 | | rhs '[' newlines arrayvalues pop ']' 109 | { Located $2 (reverse $4) } 110 | | rhs '[' newlines arrayvalues ',' newlines pop ']' 111 | { Located $2 (reverse $4) } 112 | 113 | arrayvalues :: { [Val Position] } 114 | : val newlines 115 | { [$1] } 116 | | arrayvalues ',' newlines val newlines 117 | { $4 : $1 } 118 | 119 | newlines :: { () } 120 | : { () } 121 | | newlines NEWLINE { () } 122 | 123 | sepBy(p,q) :: { [p] } 124 | : { [] } 125 | | sepBy1(p,q) { NonEmpty.toList $1 } 126 | 127 | sepBy1(p,q) :: { NonEmpty p } 128 | : sepBy1_(p,q) { NonEmpty.reverse $1 } 129 | 130 | sepBy1_(p,q) :: { NonEmpty p } 131 | : p { pure $1 } 132 | | sepBy1_(p,q) q p { NonEmpty.cons $3 $1 } 133 | 134 | rhs :: { () } 135 | : {% push ValueContext } 136 | 137 | lhs :: { () } 138 | : {% push TableContext } 139 | 140 | pop :: { () } 141 | : {% pop } 142 | 143 | { 144 | 145 | -- | Parse a list of tokens either returning the first unexpected 146 | -- token or a list of the TOML statements in the file to be 147 | -- processed by "Toml.Semantics". 148 | parseRawToml :: Text -> Either (Located String) [Expr Position] 149 | parseRawToml = runParser parseRawToml_ TopContext . Located startPos 150 | 151 | } 152 | -------------------------------------------------------------------------------- /src/Toml/Syntax/ParserUtils.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax.ParserUtils 3 | Description : Primitive operations used by the happy-generated parser 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module contains all the primitives used by the Parser module. 9 | By extracting it from the @.y@ file we minimize the amount of code 10 | that has warnings disabled and get better editor support. 11 | 12 | -} 13 | module Toml.Syntax.ParserUtils ( 14 | Parser, 15 | runParser, 16 | pureP, 17 | thenP, 18 | asString, 19 | asMlString, 20 | asBareKey, 21 | asInteger, 22 | asBool, 23 | asFloat, 24 | asOffsetDateTime, 25 | asLocalDate, 26 | asLocalTime, 27 | asLocalDateTime, 28 | locVal, 29 | 30 | lexerP, 31 | errorP, 32 | 33 | -- * Lexer-state management 34 | push, 35 | pop, 36 | ) where 37 | 38 | import Data.Text (Text) 39 | import Data.Time 40 | import Data.List.NonEmpty (NonEmpty((:|))) 41 | import Data.List.NonEmpty qualified as NonEmpty 42 | import Toml.Pretty (prettyToken) 43 | import Toml.Syntax.Lexer (scanToken, Context(..)) 44 | import Toml.Syntax.Position (Located(..), Position) 45 | import Toml.Syntax.Token (Token(..)) 46 | 47 | -- continuation passing implementation of a state monad with errors 48 | newtype Parser r a = P { 49 | getP :: 50 | NonEmpty Context -> Located Text -> 51 | (NonEmpty Context -> Located Text -> a -> Either (Located String) r) -> 52 | Either (Located String) r 53 | } 54 | 55 | -- | Run the top-level parser 56 | runParser :: Parser r r -> Context -> Located Text -> Either (Located String) r 57 | runParser (P k) ctx str = k (ctx :| []) str \_ _ r -> Right r 58 | 59 | -- | Bind implementation used in the happy-generated parser 60 | thenP :: Parser r a -> (a -> Parser r b) -> Parser r b 61 | thenP (P m) f = P \ctx str k -> m ctx str \ctx' str' x -> getP (f x) ctx' str' k 62 | {-# Inline thenP #-} 63 | 64 | -- | Return implementation used in the happy-generated parser 65 | pureP :: a -> Parser r a 66 | pureP x = P \ctx str k -> k ctx str x 67 | {-# Inline pureP #-} 68 | 69 | -- | Add a new context to the lexer context stack 70 | push :: Context -> Parser r () 71 | push x = P \st str k -> k (NonEmpty.cons x st) str () 72 | {-# Inline push #-} 73 | 74 | -- | Pop the top context off the lexer context stack. It is a program 75 | -- error to pop without first pushing. 76 | pop :: Parser r () 77 | pop = P \ctx str k -> 78 | case snd (NonEmpty.uncons ctx) of 79 | Nothing -> error "toml-parser: PANIC! malformed production in parser" 80 | Just ctx' -> k ctx' str () 81 | {-# Inline pop #-} 82 | 83 | -- | Operation the parser generator uses when it reaches an unexpected token. 84 | errorP :: Located Token -> Parser r a 85 | errorP e = P \_ _ _ -> Left (fmap (\t -> "parse error: unexpected " ++ prettyToken t) e) 86 | 87 | -- | Operation the parser generator uses to request the next token. 88 | lexerP :: (Located Token -> Parser r a) -> Parser r a 89 | lexerP f = P \st str k -> 90 | case scanToken (NonEmpty.head st) str of 91 | Left le -> Left (("lexical error: " ++) <$> le) 92 | Right (t, str') -> getP (f t) st str' k 93 | {-# Inline lexerP #-} 94 | 95 | 96 | asString :: Token -> Maybe Text 97 | asString = 98 | \case 99 | TokString i -> Just i 100 | _ -> Nothing 101 | 102 | asBareKey :: Token -> Maybe Text 103 | asBareKey = 104 | \case 105 | TokBareKey i -> Just i 106 | _ -> Nothing 107 | 108 | asMlString :: Token -> Maybe Text 109 | asMlString = 110 | \case 111 | TokMlString i -> Just i 112 | _ -> Nothing 113 | 114 | 115 | asInteger :: Token -> Maybe Integer 116 | asInteger = 117 | \case 118 | TokInteger i -> Just i 119 | _ -> Nothing 120 | 121 | asBool :: Token -> Maybe Bool 122 | asBool = 123 | \case 124 | TokTrue -> Just True 125 | TokFalse -> Just False 126 | _ -> Nothing 127 | 128 | asFloat :: Token -> Maybe Double 129 | asFloat = 130 | \case 131 | TokFloat x -> Just x 132 | _ -> Nothing 133 | 134 | asOffsetDateTime :: Token -> Maybe ZonedTime 135 | asOffsetDateTime = 136 | \case 137 | TokOffsetDateTime x -> Just x 138 | _ -> Nothing 139 | 140 | 141 | asLocalDateTime :: Token -> Maybe LocalTime 142 | asLocalDateTime = 143 | \case 144 | TokLocalDateTime x -> Just x 145 | _ -> Nothing 146 | 147 | 148 | asLocalDate :: Token -> Maybe Day 149 | asLocalDate = 150 | \case 151 | TokLocalDate x -> Just x 152 | _ -> Nothing 153 | 154 | asLocalTime :: Token -> Maybe TimeOfDay 155 | asLocalTime = 156 | \case 157 | TokLocalTime x -> Just x 158 | _ -> Nothing 159 | 160 | locVal :: (Position -> a -> b) -> Located a -> b 161 | locVal f (Located l x) = f l x 162 | -------------------------------------------------------------------------------- /src/Toml/Syntax/Position.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax.Position 3 | Description : File position representation 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module provides the 'Position' type for tracking locations 9 | in files while doing lexing and parsing for providing more useful 10 | error messages. 11 | 12 | This module assumes 8 column wide tab stops. 13 | 14 | -} 15 | module Toml.Syntax.Position ( 16 | Located(..), 17 | Position(..), 18 | startPos, 19 | move, 20 | ) where 21 | 22 | -- | A value annotated with its text file position 23 | data Located a = Located 24 | { locPosition :: {-# UNPACK #-} !Position -- ^ position 25 | , locThing :: !a -- ^ thing at position 26 | } 27 | deriving ( 28 | Read {- ^ Default instance -}, 29 | Show {- ^ Default instance -}, 30 | Functor {- ^ Default instance -}, 31 | Foldable {- ^ Default instance -}, 32 | Traversable {- ^ Default instance -}) 33 | 34 | -- | A position in a text file 35 | data Position = Position { 36 | posIndex :: {-# UNPACK #-} !Int, -- ^ code-point index (zero-based) 37 | posLine :: {-# UNPACK #-} !Int, -- ^ line index (one-based) 38 | posColumn :: {-# UNPACK #-} !Int -- ^ column index (one-based) 39 | } deriving ( 40 | Read {- ^ Default instance -}, 41 | Show {- ^ Default instance -}, 42 | Ord {- ^ Default instance -}, 43 | Eq {- ^ Default instance -}) 44 | 45 | -- | The initial 'Position' for the start of a file 46 | startPos :: Position 47 | startPos = Position { posIndex = 0, posLine = 1, posColumn = 1 } 48 | 49 | -- | Adjust a file position given a single character handling 50 | -- newlines and tabs. All other characters are considered to fill 51 | -- exactly one column. 52 | move :: Char -> Position -> Position 53 | move x Position{ posIndex = i, posLine = l, posColumn = c} = 54 | case x of 55 | '\n' -> Position{ posIndex = i+1, posLine = l+1, posColumn = 1 } 56 | '\t' -> Position{ posIndex = i+1, posLine = l, posColumn = (c + 7) `quot` 8 * 8 + 1 } 57 | _ -> Position{ posIndex = i+1, posLine = l, posColumn = c+1 } 58 | -------------------------------------------------------------------------------- /src/Toml/Syntax/Token.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax.Token 3 | Description : Lexical tokens 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module provides the datatype for the lexical syntax of TOML files. 9 | These tokens are generated by "Toml.Syntax.Lexer" and consumed in "Toml.Syntax.Parser". 10 | 11 | -} 12 | module Toml.Syntax.Token ( 13 | -- * Types 14 | Token(..), 15 | 16 | -- * Integer literals 17 | mkBinInteger, 18 | mkDecInteger, 19 | mkOctInteger, 20 | mkHexInteger, 21 | 22 | -- * Float literals 23 | mkFloat, 24 | 25 | -- * Date and time patterns 26 | localDatePatterns, 27 | localTimePatterns, 28 | localDateTimePatterns, 29 | offsetDateTimePatterns, 30 | ) where 31 | 32 | import Data.Char (digitToInt) 33 | import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) 34 | import Data.Text (Text) 35 | import Numeric (readInt, readHex, readOct) 36 | 37 | -- | Lexical token 38 | data Token 39 | = TokTrue -- ^ @true@ 40 | | TokFalse -- ^ @false@ 41 | | TokComma -- ^ @','@ 42 | | TokEquals -- ^ @'='@ 43 | | TokNewline -- ^ @end-of-line@ 44 | | TokPeriod -- ^ @'.'@ 45 | | TokSquareO -- ^ @'['@ 46 | | TokSquareC -- ^ @']'@ 47 | | Tok2SquareO -- ^ @'[['@ 48 | | Tok2SquareC -- ^ @']]'@ 49 | | TokCurlyO -- ^ @'{'@ 50 | | TokCurlyC -- ^ @'}'@ 51 | | TokBareKey Text -- ^ bare key 52 | | TokString Text -- ^ string literal 53 | | TokMlString Text -- ^ multiline string literal 54 | | TokInteger !Integer -- ^ integer literal 55 | | TokFloat !Double -- ^ floating-point literal 56 | | TokOffsetDateTime !ZonedTime -- ^ date-time with timezone offset 57 | | TokLocalDateTime !LocalTime -- ^ local date-time 58 | | TokLocalDate !Day -- ^ local date 59 | | TokLocalTime !TimeOfDay -- ^ local time 60 | | TokEOF -- ^ @end-of-input@ 61 | deriving (Read, Show) 62 | 63 | -- | Remove underscores from number literals 64 | scrub :: String -> String 65 | scrub = filter ('_' /=) 66 | 67 | -- | Construct a 'TokInteger' from a decimal integer literal lexeme. 68 | mkDecInteger :: String -> Token 69 | mkDecInteger ('+':xs) = TokInteger (read (scrub xs)) 70 | mkDecInteger xs = TokInteger (read (scrub xs)) 71 | 72 | -- | Construct a 'TokInteger' from a hexadecimal integer literal lexeme. 73 | mkHexInteger :: String -> Token 74 | mkHexInteger ('0':'x':xs) = TokInteger (fst (head (readHex (scrub xs)))) 75 | mkHexInteger _ = error "processHex: bad input" 76 | 77 | -- | Construct a 'TokInteger' from a octal integer literal lexeme. 78 | mkOctInteger :: String -> Token 79 | mkOctInteger ('0':'o':xs) = TokInteger (fst (head (readOct (scrub xs)))) 80 | mkOctInteger _ = error "processHex: bad input" 81 | 82 | -- | Construct a 'TokInteger' from a binary integer literal lexeme. 83 | mkBinInteger :: String -> Token 84 | mkBinInteger ('0':'b':xs) = TokInteger (fst (head (readBin (scrub xs)))) 85 | mkBinInteger _ = error "processHex: bad input" 86 | 87 | -- This wasn't added to base until 4.16 88 | readBin :: (Eq a, Num a) => ReadS a 89 | readBin = readInt 2 isBinDigit digitToInt 90 | 91 | isBinDigit :: Char -> Bool 92 | isBinDigit x = x == '0' || x == '1' 93 | 94 | -- | Construct a 'TokFloat' from a floating-point literal lexeme. 95 | mkFloat :: String -> Token 96 | mkFloat "nan" = TokFloat (0/0) 97 | mkFloat "+nan" = TokFloat (0/0) 98 | mkFloat "-nan" = TokFloat (0/0) 99 | mkFloat "inf" = TokFloat (1/0) 100 | mkFloat "+inf" = TokFloat (1/0) 101 | mkFloat "-inf" = TokFloat (-1/0) 102 | mkFloat ('+':x) = TokFloat (read (scrub x)) 103 | mkFloat x = TokFloat (read (scrub x)) 104 | 105 | -- | Format strings for local date lexemes. 106 | localDatePatterns :: [String] 107 | localDatePatterns = ["%Y-%m-%d"] 108 | 109 | -- | Format strings for local time lexemes. 110 | localTimePatterns :: [String] 111 | localTimePatterns = ["%H:%M:%S%Q"] 112 | 113 | -- | Format strings for local datetime lexemes. 114 | localDateTimePatterns :: [String] 115 | localDateTimePatterns = 116 | ["%Y-%m-%dT%H:%M:%S%Q", 117 | "%Y-%m-%d %H:%M:%S%Q"] 118 | 119 | -- | Format strings for offset datetime lexemes. 120 | offsetDateTimePatterns :: [String] 121 | offsetDateTimePatterns = 122 | ["%Y-%m-%dT%H:%M:%S%Q%Ez","%Y-%m-%dT%H:%M:%S%QZ", 123 | "%Y-%m-%d %H:%M:%S%Q%Ez","%Y-%m-%d %H:%M:%S%QZ"] 124 | -------------------------------------------------------------------------------- /src/Toml/Syntax/Types.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toml.Syntax.Types 3 | Description : Raw expressions from a parsed TOML file 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module provides a raw representation of TOML files as 9 | a list of table definitions and key-value assignments. 10 | 11 | These values use the raw dotted keys and have no detection 12 | for overlapping assignments. 13 | 14 | Further processing will happen in the "Semantics" module. 15 | 16 | -} 17 | module Toml.Syntax.Types ( 18 | Key, 19 | Expr(..), 20 | Val(..), 21 | SectionKind(..), 22 | ) where 23 | 24 | import Data.List.NonEmpty (NonEmpty) 25 | import Data.Text (Text) 26 | import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) 27 | 28 | -- | Non-empty sequence of dotted simple keys 29 | type Key a = NonEmpty (a, Text) 30 | 31 | -- | Headers and assignments corresponding to lines of a TOML file 32 | data Expr a 33 | = KeyValExpr (Key a) (Val a) -- ^ key value assignment: @key = value@ 34 | | TableExpr (Key a) -- ^ table: @[key]@ 35 | | ArrayTableExpr (Key a) -- ^ array of tables: @[[key]]@ 36 | deriving (Read, Show) 37 | 38 | 39 | -- | Unvalidated TOML values. Table are represented as a list of 40 | -- assignments rather than as resolved maps. 41 | data Val a 42 | = ValInteger a Integer 43 | | ValFloat a Double 44 | | ValArray a [Val a] 45 | | ValTable a [(Key a, Val a)] 46 | | ValBool a Bool 47 | | ValString a Text 48 | | ValTimeOfDay a TimeOfDay 49 | | ValZonedTime a ZonedTime 50 | | ValLocalTime a LocalTime 51 | | ValDay a Day 52 | deriving (Read, Show) 53 | 54 | -- | Kinds of table headers 55 | data SectionKind 56 | = TableKind -- ^ [table] 57 | | ArrayTableKind -- ^ [[array of tables]] 58 | deriving (Read, Show, Eq) 59 | -------------------------------------------------------------------------------- /test-drivers/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 Eric Mertens 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /test-drivers/decoder/Main.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | {-| 4 | Module : Main 5 | Description : Decoder driver for BurntSushi TOML test suite 6 | Copyright : (c) Eric Mertens, 2023 7 | License : ISC 8 | Maintainer : emertens@gmail.com 9 | 10 | Decode TOML into JSON for use with 11 | 12 | -} 13 | module Main (main) where 14 | 15 | import Data.Aeson qualified as Aeson 16 | import Data.ByteString.Lazy qualified as BS 17 | import Data.Text qualified as Text 18 | import Data.Text.IO qualified as Text 19 | import Toml (Value(..), Value'(..), parse, Table'(..)) 20 | import Toml.Pretty (prettyValue) 21 | 22 | main :: IO () 23 | main = 24 | do txt <- Text.getContents 25 | case parse txt of 26 | Left e -> fail e 27 | Right t -> BS.putStr (Aeson.encode t) 28 | 29 | simple :: Aeson.Key -> String -> Aeson.Value 30 | simple ty value = Aeson.object ["type" Aeson..= ty, "value" Aeson..= value] 31 | 32 | instance Aeson.ToJSON (Toml.Value' a) where 33 | toJSON v = 34 | case v of 35 | Table' _ t -> Aeson.toJSON t 36 | List' _ a -> Aeson.toJSON a 37 | Text' _ s -> simple "string" (Text.unpack s) 38 | Integer' _ _ -> simple "integer" (show (prettyValue v)) 39 | Double' _ _ -> simple "float" (show (prettyValue v)) 40 | Bool' _ _ -> simple "bool" (show (prettyValue v)) 41 | TimeOfDay' _ _ -> simple "time-local" (show (prettyValue v)) 42 | ZonedTime' _ _ -> simple "datetime" (show (prettyValue v)) 43 | LocalTime' _ _ -> simple "datetime-local" (show (prettyValue v)) 44 | Day' _ _ -> simple "date-local" (show (prettyValue v)) 45 | 46 | instance Aeson.ToJSON (Table' a) where 47 | toJSON (MkTable t) = Aeson.toJSON (fmap snd t) 48 | -------------------------------------------------------------------------------- /test-drivers/encoder/Main.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings, TypeOperators, TypeFamilies #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | {-| 4 | Module : Main 5 | Description : Encoder driver for BurntSushi TOML test suite 6 | Copyright : (c) Eric Mertens, 2023 7 | License : ISC 8 | Maintainer : emertens@gmail.com 9 | 10 | Encode TOML into JSON for use with 11 | 12 | -} 13 | module Main (main) where 14 | 15 | import Control.Applicative (empty) 16 | import Data.Aeson qualified as Aeson 17 | import Data.Aeson.Types qualified as Aeson 18 | import Data.ByteString.Lazy qualified as BS 19 | import Data.Foldable (toList) 20 | import Data.Map qualified as Map 21 | import Data.Text (Text) 22 | import Data.Text qualified as Text 23 | import System.Exit (exitFailure) 24 | import Toml (prettyToml, Value(..), Value'(..), Table) 25 | import Toml.Syntax.Lexer (lexValue, Token(..)) 26 | import Toml.Schema (toValue) 27 | 28 | main :: IO () 29 | main = 30 | do txt <- BS.getContents 31 | case Aeson.decode txt of 32 | Just (Toml.Table t) -> putStr (show (prettyToml t)) 33 | Nothing -> exitFailure 34 | 35 | instance a ~ () => Aeson.FromJSON (Toml.Value' a) where 36 | parseJSON = 37 | mconcat [ 38 | Aeson.withArray "array" \xs -> 39 | Toml.List <$> traverse Aeson.parseJSON (toList xs), 40 | Aeson.withObject "value" \o -> 41 | do ty <- o Aeson..: "type" 42 | vl <- o Aeson..: "value" 43 | decodeValue ty vl, 44 | fmap (toValue :: Map.Map String Value -> Value) . Aeson.parseJSON 45 | ] 46 | 47 | decodeValue :: String -> Text -> Aeson.Parser Toml.Value 48 | decodeValue "string" x = pure (Toml.Text x) 49 | decodeValue "bool" (lexValue -> Right TokTrue ) = pure (Toml.Bool True) 50 | decodeValue "bool" (lexValue -> Right TokFalse ) = pure (Toml.Bool False) 51 | decodeValue "integer" (lexValue -> Right (TokInteger x)) = pure (Toml.Integer x) 52 | decodeValue "time-local" (lexValue -> Right (TokLocalTime x)) = pure (Toml.TimeOfDay x) 53 | decodeValue "datetime" (lexValue -> Right (TokOffsetDateTime x)) = pure (Toml.ZonedTime x) 54 | decodeValue "datetime-local" (lexValue -> Right (TokLocalDateTime x)) = pure (Toml.LocalTime x) 55 | decodeValue "date-local" (lexValue -> Right (TokLocalDate x)) = pure (Toml.Day x) 56 | decodeValue "float" (lexValue -> Right (TokFloat x)) = pure (Toml.Double x) 57 | decodeValue "float" (lexValue -> Right (TokInteger x)) = pure (Toml.Double (fromInteger x)) 58 | -- extra infinities as toml-tests are inconsistent 59 | decodeValue "float" "+Inf" = pure (Toml.Double (1/0)) 60 | decodeValue "float" "-Inf" = pure (Toml.Double (-1/0)) 61 | decodeValue _ _ = empty 62 | -------------------------------------------------------------------------------- /test-drivers/highlighter/Main.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Main 3 | Description : Decoder driver for BurntSushi TOML test suite 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | Decode TOML into JSON for use with 9 | 10 | -} 11 | module Main (main) where 12 | 13 | import Data.Text.IO qualified as Text 14 | import Prettyprinter.Render.Terminal 15 | import Toml 16 | import Toml.Pretty (prettyLocated, prettyTomlOrdered) 17 | import Toml.Syntax (parseRawToml) 18 | import Toml.Semantics (semantics) 19 | import Toml.Semantics.Ordered (extractTableOrder, projectKey) 20 | 21 | main :: IO () 22 | main = 23 | do txt <- Text.getContents 24 | case parseRawToml txt of 25 | Left e -> fail (prettyLocated e) 26 | Right exprs -> 27 | let to = extractTableOrder exprs in 28 | case semantics exprs of 29 | Left e -> fail (prettySemanticError e) 30 | Right toml -> putDoc (style <$> prettyTomlOrdered (projectKey to) toml) 31 | 32 | style :: DocClass -> AnsiStyle 33 | style TableClass = colorDull Yellow <> bold 34 | style NumberClass = colorDull Cyan 35 | style DateClass = colorDull Green 36 | style StringClass = colorDull Red 37 | style KeyClass = colorDull Blue 38 | style BoolClass = colorDull Magenta 39 | -------------------------------------------------------------------------------- /test-drivers/toml-test-drivers.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: toml-test-drivers 3 | version: 1.0.0.0 4 | synopsis: toml-parser test drivers 5 | description: 6 | Test executables for the toml-parser library. 7 | license: ISC 8 | license-file: LICENSE 9 | author: Eric Mertens 10 | maintainer: emertens@gmail.com 11 | copyright: 2023 Eric Mertens 12 | category: Text 13 | build-type: Simple 14 | tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.2, 9.10.1, 9.12.2} 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/glguy/toml-parser 19 | tag: main 20 | 21 | common shared 22 | default-language: Haskell2010 23 | default-extensions: 24 | BlockArguments 25 | DeriveTraversable 26 | GeneralizedNewtypeDeriving 27 | ImportQualifiedPost 28 | LambdaCase 29 | ScopedTypeVariables 30 | ViewPatterns 31 | build-depends: 32 | base ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21}, 33 | toml-parser ^>= 2.0.1.0, 34 | 35 | executable TomlDecoder 36 | import: shared 37 | hs-source-dirs: decoder 38 | main-is: Main.hs 39 | build-depends: 40 | aeson ^>= {2.1, 2.2}, 41 | bytestring ^>= {0.10, 0.11, 0.12}, 42 | text, 43 | 44 | executable TomlEncoder 45 | import: shared 46 | hs-source-dirs: encoder 47 | main-is: Main.hs 48 | build-depends: 49 | aeson ^>= {2.1, 2.2}, 50 | bytestring ^>= {0.10, 0.11, 0.12}, 51 | containers ^>= {0.5, 0.6, 0.7}, 52 | text, 53 | 54 | executable TomlHighlighter 55 | import: shared 56 | hs-source-dirs: highlighter 57 | main-is: Main.hs 58 | build-depends: 59 | prettyprinter ^>= 1.7.1, 60 | prettyprinter-ansi-terminal ^>= 1.1.3, 61 | text, 62 | -------------------------------------------------------------------------------- /test/DecodeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language DuplicateRecordFields, OverloadedStrings #-} 2 | {-| 3 | Module : DecodeSpec 4 | Description : Show that decoding TOML works using the various provided classes 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | -} 10 | module DecodeSpec (spec) where 11 | 12 | import Data.Maybe (fromMaybe) 13 | import GHC.Generics (Generic) 14 | import QuoteStr (quoteStr) 15 | import Test.Hspec (it, shouldBe, Spec) 16 | import Toml (decode, encode) 17 | import Toml.Schema 18 | 19 | newtype Fruits = Fruits { fruits :: [Fruit] } 20 | deriving (Eq, Show, Generic) 21 | 22 | data Fruit = Fruit { 23 | name :: String, 24 | physical :: Maybe Physical, 25 | varieties :: [Variety] 26 | } deriving (Eq, Show, Generic) 27 | 28 | data Physical = Physical { 29 | color :: String, 30 | shape :: String 31 | } deriving (Eq, Show, Generic) 32 | 33 | newtype Variety = Variety { 34 | name :: String 35 | } deriving (Eq, Show, Generic) 36 | 37 | instance FromValue Fruits where fromValue = genericFromTable 38 | instance FromValue Physical where fromValue = genericFromTable 39 | instance FromValue Variety where fromValue = genericFromTable 40 | 41 | instance ToTable Fruits where toTable = genericToTable 42 | instance ToTable Physical where toTable = genericToTable 43 | instance ToTable Variety where toTable = genericToTable 44 | 45 | instance ToValue Fruits where toValue = defaultTableToValue 46 | instance ToValue Fruit where toValue = defaultTableToValue 47 | instance ToValue Physical where toValue = defaultTableToValue 48 | instance ToValue Variety where toValue = defaultTableToValue 49 | 50 | instance FromValue Fruit where 51 | fromValue = parseTableFromValue (Fruit 52 | <$> reqKey "name" 53 | <*> optKey "physical" 54 | <*> (fromMaybe [] <$> optKey "varieties")) 55 | 56 | instance ToTable Fruit where 57 | toTable (Fruit n mbp vs) = table $ 58 | ["varieties" .= vs | not (null vs)] ++ 59 | ["physical" .= p | Just p <- [mbp]] ++ 60 | ["name" .= n] 61 | 62 | spec :: Spec 63 | spec = 64 | do let expect = Fruits [ 65 | Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"], 66 | Fruit "banana" Nothing [Variety "plantain"]] 67 | 68 | it "handles fruit example" $ 69 | decode [quoteStr| 70 | [[fruits]] 71 | name = "apple" 72 | 73 | [fruits.physical] # subtable 74 | color = "red" 75 | shape = "round" 76 | 77 | [[fruits.varieties]] # nested array of tables 78 | name = "red delicious" 79 | 80 | [[fruits.varieties]] 81 | name = "granny smith" 82 | 83 | [[fruits]] 84 | name = "banana" 85 | 86 | [[fruits.varieties]] 87 | name = "plantain"|] 88 | `shouldBe` 89 | Success mempty expect 90 | 91 | it "encodes correctly" $ 92 | show (encode expect) 93 | `shouldBe` 94 | [quoteStr| 95 | [[fruits]] 96 | name = "apple" 97 | 98 | [fruits.physical] 99 | color = "red" 100 | shape = "round" 101 | 102 | [[fruits.varieties]] 103 | name = "red delicious" 104 | 105 | [[fruits.varieties]] 106 | name = "granny smith" 107 | 108 | [[fruits]] 109 | name = "banana" 110 | 111 | [[fruits.varieties]] 112 | name = "plantain"|] 113 | 114 | it "generates warnings for unused keys" $ 115 | decode [quoteStr| 116 | [[fruits]] 117 | name = "peach" 118 | taste = "sweet" 119 | count = 5 120 | [[fruits]] 121 | name = "pineapple" 122 | color = "yellow"|] 123 | `shouldBe` 124 | Success [ 125 | "4:1: unexpected key: count in fruits[0]", 126 | "3:1: unexpected key: taste in fruits[0]", 127 | "7:1: unexpected key: color in fruits[1]"] 128 | (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) 129 | 130 | it "handles missing key errors" $ 131 | (decode "[[fruits]]" :: Result String Fruits) 132 | `shouldBe` 133 | Failure ["1:3: missing key: name in fruits[0]"] 134 | 135 | it "handles parse errors while decoding" $ 136 | (decode "x =" :: Result String Fruits) 137 | `shouldBe` 138 | Failure ["1:4: parse error: unexpected end-of-input"] 139 | -------------------------------------------------------------------------------- /test/DerivingViaSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia, DeriveGeneric, OverloadedStrings #-} 2 | {-| 3 | Module : DerivingViaSpec 4 | Description : Show that TOML classes can be derived with DerivingVia 5 | Copyright : (c) Eric Mertens, 2024 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module ensures that the classes are actually derivable with 10 | generalized newtype deriving. In particular 'fromValue' uses the 11 | 'Matcher' type and that type can't use monad transformers without 12 | preventing this from working. The test ensures we don't have a 13 | regression later. 14 | 15 | -} 16 | module DerivingViaSpec (spec) where 17 | 18 | import GHC.Generics (Generic) 19 | import Test.Hspec (it, shouldBe, Spec) 20 | import Toml.Schema 21 | 22 | data Physical = Physical { 23 | color :: String, 24 | shape :: String 25 | } 26 | deriving (Eq, Show, Generic) 27 | deriving (ToTable, FromValue, ToValue) via GenericTomlTable Physical 28 | 29 | data TwoThings = TwoThings Int String 30 | deriving (Eq, Show, Generic) 31 | deriving (FromValue, ToValue) via GenericTomlArray TwoThings 32 | 33 | spec :: Spec 34 | spec = 35 | do let sem = Physical "red" "round" 36 | tab = table ["color" .= Text "red", "shape" .= Text "round"] 37 | 38 | it "supports toValue" $ 39 | toValue sem 40 | `shouldBe` 41 | Table tab 42 | 43 | it "supports toTable" $ 44 | toTable sem 45 | `shouldBe` 46 | tab 47 | 48 | it "supports fromValue" $ 49 | runMatcher (fromValue (Table tab)) 50 | `shouldBe` 51 | Success [] sem 52 | 53 | it "converts from arrays positionally" $ 54 | runMatcher (fromValue (List [Integer 42, Text "forty-two"])) 55 | `shouldBe` 56 | Success [] (TwoThings 42 "forty-two") 57 | 58 | it "converts to arrays positionally" $ 59 | toValue (TwoThings 42 "forty-two") 60 | `shouldBe` 61 | List [Integer 42, Text "forty-two"] 62 | -------------------------------------------------------------------------------- /test/FromValueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | {-| 3 | Module : FromValueSpec 4 | Description : Exercise various components of FromValue 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | -} 10 | module FromValueSpec (spec) where 11 | 12 | import Control.Applicative ((<|>), empty) 13 | import Control.Monad (when) 14 | import Test.Hspec (it, shouldBe, Spec) 15 | import Toml 16 | import Toml.Schema 17 | import Toml.Syntax (startPos) 18 | 19 | humanMatcher :: Matcher l a -> Result String a 20 | humanMatcher m = 21 | case runMatcher m of 22 | Failure e -> Failure (prettyMatchMessage . fmap (const startPos) <$> e) 23 | Success w x -> Success (prettyMatchMessage . fmap (const startPos) <$> w) x 24 | 25 | spec :: Spec 26 | spec = 27 | do it "handles one reqKey" $ 28 | humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"])) 29 | `shouldBe` 30 | Success [] ("val" :: String) 31 | 32 | it "handles one optKey" $ 33 | humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"])) 34 | `shouldBe` 35 | Success [] (Just ("val" :: String)) 36 | 37 | it "handles one missing optKey" $ 38 | humanMatcher (parseTable (optKey "test") () (table ["nottest" .= Text "val"])) 39 | `shouldBe` 40 | Success ["1:1: unexpected key: nottest in "] (Nothing :: Maybe String) 41 | 42 | it "handles one missing reqKey" $ 43 | humanMatcher (parseTable (reqKey "test") () (table ["nottest" .= Text "val"])) 44 | `shouldBe` 45 | (Failure ["1:1: missing key: test in "] :: Result String String) 46 | 47 | it "handles one mismatched reqKey" $ 48 | humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"])) 49 | `shouldBe` 50 | (Failure ["1:1: expected integer but got string in test"] :: Result String Integer) 51 | 52 | it "handles one mismatched optKey" $ 53 | humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"])) 54 | `shouldBe` 55 | (Failure ["1:1: expected integer but got string in test"] :: Result String (Maybe Integer)) 56 | 57 | it "handles concurrent errors" $ 58 | humanMatcher (parseTable (reqKey "a" <|> empty <|> reqKey "b") () (table [])) 59 | `shouldBe` 60 | (Failure ["1:1: missing key: a in ", 61 | "1:1: missing key: b in "] :: Result String Integer) 62 | 63 | it "handles concurrent value mismatch" $ 64 | let v = "" in 65 | humanMatcher (Left <$> fromValue v <|> empty <|> Right <$> fromValue v) 66 | `shouldBe` 67 | (Failure [ 68 | "1:1: expected boolean but got string in ", 69 | "1:1: expected integer but got string in "] 70 | :: Result String (Either Bool Int)) 71 | 72 | it "doesn't emit an error for empty" $ 73 | humanMatcher (parseTable empty () (table [])) 74 | `shouldBe` 75 | (Failure [] :: Result String Integer) 76 | 77 | it "matches single characters" $ 78 | runMatcher (fromValue (Text "x")) 79 | `shouldBe` 80 | Success [] 'x' 81 | 82 | it "rejections non-single characters" $ 83 | humanMatcher (fromValue (Text "xy")) 84 | `shouldBe` 85 | (Failure ["1:1: expected single character in "] :: Result String Char) 86 | 87 | it "collects warnings in table matching" $ 88 | let pt = 89 | do i1 <- reqKey "k1" 90 | i2 <- reqKey "k2" 91 | let n = i1 + i2 92 | when (odd n) (warnTable "k1 and k2 sum to an odd value") 93 | pure n 94 | in 95 | humanMatcher (parseTable pt () (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)])) 96 | `shouldBe` 97 | Success ["k1 and k2 sum to an odd value in "] (3 :: Integer) 98 | 99 | it "offers helpful messages when no keys match" $ 100 | let pt = pickKey [Key "this" \_ -> pure 'a', Key "." \_ -> pure 'b'] 101 | in 102 | humanMatcher (parseTable pt () (table [])) 103 | `shouldBe` 104 | (Failure ["1:1: possible keys: this, \".\" in "] :: Result String Char) 105 | 106 | it "generates an error message on an empty pickKey" $ 107 | let pt = pickKey [] 108 | in 109 | humanMatcher (parseTable pt () (table [])) 110 | `shouldBe` 111 | (Failure [] :: Result String Char) 112 | -------------------------------------------------------------------------------- /test/HieDemoSpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language GADTs, OverloadedStrings #-} 2 | {-| 3 | Module : HieDemoSpec 4 | Description : Exercise various components of FromValue on a life-sized example 5 | Copyright : (c) Eric Mertens, 2023 6 | License : ISC 7 | Maintainer : emertens@gmail.com 8 | 9 | This module demonstrates how "Toml.Schema" can handle a real-world 10 | format as used in hie-bios. These types are copied from 11 | 12 | with slight alterations because the Other case is for YAML-specific extensibility. 13 | This approach would work just the same when parameterized in that same way. 14 | 15 | -} 16 | module HieDemoSpec where 17 | 18 | import Data.Text (Text) 19 | import GHC.Generics ( Generic ) 20 | import QuoteStr (quoteStr) 21 | import Test.Hspec (Spec, it, shouldBe) 22 | import Toml (decode) 23 | import Toml.Schema as Toml 24 | 25 | ----------------------------------------------------------------------- 26 | -- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE 27 | ----------------------------------------------------------------------- 28 | 29 | -- Copyright (c) 2009, IIJ Innovation Institute Inc. 30 | -- All rights reserved. 31 | 32 | -- Redistribution and use in source and binary forms, with or without 33 | -- modification, are permitted provided that the following conditions 34 | -- are met: 35 | 36 | -- * Redistributions of source code must retain the above copyright 37 | -- notice, this list of conditions and the following disclaimer. 38 | -- * Redistributions in binary form must reproduce the above copyright 39 | -- notice, this list of conditions and the following disclaimer in 40 | -- the documentation and/or other materials provided with the 41 | -- distribution. 42 | -- * Neither the name of the copyright holders nor the names of its 43 | -- contributors may be used to endorse or promote products derived 44 | -- from this software without specific prior written permission. 45 | 46 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 47 | -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 48 | -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 49 | -- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 50 | -- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 51 | -- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 52 | -- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 53 | -- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 54 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 55 | -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 56 | -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 57 | -- POSSIBILITY OF SUCH DAMAGE. 58 | 59 | data CradleConfig = CradleConfig 60 | { cradle :: CradleComponent 61 | , dependencies :: Maybe [FilePath] 62 | } deriving (Generic, Show, Eq) 63 | 64 | data CradleComponent 65 | = Multi [MultiSubComponent] 66 | | Cabal CabalConfig 67 | | Stack StackConfig 68 | | Direct DirectConfig 69 | | Bios BiosConfig 70 | | None NoneConfig 71 | deriving (Generic, Show, Eq) 72 | 73 | data NoneConfig = NoneConfig 74 | deriving (Generic, Show, Eq) 75 | 76 | data MultiSubComponent = MultiSubComponent 77 | { path :: FilePath 78 | , config :: CradleConfig 79 | } deriving (Generic, Show, Eq) 80 | 81 | data CabalConfig = CabalConfig 82 | { cabalProject :: Maybe FilePath 83 | , cabalComponents :: OneOrManyComponents CabalComponent 84 | } deriving (Show, Eq) 85 | 86 | data CabalComponent = CabalComponent 87 | { cabalPath :: FilePath 88 | , cabalComponent :: String 89 | , cabalComponentProject :: Maybe FilePath 90 | } deriving (Show, Eq) 91 | 92 | data StackConfig = StackConfig 93 | { stackYaml :: Maybe FilePath 94 | , stackComponents :: OneOrManyComponents StackComponent 95 | } deriving (Show, Eq) 96 | 97 | data StackComponent = StackComponent 98 | { stackPath :: FilePath 99 | , stackComponent :: String 100 | , stackComponentYAML :: Maybe FilePath 101 | } deriving (Show, Eq) 102 | 103 | data OneOrManyComponents component 104 | = SingleComponent String 105 | | ManyComponents [component] 106 | | NoComponent 107 | deriving (Show, Eq) 108 | 109 | data DirectConfig = DirectConfig 110 | { arguments :: [String] 111 | } deriving (Generic, Show, Eq) 112 | 113 | data BiosConfig = BiosConfig 114 | { callable :: Callable 115 | , depsCallable :: Maybe Callable 116 | , ghcPath :: Maybe FilePath 117 | } deriving (Show, Eq) 118 | 119 | data Callable 120 | = Program FilePath 121 | | Shell String 122 | deriving (Show, Eq) 123 | 124 | ----------------------------------------------------------------------- 125 | -- END OF DERIVED CODE 126 | ----------------------------------------------------------------------- 127 | 128 | instance FromValue CradleConfig where 129 | fromValue = genericFromTable 130 | 131 | instance FromValue CradleComponent where 132 | fromValue = parseTableFromValue $ 133 | reqAlts [ 134 | KeyCase Multi "multi", 135 | KeyCase Cabal "cabal", 136 | KeyCase Stack "stack", 137 | KeyCase Direct "direct", 138 | KeyCase Bios "bios", 139 | KeyCase None "none"] 140 | 141 | instance FromValue MultiSubComponent where 142 | fromValue = genericFromTable 143 | 144 | instance FromValue CabalConfig where 145 | fromValue v@Toml.List'{} = CabalConfig Nothing . ManyComponents <$> fromValue v 146 | fromValue (Toml.Table' l t) = getComponentTable CabalConfig "cabalProject" l t 147 | fromValue _ = fail "cabal configuration expects table or array" 148 | 149 | getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> Text -> l -> Toml.Table' l -> Matcher l a 150 | getComponentTable con pathKey = parseTable $ con 151 | <$> optKey pathKey 152 | <*> pickKey [ 153 | Key "component" (fmap SingleComponent . fromValue), 154 | Key "components" (fmap ManyComponents . fromValue), 155 | Else (pure NoComponent)] 156 | 157 | instance FromValue CabalComponent where 158 | fromValue = parseTableFromValue $ CabalComponent 159 | <$> reqKey "path" 160 | <*> reqKey "component" 161 | <*> optKey "cabalProject" 162 | 163 | instance FromValue StackConfig where 164 | fromValue v@Toml.List'{} = StackConfig Nothing . ManyComponents <$> fromValue v 165 | fromValue (Toml.Table' l t) = getComponentTable StackConfig "stackYaml" l t 166 | fromValue _ = fail "stack configuration expects table or array" 167 | 168 | instance FromValue StackComponent where 169 | fromValue = parseTableFromValue $ StackComponent 170 | <$> reqKey "path" 171 | <*> reqKey "component" 172 | <*> optKey "stackYaml" 173 | 174 | instance FromValue DirectConfig where 175 | fromValue = genericFromTable 176 | 177 | instance FromValue BiosConfig where 178 | fromValue = parseTableFromValue $ BiosConfig 179 | <$> getCallable 180 | <*> getDepsCallable 181 | <*> optKey "with-ghc" 182 | where 183 | getCallable = 184 | reqAlts [ 185 | KeyCase Program "program", 186 | KeyCase Shell "shell"] 187 | getDepsCallable = 188 | optAlts [ 189 | KeyCase Program "dependency-program", 190 | KeyCase Shell "dependency-shell"] 191 | 192 | data KeyCase a where 193 | KeyCase :: FromValue b => (b -> a) -> Text -> KeyCase a 194 | 195 | reqAlts :: [KeyCase a] -> ParseTable l a 196 | reqAlts xs = pickKey 197 | [Key key (fmap con . fromValue) | KeyCase con key <- xs] 198 | 199 | optAlts :: [KeyCase a] -> ParseTable l (Maybe a) 200 | optAlts xs = pickKey $ 201 | [Key key (fmap (Just . con) . fromValue) | KeyCase con key <- xs] ++ 202 | [Else (pure Nothing)] 203 | 204 | instance FromValue NoneConfig where 205 | fromValue = parseTableFromValue (pure NoneConfig) 206 | 207 | spec :: Spec 208 | spec = 209 | do it "parses this project's hie.toml" $ 210 | decode [quoteStr| 211 | dependencies = [ 212 | "src/Toml/Lexer.x", 213 | "src/Toml/Parser.y", 214 | ] 215 | 216 | [[cradle.cabal]] 217 | path = "./src" 218 | component = "toml-parser:lib:toml-parser" 219 | 220 | [[cradle.cabal]] 221 | path = "./test" 222 | component = "toml-parser:test:unittests" 223 | 224 | [[cradle.cabal]] 225 | path = "./test-drivers/encoder" 226 | component = "toml-test-drivers:exe:TomlEncoder" 227 | 228 | [[cradle.cabal]] 229 | path = "./test-drivers/decoder" 230 | component = "toml-test-drivers:exe:TomlDecoder" 231 | 232 | [[cradle.cabal]] 233 | path = "./test-drivers/highlighter" 234 | component = "toml-test-drivers:exe:TomlHighlighter" 235 | |] 236 | `shouldBe` 237 | Success [] CradleConfig 238 | { cradle = 239 | Cabal 240 | CabalConfig 241 | { cabalProject = Nothing 242 | , cabalComponents = 243 | ManyComponents 244 | [ CabalComponent 245 | { cabalPath = "./src" 246 | , cabalComponent = "toml-parser:lib:toml-parser" 247 | , cabalComponentProject = Nothing 248 | } 249 | , CabalComponent 250 | { cabalPath = "./test" 251 | , cabalComponent = "toml-parser:test:unittests" 252 | , cabalComponentProject = Nothing 253 | } 254 | , CabalComponent 255 | { cabalPath = "./test-drivers/encoder" 256 | , cabalComponent = "toml-test-drivers:exe:TomlEncoder" 257 | , cabalComponentProject = Nothing 258 | } 259 | , CabalComponent 260 | { cabalPath = "./test-drivers/decoder" 261 | , cabalComponent = "toml-test-drivers:exe:TomlDecoder" 262 | , cabalComponentProject = Nothing 263 | } 264 | , CabalComponent 265 | { cabalPath = "./test-drivers/highlighter" 266 | , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" 267 | , cabalComponentProject = Nothing 268 | } 269 | ] 270 | } 271 | , dependencies = Just ["src/Toml/Lexer.x" , "src/Toml/Parser.y"] 272 | } 273 | 274 | it "has focused error messages" $ 275 | decode [quoteStr| 276 | [cradle.cabal] 277 | path = "./src" 278 | component = 42 279 | |] 280 | `shouldBe` 281 | (Failure ["3:13: expected string but got integer in cradle.cabal.component"] 282 | :: Result String CradleConfig) 283 | 284 | it "detects unusd keys" $ 285 | decode [quoteStr| 286 | [[cradle.multi]] 287 | path = "./src" 288 | [cradle.multi.config.cradle.cabal] 289 | component = "toml-parser:lib:toml-parser" 290 | thing1 = 10 # unused key for test case 291 | 292 | [[cradle.multi]] 293 | path = "./test" 294 | [cradle.multi.config.cradle.stack] 295 | component = "toml-parser:test:unittests" 296 | thing2 = 20 # more unused keys for test case 297 | thing3 = false 298 | |] 299 | `shouldBe` 300 | Success 301 | [ "5:1: unexpected key: thing1 in cradle.multi[0].config.cradle.cabal" 302 | , "11:1: unexpected key: thing2 in cradle.multi[1].config.cradle.stack" 303 | , "12:1: unexpected key: thing3 in cradle.multi[1].config.cradle.stack" 304 | 305 | ] 306 | CradleConfig 307 | { cradle = 308 | Multi 309 | [ MultiSubComponent 310 | { path = "./src" 311 | , config = 312 | CradleConfig 313 | { cradle = 314 | Cabal 315 | CabalConfig 316 | { cabalProject = Nothing 317 | , cabalComponents = SingleComponent "toml-parser:lib:toml-parser" 318 | } 319 | , dependencies = Nothing 320 | } 321 | } 322 | , MultiSubComponent 323 | { path = "./test" 324 | , config = 325 | CradleConfig 326 | { cradle = 327 | Stack 328 | StackConfig 329 | { stackYaml = Nothing 330 | , stackComponents = SingleComponent "toml-parser:test:unittests" 331 | } 332 | , dependencies = Nothing 333 | } 334 | } 335 | ] 336 | , dependencies = Nothing 337 | } 338 | 339 | it "parses things using components" $ 340 | decode [quoteStr| 341 | dependencies = [ 342 | "src/Toml/Lexer.x", 343 | "src/Toml/Parser.y", 344 | ] 345 | 346 | [cradle.cabal] 347 | cabalProject = "cabal.project" 348 | 349 | [[cradle.cabal.components]] 350 | path = "./src" 351 | component = "toml-parser:lib:toml-parser" 352 | 353 | [[cradle.cabal.components]] 354 | path = "./test" 355 | component = "toml-parser:test:unittests" 356 | 357 | [[cradle.cabal.components]] 358 | path = "./test-drivers/encoder" 359 | component = "toml-test-drivers:exe:TomlEncoder" 360 | 361 | [[cradle.cabal.components]] 362 | path = "./test-drivers/decoder" 363 | component = "toml-test-drivers:exe:TomlDecoder" 364 | 365 | [[cradle.cabal.components]] 366 | path = "./test-drivers/highlighter" 367 | component = "toml-test-drivers:exe:TomlHighlighter" 368 | |] 369 | `shouldBe` 370 | Success 371 | [] 372 | CradleConfig 373 | { cradle = 374 | Cabal 375 | CabalConfig 376 | { cabalProject = Just "cabal.project" 377 | , cabalComponents = 378 | ManyComponents 379 | [ CabalComponent 380 | { cabalPath = "./src" 381 | , cabalComponent = "toml-parser:lib:toml-parser" 382 | , cabalComponentProject = Nothing 383 | } 384 | , CabalComponent 385 | { cabalPath = "./test" 386 | , cabalComponent = "toml-parser:test:unittests" 387 | , cabalComponentProject = Nothing 388 | } 389 | , CabalComponent 390 | { cabalPath = "./test-drivers/encoder" 391 | , cabalComponent = "toml-test-drivers:exe:TomlEncoder" 392 | , cabalComponentProject = Nothing 393 | } 394 | , CabalComponent 395 | { cabalPath = "./test-drivers/decoder" 396 | , cabalComponent = "toml-test-drivers:exe:TomlDecoder" 397 | , cabalComponentProject = Nothing 398 | } 399 | , CabalComponent 400 | { cabalPath = "./test-drivers/highlighter" 401 | , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" 402 | , cabalComponentProject = Nothing 403 | } 404 | ] 405 | } 406 | , dependencies = Just [ "src/Toml/Lexer.x" , "src/Toml/Parser.y" ] 407 | } 408 | 409 | it "handles the none case" $ 410 | decode [quoteStr| 411 | [cradle.none]|] 412 | `shouldBe` 413 | Success [] (CradleConfig { 414 | cradle = None NoneConfig, 415 | dependencies = Nothing}) 416 | -------------------------------------------------------------------------------- /test/LexerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module LexerSpec (spec) where 3 | 4 | import Data.Text (Text) 5 | import Test.Hspec (it, shouldBe, Spec) 6 | import Toml 7 | import Toml.Schema (table, (.=)) 8 | 9 | parse_ :: Text -> Either String Table 10 | parse_ str = forgetTableAnns <$> parse str 11 | 12 | spec :: Spec 13 | spec = 14 | do it "handles special cased control character" $ 15 | parse "x = '\SOH'" 16 | `shouldBe` 17 | Left "1:6: lexical error: control characters prohibited" 18 | 19 | it "recommends escapes for control characters (1)" $ 20 | parse "x = \"\SOH\"" 21 | `shouldBe` 22 | Left "1:6: lexical error: control characters must be escaped, use: \\u0001" 23 | 24 | it "recommends escapes for control characters (2)" $ 25 | parse "x = \"\DEL\"" 26 | `shouldBe` 27 | Left "1:6: lexical error: control characters must be escaped, use: \\u007F" 28 | 29 | -- These seem boring, but they provide test coverage of an error case in the state machine 30 | it "handles unexpected '}'" $ 31 | parse "}" 32 | `shouldBe` 33 | Left "1:1: parse error: unexpected '}'" 34 | 35 | it "handles unexpected '{'" $ 36 | parse "{" 37 | `shouldBe` 38 | Left "1:1: parse error: unexpected '{'" 39 | 40 | it "accepts tabs" $ 41 | parse_ "x\t=\t1" 42 | `shouldBe` 43 | Right (table ["x" .= Integer 1]) 44 | 45 | it "computes columns correctly with tabs" $ 46 | parse "x\t=\t=" 47 | `shouldBe` 48 | Left "1:17: parse error: unexpected '='" 49 | 50 | it "detects non-scalars in strings" $ 51 | parse "x = \"\\udfff\"" 52 | `shouldBe` 53 | Left "1:6: lexical error: non-scalar unicode escape" 54 | 55 | it "catches unclosed [" $ 56 | parse "x = [1,2,3" 57 | `shouldBe` 58 | Left "1:11: parse error: unexpected end-of-input" 59 | 60 | it "catches unclosed {" $ 61 | parse "x = { y" 62 | `shouldBe` 63 | Left "1:8: parse error: unexpected end-of-input" 64 | 65 | it "catches unclosed \"" $ 66 | parse "x = \"abc" 67 | `shouldBe` 68 | Left "1:5: lexical error: unterminated basic string" 69 | 70 | it "catches unclosed \"\"\"" $ 71 | parse "x = \"\"\"test" 72 | `shouldBe` 73 | Left "1:5: lexical error: unterminated multi-line basic string" 74 | 75 | it "catches unclosed '" $ 76 | parse "x = 'abc\ny = 2" 77 | `shouldBe` 78 | Left "1:9: lexical error: unexpected end-of-line" 79 | 80 | it "catches unclosed '" $ 81 | parse "x = 'abc" 82 | `shouldBe` 83 | Left "1:5: lexical error: unterminated literal string" 84 | 85 | it "catches unclosed '''" $ 86 | parse "x = '''test\n\n" 87 | `shouldBe` 88 | Left "1:5: lexical error: unterminated multi-line literal string" 89 | 90 | it "handles escapes at the end of input" $ 91 | parse "x = \"\\" 92 | `shouldBe` 93 | Left "1:6: lexical error: incomplete escape sequence" 94 | 95 | it "handles invalid escapes" $ 96 | parse "x = \"\\p\"" 97 | `shouldBe` 98 | Left "1:6: lexical error: unknown escape sequence" 99 | 100 | it "allows multi-byte characters in ''' strings" $ 101 | parse_ "x = '''§'''" 102 | `shouldBe` 103 | Right (table ["x" .= Text "§"]) 104 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/PrettySpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module PrettySpec (spec) where 3 | 4 | import Data.Map qualified as Map 5 | import Data.Text (Text) 6 | import QuoteStr (quoteStr) 7 | import Test.Hspec (it, shouldBe, Spec) 8 | import Toml 9 | 10 | tomlString :: Table -> String 11 | tomlString = show . prettyToml 12 | 13 | parse_ :: Text -> Either String Table 14 | parse_ str = forgetTableAnns <$> parse str 15 | 16 | spec :: Spec 17 | spec = 18 | do it "renders example 1" $ 19 | show (encode (Map.singleton ("x" :: Text) (1 :: Integer))) 20 | `shouldBe` [quoteStr| 21 | x = 1|] 22 | 23 | it "renders example 2" $ 24 | fmap tomlString (parse_ "x=1\ny=2") 25 | `shouldBe` Right [quoteStr| 26 | x = 1 27 | y = 2|] 28 | 29 | it "renders example lists" $ 30 | fmap tomlString (parse_ "x=[1,'two', [true]]") 31 | `shouldBe` Right [quoteStr| 32 | x = [1, "two", [true]]|] 33 | 34 | it "renders empty tables" $ 35 | fmap tomlString (parse_ "x.y.z={}\nz.y.w=false") 36 | `shouldBe` Right [quoteStr| 37 | [x.y.z] 38 | 39 | [z] 40 | y.w = false|] 41 | 42 | it "renders empty tables in array of tables" $ 43 | fmap tomlString (parse_ "ex=[{},{},{a=9}]") 44 | `shouldBe` Right [quoteStr| 45 | [[ex]] 46 | 47 | [[ex]] 48 | 49 | [[ex]] 50 | a = 9|] 51 | 52 | it "renders multiple tables" $ 53 | fmap tomlString (parse_ "a.x=1\nb.x=3\na.y=2\nb.y=4") 54 | `shouldBe` Right [quoteStr| 55 | [a] 56 | x = 1 57 | y = 2 58 | 59 | [b] 60 | x = 3 61 | y = 4|] 62 | 63 | it "renders escapes in strings" $ 64 | fmap tomlString (parse_ "a=\"\\\\\\b\\t\\r\\n\\f\\\"\\u007f\\U0001000c\"") 65 | `shouldBe` Right [quoteStr| 66 | a = "\\\b\t\r\n\f\"\u007F\U0001000C"|] 67 | 68 | it "renders multiline strings" $ 69 | fmap tomlString (parse_ [quoteStr| 70 | Everything-I-Touch = "Everything I touch\nwith tenderness, alas,\npricks like a bramble." 71 | Two-More = [ 72 | "The west wind whispered,\nAnd touched the eyelids of spring:\nHer eyes, Primroses.", 73 | "Plum flower temple:\nVoices rise\nFrom the foothills", 74 | ]|]) 75 | `shouldBe` Right [quoteStr| 76 | Everything-I-Touch = """ 77 | Everything I touch 78 | with tenderness, alas, 79 | pricks like a bramble.""" 80 | Two-More = [ """ 81 | The west wind whispered, 82 | And touched the eyelids of spring: 83 | Her eyes, Primroses.""" 84 | , "Plum flower temple:\nVoices rise\nFrom the foothills" ]|] 85 | 86 | it "renders floats" $ 87 | fmap tomlString (parse_ "a=0.0\nb=-0.1\nc=0.1\nd=3.141592653589793\ne=4e123") 88 | `shouldBe` Right [quoteStr| 89 | a = 0.0 90 | b = -0.1 91 | c = 0.1 92 | d = 3.141592653589793 93 | e = 4.0e123|] 94 | 95 | it "renders special floats" $ 96 | fmap tomlString (parse_ "a=inf\nb=-inf\nc=nan") 97 | `shouldBe` Right [quoteStr| 98 | a = inf 99 | b = -inf 100 | c = nan|] 101 | 102 | it "renders empty documents" $ 103 | fmap tomlString (parse_ "") 104 | `shouldBe` Right "" 105 | 106 | it "renders dates and time" $ 107 | fmap tomlString (parse_ [quoteStr| 108 | a = 2020-05-07 109 | b = 15:16:17.990 110 | c = 2020-05-07T15:16:17.990 111 | d = 2020-05-07T15:16:17.990Z 112 | e = 2020-05-07T15:16:17-07:00 113 | f = 2021-09-06T14:15:19+08:00 114 | g = 0008-10-11T12:13:14+15:00|]) 115 | `shouldBe` Right [quoteStr| 116 | a = 2020-05-07 117 | b = 15:16:17.99 118 | c = 2020-05-07T15:16:17.99 119 | d = 2020-05-07T15:16:17.99Z 120 | e = 2020-05-07T15:16:17-07:00 121 | f = 2021-09-06T14:15:19+08:00 122 | g = 0008-10-11T12:13:14+15:00|] 123 | 124 | it "renders quoted keys" $ 125 | fmap tomlString (parse_ "''.'a b'.'\"' = 10") 126 | `shouldBe` Right [quoteStr| 127 | ""."a b"."\"" = 10|] 128 | 129 | it "renders inline tables" $ 130 | fmap tomlString (parse_ [quoteStr| 131 | x = [[{a = 'this is a longer example', b = 'and it will linewrap'},{c = 'all on its own'}]]|]) 132 | `shouldBe` Right [quoteStr| 133 | x = [ [ {a = "this is a longer example", b = "and it will linewrap"} 134 | , {c = "all on its own"} ] ]|] 135 | 136 | it "factors out unique table prefixes in leaf tables" $ 137 | fmap tomlString (parse_ [quoteStr| 138 | [x] 139 | i = 1 140 | p.q = "a" 141 | y.z = "c"|]) 142 | `shouldBe` Right [quoteStr| 143 | [x] 144 | i = 1 145 | p.q = "a" 146 | y.z = "c"|] 147 | -------------------------------------------------------------------------------- /test/QuoteStr.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : QuoteStr 3 | Description : Quasiquoter for multi-line string literals 4 | Copyright : (c) Eric Mertens, 2023 5 | License : ISC 6 | Maintainer : emertens@gmail.com 7 | 8 | This module makes it easy to write inline TOML for 9 | test cases without worrying about escaping newlines 10 | or quotation marks. 11 | 12 | -} 13 | module QuoteStr (quoteStr) where 14 | 15 | import Language.Haskell.TH (Exp(LitE), ExpQ, Lit(StringL)) 16 | import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) 17 | import Data.List ( stripPrefix ) 18 | 19 | quoteStr :: QuasiQuoter 20 | quoteStr = QuasiQuoter { 21 | quoteDec = \_ -> fail "quoteStr doesn't support declarations", 22 | quotePat = \_ -> fail "quoteStr doesn't support patterns", 23 | quoteType = \_ -> fail "quoteStr doesn't support types", 24 | quoteExp = processString 25 | } 26 | 27 | processString :: String -> ExpQ 28 | processString ('\n':xs) = 29 | let ws = takeWhile (' '==) xs 30 | 31 | cleanup "" = pure "" 32 | cleanup x = case stripPrefix ws x of 33 | Nothing -> fail "bad prefix" 34 | Just x' -> pure x' 35 | in LitE . StringL . unlines <$> traverse cleanup (lines xs) 36 | processString _ = fail "malformed string literal" 37 | -------------------------------------------------------------------------------- /test/ToValueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module ToValueSpec where 3 | 4 | import Test.Hspec (it, shouldBe, Spec) 5 | import Toml (Value'(Integer, Text, List)) 6 | import Toml.Schema (ToValue(toValue)) 7 | 8 | spec :: Spec 9 | spec = 10 | do it "converts characters as singleton strings" $ 11 | toValue '!' `shouldBe` Text "!" 12 | 13 | it "converts strings normally" $ 14 | toValue ("demo" :: String) `shouldBe` Text "demo" 15 | 16 | it "converts lists" $ 17 | toValue [1,2,3::Int] `shouldBe` List [Integer 1, Integer 2, Integer 3] 18 | -------------------------------------------------------------------------------- /toml-parser.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: toml-parser 3 | version: 2.0.1.2 4 | synopsis: TOML 1.0.0 parser 5 | description: 6 | TOML parser using generated lexers and parsers with 7 | careful attention to the TOML 1.0.0 semantics for 8 | defining tables. 9 | license: ISC 10 | license-file: LICENSE 11 | author: Eric Mertens 12 | maintainer: emertens@gmail.com 13 | copyright: 2023 Eric Mertens 14 | category: Text 15 | build-type: Simple 16 | tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.2, 9.10.1, 9.12.2} 17 | 18 | extra-doc-files: 19 | ChangeLog.md 20 | README.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/glguy/toml-parser 25 | tag: main 26 | 27 | common extensions 28 | default-language: Haskell2010 29 | default-extensions: 30 | BlockArguments 31 | DeriveDataTypeable 32 | DeriveGeneric 33 | DeriveTraversable 34 | EmptyCase 35 | FlexibleContexts 36 | FlexibleInstances 37 | GeneralizedNewtypeDeriving 38 | ImportQualifiedPost 39 | LambdaCase 40 | ScopedTypeVariables 41 | TypeOperators 42 | TypeSynonymInstances 43 | ViewPatterns 44 | 45 | library 46 | import: extensions 47 | hs-source-dirs: src 48 | default-language: Haskell2010 49 | exposed-modules: 50 | Toml 51 | Toml.Pretty 52 | Toml.Schema 53 | Toml.Schema.FromValue 54 | Toml.Schema.Generic 55 | Toml.Schema.Generic.FromValue 56 | Toml.Schema.Generic.ToValue 57 | Toml.Schema.Matcher 58 | Toml.Schema.ParseTable 59 | Toml.Schema.ToValue 60 | Toml.Semantics 61 | Toml.Semantics.Ordered 62 | Toml.Semantics.Types 63 | Toml.Syntax 64 | Toml.Syntax.Lexer 65 | Toml.Syntax.Parser 66 | Toml.Syntax.Position 67 | Toml.Syntax.Token 68 | Toml.Syntax.Types 69 | other-modules: 70 | Toml.Syntax.LexerUtils 71 | Toml.Syntax.ParserUtils 72 | build-depends: 73 | array ^>= 0.5, 74 | base ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21}, 75 | containers ^>= {0.5, 0.6, 0.7, 0.8}, 76 | prettyprinter ^>= 1.7, 77 | text >= 0.2 && < 3, 78 | time ^>= {1.9, 1.10, 1.11, 1.12, 1.14}, 79 | transformers ^>= {0.5, 0.6}, 80 | build-tool-depends: 81 | alex:alex >= 3.2, 82 | happy:happy >= 1.19, 83 | if impl(ghc >= 9.8) 84 | ghc-options: -Wno-x-partial 85 | 86 | test-suite unittests 87 | import: extensions 88 | type: exitcode-stdio-1.0 89 | hs-source-dirs: test 90 | main-is: Main.hs 91 | default-extensions: 92 | QuasiQuotes 93 | build-tool-depends: 94 | hspec-discover:hspec-discover ^>= {2.10, 2.11} 95 | build-depends: 96 | base, 97 | containers, 98 | hspec ^>= {2.10, 2.11}, 99 | template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23}, 100 | text, 101 | time, 102 | toml-parser, 103 | other-modules: 104 | DecodeSpec 105 | DerivingViaSpec 106 | FromValueSpec 107 | HieDemoSpec 108 | LexerSpec 109 | PrettySpec 110 | QuoteStr 111 | TomlSpec 112 | ToValueSpec 113 | 114 | test-suite readme 115 | import: extensions 116 | type: exitcode-stdio-1.0 117 | main-is: README.lhs 118 | ghc-options: -pgmL markdown-unlit -optL "haskell toml" 119 | default-extensions: 120 | QuasiQuotes 121 | DerivingVia 122 | other-modules: 123 | QuoteStr 124 | hs-source-dirs: 125 | . 126 | test 127 | build-depends: 128 | base, 129 | toml-parser, 130 | hspec ^>= {2.10, 2.11}, 131 | template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23}, 132 | text, 133 | build-tool-depends: 134 | markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0}, 135 | 136 | executable toml-benchmarker 137 | buildable: False 138 | main-is: benchmarker.hs 139 | default-language: Haskell2010 140 | build-depends: base, toml-parser, time, text 141 | hs-source-dirs: benchmarker 142 | -------------------------------------------------------------------------------- /weeder.toml: -------------------------------------------------------------------------------- 1 | roots = [ 2 | '^Toml\.decode$', 3 | '^Toml\.encode$', 4 | '^Toml\.Pretty\.prettyTomlOrdered$', 5 | '^Toml\.ToValue\.\.=$', 6 | '^Toml\.ToValue\.table$', 7 | '^Toml\.ToValue\.Generic\.genericToTable$', 8 | '^Toml\.FromValue\.Generic\.genericParseTable$', 9 | '^Toml\.FromValue\.ParseTable\.warnTable$', 10 | '^Toml\.FromValue\.parseTableFromValue$', 11 | ] 12 | type-class-roots = true 13 | --------------------------------------------------------------------------------