├── .github └── workflows │ ├── haskell-ci.yml │ └── hlint.yml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.lhs ├── cabal.haskell-ci ├── cabal.project ├── src └── Data │ ├── Struct.hs │ └── Struct │ ├── Internal.hs │ ├── Internal │ ├── Label.hs │ ├── LinkCut.hs │ └── Order.hs │ ├── Label.hs │ ├── LinkCut.hs │ ├── Order.hs │ └── TH.hs ├── stack-7.10.yaml ├── stack-7.8.yaml ├── stack-8.4.yaml ├── structs.cabal └── tests └── unit.hs /.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.20241202 12 | # 13 | # REGENDATA ("0.19.20241202",["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-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.0.20241128 32 | compilerKind: ghc 33 | compilerVersion: 9.12.0.20241128 34 | setup-method: ghcup-prerelease 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.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 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 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Install GHC (GHCup prerelease) 126 | if: matrix.setup-method == 'ghcup-prerelease' 127 | run: | 128 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 129 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 130 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 131 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 132 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 133 | echo "HC=$HC" >> "$GITHUB_ENV" 134 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 135 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 136 | env: 137 | HCKIND: ${{ matrix.compilerKind }} 138 | HCNAME: ${{ matrix.compiler }} 139 | HCVER: ${{ matrix.compilerVersion }} 140 | - name: Set PATH and environment variables 141 | run: | 142 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 143 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 144 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 145 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 146 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 147 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 148 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 149 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 150 | if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 151 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 152 | env: 153 | HCKIND: ${{ matrix.compilerKind }} 154 | HCNAME: ${{ matrix.compiler }} 155 | HCVER: ${{ matrix.compilerVersion }} 156 | - name: env 157 | run: | 158 | env 159 | - name: write cabal config 160 | run: | 161 | mkdir -p $CABAL_DIR 162 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 207 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 208 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 209 | rm -f cabal-plan.xz 210 | chmod a+x $HOME/.cabal/bin/cabal-plan 211 | cabal-plan --version 212 | - name: install cabal-docspec 213 | run: | 214 | mkdir -p $HOME/.cabal/bin 215 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 216 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 217 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 218 | rm -f cabal-docspec.xz 219 | chmod a+x $HOME/.cabal/bin/cabal-docspec 220 | cabal-docspec --version 221 | - name: checkout 222 | uses: actions/checkout@v4 223 | with: 224 | path: source 225 | - name: initial cabal.project for sdist 226 | run: | 227 | touch cabal.project 228 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 229 | cat cabal.project 230 | - name: sdist 231 | run: | 232 | mkdir -p sdist 233 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 234 | - name: unpack 235 | run: | 236 | mkdir -p unpacked 237 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 238 | - name: generate cabal.project 239 | run: | 240 | PKGDIR_structs="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/structs-[0-9.]*')" 241 | echo "PKGDIR_structs=${PKGDIR_structs}" >> "$GITHUB_ENV" 242 | rm -f cabal.project cabal.project.local 243 | touch cabal.project 244 | touch cabal.project.local 245 | echo "packages: ${PKGDIR_structs}" >> cabal.project 246 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package structs" >> cabal.project ; fi 247 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 248 | cat >> cabal.project <> cabal.project 252 | fi 253 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(structs)$/; }' >> cabal.project.local 254 | cat cabal.project 255 | cat cabal.project.local 256 | - name: dump install plan 257 | run: | 258 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 259 | cabal-plan 260 | - name: restore cache 261 | uses: actions/cache/restore@v4 262 | with: 263 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 264 | path: ~/.cabal/store 265 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 266 | - name: install dependencies 267 | run: | 268 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 269 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 270 | - name: build 271 | run: | 272 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 273 | - name: tests 274 | run: | 275 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 276 | - name: docspec 277 | run: | 278 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 279 | cabal-docspec $ARG_COMPILER 280 | - name: cabal check 281 | run: | 282 | cd ${PKGDIR_structs} || false 283 | ${CABAL} -vnormal check 284 | - name: haddock 285 | run: | 286 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 287 | - name: save cache 288 | if: always() 289 | uses: actions/cache/save@v4 290 | with: 291 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 292 | path: ~/.cabal/store 293 | -------------------------------------------------------------------------------- /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: HLint 2 | on: 3 | - push 4 | - pull_request 5 | jobs: 6 | hlint: 7 | runs-on: ubuntu-latest 8 | 9 | steps: 10 | - name: Checkout repository 11 | uses: actions/checkout@v4 12 | 13 | - name: 'Set up HLint' 14 | uses: haskell-actions/hlint-setup@v2 15 | with: 16 | version: '3.5' 17 | 18 | - name: 'Run HLint' 19 | uses: haskell-actions/hlint-run@v2 20 | with: 21 | path: src/ 22 | fail-on: suggestion 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | docs 5 | wiki 6 | TAGS 7 | tags 8 | wip 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *.dyn_hi 15 | *.dyn_o 16 | *~ 17 | *# 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | codex.tags 21 | .stack-work 22 | stack.yaml 23 | cabal-dev 24 | *.chi 25 | *.chs.h 26 | *.dyn_o 27 | *.dyn_hi 28 | .hpc 29 | .hsenv 30 | *.prof 31 | *.aux 32 | *.hp 33 | *.eventlog 34 | cabal.project.local 35 | cabal.project.local~ 36 | .HTF/ 37 | .ghc.environment.* 38 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [-XCPP, --cpp-define=HLINT, --cpp-ansi] 2 | 3 | - ignore: {name: Reduce duplication} 4 | - ignore: {name: Redundant lambda} 5 | - ignore: {name: Use >=>} 6 | - ignore: {name: Use const} 7 | - ignore: {name: Use module export list} 8 | - ignore: {name: Use newtype instead of data} 9 | - ignore: {name: Avoid lambda using `infix`} 10 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | ## 0.1.9 [2023.08.06] 2 | * Support building with `template-haskell-2.21.*` (GHC 9.8). 3 | 4 | ## 0.1.8 [2023.02.22] 5 | * Avoid some dodgy uses of `unsafeCoerce#` from `Any` (a lifted type) to 6 | `MutableByteArray# s` (an unlifted type) in the internals of the library. 7 | While these uses of `unsafeCoerce#` have not been observed to cause any 8 | improper behavior at runtime, the previous situation was rather delicate. 9 | 10 | ## 0.1.7 [2023.01.22] 11 | * Avoid a particularly dodgy use of `unsafeCoerce#` in the implementation of 12 | `isNil` when building with GHC 9.4 or later. This is necessary to make the 13 | `isNil` function behave properly on GHC 9.6, as changes to GHC's optimizer in 14 | 9.6 make that use of `unsafeCoerce#` produce unexpected results at runtime. 15 | 16 | ## 0.1.6 [2021.04.30] 17 | * Make the test suite compile on recent GHCs. 18 | 19 | ## 0.1.5 [2021.02.17] 20 | * The build-type has been changed from `Custom` to `Simple`. 21 | To achieve this, the `doctests` test suite has been removed in favor of using 22 | [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) 23 | to run the doctests. 24 | 25 | ## 0.1.4 [2020.10.02] 26 | * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). 27 | 28 | ## 0.1.3 [2020.01.29] 29 | * Achieve forward compatibility with 30 | [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). 31 | 32 | ## 0.1.2 [2019.05.02] 33 | * Add a unit test suite. 34 | 35 | ## 0.1.1 36 | * Add a library dependency in the `doctests` test suite 37 | 38 | ## 0.1 39 | * Add compare-and-swap support for struct slots 40 | * Add `Data.Struct.TH`, which provides Template Haskell support for 41 | generating structs 42 | * Remove unneeded proxy argument to `struct` 43 | * Add a type parameter to `Order` 44 | * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build 45 | with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and 46 | sandboxes. 47 | 48 | ## 0 49 | * Repository initialized 50 | * Added structures for list labeling, order-maintenance, and link-cut trees. 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2015 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | structs 2 | ========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/structs.svg)](https://hackage.haskell.org/package/structs) [![Build Status](https://github.com/ekmett/structs/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/structs/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package explores strict mutable data structures in Haskell. 7 | 8 | In particular, pointer-based data structures are effectively 'half price' due to the encoding used. 9 | 10 | However, the result is that if you use the `slot` and `field` system wrong, you can and will `SEGFAULT`. 11 | 12 | This means the `Internal` modules are very much internal. 13 | 14 | Some documentation is available at 15 | [http://ekmett.github.io/structs/Data-Struct.html](http://ekmett.github.io/structs/Data-Struct.html) 16 | 17 | 18 | Examples 19 | -------- 20 | 21 | ## Non-recursive data types 22 | 23 | 24 | We use the template haskell helper `makeStruct` to automatically convert 25 | a Haskell `data` definition to a `Struct`. 26 | 27 | 28 | As an example, we create a type that mimics a tuple of integers. 29 | 30 | ```hs 31 | makeStruct [d| 32 | data TupleInts a s = TupleInts 33 | { tupleLeft, tupleRight :: a 34 | } 35 | |] 36 | ``` 37 | This declaration uses `makeStruct`, which will generate a bunch of 38 | helper functions for us to use. 39 | 40 | 41 | Notice the extra type parameter `s` in `TupleInts a s`. This is used to 42 | carry around state information by `structs`, and so is mandatory. 43 | 44 | 45 | ```hs 46 | -- Create a new tuple of ints. 47 | mkTupleInts :: PrimMonad m => Int -> Int -> m (TupleInts a (PrimState m)) 48 | mkTupleInts a b = st newTupleInts a b 49 | ``` 50 | 51 | `newTupleInts` is a function that was auto-generated by `makeStructs`, whose 52 | parameters are all the fields, which returns a `TupleInts` within a 53 | `PrimMonad` context. Notice the use of `PrimState m` for the state 54 | type parameter of `TupleInts`, which is used to carry the state around. 55 | 56 | 57 | ```hs 58 | -- set the left element of the tuple 59 | setTupleLeft :: PrimMonad m => TupleInts a (PrimState m) -> a -> m () 60 | setTupleLeft tup val = setField tupleLeft tup val 61 | 62 | -- get the left element of the tuple 63 | getTupleLeft :: PrimMonad m => TupleInts a (PrimState m) -> m a 64 | getTupleLeft tup = getField tupleLeft tup 65 | ``` 66 | 67 | 68 | The Template Haskell generates `tupleLeft, tupleRight :: Field (TupleInts a) a`, which 69 | can be used to get and set fields with `getField, setField`. The type signature 70 | indicates that `tupleLeft, tupleRight` extract an `a` from a `TupleInts a`. 71 | 72 | 73 | ## Recursive data types 74 | 75 | We identify recursive members of a struct with `Slot`s. These are like 76 | 77 | ```hs 78 | makeStruct [d| 79 | data LinkedList a s = LinkedList 80 | { val :: a, 81 | next :: !(LinkedList a s) } 82 | |] 83 | ``` 84 | 85 | for this definition, `makeStruct` auto-generates 86 | `next :: Slot (LinkedList a s) (LinkedList a s)`. 87 | Similar to the case of `Field`, the type tells us that `next` extracts 88 | a `LinkedList a s` from a `LinkedList a s` 89 | 90 | 91 | ``` 92 | -- Make an empty linked list 93 | mkEmptyLinkedList :: LinkedList a s 94 | mkEmptyLinkedList = Nil 95 | ``` 96 | 97 | `Nil` is a special value which can be assigned to any `Struct`. 98 | 99 | 100 | ```hs 101 | -- Make a linked list node with a value 102 | mkLinkedListNode :: PrimMonad m => a -> m (LinkedList a (PrimState m)) 103 | mkLinkedListNode a = newLinkedList a Nil 104 | ``` 105 | Once again, `newLinkedList` is auto-generated by `makeStruct` which we 106 | use to initialize the linked list. 107 | 108 | ``` 109 | -- Append a node to a linked list. 110 | appendLinkedList :: PrimMonad m => 111 | LinkedList x (PrimState m) 112 | -> x 113 | -> m (LinkedList x (PrimState m)) 114 | appendLinkedList xs x = do 115 | isend <- isNil <$> (get next xs) 116 | if isend 117 | then do 118 | nodex <- mkLinkedListNode x 119 | set next xs nodex 120 | return xs 121 | else do 122 | xs' <- get next xs 123 | appendLinkedList xs' x 124 | makeStruct [d| 125 | data LinkedList a s = LinkedList 126 | { val :: a, 127 | next :: !(LinkedList a s) } 128 | |] 129 | 130 | -- Make an empty linked list 131 | mkEmptyLinkedList :: LinkedList a s 132 | mkEmptyLinkedList = Nil 133 | 134 | -- Make a linked list node with a value 135 | mkLinkedListNode :: PrimMonad m => a -> m (LinkedList a (PrimState m)) 136 | mkLinkedListNode a = newLinkedList a Nil 137 | 138 | -- Append a node to a linked list. 139 | appendLinkedList :: PrimMonad m => 140 | LinkedList x (PrimState m) 141 | -> x 142 | -> m (LinkedList x (PrimState m)) 143 | appendLinkedList xs x = do 144 | isend <- isNil <$> (get next xs) 145 | if isend 146 | then do 147 | nodex <- mkLinkedListNode x 148 | set next xs nodex 149 | return xs 150 | else do 151 | xs' <- get next xs 152 | appendLinkedList xs' x 153 | ``` 154 | 155 | The rest is straightforward uses of `get`, `set`, `getField`, and `setField` to 156 | manipulate the linked list as usual. 157 | 158 | 159 | FAQ 160 | --- 161 | 162 | 1. Why can fields not be strict? (compiler error) 163 | 2. How do I free memory once `alloc`d? 164 | 165 | 166 | Contact Information 167 | ------------------- 168 | 169 | Contributions and bug reports are welcome! 170 | 171 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 172 | 173 | -Edward Kmett 174 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | -- irc-channels: irc.freenode.org#haskell-lens 4 | irc-if-in-origin-repo: True 5 | docspec: True 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /src/Data/Struct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE Unsafe #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (C) 2015 Edward Kmett 7 | -- License : BSD-style (see the file LICENSE) 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | ----------------------------------------------------------------------------- 13 | module Data.Struct 14 | ( Struct(..) 15 | , Object 16 | , destruct 17 | , construct 18 | , eqStruct 19 | , alloc 20 | -- * Nil 21 | , pattern Nil 22 | , isNil 23 | , NullPointerException(..) 24 | -- * Slots and Fields 25 | , Slot, slot 26 | , get, set 27 | , Field, field 28 | , unboxedField 29 | , getField, setField, modifyField, modifyField' 30 | , Precomposable(..) 31 | ) where 32 | 33 | import Data.Struct.Internal 34 | -------------------------------------------------------------------------------- /src/Data/Struct/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE Unsafe #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ViewPatterns #-} 9 | {-# LANGUAGE UnboxedTuples #-} 10 | {-# LANGUAGE DeriveAnyClass #-} 11 | {-# LANGUAGE PatternSynonyms #-} 12 | {-# LANGUAGE ConstraintKinds #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE DefaultSignatures #-} 15 | 16 | #if __GLASGOW_HASKELL__ < 806 17 | {-# LANGUAGE TypeInType #-} 18 | #endif 19 | 20 | {-# OPTIONS_HADDOCK not-home #-} 21 | ----------------------------------------------------------------------------- 22 | -- | 23 | -- Copyright : (C) 2015-2017 Edward Kmett 24 | -- License : BSD-style (see the file LICENSE) 25 | -- Maintainer : Edward Kmett 26 | -- Stability : experimental 27 | -- Portability : non-portable 28 | -- 29 | ----------------------------------------------------------------------------- 30 | 31 | module Data.Struct.Internal where 32 | 33 | import Control.Exception 34 | import Control.Monad.Primitive 35 | import Control.Monad.ST 36 | import Data.Primitive 37 | import Data.Coerce 38 | import GHC.Exts 39 | 40 | #if MIN_VERSION_base(4,15,0) 41 | import Unsafe.Coerce (unsafeCoerceUnlifted) 42 | #endif 43 | 44 | -- $setup 45 | -- >>> import Control.Monad.Primitive 46 | 47 | #ifdef HLINT 48 | {-# ANN module "HLint: ignore Eta reduce" #-} 49 | {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} 50 | {-# ANN module "HLint: ignore Avoid lambda" #-} 51 | {-# ANN module "HLint: ignore Redundant lambda" #-} 52 | #endif 53 | 54 | data NullPointerException = NullPointerException deriving (Show, Exception) 55 | 56 | -- | A 'Dict' reifies an instance of the constraint @p@ into a value. 57 | data Dict p where 58 | Dict :: p => Dict p 59 | 60 | -- | Run an ST calculation inside of a PrimMonad. This lets us avoid dispatching everything through the 'PrimMonad' dictionary. 61 | st :: PrimMonad m => ST (PrimState m) a -> m a 62 | st = primToPrim 63 | {-# INLINE[0] st #-} 64 | 65 | -- | An instance for 'Struct' @t@ is a witness to the machine-level 66 | -- equivalence of @t@ and @Object@. 67 | class Struct t where 68 | struct :: Dict (Coercible (t s) (Object s)) 69 | #ifndef HLINT 70 | default struct :: Coercible (t s) (Object s) => Dict (Coercible (t s) (Object s)) 71 | #endif 72 | struct = Dict 73 | {-# MINIMAL #-} 74 | 75 | data Object s = Object { runObject :: SmallMutableArray# s Any } 76 | 77 | instance Struct Object 78 | 79 | coerceF :: Dict (Coercible a b) -> a -> b 80 | coerceF Dict = coerce 81 | {-# INLINE coerceF #-} 82 | 83 | coerceB :: Dict (Coercible a b) -> b -> a 84 | coerceB Dict = coerce 85 | {-# INLINE coerceB #-} 86 | 87 | destruct :: Struct t => t s -> SmallMutableArray# s Any 88 | destruct = \x -> runObject (coerceF struct x) 89 | {-# INLINE destruct #-} 90 | 91 | construct :: Struct t => SmallMutableArray# s Any -> t s 92 | construct = \x -> coerceB struct (Object x) 93 | {-# INLINE construct #-} 94 | 95 | unsafeCoerceStruct :: (Struct x, Struct y) => x s -> y s 96 | unsafeCoerceStruct x = construct (destruct x) 97 | 98 | eqStruct :: Struct t => t s -> t s -> Bool 99 | eqStruct = \x y -> isTrue# (destruct x `sameSmallMutableArray#` destruct y) 100 | {-# INLINE eqStruct #-} 101 | 102 | instance Eq (Object s) where 103 | (==) = eqStruct 104 | 105 | #ifndef HLINT 106 | pattern Struct :: Struct t => () => SmallMutableArray# s Any -> t s 107 | pattern Struct x <- (destruct -> x) where 108 | Struct x = construct x 109 | #endif 110 | 111 | -- | Allocate a structure made out of `n` slots. Initialize the structure before proceeding! 112 | alloc :: (PrimMonad m, Struct t) => Int -> m (t (PrimState m)) 113 | alloc (I# n#) = primitive $ \s -> case newSmallArray# n# undefined s of (# s', b #) -> (# s', construct b #) 114 | 115 | -------------------------------------------------------------------------------- 116 | -- * Tony Hoare's billion dollar mistake 117 | -------------------------------------------------------------------------------- 118 | 119 | -- | Box is designed to mirror object's single field but using the 'Null' type 120 | -- instead of a mutable array. This hack relies on GHC reusing the same 'Null' 121 | -- data constructor for all occurrences. Box's field must not be strict to 122 | -- prevent the compiler from making assumptions about its contents. 123 | data Box = Box Null 124 | data Null = Null 125 | 126 | -- | Predicate to check if a struct is 'Nil'. 127 | -- 128 | -- >>> isNil (Nil :: Object (PrimState IO)) 129 | -- True 130 | -- >>> o <- alloc 1 :: IO (Object (PrimState IO)) 131 | -- >>> isNil o 132 | -- False 133 | isNil :: Struct t => t s -> Bool 134 | isNil t = isTrue# ( 135 | #if MIN_VERSION_base(4,17,0) 136 | -- In base-4.17.0.0 or later, reallyUnsafePtrEquality# is levity polymorphic 137 | -- and heterogeneous, so we can directly invoke it on @destruct t@ (of type 138 | -- @SmallMutableArray# s Any :: UnliftedType@)) and @Null@ (of type 139 | -- @Null :: Type@). 140 | reallyUnsafePtrEquality# 141 | #else 142 | -- In earlier versions of base, reallyUnsafePtrEquality#'s type is more 143 | -- restrictive: both arguments must have the same type, and the type of the 144 | -- arguments must be lifted (i.e., of kind @Type@). To make this work, we use 145 | -- unsafeCoerce# to coerce both arguments to type @Any :: Type@, which allows 146 | -- the application of reallyUnsafePtrEquality# to typecheck. 147 | -- 148 | -- Note that we are coercing from SmallMutableArray#, an unlifted type, to 149 | -- Any, a lifted type. This is on shaky ground, as GHC only guarantees that 150 | -- coercing to Any works for lifted types. GHC seemed to tolerate coercing 151 | -- from SmallMutableArray# to Any for many releases, but this stopped working 152 | -- in GHC 9.6: see https://gitlab.haskell.org/ghc/ghc/-/issues/22813. Luckily, 153 | -- we can avoid the issue by using a levity polymorphic version of 154 | -- reallyUnsafePtrEquality# directly, without any intermediate coercions to 155 | -- Any. 156 | unsafeCoerce# reallyUnsafePtrEquality# 157 | #endif 158 | (destruct t) Null) 159 | {-# INLINE isNil #-} 160 | 161 | #ifndef HLINT 162 | -- | Truly imperative. 163 | pattern Nil :: Struct t => () => t s 164 | pattern Nil <- (isNil -> True) where 165 | Nil = unsafeCoerce# Box Null 166 | #endif 167 | 168 | -------------------------------------------------------------------------------- 169 | -- * Faking SmallMutableArrayArray#s 170 | -------------------------------------------------------------------------------- 171 | 172 | {- 173 | The types of writeSmallArray#, readSmallArray#, and casSmallArray# became 174 | levity polymorphic in @base-4.17.0.0@, which allows us to coerce from a 175 | @SmallMutableArray# s Any@ to a @SmallMutableArray# s (SmallMutableArray# s 176 | Any)@ or a @SmallMutableArray# s MutableByteArray#@. These types are all of 177 | kind UnliftedType, so we can accomplish this coercion using 178 | unsafeCoerceUnlifted instead of its dodgier alternative, unsafeCoerce#. 179 | 180 | On older versions of base, SmallMutableArray# is of kind @Type -> Type -> 181 | UnliftedType@, so we must resort to sketchier uses of unsafeCoerce#. For 182 | instance, the implementation of readMutableByteArraySmallArray# must coerce from 183 | this type: 184 | 185 | SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, Any #) 186 | 187 | To this type: 188 | 189 | SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, MutableByteArray# s #) 190 | 191 | This implies coercing (Any :: Type) to (MutableByteArray# s :: UnliftedType). 192 | This is on shaky ground, as the coercion changes a lifted type to an unlifted 193 | type! Unfortunately, we can't really do better given SmallMutableArray#'s 194 | restrictive kind. 195 | 196 | Note that both the pre- and post-@base-4.17.0.0@ versions of the code use the 197 | same number of unsafe coercions. The difference lies in whether you are 198 | coercing from @Any@ to @MutableByteArray# s@ (a kind-heterogeneous coercion) 199 | versus coercing from @SmallMutableArray# s Any@ to @SmallMutableArray# s 200 | (MutableByteArray# s)@ (a kind-homogeneous coercion). You'll still need /some/ 201 | sort of unsafe coercion given the fact that the @structs@ library uniformly 202 | represents everything as @SmallMutableArray# s Any@, but at the very least, the 203 | latter types of coercions avoid casting directly from lifted to unlifted types. 204 | 205 | See https://gitlab.haskell.org/ghc/ghc/-/issues/22813 for the GHC issue that 206 | led to the current design of this code. 207 | -} 208 | 209 | writeSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> State# s -> State# s 210 | #if MIN_VERSION_base(4,17,0) 211 | writeSmallMutableArraySmallArray# m i a s = writeSmallArray# (unsafeCoerceUnlifted m) i a s 212 | #else 213 | writeSmallMutableArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s 214 | #endif 215 | {-# INLINE writeSmallMutableArraySmallArray# #-} 216 | 217 | readSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, SmallMutableArray# s Any #) 218 | #if MIN_VERSION_base(4,17,0) 219 | readSmallMutableArraySmallArray# m i s = readSmallArray# (unsafeCoerceUnlifted m) i s 220 | #else 221 | readSmallMutableArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s 222 | #endif 223 | {-# INLINE readSmallMutableArraySmallArray# #-} 224 | 225 | writeMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> MutableByteArray# s -> State# s -> State# s 226 | #if MIN_VERSION_base(4,17,0) 227 | writeMutableByteArraySmallArray# m i a s = writeSmallArray# (unsafeCoerceUnlifted m) i a s 228 | #else 229 | writeMutableByteArraySmallArray# m i a s = unsafeCoerce# writeSmallArray# m i a s 230 | #endif 231 | {-# INLINE writeMutableByteArraySmallArray# #-} 232 | 233 | readMutableByteArraySmallArray# :: SmallMutableArray# s Any -> Int# -> State# s -> (# State# s, MutableByteArray# s #) 234 | #if MIN_VERSION_base(4,17,0) 235 | readMutableByteArraySmallArray# m i s = readSmallArray# (unsafeCoerceUnlifted m) i s 236 | #else 237 | readMutableByteArraySmallArray# m i s = unsafeCoerce# readSmallArray# m i s 238 | #endif 239 | {-# INLINE readMutableByteArraySmallArray# #-} 240 | 241 | casSmallMutableArraySmallArray# :: SmallMutableArray# s Any -> Int# -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #) 242 | #if MIN_VERSION_base(4,17,0) 243 | casSmallMutableArraySmallArray# m i o n s = casSmallArray# (unsafeCoerceUnlifted m) i o n s 244 | #else 245 | casSmallMutableArraySmallArray# m i o n s = unsafeCoerce# casSmallArray# m i o n s 246 | #endif 247 | {-# INLINE casSmallMutableArraySmallArray# #-} 248 | 249 | #if !(MIN_VERSION_base(4,15,0)) 250 | unsafeCoerceUnlifted :: forall (a :: TYPE UnliftedRep) (b :: TYPE UnliftedRep). a -> b 251 | unsafeCoerceUnlifted = unsafeCoerce# 252 | #endif 253 | 254 | #if !(MIN_VERSION_base(4,10,0)) 255 | type UnliftedRep = PtrRepUnlifted 256 | #endif 257 | 258 | -------------------------------------------------------------------------------- 259 | -- * Field Accessors 260 | -------------------------------------------------------------------------------- 261 | 262 | -- | A 'Slot' is a reference to another unboxed mutable object. 263 | data Slot x y = Slot 264 | (forall s. SmallMutableArray# s Any -> State# s -> (# State# s, SmallMutableArray# s Any #)) 265 | (forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> State# s) 266 | (forall s. SmallMutableArray# s Any -> SmallMutableArray# s Any -> SmallMutableArray# s Any -> State# s -> (# State# s, Int#, SmallMutableArray# s Any #)) 267 | 268 | -- | We can compose slots to get a nested slot or field accessor 269 | class Precomposable t where 270 | ( # ) :: Slot x y -> t y z -> t x z 271 | 272 | instance Precomposable Slot where 273 | Slot gxy _ _ # Slot gyz syz cyz = Slot 274 | (\x s -> case gxy x s of (# s', y #) -> gyz y s') 275 | (\x z s -> case gxy x s of (# s', y #) -> syz y z s') 276 | (\x o n s -> case gxy x s of (# s', y #) -> cyz y o n s') 277 | 278 | -- | The 'Slot' at the given position in a 'Struct' 279 | slot :: Int {- ^ slot -} -> Slot s t 280 | slot (I# i) = Slot 281 | (\m s -> readSmallMutableArraySmallArray# m i s) 282 | (\m a s -> writeSmallMutableArraySmallArray# m i a s) 283 | (\m o n s -> casSmallMutableArraySmallArray# m i o n s) 284 | 285 | -- | Get the value from a 'Slot' 286 | get :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> m (y (PrimState m)) 287 | get (Slot go _ _) = \x -> primitive $ \s -> case go (destruct x) s of 288 | (# s', y #) -> (# s', construct y #) 289 | {-# INLINE get #-} 290 | 291 | -- | Set the value of a 'Slot' 292 | set :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> m () 293 | set (Slot _ go _) = \x y -> primitive_ (go (destruct x) (destruct y)) 294 | {-# INLINE set #-} 295 | 296 | -- | Compare-and-swap the value of the slot. Takes the expected old value, the new value and returns if it succeeded and the value found. 297 | cas :: (PrimMonad m, Struct x, Struct y) => Slot x y -> x (PrimState m) -> y (PrimState m) -> y (PrimState m) -> m (Bool, y (PrimState m)) 298 | cas (Slot _ _ go) = \m o n -> primitive $ \s -> case go (destruct m) (destruct o) (destruct n) s of 299 | (# s', i, r #) -> (# s', (tagToEnum# i :: Bool, construct r) #) 300 | 301 | -- | A 'Field' is a reference from a struct to a normal Haskell data type. 302 | data Field x a = Field 303 | (forall s. SmallMutableArray# s Any -> State# s -> (# State# s, a #)) -- get 304 | (forall s. SmallMutableArray# s Any -> a -> State# s -> State# s) -- set 305 | 306 | instance Precomposable Field where 307 | Slot gxy _ _ # Field gyz syz = Field 308 | (\x s -> case gxy x s of (# s', y #) -> gyz y s') 309 | (\x z s -> case gxy x s of (# s', y #) -> syz y z s') 310 | 311 | -- | Store the reference to the Haskell data type in a normal field 312 | field :: Int {- ^ slot -} -> Field s a 313 | field (I# i) = Field 314 | (\m s -> readSmallArray# (unsafeCoerceUnlifted m) i s) 315 | (\m a s -> writeSmallArray# (unsafeCoerceUnlifted m) i a s) 316 | {-# INLINE field #-} 317 | 318 | -- | Store the reference in the nth slot in the nth argument, treated as a MutableByteArray 319 | unboxedField :: Prim a => Int {- ^ slot -} -> Int {- ^ argument -} -> Field s a 320 | unboxedField (I# i) (I# j) = Field 321 | (\m s -> case readMutableByteArraySmallArray# m i s of 322 | (# s', mba #) -> readByteArray# mba j s') 323 | (\m a s -> case readMutableByteArraySmallArray# m i s of 324 | (# s', mba #) -> writeByteArray# mba j a s') 325 | {-# INLINE unboxedField #-} 326 | 327 | -- | Initialized the mutable array used by 'unboxedField'. Returns the array 328 | -- after storing it in the struct to help with initialization. 329 | initializeUnboxedField :: 330 | (PrimMonad m, Struct x) => 331 | Int {- ^ slot -} -> 332 | Int {- ^ elements -} -> 333 | Int {- ^ element size -} -> 334 | x (PrimState m) {- ^ struct -} -> 335 | m (MutableByteArray (PrimState m)) 336 | initializeUnboxedField (I# i) (I# n) (I# z) m = 337 | primitive $ \s -> 338 | case newByteArray# (n *# z) s of 339 | (# s1, mba #) -> 340 | (# writeMutableByteArraySmallArray# (destruct m) i mba s1, MutableByteArray mba #) 341 | {-# INLINE initializeUnboxedField #-} 342 | 343 | -- | Get the value of a field in a struct 344 | getField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> m a 345 | getField (Field go _) = \x -> primitive (go (destruct x)) 346 | {-# INLINE getField #-} 347 | 348 | -- | Set the value of a field in a struct 349 | setField :: (PrimMonad m, Struct x) => Field x a -> x (PrimState m) -> a -> m () 350 | setField (Field _ go) = \x y -> primitive_ (go (destruct x) y) 351 | {-# INLINE setField #-} 352 | 353 | 354 | -------------------------------------------------------------------------------- 355 | -- * Modifiers 356 | -------------------------------------------------------------------------------- 357 | 358 | modifyField :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m () 359 | modifyField s = \o f -> st (setField s o . f =<< getField s o) 360 | {-# INLINE modifyField #-} 361 | 362 | modifyField' :: (Struct x, PrimMonad m) => Field x a -> x (PrimState m) -> (a -> a) -> m () 363 | modifyField' s = \o f -> st (setField s o =<< (\x -> return $! f x) =<< getField s o) 364 | {-# INLINE modifyField' #-} 365 | -------------------------------------------------------------------------------- /src/Data/Struct/Internal/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Unsafe #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Copyright : (C) 2015 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Data.Struct.Internal.Label where 15 | 16 | import Control.Exception 17 | import Control.Monad 18 | import Control.Monad.Primitive 19 | import Control.Monad.ST 20 | import Data.Bits 21 | import Data.Struct.Internal 22 | import Data.Word 23 | 24 | -- $setup 25 | -- >>> import Data.Struct.Internal 26 | -- >>> import Data.Struct.Internal.Label 27 | 28 | #ifdef HLINT 29 | {-# ANN module "HLint: ignore Eta reduce" #-} 30 | #endif 31 | 32 | ------------------------------------------------------------------------------------ 33 | -- * List Labeling: Maintain n keys each labeled with n^2 bits w/ log n update time. 34 | -- 35 | -- After about 2^32 elements, this structure will continue to work, but will become 36 | -- unacceptably slow and the asymptotic analysis will become wrong. 37 | ------------------------------------------------------------------------------------ 38 | 39 | type Key = Word64 40 | 41 | midBound :: Key 42 | midBound = unsafeShiftR maxBound 1 43 | 44 | key :: Field Label Key 45 | key = field 0 46 | {-# INLINE key #-} 47 | 48 | next :: Slot Label Label 49 | next = slot 1 50 | {-# INLINE next #-} 51 | 52 | prev :: Slot Label Label 53 | prev = slot 2 54 | {-# INLINE prev #-} 55 | 56 | -- | Logarithmic time list labeling solution 57 | newtype Label s = Label (Object s) 58 | 59 | instance Eq (Label s) where (==) = eqStruct 60 | 61 | instance Struct Label 62 | 63 | -- | Construct an explicit list labeling structure. 64 | -- 65 | -- >>> x <- makeLabel 0 Nil Nil 66 | -- >>> isNil x 67 | -- False 68 | -- >>> n <- get next x 69 | -- >>> isNil n 70 | -- True 71 | -- >>> p <- get prev x 72 | -- >>> isNil p 73 | -- True 74 | 75 | makeLabel :: PrimMonad m => Key -> Label (PrimState m) -> Label (PrimState m) -> m (Label (PrimState m)) 76 | makeLabel a p n = st $ do 77 | this <- alloc 3 78 | setField key this a 79 | set next this n 80 | set prev this p 81 | return this 82 | {-# INLINE makeLabel #-} 83 | 84 | -- | O(1). Create a new labeling structure. Labels from different list labeling structures are incomparable. 85 | new :: PrimMonad m => m (Label (PrimState m)) 86 | new = makeLabel midBound Nil Nil 87 | {-# INLINE new #-} 88 | 89 | -- | O(1). Remove a label 90 | delete :: PrimMonad m => Label (PrimState m) -> m () 91 | delete this = st $ unless (isNil this) $ do 92 | p <- get prev this 93 | n <- get next this 94 | unless (isNil p) $ do 95 | set next p n 96 | set prev this Nil 97 | unless (isNil n) $ do 98 | set prev n p 99 | set next this Nil 100 | {-# INLINE delete #-} 101 | 102 | -- | O(log n) amortized. Insert a new label after a given label. 103 | insertAfter :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m)) 104 | insertAfter this = st $ do 105 | when (isNil this) $ throw NullPointerException 106 | v0 <- getField key this 107 | n <- get next this 108 | v1 <- if isNil n 109 | then return maxBound 110 | else getField key n 111 | fresh <- makeLabel (v0 + unsafeShiftR (v1 - v0) 1) this n 112 | set next this fresh 113 | unless (isNil n) $ set prev n fresh 114 | growRight this v0 n 2 115 | return fresh 116 | where 117 | growRight :: Label s -> Key -> Label s -> Word64 -> ST s () 118 | growRight !n0 !_ Nil !j = growLeft n0 j 119 | growRight n0 v0 nj j = do 120 | vj <- getField key nj 121 | if vj-v0 < j*j 122 | then do 123 | nj' <- get next nj 124 | growRight n0 v0 nj' (j+1) 125 | else do 126 | n1 <- get next n0 -- start at the fresh node 127 | balance n1 v0 (delta (vj-v0) j) j -- it moves over 128 | 129 | growLeft :: Label s -> Word64 -> ST s () 130 | growLeft !c !j = do 131 | p <- get prev c 132 | if isNil p 133 | then balance c 0 (delta maxBound j) j -- full rebuild 134 | else do 135 | vp <- getField key p 136 | p' <- get prev p 137 | let !j' = j+1 138 | if maxBound - vp < j'*j' 139 | then growLeft p' j' 140 | else balance c vp (delta (maxBound-vp) j') j' 141 | 142 | balance :: Label s -> Key -> Key -> Word64 -> ST s () 143 | balance !_ !_ !_ 0 = return () 144 | balance Nil _ _ _ = return () -- error "balanced past the end" -- return () 145 | balance c v dv j = do 146 | let !v' = v + dv 147 | setField key c v' 148 | n <- get next c 149 | balance n v' dv (j-1) 150 | {-# INLINE insertAfter #-} 151 | 152 | -- | O(1). Split off all labels after the current label. 153 | cutAfter :: PrimMonad m => Label (PrimState m) -> m () 154 | cutAfter this = st $ do 155 | when (isNil this) $ throw NullPointerException 156 | n <- get next this 157 | unless (isNil n) $ do 158 | set next this Nil 159 | set prev n Nil 160 | {-# INLINE cutAfter #-} 161 | 162 | -- | O(1). Split off all labels before the current label. 163 | cutBefore :: PrimMonad m => Label (PrimState m) -> m () 164 | cutBefore this = st $ do 165 | when (isNil this) $ throw NullPointerException 166 | p <- get prev this 167 | unless (isNil p) $ do 168 | set next p Nil 169 | set prev this Nil 170 | {-# INLINE cutBefore #-} 171 | 172 | -- | O(n). Retrieve the least label 173 | least :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m)) 174 | least xs0 175 | | isNil xs0 = throw NullPointerException 176 | | otherwise = st $ go xs0 where 177 | go :: Label s -> ST s (Label s) 178 | go this = do 179 | p <- get prev this 180 | if isNil p 181 | then return this 182 | else go p 183 | {-# INLINE least #-} 184 | 185 | -- | O(n). Retrieve the greatest label 186 | greatest :: PrimMonad m => Label (PrimState m) -> m (Label (PrimState m)) 187 | greatest xs0 188 | | isNil xs0 = throw NullPointerException 189 | | otherwise = st $ go xs0 where 190 | go :: Label s -> ST s (Label s) 191 | go this = do 192 | n <- get next this 193 | if isNil n 194 | then return this 195 | else go n 196 | {-# INLINE greatest #-} 197 | 198 | -- | O(1). Compare two labels for ordering. 199 | compareM :: PrimMonad m => Label (PrimState m) -> Label (PrimState m) -> m Ordering 200 | compareM i j 201 | | isNil i || isNil j = throw NullPointerException 202 | | otherwise = compare <$> getField key i <*> getField key j 203 | {-# INLINE compareM #-} 204 | 205 | delta :: Key -> Word64 -> Key 206 | delta m j = max 1 $ quot m (j+1) 207 | {-# INLINE delta #-} 208 | 209 | -- | O(1). Extract the current value assignment for this label. Any label mutation, even on other labels in this label structure, may change this answer. 210 | value :: PrimMonad m => Label (PrimState m) -> m Key 211 | value this = getField key this 212 | {-# INLINE value #-} 213 | 214 | -- | O(n). Get the keys of every label from here to the right. 215 | keys :: PrimMonad m => Label (PrimState m) -> m [Key] 216 | keys this = st $ 217 | if isNil this 218 | then return [] 219 | else do 220 | x <- getField key this 221 | n <- get next this 222 | xs <- keys n 223 | return (x:xs) 224 | {-# INLINE keys #-} 225 | -------------------------------------------------------------------------------- /src/Data/Struct/Internal/LinkCut.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RoleAnnotations #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | {-# OPTIONS_GHC -fno-warn-monomorphism-restriction #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (C) 2015-2017 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Data.Struct.Internal.LinkCut where 17 | 18 | import Control.Exception 19 | import Control.Monad 20 | import Control.Monad.Primitive 21 | import Control.Monad.ST 22 | import Data.Struct.Internal 23 | import Data.Struct.TH 24 | 25 | -- $setup 26 | -- >>> import Data.Struct.Internal.LinkCut 27 | 28 | #ifdef HLINT 29 | {-# ANN module "HLint: ignore Reduce duplication" #-} 30 | {-# ANN module "HLint: ignore Redundant do" #-} 31 | #endif 32 | 33 | -- | Amortized Link-Cut trees via splay trees based on Tarjan's little book. 34 | -- 35 | -- These support O(log n) operations for a lot of stuff. 36 | -- 37 | -- The parameter `a` is an arbitrary user-supplied monoid that will be summarized 38 | -- along the path to the root of the tree. 39 | -- 40 | -- In this example the choice of 'Monoid' is 'String', so we can get a textual description of the path to the root. 41 | -- 42 | -- >>> x <- new "x" 43 | -- >>> y <- new "y" 44 | -- >>> link x y -- now x is a child of y 45 | -- >>> x == y 46 | -- False 47 | -- >>> connected x y 48 | -- True 49 | -- >>> z <- new "z" 50 | -- >>> link z x -- now z is a child of y 51 | -- >>> (y ==) <$> root z 52 | -- True 53 | -- >>> cost z 54 | -- "yxz" 55 | -- >>> w <- new "w" 56 | -- >>> u <- new "u" 57 | -- >>> v <- new "v" 58 | -- >>> link u w 59 | -- >>> link v z 60 | -- >>> link w z 61 | -- >>> cost u 62 | -- "yxzwu" 63 | -- >>> (y ==) <$> root v 64 | -- True 65 | -- >>> connected x v 66 | -- True 67 | -- >>> cut z 68 | -- 69 | -- @ 70 | -- y 71 | -- x z y 72 | -- z ==> w v x 73 | -- w v u 74 | -- u 75 | -- @ 76 | -- 77 | -- >>> connected x v 78 | -- False 79 | -- >>> cost u 80 | -- "zwu" 81 | -- >>> (z ==) <$> root v 82 | -- True 83 | makeStruct [d| 84 | data LinkCut a s = LinkCut 85 | { path, parent, left, right :: !(LinkCut a s) 86 | , value, summary :: a 87 | } 88 | |] 89 | 90 | -- | O(1). Allocate a new link-cut tree with a given monoidal summary. 91 | new :: PrimMonad m => a -> m (LinkCut a (PrimState m)) 92 | new a = st (newLinkCut Nil Nil Nil Nil a a) 93 | {-# INLINE new #-} 94 | 95 | -- | O(log n). @'cut' v@ removes the linkage between @v@ upwards to whatever tree it was in, making @v@ a root node. 96 | -- 97 | -- Repeated calls on the same value without intermediate accesses are O(1). 98 | cut :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m () 99 | cut this = st $ do 100 | access this 101 | l <- get left this 102 | unless (isNil l) $ do 103 | set left this Nil 104 | set parent l Nil 105 | v <- getField value this 106 | setField summary this v 107 | {-# INLINE cut #-} 108 | 109 | -- | O(log n). @'link' v w@ inserts @v@ which must be the root of a tree in as a child of @w@. @v@ and @w@ must not be 'connected'. 110 | link :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> LinkCut a (PrimState m) -> m () 111 | link v w = st $ do 112 | -- w w<~v 113 | -- a , v => a 114 | -- 115 | -- 116 | access v 117 | access w 118 | set path v w 119 | {-# INLINE link #-} 120 | 121 | -- | O(log n). @'connected' v w@ determines if @v@ and @w@ inhabit the same tree. 122 | connected :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> LinkCut a (PrimState m) -> m Bool 123 | connected v w = st $ (==) <$> root v <*> root w 124 | {-# INLINE connected #-} 125 | 126 | -- | O(log n). @'cost' v@ computes the root-to-leaf path cost of @v@ under whatever 'Monoid' was built into the tree. 127 | -- 128 | -- Repeated calls on the same value without intermediate accesses are O(1). 129 | cost :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m a 130 | cost v = st $ do 131 | access v 132 | getField summary v 133 | {-# INLINE cost #-} 134 | 135 | -- | O(log n). Find the root of a tree. 136 | -- 137 | -- Repeated calls on the same value without intermediate accesses are O(1). 138 | root :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m)) 139 | root this = st $ do 140 | access this 141 | r <- leftmost this 142 | splay r -- r is already in the root aux tree 143 | return r 144 | where 145 | leftmost v = do 146 | l <- get left v 147 | if isNil l then return v 148 | else leftmost l 149 | {-# INLINE root #-} 150 | 151 | -- | O(log n). Move upward one level. 152 | -- 153 | -- This will return 'Nil' if the parent is not available. 154 | -- 155 | -- Note: Repeated calls on the same value without intermediate accesses are O(1). 156 | up :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m)) 157 | up this = st $ do 158 | access this 159 | a <- get left this 160 | if isNil a then return Nil 161 | else do 162 | p <- rightmost a 163 | splay p -- p is already in the root aux tree 164 | return p 165 | where 166 | rightmost v = do 167 | p <- get right v 168 | if isNil p then return v 169 | else rightmost p 170 | {-# INLINE up #-} 171 | 172 | -- | O(1) 173 | summarize :: Monoid a => LinkCut a s -> ST s a 174 | summarize this 175 | | isNil this = return mempty 176 | | otherwise = getField summary this 177 | {-# INLINE summarize #-} 178 | 179 | -- | O(log n) 180 | access :: Monoid a => LinkCut a s -> ST s () 181 | access this = do 182 | when (isNil this) $ throw NullPointerException 183 | splay this 184 | -- the right hand child is no longer preferred 185 | r <- get right this 186 | unless (isNil r) $ do 187 | set right this Nil 188 | set parent r Nil 189 | set path r this 190 | -- resummarize 191 | l <- get left this 192 | sl <- summarize l 193 | v <- getField value this 194 | setField summary this (sl `mappend` v) 195 | go this 196 | splay this 197 | where 198 | go v = do 199 | w <- get path v 200 | unless (isNil w) $ do 201 | splay w 202 | -- w v w 203 | -- a b c d ==> a v, b.path = w 204 | -- c d 205 | b <- get right w 206 | unless (isNil b) $ do -- b is no longer on the preferred path 207 | set path b w 208 | set parent b Nil 209 | a <- get left w 210 | sa <- summarize a 211 | vw <- getField value w 212 | sv <- getField summary v 213 | set parent v w 214 | set right w v 215 | setField summary w (sa `mappend` vw `mappend` sv) 216 | go w 217 | 218 | -- | O(log n). Splay within an auxiliary tree 219 | splay :: Monoid a => LinkCut a s -> ST s () 220 | splay x = do 221 | p <- get parent x 222 | unless (isNil p) $ do 223 | g <- get parent p 224 | pl <- get left p 225 | if isNil g then do -- zig step 226 | set parent p x 227 | set parent x Nil 228 | pp <- get path p 229 | set path x pp 230 | set path p Nil 231 | sp <- getField summary p 232 | setField summary x sp 233 | if pl == x then do 234 | -- p x 235 | -- x d ==> b p 236 | -- b c c d 237 | c <- get right x 238 | d <- get right p 239 | unless (isNil c) $ set parent c p 240 | set right x p 241 | set left p c 242 | sc <- summarize c 243 | sd <- summarize d 244 | vp <- getField value p 245 | setField summary p (sc `mappend` vp `mappend` sd) 246 | else do 247 | -- p x 248 | -- a x ==> p c 249 | -- b c a b 250 | b <- get left x 251 | unless (isNil b) $ set parent b p 252 | let a = pl 253 | set left x p 254 | set right p b 255 | sa <- summarize a 256 | sb <- summarize b 257 | vp <- getField value p 258 | setField summary p (sa `mappend` vp `mappend` sb) 259 | else do -- zig-zig or zig-zag 260 | gg <- get parent g 261 | gl <- get left g 262 | sg <- getField summary g 263 | setField summary x sg 264 | set parent x gg 265 | gp <- get path g 266 | set path x gp 267 | set path g Nil 268 | if gl == p then do 269 | if pl == x then do -- zig-zig 270 | -- g x 271 | -- p d a p 272 | -- x c ==> b g 273 | -- a b c d 274 | b <- get right x 275 | c <- get right p 276 | d <- get right g 277 | set parent p x 278 | set parent g p 279 | unless (isNil b) $ set parent b p 280 | unless (isNil c) $ set parent c g 281 | set right x p 282 | set right p g 283 | set left p b 284 | set left g c 285 | sb <- summarize b 286 | vp <- getField value p 287 | sc <- summarize c 288 | vg <- getField value g 289 | sd <- summarize d 290 | let sg' = sc `mappend` vg `mappend` sd 291 | setField summary g sg' 292 | setField summary p (sb `mappend` vp `mappend` sg') 293 | else do -- zig-zag 294 | -- g x 295 | -- p d ==> p g 296 | -- a x a b c d 297 | -- b c 298 | let a = pl 299 | b <- get left x 300 | c <- get right x 301 | d <- get right g 302 | set parent p x 303 | set parent g x 304 | unless (isNil b) $ set parent b p 305 | unless (isNil c) $ set parent c g 306 | set left x p 307 | set right x g 308 | set right p b 309 | set left g c 310 | sa <- summarize a 311 | vp <- getField value p 312 | sb <- summarize b 313 | setField summary p (sa `mappend` vp `mappend` sb) 314 | sc <- summarize c 315 | vg <- getField value g 316 | sd <- summarize d 317 | setField summary g (sc `mappend` vg `mappend` sd) 318 | else if pl == x then do -- zig-zag 319 | -- g x 320 | -- a p g p 321 | -- x d ==> a b c d 322 | -- b c 323 | let a = gl 324 | b <- get left x 325 | c <- get right x 326 | d <- get right p 327 | set parent g x 328 | set parent p x 329 | unless (isNil b) $ set parent b g 330 | unless (isNil c) $ set parent c p 331 | set left x g 332 | set right x p 333 | set right g b 334 | set left p c 335 | sa <- summarize a 336 | vg <- getField value g 337 | sb <- summarize b 338 | setField summary g (sa `mappend` vg `mappend` sb) 339 | sc <- summarize c 340 | vp <- getField value p 341 | sd <- summarize d 342 | setField summary p (sc `mappend` vp `mappend` sd) 343 | else do -- zig-zig 344 | -- g x 345 | -- a p p d 346 | -- b x ==> g c 347 | -- c d a b 348 | let a = gl 349 | let b = pl 350 | c <- get left x 351 | unless (isNil b) $ set parent b g 352 | unless (isNil c) $ set parent c p 353 | set parent p x 354 | set parent g p 355 | set left x p 356 | set left p g 357 | set right g b 358 | set right p c 359 | sa <- summarize a 360 | vg <- getField value g 361 | sb <- summarize b 362 | vp <- getField value p 363 | sc <- summarize c 364 | let sg' = sa `mappend` vg `mappend` sb 365 | setField summary g sg' 366 | setField summary p (sg' `mappend` vp `mappend` sc) 367 | unless (isNil gg) $ do 368 | ggl <- get left gg 369 | -- NB: this replacement leaves the summary intact 370 | if ggl == g then set left gg x 371 | else set right gg x 372 | splay x 373 | -------------------------------------------------------------------------------- /src/Data/Struct/Internal/Order.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (C) 2015 Edward Kmett 7 | -- License : BSD-style (see the file LICENSE) 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | ----------------------------------------------------------------------------- 13 | module Data.Struct.Internal.Order where 14 | 15 | import Control.Exception 16 | import Control.Monad 17 | import Control.Monad.Primitive 18 | import Control.Monad.ST 19 | import Data.Bits 20 | import Data.Struct.Internal 21 | import Data.Struct.Internal.Label (Label, Key) 22 | import qualified Data.Struct.Label as Label 23 | import qualified Data.Struct.Internal.Label as Label (key) 24 | import Data.Word 25 | 26 | -------------------------------------------------------------------------------- 27 | -- * Order Maintenance 28 | -------------------------------------------------------------------------------- 29 | 30 | -- | This structure maintains an order-maintenance structure as two levels of list-labeling. 31 | -- 32 | -- The upper labeling scheme holds @(n / log w)@ elements in a universe of size @w^2@, operating in O(log n) amortized time per operation. 33 | -- 34 | -- It is accelerated by an indirection structure where each smaller universe holds O(log w) elements, with total label space @2^log w = w@ and O(1) expected update cost, so we 35 | -- can charge rebuilds to the upper structure to the lower structure. 36 | -- 37 | -- Every insert to the upper structure is amortized across @O(log w)@ operations below. 38 | -- 39 | -- This means that inserts are O(1) amortized, while comparisons remain O(1) worst-case. 40 | 41 | newtype Order a s = Order { runOrder :: Object s } 42 | 43 | instance Eq (Order a s) where (==) = eqStruct 44 | 45 | instance Struct (Order a) 46 | 47 | key :: Field (Order a) Key 48 | key = field 0 49 | {-# INLINE key #-} 50 | 51 | value :: Field (Order a) a 52 | value = field 1 53 | {-# INLINE value #-} 54 | 55 | next :: Slot (Order a) (Order a) 56 | next = slot 2 57 | {-# INLINE next #-} 58 | 59 | prev :: Slot (Order a) (Order a) 60 | prev = slot 3 61 | {-# INLINE prev #-} 62 | 63 | parent :: Slot (Order a) Label 64 | parent = slot 4 65 | {-# INLINE parent #-} 66 | 67 | makeOrder :: PrimMonad m => Label (PrimState m) -> Key -> a -> Order a (PrimState m) -> Order a (PrimState m) -> m (Order a (PrimState m)) 68 | makeOrder mom a v p n = st $ do 69 | this <- alloc 5 70 | set parent this mom 71 | setField key this a 72 | setField value this v 73 | set prev this p 74 | set next this n 75 | return this 76 | {-# INLINE makeOrder #-} 77 | 78 | -- | O(1) compareM, O(1) amortized insert 79 | compareM :: PrimMonad m => Order a (PrimState m) -> Order a (PrimState m) -> m Ordering 80 | compareM i j 81 | | isNil i || isNil j = throw NullPointerException 82 | | otherwise = st $ do 83 | ui <- get parent i 84 | uj <- get parent j 85 | xs <- Label.compareM ui uj 86 | case xs of 87 | EQ -> compare <$> getField key i <*> getField key j 88 | x -> return x 89 | {-# INLINE compareM #-} 90 | 91 | insertAfter :: PrimMonad m => Order a (PrimState m) -> a -> m (Order a (PrimState m)) 92 | insertAfter n0 a1 = st $ do 93 | when (isNil n0) $ throw NullPointerException 94 | mom <- get parent n0 95 | k0 <- getField key n0 96 | n2 <- get next n0 97 | k2 <- if isNil n2 then return maxBound else getField key n2 98 | let !k1 = k0 + unsafeShiftR (k2 - k0) 1 99 | n1 <- makeOrder mom k1 a1 n0 n2 100 | unless (isNil n2) $ set prev n2 n1 101 | set next n0 n1 102 | when (k0 + 1 == k2) $ rewind mom n0 -- we have a collision, rebalance 103 | return n1 104 | where 105 | -- find the smallest sibling 106 | rewind :: Label s -> Order a s -> ST s () 107 | rewind mom this = do 108 | p <- get prev this 109 | if isNil p then rebalance mom mom this 0 64 110 | else do 111 | dad <- get parent p 112 | if mom == dad then rewind mom p 113 | else rebalance mom mom p 0 64 114 | 115 | -- break up the family 116 | rebalance :: Label s -> Label s -> Order a s -> Word64 -> Int -> ST s () 117 | rebalance mom dad this k j = unless (isNil this) $ do 118 | guardian <- get parent this 119 | when (mom == guardian) $ do 120 | setField key this k 121 | set parent this dad 122 | n <- get next this 123 | if j > 0 then rebalance mom dad n (k + deltaU) (j-1) 124 | else do 125 | stepdad <- Label.insertAfter dad 126 | rebalance mom stepdad n deltaU logU 127 | 128 | delete :: PrimMonad m => Order a (PrimState m) -> m () 129 | delete this = st $ do 130 | when (isNil this) $ throw NullPointerException 131 | mom <- get parent this 132 | 133 | p <- get prev this 134 | n <- get next this 135 | 136 | set prev this Nil 137 | set next this Nil 138 | 139 | x <- if isNil p then return False 140 | else do 141 | set next p n 142 | pmom <- get parent p 143 | return (mom == pmom) 144 | 145 | y <- if isNil n then return False 146 | else do 147 | set prev n p 148 | nmom <- get parent n 149 | return (mom == nmom) 150 | 151 | unless (x || y) $ Label.delete mom 152 | {-# INLINE delete #-} 153 | 154 | logU :: Int 155 | logU = 64 156 | 157 | loglogU :: Int 158 | loglogU = 6 159 | 160 | deltaU :: Key 161 | deltaU = unsafeShiftR maxBound loglogU -- U / log U 162 | 163 | new :: PrimMonad m => a -> m (Order a (PrimState m)) 164 | new a = st $ do 165 | l <- Label.new 166 | makeOrder l (unsafeShiftR maxBound 1) a Nil Nil 167 | {-# INLINE new #-} 168 | 169 | keys :: PrimMonad m => Order a (PrimState m) -> m (Key, Key) 170 | keys this = st $ do 171 | mom <- get parent this 172 | (,) <$> getField Label.key mom <*> getField key this 173 | {-# INLINE keys #-} 174 | -------------------------------------------------------------------------------- /src/Data/Struct/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (C) 2015 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Data.Struct.Label 12 | ( Label 13 | , new 14 | , insertAfter 15 | , delete 16 | , least 17 | , greatest 18 | , cutAfter 19 | , cutBefore 20 | , compareM 21 | ) where 22 | 23 | import Data.Struct.Internal.Label 24 | -------------------------------------------------------------------------------- /src/Data/Struct/LinkCut.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (C) 2015 Edward Kmett 4 | -- License : BSD-style (see the file LICENSE) 5 | -- Maintainer : Edward Kmett 6 | -- Stability : experimental 7 | -- Portability : non-portable 8 | -- 9 | ----------------------------------------------------------------------------- 10 | module Data.Struct.LinkCut 11 | ( LinkCut 12 | , new 13 | , link 14 | , cut 15 | , root 16 | , cost 17 | , parent 18 | , connected 19 | ) where 20 | 21 | import Control.Monad.Primitive 22 | import Data.Struct.Internal.LinkCut hiding (parent) 23 | 24 | -- | O(log n). Find the parent of a node. 25 | -- 26 | -- This will return 'Nil' if the parent does not exist. 27 | -- 28 | -- Repeated calls on the same value without intermediate accesses are O(1). 29 | parent :: (PrimMonad m, Monoid a) => LinkCut a (PrimState m) -> m (LinkCut a (PrimState m)) 30 | parent = up 31 | -------------------------------------------------------------------------------- /src/Data/Struct/Order.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (C) 2015 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Data.Struct.Order 12 | ( Order 13 | , new 14 | , value 15 | , insertAfter 16 | , delete 17 | ) where 18 | 19 | import Data.Struct.Internal.Order 20 | -------------------------------------------------------------------------------- /src/Data/Struct/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Data.Struct.TH (makeStruct) where 5 | 6 | import Control.Monad (when, zipWithM) 7 | import Control.Monad.Primitive (PrimMonad, PrimState) 8 | import Data.Either (partitionEithers) 9 | import qualified Data.List.NonEmpty as NE 10 | import Data.List.NonEmpty (NonEmpty(..)) 11 | import Data.Primitive 12 | import Data.Struct 13 | import Data.Struct.Internal (Dict(Dict), initializeUnboxedField, st) 14 | import Data.List (groupBy, nub) 15 | import Language.Haskell.TH 16 | import Language.Haskell.TH.Datatype.TyVarBndr 17 | import Language.Haskell.TH.Syntax (VarStrictType) 18 | 19 | #ifdef HLINT 20 | {-# ANN module "HLint: ignore Use ." #-} 21 | #endif 22 | 23 | data StructRep = StructRep 24 | { srState :: Name 25 | , srName :: Name 26 | , srTyVars :: [TyVarBndrVis] 27 | #if MIN_VERSION_template_haskell(2,12,0) 28 | , srDerived :: [DerivClause] 29 | #else 30 | , srDerived :: Cxt 31 | #endif 32 | , srCxt :: Cxt 33 | , srConstructor :: Name 34 | , srMembers :: [Member] 35 | } deriving Show 36 | 37 | data Member = Member 38 | { _memberRep :: Representation 39 | , memberName :: Name 40 | , _memberType :: Type 41 | } 42 | deriving Show 43 | 44 | data Representation = BoxedField | UnboxedField | Slot 45 | deriving Show 46 | 47 | -- | Generate allocators, slots, fields, unboxed fields, Eq instances, 48 | -- and Struct instances for the given "data types". 49 | -- 50 | -- Inputs are expected to be "data types" parameterized by a state 51 | -- type. Strict fields are considered to be slots, Non-strict fields 52 | -- are considered to be boxed types, Unpacked fields are considered 53 | -- to be unboxed primitives. 54 | -- 55 | -- The data type should use record syntax and have a single constructor. 56 | -- The field names will be used to generate slot, field, and unboxedField 57 | -- values of the same name. 58 | -- 59 | -- An allocator for the struct is generated by prefixing "alloc" to the 60 | -- data type name. 61 | makeStruct :: DecsQ -> DecsQ 62 | makeStruct dsq = 63 | do ds <- dsq 64 | (passthrough, reps) <- partitionEithers <$> traverse computeRep ds 65 | ds's <- traverse (generateCode passthrough) reps 66 | return (passthrough ++ concat ds's) 67 | 68 | mkAllocName :: StructRep -> Name 69 | mkAllocName rep = mkName ("alloc" ++ nameBase (srName rep)) 70 | 71 | mkInitName :: StructRep -> Name 72 | mkInitName rep = mkName ("new" ++ nameBase (srName rep)) 73 | 74 | ------------------------------------------------------------------------ 75 | -- Input validation 76 | ------------------------------------------------------------------------ 77 | 78 | computeRep :: Dec -> Q (Either Dec StructRep) 79 | computeRep (DataD c n vs _ cs ds) = 80 | do state <- validateStateType vs 81 | (conname, confields) <- validateContructor cs 82 | members <- traverse (validateMember state) confields 83 | 84 | return $ Right StructRep 85 | { srState = state 86 | , srName = n 87 | , srTyVars = vs 88 | , srConstructor = conname 89 | , srMembers = members 90 | , srDerived = ds 91 | , srCxt = c 92 | } 93 | computeRep d = return (Left d) 94 | 95 | -- | Check that only a single data constructor was provided and 96 | -- that it was a record constructor. 97 | validateContructor :: [Con] -> Q (Name,[VarStrictType]) 98 | validateContructor [RecC name fields] = return (name,fields) 99 | validateContructor [_] = fail "Expected a record constructor" 100 | validateContructor xs = fail ("Expected 1 constructor, got " ++ show (length xs)) 101 | 102 | -- A struct type's final type variable should be suitable for 103 | -- use as the ('PrimState' m) argument. 104 | validateStateType :: [TyVarBndrVis] -> Q Name 105 | validateStateType xs = 106 | do when (null xs) (fail "state type expected but no type variables found") 107 | elimTV return validateKindedTV (last xs) 108 | where 109 | validateKindedTV :: Name -> Kind -> Q Name 110 | validateKindedTV n k 111 | | k == starK = return n 112 | | otherwise = fail "state type should have kind *" 113 | 114 | -- | Figure out which record fields are Slots and which are 115 | -- Fields. Slots will have types ending in the state type 116 | validateMember :: Name -> VarStrictType -> Q Member 117 | validateMember s (fieldname,Bang NoSourceUnpackedness NoSourceStrictness,fieldtype) = 118 | do when (occurs s fieldtype) 119 | (fail ("state type may not occur in field `" ++ nameBase fieldname ++ "`")) 120 | return (Member BoxedField fieldname fieldtype) 121 | validateMember s (fieldname,Bang NoSourceUnpackedness SourceStrict,fieldtype) = 122 | do f <- unapplyType fieldtype s 123 | when (occurs s f) 124 | (fail ("state type may only occur in final position in slot `" ++ nameBase fieldname ++ "`")) 125 | return (Member Slot fieldname f) 126 | validateMember s (fieldname,Bang SourceUnpack SourceStrict,fieldtype) = 127 | do when (occurs s fieldtype) 128 | (fail ("state type may not occur in unpacked field `" ++ nameBase fieldname ++ "`")) 129 | return (Member UnboxedField fieldname fieldtype) 130 | validateMember _ _ = fail "validateMember: can't unpack nonstrict fields" 131 | 132 | unapplyType :: Type -> Name -> Q Type 133 | unapplyType (AppT f (VarT x)) y | x == y = return f 134 | unapplyType t n = 135 | fail $ "Unable to match state type of slot: " ++ show t ++ " | expected: " ++ nameBase n 136 | 137 | ------------------------------------------------------------------------ 138 | -- Code generation 139 | ------------------------------------------------------------------------ 140 | 141 | generateCode :: [Dec] -> StructRep -> DecsQ 142 | generateCode ds rep = concat <$> sequence 143 | [ generateDataType rep 144 | , generateStructInstance rep 145 | , generateMembers rep 146 | , generateNew rep 147 | , generateAlloc rep 148 | , generateRoles ds rep 149 | ] 150 | 151 | -- Generates: newtype TyCon a b c s = DataCon (Object s) 152 | generateDataType :: StructRep -> DecsQ 153 | generateDataType rep = sequence 154 | [ newtypeD (return (srCxt rep)) (srName rep) (srTyVars rep) 155 | Nothing 156 | (normalC 157 | (srConstructor rep) 158 | [ bangType 159 | (bang noSourceUnpackedness noSourceStrictness) 160 | [t| Object $(varT (srState rep)) |] 161 | ]) 162 | #if MIN_VERSION_template_haskell(2,12,0) 163 | (map return (srDerived rep)) 164 | #else 165 | (return (srDerived rep)) 166 | #endif 167 | ] 168 | 169 | generateRoles :: [Dec] -> StructRep -> DecsQ 170 | generateRoles ds rep 171 | | hasRoleAnnotation = return [] 172 | | otherwise = sequence [ roleAnnotD (srName rep) (computeRoles rep) ] 173 | 174 | where 175 | hasRoleAnnotation = any isTargetRoleAnnot ds 176 | 177 | isTargetRoleAnnot (RoleAnnotD n _) = n == srName rep 178 | isTargetRoleAnnot _ = False 179 | 180 | -- Currently all roles are set to nominal. A more general solution 181 | -- should be able to infer some representional/phantom roles. To do 182 | -- this for arbitrary types we'll need a way to query the roles of 183 | -- existing type constructors to infer the correct roles. 184 | computeRoles :: StructRep -> [Role] 185 | computeRoles = map (const NominalR) . srTyVars 186 | 187 | -- | Type of the object not applied to a state type. This 188 | -- should have kind * -> * 189 | repType1 :: StructRep -> TypeQ 190 | repType1 rep = repTypeHelper (srName rep) (init (srTyVars rep)) 191 | 192 | -- | Type of the object as originally declared, fully applied. 193 | repType :: StructRep -> TypeQ 194 | repType rep = repTypeHelper (srName rep) (srTyVars rep) 195 | 196 | repTypeHelper :: Name -> [TyVarBndrVis] -> TypeQ 197 | repTypeHelper c vs = foldl appT (conT c) (tyVarBndrT <$> vs) 198 | 199 | -- Construct a 'TypeQ' from a 'TyVarBndr' 200 | tyVarBndrT :: TyVarBndrVis -> TypeQ 201 | tyVarBndrT = elimTV varT (sigT . varT) 202 | 203 | generateStructInstance :: StructRep -> DecsQ 204 | generateStructInstance rep = 205 | [d| instance Struct $(repType1 rep) where struct = Dict 206 | instance Eq $(repType rep) where (==) = eqStruct 207 | |] 208 | 209 | -- generates: allocDataCon = alloc 210 | generateAlloc :: StructRep -> DecsQ 211 | generateAlloc rep = 212 | do mName <- newName "m" 213 | let m :: TypeQ 214 | m = varT mName 215 | 216 | n = length (groupBy isNeighbor (srMembers rep)) 217 | allocName = mkAllocName rep 218 | 219 | simpleDefinition rep allocName 220 | (forallT [plainTVSpecified mName] (cxt []) 221 | [t| PrimMonad $m => $m ( $(repType1 rep) (PrimState $m) ) |]) 222 | [| alloc n |] 223 | 224 | 225 | -- generates: 226 | -- newDataCon a .. = do this <- alloc ; set field1 this a; ...; return this 227 | generateNew :: StructRep -> DecsQ 228 | generateNew rep = 229 | do this <- newName "this" 230 | let ms = NE.groupBy isNeighbor (srMembers rep) 231 | 232 | addName m = do n <- newName (nameBase (memberName m)) 233 | return (n,m) 234 | 235 | msWithArgs <- traverse (traverse addName) ms 236 | 237 | let name = mkInitName rep 238 | body = doE 239 | -- allocate struct 240 | $ bindS (varP this) (varE (mkAllocName rep)) 241 | 242 | -- initialize each member 243 | : (noBindS <$> zipWith (assignN (varE this)) [0..] msWithArgs) 244 | 245 | -- return initialized struct 246 | ++ [ noBindS [| return $(varE this) |] ] 247 | 248 | sequence 249 | [ sigD name (newStructType rep) 250 | , funD name [ clause (varP . fst <$> concatMap NE.toList msWithArgs) 251 | (normalB [| st $body |] ) [] ] 252 | ] 253 | 254 | 255 | assignN :: ExpQ -> Int -> NonEmpty (Name,Member) -> ExpQ 256 | 257 | assignN this _ ((arg,Member BoxedField n _) :| []) = 258 | [| setField $(varE n) $this $(varE arg) |] 259 | 260 | assignN this _ ((arg,Member Slot n _) :| []) = 261 | [| set $(varE n) $this $(varE arg)|] 262 | 263 | assignN this i us = 264 | do let n = NE.length us 265 | mba <- newName "mba" 266 | let arg0 = fst (NE.head us) 267 | doE $ bindS (varP mba) [| initializeUnboxedField i n (sizeOf $(varE arg0)) $this |] 268 | : [ noBindS [| writeByteArray $(varE mba) j $(varE arg) |] 269 | | (j,(arg,_)) <- zip [0 :: Int ..] (NE.toList us) ] 270 | 271 | -- | The type of the struct initializer is complicated enough to 272 | -- pull it out here. 273 | -- generates: 274 | -- PrimMonad m => field1 -> field2 -> ... -> m (TyName a b ... (PrimState m)) 275 | newStructType :: StructRep -> TypeQ 276 | newStructType rep = 277 | do mName <- newName "m" 278 | let m :: TypeQ 279 | m = varT mName 280 | 281 | s = [t| PrimState $m |] 282 | obj = repType1 rep 283 | 284 | buildType (Member BoxedField _ t) = return t 285 | buildType (Member UnboxedField _ t) = return t 286 | buildType (Member Slot _ f) = [t| $(return f) $s |] 287 | 288 | r = foldr (-->) 289 | [t| $m ($obj $s) |] 290 | (buildType <$> srMembers rep) 291 | 292 | primPreds = primPred <$> nub [ t | Member UnboxedField _ (VarT t) <- srMembers rep ] 293 | 294 | forallRepT rep $ forallT [plainTVSpecified mName] (cxt primPreds) 295 | [t| PrimMonad $m => $r |] 296 | 297 | -- generates a slot, field, or unboxedField definition per member 298 | generateMembers :: StructRep -> DecsQ 299 | generateMembers rep 300 | = concat <$> 301 | zipWithM 302 | (generateMember1 rep) 303 | [0..] 304 | (groupBy isNeighbor (srMembers rep)) 305 | 306 | isNeighbor :: Member -> Member -> Bool 307 | isNeighbor (Member UnboxedField _ t) (Member UnboxedField _ u) = t == u 308 | isNeighbor _ _ = False 309 | 310 | ------------------------------------------------------------------------ 311 | 312 | generateMember1 :: StructRep -> Int -> [Member] -> DecsQ 313 | 314 | -- generates: fieldname = field 315 | generateMember1 rep n [Member BoxedField fieldname fieldtype] = 316 | simpleDefinition rep fieldname 317 | [t| Field $(repType1 rep) $(return fieldtype) |] 318 | [| field n |] 319 | 320 | -- generates: slotname = slot 321 | generateMember1 rep n [Member Slot slotname slottype] = 322 | simpleDefinition rep slotname 323 | [t| Slot $(repType1 rep) $(return slottype) |] 324 | [| slot n |] 325 | 326 | -- It the first type patterns didn't hit then we expect a list 327 | -- of unboxed fields due to the call to groupBy in generateMembers 328 | -- generates: fieldname = unboxedField 329 | generateMember1 rep n us = 330 | concat <$> sequence 331 | [ simpleDefinition rep fieldname 332 | (addPrimCxt fieldtype 333 | [t| Field $(repType1 rep) $(return fieldtype) |]) 334 | [| unboxedField n i |] 335 | 336 | | (i,Member UnboxedField fieldname fieldtype) <- zip [0 :: Int ..] us 337 | ] 338 | where 339 | addPrimCxt (VarT t) = forallT [] (cxt [primPred t]) 340 | addPrimCxt _ = id 341 | 342 | -- Generate code for definitions without arguments, with type variables 343 | -- quantified over those in the struct rep, including an inline pragma 344 | simpleDefinition :: StructRep -> Name -> TypeQ -> ExpQ -> DecsQ 345 | simpleDefinition rep name typ def = 346 | sequence 347 | [ sigD name (forallRepT rep typ) 348 | , simpleValD name def 349 | , pragInlD name Inline FunLike AllPhases 350 | ] 351 | 352 | ------------------------------------------------------------------------ 353 | 354 | -- Simple use of 'valD' bind an expression to a name 355 | simpleValD :: Name -> ExpQ -> DecQ 356 | simpleValD var val = valD (varP var) (normalB val) [] 357 | 358 | -- Quantifies over all of the type variables in a struct data type 359 | -- except the state variable which is likely to be ('PrimState' s) 360 | forallRepT :: StructRep -> TypeQ -> TypeQ 361 | forallRepT rep = forallT (init (changeTVFlags SpecifiedSpec (srTyVars rep))) (cxt []) 362 | 363 | (-->) :: TypeQ -> TypeQ -> TypeQ 364 | f --> x = arrowT `appT` f `appT` x 365 | 366 | primPred :: Name -> PredQ 367 | primPred t = [t| Prim $(varT t) |] 368 | 369 | occurs :: Name -> Type -> Bool 370 | occurs n (AppT f x) = occurs n f || occurs n x 371 | occurs n (VarT m) = n == m 372 | occurs n (ForallT _ _ t) = occurs n t -- all names are fresh in quoted code, see below 373 | occurs n (SigT t _) = occurs n t 374 | occurs _ _ = False 375 | 376 | #if !MIN_VERSION_template_haskell(2,21,0) && !MIN_VERSION_th_abstraction(0,6,0) 377 | type TyVarBndrVis = TyVarBndrUnit 378 | #endif 379 | 380 | -- Prelude Language.Haskell.TH> runQ (stringE . show =<< [t| forall a. a -> (forall a. a) |]) 381 | -- LitE (StringL "ForallT [PlainTV a_0] [] (AppT (AppT ArrowT (VarT a_0)) (ForallT [PlainTV a_1] [] (VarT a_1)))") 382 | -------------------------------------------------------------------------------- /stack-7.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-3.10 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: 6 | structs: 7 | test-hlint: true 8 | test-doctests: true 9 | extra-package-dbs: [] 10 | -------------------------------------------------------------------------------- /stack-7.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-2.21 2 | -------------------------------------------------------------------------------- /stack-8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.10 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: 6 | structs: 7 | test-hlint: true 8 | test-doctests: true 9 | extra-package-dbs: [] 10 | -------------------------------------------------------------------------------- /structs.cabal: -------------------------------------------------------------------------------- 1 | name: structs 2 | category: Data 3 | version: 0.1.9 4 | license: BSD3 5 | cabal-version: 1.22 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/structs/ 11 | bug-reports: http://github.com/ekmett/structs/issues 12 | copyright: Copyright (C) 2015-2017 Edward A. Kmett 13 | build-type: Simple 14 | tested-with: GHC == 8.0.2 15 | , GHC == 8.2.2 16 | , GHC == 8.4.4 17 | , GHC == 8.6.5 18 | , GHC == 8.8.4 19 | , GHC == 8.10.7 20 | , GHC == 9.0.2 21 | , GHC == 9.2.8 22 | , GHC == 9.4.8 23 | , GHC == 9.6.6 24 | , GHC == 9.8.4 25 | , GHC == 9.10.1 26 | , GHC == 9.12.1 27 | synopsis: Strict GC'd imperative object-oriented programming with cheap pointers. 28 | description: 29 | This project is an experiment with a small GC'd strict mutable imperative universe with cheap pointers inside of the GHC runtime system. 30 | 31 | extra-source-files: 32 | .hlint.yaml 33 | CHANGELOG.markdown 34 | README.markdown 35 | 36 | source-repository head 37 | type: git 38 | location: git://github.com/ekmett/structs.git 39 | 40 | library 41 | build-depends: 42 | base >= 4.9 && < 5, 43 | deepseq, 44 | template-haskell >= 2.11 && < 2.24, 45 | -- TODO: Eventually, we should bump the lower version bounds to >=0.6 so that 46 | -- we can remove some CPP in Data.Struct.TH. 47 | th-abstraction >= 0.4 && < 0.8, 48 | ghc-prim, 49 | primitive 50 | 51 | exposed-modules: 52 | Data.Struct 53 | Data.Struct.TH 54 | Data.Struct.Internal 55 | Data.Struct.Internal.Label 56 | Data.Struct.Internal.LinkCut 57 | Data.Struct.Internal.Order 58 | Data.Struct.Label 59 | Data.Struct.LinkCut 60 | Data.Struct.Order 61 | 62 | ghc-options: -Wall -fwarn-monomorphism-restriction -fwarn-identities -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -fno-warn-wrong-do-bind 63 | -Wno-unticked-promoted-constructors 64 | hs-source-dirs: src 65 | default-language: Haskell2010 66 | 67 | test-suite unit 68 | type: exitcode-stdio-1.0 69 | main-is: unit.hs 70 | hs-source-dirs: tests 71 | default-language: Haskell2010 72 | build-depends: 73 | structs, 74 | base, 75 | QuickCheck, 76 | tasty, 77 | tasty-quickcheck, 78 | tasty-hunit, 79 | primitive 80 | -------------------------------------------------------------------------------- /tests/unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RoleAnnotations #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | import Test.Tasty 6 | import Test.Tasty.QuickCheck as QC 7 | import Test.QuickCheck.Modifiers (NonEmptyList (..)) 8 | import Test.Tasty.HUnit 9 | 10 | import Data.Ord 11 | 12 | import Control.Exception 13 | import Control.Monad 14 | import Control.Monad.Primitive 15 | import Control.Monad.ST 16 | import Data.Struct.Internal 17 | import Data.Struct.TH 18 | 19 | 20 | -- Simple use of makeStruct 21 | makeStruct [d| 22 | data TupleInts a s = TupleInts 23 | { tupleLeft, tupleRight :: a 24 | } 25 | |] 26 | 27 | -- Create a new tuple of ints 28 | mkTupleInts a b = st (newTupleInts a b) 29 | 30 | setTupleLeft :: PrimMonad m => TupleInts a (PrimState m) -> a -> m () 31 | setTupleLeft tup val = setField tupleLeft tup val 32 | 33 | getTupleLeft :: PrimMonad m => TupleInts a (PrimState m) -> m a 34 | getTupleLeft tup = getField tupleLeft tup 35 | 36 | 37 | -- Questions on API: 38 | -- How does Nil work 39 | 40 | -- makeStruct of a data type with pointers. 41 | 42 | makeStruct [d| 43 | data LinkedList a s = LinkedList 44 | { val :: a, 45 | next :: !(LinkedList a s) } 46 | |] 47 | 48 | -- Make an empty linked list 49 | mkEmptyLinkedList :: LinkedList a s 50 | mkEmptyLinkedList = Nil 51 | 52 | -- Make a linked list node with a value 53 | mkLinkedListNode :: PrimMonad m => a -> m (LinkedList a (PrimState m)) 54 | mkLinkedListNode a = newLinkedList a Nil 55 | 56 | -- Append a node to a linked list. 57 | appendLinkedList :: PrimMonad m => 58 | LinkedList x (PrimState m) 59 | -> x 60 | -> m (LinkedList x (PrimState m)) 61 | appendLinkedList xs x = do 62 | isend <- isNil <$> (get next xs) 63 | if isend 64 | then do 65 | nodex <- mkLinkedListNode x 66 | set next xs nodex 67 | return xs 68 | else do 69 | xs' <- get next xs 70 | appendLinkedList xs' x 71 | 72 | -- Retreive the nth value from the linked list. 73 | nthLinkedList :: PrimMonad m => Int -> LinkedList a (PrimState m) -> m a 74 | nthLinkedList 0 xs = getField val xs 75 | nthLinkedList i xs = get next xs >>= nthLinkedList (i - 1) 76 | 77 | -- Convert a haskell list to a linked list 78 | listToLinkedList :: PrimMonad m => [a] -> m (LinkedList a (PrimState m)) 79 | listToLinkedList [] = return mkEmptyLinkedList 80 | listToLinkedList (x:xs) = do 81 | head <- mkLinkedListNode x 82 | rest <- listToLinkedList xs 83 | set next head rest 84 | 85 | return head 86 | 87 | 88 | -- TODO: setup ViewPatterns to check when something is nil 89 | -- concat xs ys == xs := xs ++ ys 90 | concatLinkedList :: PrimMonad m => 91 | LinkedList a (PrimState m) 92 | -> LinkedList a (PrimState m) 93 | -> m () 94 | concatLinkedList xs ys = 95 | if isNil xs 96 | then error "head of list is undefined" 97 | else do 98 | isend <- isNil <$> (get next xs) 99 | if isend 100 | then set next xs ys 101 | else get next xs >>= \xs' -> concatLinkedList xs' ys 102 | 103 | 104 | -- datatype with UNPACKED 105 | makeStruct [d| data Vec3 s = Vec3 { x, y, z :: {-# UNPACK #-} !Int } |] 106 | 107 | -- Test bench 108 | -- ========== 109 | main = defaultMain tests 110 | 111 | tests :: TestTree 112 | tests = testGroup "Tests" [properties, unitTests] 113 | 114 | properties :: TestTree 115 | properties = testGroup "Properties" [qcProps] 116 | 117 | 118 | -- Return if a list equal to some linked list representation. 119 | listEqLinkedList :: PrimMonad m => Eq a => [a] -> LinkedList a (PrimState m) -> m Bool 120 | listEqLinkedList [] l = return $ isNil l 121 | listEqLinkedList (x:xs) l = do 122 | xval <- getField val l 123 | if xval == x 124 | then do 125 | l' <- get next l 126 | listEqLinkedList xs l' 127 | else return False 128 | 129 | 130 | qcProps = testGroup "(checked by QuickCheck)" 131 | [ QC.testProperty @([Int] -> Bool) "list to linked list" $ 132 | \xs -> runST $ do 133 | lxs <- listToLinkedList xs 134 | listEqLinkedList xs lxs 135 | 136 | , QC.testProperty @(NonEmptyList Int -> Bool) "Indexing linked lists" $ 137 | \xs -> runST $ do 138 | lxs <- listToLinkedList (getNonEmpty xs) 139 | 140 | -- TODO: missing Foldable instance for NonEmptyList 141 | xsAtIx <- sequenceA [nthLinkedList ix lxs | ix <- [0.. length (getNonEmpty xs) - 1]] 142 | return $ xsAtIx == getNonEmpty xs 143 | 144 | -- return $ getNonEmpty lxs == xsAtIx 145 | 146 | , QC.testProperty @(NonEmptyList Int -> [Int] -> Bool) "Appending linked lists" $ 147 | \xs ys -> runST $ do 148 | lxs <- listToLinkedList (getNonEmpty xs) 149 | lys <- listToLinkedList ys 150 | 151 | -- this mutates lxs 152 | concatLinkedList lxs lys 153 | 154 | listEqLinkedList ((getNonEmpty xs) ++ ys) lxs 155 | ] 156 | 157 | 158 | 159 | -- Try out the `Precomposable` system 160 | nextnext :: Slot (LinkedList a) (LinkedList a) 161 | nextnext = next # next 162 | 163 | nextnextval :: Field (LinkedList a) a 164 | nextnextval = nextnext # val 165 | 166 | 167 | unitTests = testGroup "Unit tests" 168 | [ testCase "create and get value from tuple" $ 169 | runST $ do 170 | c <- mkTupleInts 10 20 171 | val <- getTupleLeft c 172 | return (val @?= 10) 173 | , testCase "set and get value from tuple" $ runST $ do 174 | c <- mkTupleInts 10 20 175 | setTupleLeft c 30 176 | val <- getTupleLeft c 177 | return (val @?= 30) 178 | , testCase "pull the values out of a linked list using nextnextval" $ runST $ do 179 | xs <- listToLinkedList [1, 2, 3] 180 | nnv <- getField nextnextval xs 181 | return (nnv @?= 3) 182 | 183 | ] 184 | --------------------------------------------------------------------------------