├── README.lhs ├── stack.yaml ├── stack-lts12.yaml ├── stack-lts13.yaml ├── stack-lts14.yaml ├── stack-lts16.yaml ├── stack-lts18.yaml ├── stack-lts19.yaml ├── stack-lts20.yaml ├── stack-lts21.yaml ├── stack-lts22.yaml ├── stack-lts23.yaml ├── stack-lts24.yaml ├── .github ├── CODEOWNERS └── workflows │ ├── restyled.yml │ ├── release.yml │ └── ci.yml ├── .gitignore ├── .stack-all ├── stack-nightly.yaml ├── .restyled.yaml ├── .hlint.yaml ├── renovate.json ├── .weeder.yaml ├── CHANGELOG.md ├── library ├── Closed.hs └── Closed │ └── Internal.hs ├── .releaserc.yaml ├── .stylish-haskell.yaml ├── Makefile ├── package.yaml ├── fourmolu.yaml ├── LICENSE ├── closed.cabal ├── brittany.yaml └── README.md /README.lhs: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-lts24.yaml -------------------------------------------------------------------------------- /stack-lts12.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | -------------------------------------------------------------------------------- /stack-lts13.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.30 2 | -------------------------------------------------------------------------------- /stack-lts14.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | -------------------------------------------------------------------------------- /stack-lts16.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | -------------------------------------------------------------------------------- /stack-lts18.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | -------------------------------------------------------------------------------- /stack-lts19.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.33 2 | -------------------------------------------------------------------------------- /stack-lts20.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | -------------------------------------------------------------------------------- /stack-lts21.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | -------------------------------------------------------------------------------- /stack-lts22.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.44 2 | -------------------------------------------------------------------------------- /stack-lts23.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.27 2 | -------------------------------------------------------------------------------- /stack-lts24.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-24.0 2 | -------------------------------------------------------------------------------- /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @freckle/backenders 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | stack*.yaml.lock 3 | -------------------------------------------------------------------------------- /.stack-all: -------------------------------------------------------------------------------- 1 | [versions] 2 | oldest = lts-12 3 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2024-07-18 2 | -------------------------------------------------------------------------------- /.restyled.yaml: -------------------------------------------------------------------------------- 1 | restylers: 2 | - fourmolu 3 | - "!stylish-haskell" 4 | - "*" 5 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: "Redundant do", within: spec} 2 | - ignore: {name: "Reduce duplication", within: spec} 3 | -------------------------------------------------------------------------------- /renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://docs.renovatebot.com/renovate-schema.json", 3 | "extends": [ 4 | "local>freckle/renovate-config" 5 | ] 6 | } 7 | -------------------------------------------------------------------------------- /.weeder.yaml: -------------------------------------------------------------------------------- 1 | - package: 2 | - name: closed 3 | - section: 4 | - name: test:readme 5 | - message: 6 | - name: Redundant build-depends entry 7 | - depends: markdown-unlit 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.2.0.2 2 | 3 | * Add support for GHCs 9.0 and 9.2 4 | 5 | ## 0.2.0.1 6 | 7 | * Add support for `ghc 8.6.X` 8 | * Convert from SemVer to PVP 9 | 10 | ## 0.2.0 11 | 12 | * Add instances for `PersistField` and `PersistFieldSql` 13 | * Fix README rendering issue on GitHub 14 | 15 | ## 0.1.0 (initial release) 16 | 17 | * Initial public release 18 | -------------------------------------------------------------------------------- /.github/workflows/restyled.yml: -------------------------------------------------------------------------------- 1 | name: Restyled 2 | 3 | on: 4 | pull_request: 5 | 6 | concurrency: 7 | group: ${{ github.workflow }}-${{ github.ref }} 8 | cancel-in-progress: true 9 | 10 | jobs: 11 | restyled: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v6 15 | - uses: restyled-io/actions/setup@v4 16 | - uses: restyled-io/actions/run@v4 17 | with: 18 | suggestions: true 19 | -------------------------------------------------------------------------------- /library/Closed.hs: -------------------------------------------------------------------------------- 1 | module Closed 2 | ( Endpoint (..) 3 | , Closed 4 | , Bounds 5 | , Single 6 | , FiniteNat 7 | , closed 8 | , unsafeClosed 9 | , clamp 10 | , getClosed 11 | , lowerBound 12 | , upperBound 13 | , equals 14 | , cmp 15 | , natToClosed 16 | , weakenUpper 17 | , weakenLower 18 | , strengthenUpper 19 | , strengthenLower 20 | , add 21 | , sub 22 | , multiply 23 | , isValidClosed 24 | ) where 25 | 26 | import Closed.Internal 27 | -------------------------------------------------------------------------------- /.releaserc.yaml: -------------------------------------------------------------------------------- 1 | tagFormat: "v0.${version}" # PVP prefixed 2 | 3 | plugins: 4 | - - "@semantic-release/commit-analyzer" 5 | - preset: "conventionalcommits" 6 | - - "@semantic-release/release-notes-generator" 7 | - preset: "conventionalcommits" 8 | - - "@semantic-release/github" 9 | - successCommentCondition: false 10 | failCommentCondition: false 11 | - - "semantic-release-stack-upload" 12 | - pvpBounds: lower 13 | stripSuffix: true 14 | 15 | branches: 16 | - main 17 | - name: rc/* 18 | prerelease: '${name.replace(/^rc\//, "rc-")}' 19 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | steps: 3 | - simple_align: 4 | cases: false 5 | top_level_patterns: false 6 | records: false 7 | - imports: 8 | align: none 9 | list_align: after_alias 10 | pad_module_names: false 11 | long_list_align: new_line_multiline 12 | empty_list_align: right_after 13 | list_padding: 2 14 | separate_lists: false 15 | space_surround: false 16 | - language_pragmas: 17 | style: vertical 18 | align: false 19 | remove_redundant: false 20 | - trailing_whitespace: {} 21 | columns: 80 22 | newline: native 23 | cabal: true 24 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | - rc/* 8 | 9 | jobs: 10 | release: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v6 14 | 15 | - id: release 16 | uses: cycjimmy/semantic-release-action@v4 17 | with: 18 | extra_plugins: | 19 | conventional-changelog-conventionalcommits 20 | semantic-release-stack-upload 21 | env: 22 | FORCE_COLOR: 1 23 | GITHUB_TOKEN: ${{ github.token }} 24 | HACKAGE_KEY: ${{ secrets.HACKAGE_UPLOAD_API_KEY }} 25 | STACK_YAML: stack-lts12.yaml 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: setup build test lint 2 | 3 | .PHONY: setup 4 | setup: 5 | stack setup $(STACK_ARGUMENTS) 6 | stack build $(STACK_ARGUMENTS) --dependencies-only --test --no-run-tests 7 | stack install $(STACK_ARGUMENTS) --copy-compiler-tool hlint weeder 8 | 9 | .PHONY: build 10 | build: 11 | stack build $(STACK_ARGUMENTS) --fast --pedantic --test --no-run-tests 12 | 13 | .PHONY: test 14 | test: 15 | stack build $(STACK_ARGUMENTS) --fast --pedantic --test 16 | 17 | .PHONY: lint 18 | lint: 19 | stack exec $(STACK_ARGUMENTS) hlint library 20 | stack exec $(STACK_ARGUMENTS) weeder . 21 | 22 | .PHONY: clean 23 | clean: 24 | stack clean 25 | 26 | .PHONY: check-nightly 27 | check-nightly: STACK_ARGUMENTS=--stack-yaml stack-nightly.yaml --resolver nightly 28 | check-nightly: setup build test 29 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: closed 2 | version: 0.0.0.0 # maintained by semantic-release 3 | synopsis: Integers bounded by a closed interval 4 | description: Integers bounded by a closed interval checked at compile time 5 | category: Data 6 | author: Chris Parks 7 | maintainer: Freckle Education 8 | github: frontrowed/closed 9 | license: MIT 10 | 11 | dependencies: 12 | - aeson 13 | - base >= 4.9 && < 5 14 | - cassava 15 | - persistent 16 | - text 17 | 18 | library: 19 | source-dirs: 20 | - library 21 | dependencies: 22 | - deepseq 23 | - hashable 24 | - random 25 | - QuickCheck 26 | 27 | tests: 28 | readme: 29 | main: README.lhs 30 | ghc-options: -Wall -pgmL markdown-unlit 31 | dependencies: 32 | - closed 33 | - hspec 34 | - vector 35 | build-tools: 36 | - markdown-unlit 37 | 38 | extra-source-files: 39 | - README.lhs 40 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | column-limit: 80 # needs fourmolu >= v0.12 3 | function-arrows: leading 4 | comma-style: leading # default 5 | import-export-style: leading 6 | import-grouping: # needs fourmolu >= v0.17 7 | - name: "Preludes" 8 | rules: 9 | - glob: Prelude 10 | - name: "Everything else" 11 | rules: 12 | - match: all 13 | priority: 100 14 | indent-wheres: false # default 15 | record-brace-space: true 16 | newlines-between-decls: 1 # default 17 | haddock-style: single-line 18 | let-style: mixed 19 | in-style: left-align 20 | single-constraint-parens: never # needs fourmolu >= v0.12 21 | sort-constraints: true # needs fourmolu >= v0.17 22 | sort-derived-classes: true # needs fourmolu >= v0.17 23 | sort-derived-clauses: true # needs fourmolu >= v0.17 24 | trailing-section-operators: false # needs fourmolu >= v0.17 25 | unicode: never # default 26 | respectful: true # default 27 | fixities: null # default 28 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | 6 | permissions: 7 | contents: read 8 | 9 | jobs: 10 | generate: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v6 14 | - id: generate 15 | uses: freckle/stack-action/generate-matrix@v5 16 | outputs: 17 | stack-yamls: ${{ steps.generate.outputs.stack-yamls }} 18 | fail-fast: false 19 | 20 | test: 21 | needs: generate 22 | runs-on: ubuntu-latest 23 | 24 | strategy: 25 | matrix: 26 | stack-yaml: ${{ fromJSON(needs.generate.outputs.stack-yamls) }} 27 | fail-fast: false 28 | 29 | steps: 30 | - uses: actions/checkout@v6 31 | - uses: freckle/stack-action@v5 32 | with: 33 | stack-yaml: ${{ matrix.stack-yaml }} 34 | 35 | lint: 36 | runs-on: ubuntu-latest 37 | steps: 38 | - uses: actions/checkout@v6 39 | - uses: haskell-actions/hlint-setup@v2 40 | - uses: haskell-actions/hlint-run@v2 41 | with: 42 | fail-on: warning 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2020 Renaissance Learning Inc 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /closed.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: closed 8 | version: 0.0.0.0 9 | synopsis: Integers bounded by a closed interval 10 | description: Integers bounded by a closed interval checked at compile time 11 | category: Data 12 | homepage: https://github.com/frontrowed/closed#readme 13 | bug-reports: https://github.com/frontrowed/closed/issues 14 | author: Chris Parks 15 | maintainer: Freckle Education 16 | license: MIT 17 | license-file: LICENSE 18 | build-type: Simple 19 | extra-source-files: 20 | README.lhs 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/frontrowed/closed 25 | 26 | library 27 | exposed-modules: 28 | Closed 29 | Closed.Internal 30 | other-modules: 31 | Paths_closed 32 | hs-source-dirs: 33 | library 34 | build-depends: 35 | QuickCheck 36 | , aeson 37 | , base >=4.9 && <5 38 | , cassava 39 | , deepseq 40 | , hashable 41 | , persistent 42 | , random 43 | , text 44 | default-language: Haskell2010 45 | 46 | test-suite readme 47 | type: exitcode-stdio-1.0 48 | main-is: README.lhs 49 | other-modules: 50 | Paths_closed 51 | ghc-options: -Wall -pgmL markdown-unlit 52 | build-tool-depends: 53 | markdown-unlit:markdown-unlit 54 | build-depends: 55 | aeson 56 | , base >=4.9 && <5 57 | , cassava 58 | , closed 59 | , hspec 60 | , persistent 61 | , text 62 | , vector 63 | default-language: Haskell2010 64 | -------------------------------------------------------------------------------- /brittany.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | conf_debug: 3 | dconf_roundtrip_exactprint_only: false 4 | dconf_dump_bridoc_simpl_par: false 5 | dconf_dump_ast_unknown: false 6 | dconf_dump_bridoc_simpl_floating: false 7 | dconf_dump_config: false 8 | dconf_dump_bridoc_raw: false 9 | dconf_dump_bridoc_final: false 10 | dconf_dump_bridoc_simpl_alt: false 11 | dconf_dump_bridoc_simpl_indent: false 12 | dconf_dump_annotations: false 13 | dconf_dump_bridoc_simpl_columns: false 14 | dconf_dump_ast_full: false 15 | conf_forward: 16 | options_ghc: 17 | - -XBangPatterns 18 | - -XConstraintKinds 19 | - -XDataKinds 20 | - -XDeriveDataTypeable 21 | - -XDeriveGeneric 22 | - -XDoAndIfThenElse 23 | - -XEmptyDataDecls 24 | - -XFlexibleContexts 25 | - -XFlexibleInstances 26 | - -XFunctionalDependencies 27 | - -XGADTs 28 | - -XKindSignatures 29 | - -XLambdaCase 30 | - -XMultiParamTypeClasses 31 | - -XMultiWayIf 32 | - -XNamedFieldPuns 33 | - -XNoImplicitPrelude 34 | - -XNoMonomorphismRestriction 35 | - -XOverloadedStrings 36 | - -XPolyKinds 37 | - -XQuasiQuotes 38 | - -XRank2Types 39 | - -XRecordWildCards 40 | - -XScopedTypeVariables 41 | - -XStandaloneDeriving 42 | - -XTemplateHaskell 43 | - -XTupleSections 44 | - -XTypeApplications 45 | - -XTypeFamilies 46 | - -XTypeOperators 47 | - -XViewPatterns 48 | conf_errorHandling: 49 | econf_ExactPrintFallback: ExactPrintFallbackModeInline 50 | econf_Werror: false 51 | econf_omit_output_valid_check: false 52 | econf_produceOutputOnErrors: false 53 | conf_preprocessor: 54 | ppconf_CPPMode: CPPModeAbort 55 | ppconf_hackAroundIncludes: false 56 | conf_obfuscate: false 57 | conf_roundtrip_exactprint_only: false 58 | conf_version: 1 59 | conf_layout: 60 | lconfig_reformatModulePreamble: false 61 | lconfig_altChooser: 62 | tag: AltChooserBoundedSearch 63 | contents: 3 64 | lconfig_allowSingleLineExportList: false 65 | lconfig_importColumn: 60 66 | lconfig_hangingTypeSignature: false 67 | lconfig_importAsColumn: 50 68 | lconfig_alignmentLimit: 1 69 | lconfig_indentListSpecial: true 70 | lconfig_indentAmount: 2 71 | lconfig_alignmentBreakOnMultiline: true 72 | lconfig_cols: 80 73 | lconfig_indentPolicy: IndentPolicyLeft 74 | lconfig_indentWhereSpecial: true 75 | lconfig_columnAlignMode: 76 | tag: ColumnAlignModeDisabled 77 | contents: 0.7 78 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # closed 2 | 3 | Integers bounded by a closed interval 4 | 5 | ## Build 6 | 7 | ```plaintext 8 | stack build 9 | ``` 10 | 11 | ## Tutorial 12 | 13 | ### Overview 14 | 15 | This package exports one core data type `Closed (n :: Nat) (m :: Nat)` for describing integers bounded by a closed interval. That is, given `cx :: Closed n m`, `getClosed cx` is an integer `x` where `n <= x <= m`. 16 | 17 | We also export a type family `Bounds` for describing open and half-open intervals in terms of closed intervals. 18 | 19 | ```plaintext 20 | Bounds (Inclusive 0) (Inclusive 10) => Closed 0 10 21 | Bounds (Inclusive 0) (Exclusive 10) => Closed 0 9 22 | Bounds (Exclusive 0) (Inclusive 10) => Closed 1 10 23 | Bounds (Exclusive 0) (Exclusive 10) => Closed 1 9 24 | ``` 25 | 26 | ### Preamble 27 | 28 | For most uses of `closed`, you'll only need `DataKinds` and maybe `TypeFamilies`. The other extensions below just make some of the tests concise. 29 | 30 | ```haskell 31 | {-# LANGUAGE TypeFamilies #-} 32 | {-# LANGUAGE DataKinds #-} 33 | {-# LANGUAGE OverloadedStrings #-} 34 | {-# LANGUAGE OverloadedLists #-} 35 | {-# LANGUAGE TypeApplications #-} 36 | {-# LANGUAGE ScopedTypeVariables #-} 37 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 38 | 39 | module Main where 40 | 41 | import Closed 42 | import Control.Exception 43 | import Data.Aeson 44 | import Database.Persist 45 | import Data.Proxy 46 | import Data.Text 47 | import Data.Vector 48 | import GHC.TypeLits 49 | import qualified Data.Csv as CSV 50 | import Test.Hspec 51 | import Test.Hspec.QuickCheck 52 | import Text.Read (readEither) 53 | 54 | main :: IO () 55 | main = hspec $ do 56 | ``` 57 | 58 | ### Construction 59 | 60 | The safe constructor `closed` uses `Maybe` to indicate failure. There is also an unsafe constructor `unsafeClosed` as well as a `Num` instance that implements `fromInteger`. 61 | 62 | ```haskell 63 | describe "safe construction" $ do 64 | 65 | it "should successfully construct values in the specified bounds" $ do 66 | let result = closed 2 :: Maybe (Bounds (Inclusive 2) (Exclusive 5)) 67 | getClosed <$> result `shouldBe` Just 2 68 | 69 | it "should fail to construct values outside the specified bounds" $ do 70 | let result = closed 1 :: Maybe (Bounds (Inclusive 2) (Exclusive 5)) 71 | getClosed <$> result `shouldBe` Nothing 72 | 73 | describe "unsafe construction" $ do 74 | 75 | it "should successfully construct values in the specified bounds" $ do 76 | -- Note that you can use -XTypeApplications instead of type annotations 77 | let result = unsafeClosed @2 @4 2 78 | getClosed result `shouldBe` 2 79 | 80 | it "should fail to construct values outside the specified bounds" $ do 81 | let result = unsafeClosed @2 @4 1 82 | evaluate (getClosed result) `shouldThrow` anyErrorCall 83 | 84 | describe "construction with clamp" $ do 85 | it "should round up to lower bound" $ do 86 | let result = clamp @2 @4 @Int 0 87 | getClosed result `shouldBe` 2 88 | 89 | it "should round down to upper bound" $ do 90 | let result = clamp @2 @4 @Int 6 91 | getClosed result `shouldBe` 4 92 | 93 | it "should accept internal value as-is" $ do 94 | let result = clamp @2 @4 @Int 3 95 | getClosed result `shouldBe` 3 96 | 97 | describe "unsafe literal construction" $ do 98 | 99 | it "should successfully construct values in the specified bounds" $ do 100 | let result = 2 :: Bounds (Inclusive 2) (Exclusive 5) 101 | getClosed result `shouldBe` 2 102 | 103 | it "should fail to construct values outside the specified bounds" $ do 104 | let result = 1 :: Bounds (Inclusive 2) (Exclusive 5) 105 | evaluate (getClosed result) `shouldThrow` anyErrorCall 106 | ``` 107 | 108 | ### Elimination 109 | 110 | Use `getClosed` to extract the `Integer` from a `Closed` value. 111 | 112 | ```haskell 113 | describe "elimination" $ do 114 | 115 | it "should allow the integer value to be extracted" $ do 116 | let result = 1 :: Bounds (Inclusive 0) (Exclusive 10) 117 | getClosed result `shouldBe` 1 118 | ``` 119 | 120 | ### Bounds Manipulation 121 | 122 | The upper and lower bounds can be queried, strengthened, and weakened. 123 | 124 | ```haskell 125 | describe "bounds manipulation" $ do 126 | 127 | let cx = 4 :: Bounds (Inclusive 2) (Exclusive 10) 128 | 129 | it "should allow querying the bounds" $ do 130 | upperBound cx `shouldBe` (Proxy @9) 131 | lowerBound cx `shouldBe` (Proxy @2) 132 | 133 | it "should allow weakening the bounds" $ do 134 | upperBound (weakenUpper cx) `shouldBe` (Proxy @10) 135 | lowerBound (weakenLower cx) `shouldBe` (Proxy @1) 136 | 137 | it "should allow weakening the bounds by more than one" $ do 138 | upperBound (weakenUpper cx) `shouldBe` (Proxy @20) 139 | lowerBound (weakenLower cx) `shouldBe` (Proxy @0) 140 | 141 | it "should allow strengthening the bounds" $ do 142 | upperBound <$> strengthenUpper cx `shouldBe` Just (Proxy @8) 143 | lowerBound <$> strengthenLower cx `shouldBe` Just (Proxy @3) 144 | 145 | it "should allow strengthening the bounds by more than one" $ do 146 | upperBound <$> strengthenUpper cx `shouldBe` Just (Proxy @7) 147 | lowerBound <$> strengthenLower cx `shouldBe` Just (Proxy @4) 148 | ``` 149 | 150 | ### Arithmetic 151 | 152 | Arithmetic gets stuck at the upper and lower bounds instead of wrapping. This is called [Saturation Arithmetic](https://en.wikipedia.org/wiki/Saturation_arithmetic). 153 | 154 | ```haskell 155 | describe "arithmetic" $ do 156 | 157 | it "addition to the maxBound should have no effect" $ do 158 | let result = maxBound :: Bounds (Inclusive 1) (Exclusive 10) 159 | result + 1 `shouldBe` result 160 | 161 | it "subtraction from the minBound should have no effect" $ do 162 | let result = minBound :: Bounds (Inclusive 1) (Exclusive 10) 163 | result - 1 `shouldBe` result 164 | ``` 165 | 166 | ### Serialization 167 | 168 | Parsing of closed values is strict. 169 | 170 | ```haskell 171 | describe "Read" $ do 172 | 173 | it "should successfully read values in the specified bounds" $ do 174 | let result = readEither "1" :: Either String (Bounds (Inclusive 1) (Exclusive 10)) 175 | result `shouldBe` Right 1 176 | 177 | it "should fail to read values outside the specified bounds" $ do 178 | let result = readEither "0" :: Either String (Bounds (Inclusive 1) (Exclusive 10)) 179 | result `shouldBe` Left "Prelude.read: no parse" 180 | 181 | describe "json" $ do 182 | 183 | it "should successfully parse values in the specified bounds" $ do 184 | let result = eitherDecode "1" :: Either String (Bounds (Inclusive 1) (Exclusive 10)) 185 | result `shouldBe` Right 1 186 | 187 | it "should fail to parse values outside the specified bounds" $ do 188 | let result = eitherDecode "0" :: Either String (Bounds (Inclusive 1) (Exclusive 10)) 189 | result `shouldBe` Left "Error in $: parseJSON: Integer 0 is not representable in Closed 1 9" 190 | 191 | describe "csv" $ do 192 | 193 | it "should successfully parse values in the specified bounds" $ do 194 | let result = CSV.decode CSV.NoHeader "1" :: Either String (Vector (CSV.Only (Bounds (Inclusive 1) (Exclusive 10)))) 195 | result `shouldBe` Right [CSV.Only 1] 196 | 197 | it "should fail to parse values outside the specified bounds" $ do 198 | let result = CSV.decode CSV.NoHeader "0" :: Either String (Vector (CSV.Only (Bounds (Inclusive 1) (Exclusive 10)))) 199 | result `shouldBe` Left "parse error (Failed reading: conversion error: parseField: Integer 0 is not representable in Closed 1 9) at \"\"" 200 | 201 | describe "persistent" $ do 202 | 203 | it "should successfully parse values in the specified bounds" $ do 204 | let result = fromPersistValue (PersistInt64 1) :: Either Text (Bounds (Inclusive 1) (Exclusive 10)) 205 | result `shouldBe` Right 1 206 | 207 | it "should fail to parse values outside the specified bounds" $ do 208 | let result = fromPersistValue (PersistInt64 0) :: Either Text (Bounds (Inclusive 1) (Exclusive 10)) 209 | result `shouldBe` Left "fromPersistValue: Integer 0 is not representable in Closed 1 9" 210 | ``` 211 | 212 | ### Testing 213 | 214 | Closed values can be generated with QuickCheck 215 | 216 | ```haskell 217 | describe "quickcheck" $ do 218 | 219 | prop "should always generate values in the specified bounds" $ 220 | \(cx :: Closed 0 1000) -> 221 | natVal (lowerBound cx) <= getClosed cx && 222 | getClosed cx <= natVal (upperBound cx) 223 | ``` 224 | 225 | ## Release 226 | 227 | To release a new version of this library, push a commit to `main` using a 228 | conventionally-formatted commit message. 229 | 230 | - Prefix with `fix:` to release a new patch version, 231 | - Prefix with `feat:` to release a new minor version, or 232 | - Prefix with `feat!:` to release a new major version 233 | 234 | To change the "epoch" version, edit it in `package.yaml` and change the 235 | `.releaserc.yaml` tag prefix to match. 236 | 237 | ## Remarks 238 | 239 | This library was inspired by [finite-typelits](https://hackage.haskell.org/package/finite-typelits) and [finite-typelits-bounded](https://github.com/pseudonom/finite-typelits-bounded). The differences are summarized below: 240 | 241 | * `finite-typelits` - A value of `Finite (n :: Nat)` is in the half-open interval `[0, n)`. Uses modular arithmetic. 242 | * `finite-typelits-bounded` - A value of `Finite (n :: Nat)` is in the half-open interval `[0, n)`. Uses saturation arithmetic. 243 | * `closed` - A value of `Closed (n :: Nat) (m :: Nat)` is in the closed interval `[n, m]`. Uses saturation arithmetic. 244 | -------------------------------------------------------------------------------- /library/Closed/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- Prevent kind errors arising from using * to mean multiplication on 12 | -- type-level natural numbers. 13 | #if __GLASGOW_HASKELL__ >= 806 14 | {-# LANGUAGE NoStarIsType #-} 15 | #endif 16 | 17 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 18 | 19 | module Closed.Internal where 20 | 21 | import Control.DeepSeq 22 | import Control.Monad 23 | import Data.Aeson 24 | import qualified Data.Csv as CSV 25 | import Data.Hashable 26 | import Data.Kind (Type) 27 | import Data.Maybe 28 | import Data.Proxy 29 | import Data.Ratio 30 | import Data.Text (pack) 31 | import Database.Persist.Sql 32 | import GHC.Generics 33 | import GHC.Stack 34 | import GHC.TypeLits 35 | import System.Random (Random (..)) 36 | import Test.QuickCheck 37 | import Text.ParserCombinators.ReadP (pfail, readP_to_S, readS_to_P) 38 | 39 | newtype Closed (a :: Nat) (b :: Nat) = Closed 40 | { getClosed :: Integer 41 | } 42 | deriving (Generic) 43 | 44 | -- | Describe whether the endpoint of a 'Bounds' includes 45 | -- or excludes its argument 46 | data Endpoint 47 | = -- | Endpoint includes its argument 48 | Inclusive Nat 49 | | -- | Endpoint excludes its argument 50 | Exclusive Nat 51 | 52 | -- | Syntactic sugar to express open and half-open intervals using 53 | -- the 'Closed' type 54 | type family Bounds (lhs :: Endpoint) (rhs :: Endpoint) :: Type where 55 | Bounds (Inclusive a) (Inclusive b) = Closed a b 56 | Bounds (Inclusive a) (Exclusive b) = Closed a (b - 1) 57 | Bounds (Exclusive a) (Inclusive b) = Closed (a + 1) b 58 | Bounds (Exclusive a) (Exclusive b) = Closed (a + 1) (b - 1) 59 | 60 | -- | Syntactic sugar to express a value that has only one non-bottom 61 | -- inhabitant using the 'Closed' type 62 | type Single (n :: Nat) = Bounds ('Inclusive n) ('Inclusive n) 63 | 64 | -- | Syntactic sugar to express a value whose lower bound is zero 65 | type FiniteNat (rhs :: Endpoint) = Bounds ('Inclusive 0) rhs 66 | 67 | -- | Proxy for the lower bound of a 'Closed' value 68 | lowerBound :: Closed a b -> Proxy a 69 | lowerBound _ = Proxy 70 | 71 | -- | Proxy for the upper bound of a 'Closed' value 72 | upperBound :: Closed a b -> Proxy b 73 | upperBound _ = Proxy 74 | 75 | -- | Safely create a 'Closed' value using the specified argument 76 | closed 77 | :: forall a b 78 | . (KnownNat a, KnownNat b, a <= b) 79 | => Integer 80 | -> Maybe (Closed a b) 81 | closed x = result 82 | where 83 | extracted = fromJust result 84 | result = do 85 | guard $ x >= natVal (lowerBound extracted) && x <= natVal (upperBound extracted) 86 | pure $ Closed x 87 | 88 | -- | Create a 'Closed' value throwing an error if the argument is not in range 89 | unsafeClosed 90 | :: forall a b 91 | . (HasCallStack, KnownNat a, KnownNat b, a <= b) 92 | => Integer 93 | -> Closed a b 94 | unsafeClosed x = result 95 | where 96 | result = 97 | if x >= natVal (lowerBound result) && x <= natVal (upperBound result) 98 | then Closed x 99 | else error $ unrepresentable x result "unsafeClosed" 100 | 101 | -- | Clamp an @'Integral'@ in the range constrained by a @'Closed'@ interval 102 | clamp 103 | :: forall a b i 104 | . (Integral i, KnownNat a, KnownNat b, a <= b) 105 | => i 106 | -> Closed a b 107 | clamp x 108 | | fromIntegral x < getClosed (minBound @(Closed a b)) = minBound 109 | | fromIntegral x > getClosed (maxBound @(Closed a b)) = maxBound 110 | | otherwise = Closed (fromIntegral x) 111 | 112 | -- | Test equality on 'Closed' values in the same range 113 | instance Eq (Closed a b) where 114 | Closed x == Closed y = x == y 115 | 116 | -- | Compare 'Closed' values in the same range 117 | instance Ord (Closed a b) where 118 | Closed x `compare` Closed y = x `compare` y 119 | 120 | -- | Generate the lowest and highest inhabitant of a given 'Closed' type 121 | instance (KnownNat a, KnownNat b, a <= b) => Bounded (Closed a b) where 122 | maxBound = result 123 | where 124 | result = Closed (natVal (upperBound result)) 125 | 126 | minBound = result 127 | where 128 | result = Closed (natVal (lowerBound result)) 129 | 130 | -- | Enumerate values in the range of a given 'Closed' type 131 | instance (KnownNat a, KnownNat b, a <= b) => Enum (Closed a b) where 132 | fromEnum = fromEnum . getClosed 133 | toEnum = unsafeClosed . toEnum 134 | enumFrom x = enumFromTo x maxBound 135 | enumFromThen x y = enumFromThenTo x y (if x >= y then minBound else maxBound) 136 | 137 | instance Show (Closed a b) where 138 | showsPrec d (Closed x) = showParen (d > 9) $ showString "unsafeClosed " . showsPrec 10 x 139 | 140 | instance (KnownNat a, KnownNat b, a <= b) => Read (Closed a b) where 141 | readsPrec n = readP_to_S $ do 142 | i <- readS_to_P $ readsPrec @Integer n 143 | maybe pfail pure $ closed @a @b i 144 | 145 | -- | Bounded arithmetic, e.g. maxBound + 1 == maxBound 146 | instance (KnownNat a, KnownNat b, a <= b) => Num (Closed a b) where 147 | Closed x + Closed y = Closed $ min (x + y) (fromIntegral (maxBound :: Closed a b)) 148 | Closed x - Closed y = Closed $ max (x - y) (fromIntegral (minBound :: Closed a b)) 149 | Closed x * Closed y = Closed $ min (x * y) (fromIntegral (maxBound :: Closed a b)) 150 | abs = id 151 | signum = const 1 152 | fromInteger x = result 153 | where 154 | result = 155 | if x >= natVal (lowerBound result) && x <= natVal (upperBound result) 156 | then Closed x 157 | else error $ unrepresentable x result "fromInteger" 158 | 159 | instance (KnownNat a, KnownNat b, a <= b) => Real (Closed a b) where 160 | toRational (Closed x) = x % 1 161 | 162 | instance (KnownNat a, KnownNat b, a <= b) => Integral (Closed a b) where 163 | quotRem (Closed x) (Closed y) = (Closed $ x `quot` y, Closed $ x `rem` y) 164 | toInteger (Closed x) = x 165 | 166 | instance NFData (Closed a b) 167 | 168 | instance (KnownNat a, KnownNat b, a <= b) => Random (Closed a b) where 169 | randomR (a, b) g = 170 | let (x, g') = randomR (getClosed a, getClosed b) g 171 | in (unsafeClosed x, g') 172 | random = randomR (minBound, maxBound) 173 | 174 | instance Hashable (Closed a b) 175 | 176 | instance ToJSON (Closed a b) where 177 | toEncoding = toEncoding . getClosed 178 | toJSON = toJSON . getClosed 179 | 180 | instance (KnownNat a, KnownNat b, a <= b) => FromJSON (Closed a b) where 181 | parseJSON v = do 182 | x <- parseJSON v 183 | case closed x of 184 | Just cx -> pure cx 185 | n -> fail $ unrepresentable x (fromJust n) "parseJSON" 186 | 187 | instance CSV.ToField (Closed a b) where 188 | toField = CSV.toField . getClosed 189 | 190 | instance (KnownNat a, KnownNat b, a <= b) => CSV.FromField (Closed a b) where 191 | parseField s = do 192 | x <- CSV.parseField s 193 | case closed x of 194 | Just cx -> pure cx 195 | n -> fail $ unrepresentable x (fromJust n) "parseField" 196 | 197 | instance (KnownNat a, KnownNat b, a <= b) => Arbitrary (Closed a b) where 198 | arbitrary = 199 | Closed <$> choose (natVal @a Proxy, natVal @b Proxy) 200 | 201 | instance (KnownNat a, KnownNat b, a <= b) => PersistField (Closed a b) where 202 | toPersistValue = toPersistValue . fromIntegral @Integer @Int . getClosed 203 | fromPersistValue value = do 204 | x <- fromIntegral @Int @Integer <$> fromPersistValue value 205 | case closed @a @b x of 206 | Just cx -> pure cx 207 | n -> Left $ pack $ unrepresentable x (fromJust n) "fromPersistValue" 208 | 209 | instance (KnownNat a, KnownNat b, a <= b) => PersistFieldSql (Closed a b) where 210 | sqlType _ = sqlType (Proxy @Int) 211 | 212 | unrepresentable 213 | :: (KnownNat a, KnownNat b) 214 | => Integer 215 | -> Closed a b 216 | -> String 217 | -> String 218 | unrepresentable x cx prefix = 219 | prefix 220 | <> ": Integer " 221 | <> show x 222 | <> " is not representable in Closed " 223 | <> show (natVal $ lowerBound cx) 224 | <> " " 225 | <> show (natVal $ upperBound cx) 226 | 227 | -- | Convert a type-level literal into a 'Closed' value 228 | natToClosed 229 | :: forall a b x proxy 230 | . (KnownNat a, KnownNat b, KnownNat x, a <= x, x <= b) 231 | => proxy x 232 | -> Closed a b 233 | natToClosed p = Closed $ natVal p 234 | 235 | -- | Add inhabitants at the end 236 | weakenUpper :: forall k a b. (a <= b, b <= k) => Closed a b -> Closed a k 237 | weakenUpper (Closed x) = Closed x 238 | 239 | -- | Add inhabitants at the beginning 240 | weakenLower :: forall k a b. (a <= b, k <= a) => Closed a b -> Closed k b 241 | weakenLower (Closed x) = Closed x 242 | 243 | -- | Remove inhabitants from the end. Returns 'Nothing' if the input was removed 244 | strengthenUpper 245 | :: forall k a b 246 | . (KnownNat a, KnownNat b, KnownNat k, a <= b, a <= k, k <= b) 247 | => Closed a b 248 | -> Maybe (Closed a k) 249 | strengthenUpper (Closed x) = result 250 | where 251 | result = do 252 | guard $ x <= natVal (upperBound $ fromJust result) 253 | pure $ Closed x 254 | 255 | -- | Remove inhabitants from the beginning. Returns 'Nothing' if the input was removed 256 | strengthenLower 257 | :: forall k a b 258 | . (KnownNat a, KnownNat b, KnownNat k, a <= b, a <= k, k <= b) 259 | => Closed a b 260 | -> Maybe (Closed k b) 261 | strengthenLower (Closed x) = result 262 | where 263 | result = do 264 | guard $ x >= natVal (lowerBound $ fromJust result) 265 | pure $ Closed x 266 | 267 | -- | Test two different types of 'Closed' values for equality. 268 | equals :: Closed a b -> Closed o p -> Bool 269 | equals (Closed x) (Closed y) = x == y 270 | 271 | infix 4 `equals` 272 | 273 | -- | Compare two different types of 'Closed' values 274 | cmp :: Closed a b -> Closed o p -> Ordering 275 | cmp (Closed x) (Closed y) = x `compare` y 276 | 277 | -- | Add two different types of 'Closed' values 278 | add :: Closed a b -> Closed o p -> Closed (n + o) (m + p) 279 | add (Closed x) (Closed y) = Closed $ x + y 280 | 281 | -- | Subtract two different types of 'Closed' values 282 | -- Returns 'Left' for negative results, and 'Right' for positive results. 283 | sub 284 | :: Closed a b 285 | -> Closed o p 286 | -> Either (Closed (o - n) (p - m)) (Closed (n - o) (m - p)) 287 | sub (Closed x) (Closed y) 288 | | x >= y = Right $ Closed $ x - y 289 | | otherwise = Left $ Closed $ y - x 290 | 291 | -- | Multiply two different types of 'Closed' values 292 | multiply :: Closed a b -> Closed o p -> Closed (a * o) (b * p) 293 | multiply (Closed x) (Closed y) = Closed $ x * y 294 | 295 | -- | Verifies that a given 'Closed' value is valid. 296 | -- Should always return 'True' unles you bring the @Closed.Internal.Closed@ constructor into scope, 297 | -- or use 'Unsafe.Coerce.unsafeCoerce' or other nasty hacks 298 | isValidClosed :: (KnownNat a, KnownNat b) => Closed a b -> Bool 299 | isValidClosed cx@(Closed x) = 300 | natVal (lowerBound cx) <= x && x <= natVal (upperBound cx) 301 | --------------------------------------------------------------------------------