├── .github └── workflows │ └── ci.yml ├── .gitignore ├── ChangeLog ├── Data ├── TASequence.hs └── TASequence │ ├── Any.hs │ ├── BinaryTree.hs │ ├── ConsList.hs │ ├── FastCatQueue.hs │ ├── FastQueue.hs │ ├── FingerTree.hs │ ├── Queue.hs │ ├── SnocList.hs │ └── ToCatQueue.hs ├── LICENSE ├── Setup.hs ├── fake-test └── Test.hs ├── test └── Test.hs └── type-aligned.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Haskell-CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | - main 7 | pull_request: 8 | types: 9 | - opened 10 | - synchronize 11 | jobs: 12 | github-actions: 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | cabal: ["latest"] 18 | ghc: ["latest"] 19 | os: [ubuntu-latest, macOS-latest] 20 | include: 21 | - os: windows-latest 22 | experimental: true 23 | env: 24 | CONFIG: "--enable-tests --enable-benchmarks" 25 | steps: 26 | - uses: actions/checkout@v2 27 | - uses: haskell/actions/setup@v1 28 | id: setup-haskell-cabal 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | cabal-version: ${{ matrix.cabal }} 32 | - run: cabal v2-update 33 | - run: | 34 | cabal v2-configure $CONFIG 35 | echo "tests: True" >> cabal.project.local 36 | - run: cabal v2-freeze $CONFIG 37 | - uses: actions/cache@v2 38 | with: 39 | path: | 40 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 41 | dist-newstyle 42 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 43 | restore-keys: | 44 | ${{ runner.os }}-${{ matrix.ghc }}- 45 | - run: cabal v2-build $CONFIG all 46 | - run: cabal v2-test $CONFIG all 47 | - run: cabal v2-haddock $CONFIG 48 | - run: cabal v2-sdist 49 | hvr-style: 50 | name: Haskell-CI Linux - GHC ${{ matrix.ghc }} 51 | runs-on: ubuntu-18.04 52 | container: 53 | image: buildpack-deps:bionic 54 | continue-on-error: ${{ matrix.allow-failure }} 55 | strategy: 56 | matrix: 57 | include: 58 | - ghc: 8.10.4 59 | allow-failure: false 60 | - ghc: 8.8.4 61 | allow-failure: false 62 | - ghc: 8.6.5 63 | allow-failure: false 64 | - ghc: 8.4.4 65 | allow-failure: false 66 | - ghc: 8.2.2 67 | allow-failure: false 68 | - ghc: 8.0.2 69 | allow-failure: false 70 | - ghc: 7.10.3 71 | allow-failure: false 72 | - ghc: 7.8.4 73 | allow-failure: false 74 | - ghc: 7.6.3 75 | allow-failure: false 76 | - ghc: 7.4.2 77 | allow-failure: false 78 | fail-fast: false 79 | steps: 80 | - name: apt 81 | run: | 82 | apt-get update 83 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common 84 | apt-add-repository -y 'ppa:hvr/ghc' 85 | apt-get update 86 | apt-get install -y ghc-$GHC_VERSION cabal-install-3.2 87 | env: 88 | GHC_VERSION: ${{ matrix.ghc }} 89 | - name: Set PATH and environment variables 90 | run: | 91 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 92 | echo "LANG=C.UTF-8" >> $GITHUB_ENV 93 | echo "CABAL_DIR=$HOME/.cabal" >> $GITHUB_ENV 94 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> $GITHUB_ENV 95 | HC=/opt/ghc/$GHC_VERSION/bin/ghc 96 | echo "HC=$HC" >> $GITHUB_ENV 97 | echo "HCPKG=/opt/ghc/$GHC_VERSION/bin/ghc-pkg" >> $GITHUB_ENV 98 | echo "HADDOCK=/opt/ghc/$GHC_VERSION/bin/haddock" >> $GITHUB_ENV 99 | echo "CABAL=/opt/cabal/3.2/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV 100 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 101 | echo "HCNUMVER=$HCNUMVER" >> $GITHUB_ENV 102 | echo "ARG_TESTS=--enable-tests" >> $GITHUB_ENV 103 | echo "ARG_BENCH=--enable-benchmarks" >> $GITHUB_ENV 104 | echo "ARG_COMPILER=--ghc --with-compiler=/opt/ghc/$GHC_VERSION/bin/ghc" >> $GITHUB_ENV 105 | echo "GHCJSARITH=0" >> $GITHUB_ENV 106 | env: 107 | GHC_VERSION: ${{ matrix.ghc }} 108 | - name: env 109 | run: | 110 | env 111 | - name: write cabal config 112 | run: | 113 | mkdir -p $CABAL_DIR 114 | cat >> $CABAL_CONFIG < cabal-plan.xz 143 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 144 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 145 | rm -f cabal-plan.xz 146 | chmod a+x $HOME/.cabal/bin/cabal-plan 147 | - name: checkout 148 | uses: actions/checkout@v2 149 | with: 150 | path: source 151 | - name: sdist 152 | run: | 153 | mkdir -p sdist 154 | cd source || false 155 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 156 | - name: unpack 157 | run: | 158 | mkdir -p unpacked 159 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 160 | - name: generate cabal.project 161 | run: | 162 | PKGDIR_logict="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/type-aligned-[0-9.]*')" 163 | echo "PKGDIR_logict=${PKGDIR_logict}" >> $GITHUB_ENV 164 | touch cabal.project 165 | touch cabal.project.local 166 | echo "packages: ${PKGDIR_logict}" >> cabal.project 167 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package type-aligned" >> cabal.project ; fi 168 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 169 | cat >> cabal.project <> cabal.project.local 172 | cat cabal.project 173 | cat cabal.project.local 174 | - name: dump install plan 175 | run: | 176 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 177 | cabal-plan 178 | - name: cache 179 | uses: actions/cache@v2 180 | with: 181 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }} 182 | path: ~/.cabal/store 183 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 184 | - name: install dependencies 185 | run: | 186 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 187 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 188 | - name: build w/o tests 189 | run: | 190 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 191 | - name: build 192 | run: | 193 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 194 | - name: tests 195 | run: | 196 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 197 | - name: cabal check 198 | run: | 199 | cd ${PKGDIR_logict} || false 200 | ${CABAL} -vnormal check 201 | - name: haddock 202 | run: | 203 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 204 | - name: unconstrained build 205 | run: | 206 | rm -f cabal.project.local 207 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 208 | 209 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist/ 3 | *.o 4 | *.hi 5 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 0.9.6: More fixed docs 2 | 0.9.5: Fixed docs 3 | 0.9.4: Added tmap and laws 4 | 0.9.3: Not awake 5 | 0.9.2: Fixed some very small errors 6 | 0.9.1: Fixed some typos in the docs 7 | 0.9: Initial version 8 | -------------------------------------------------------------------------------- /Data/TASequence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs,TypeSynonymInstances,FlexibleInstances,Rank2Types, KindSignatures #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.TASequence 11 | -- Copyright : (c) Atze van der Ploeg 2014 12 | -- License : BSD-style 13 | -- Maintainer : atzeus@gmail.org 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- A type class for type aligned sequences: heterogeneous 17 | -- sequences where the types enforce the element order. 18 | -- 19 | -- Type aligned sequences are best explained by an example: a type 20 | -- aligned sequence of functions is a sequence f 1 , f 2 , f 3 ... f n such that 21 | -- the composition of these functions f 1 ◦ f 2 ◦ f 3 ◦ ... ◦ f n is well typed. 22 | -- In other words: the result type of each function in the sequence 23 | -- must be the same as the argument type of the next function (if any). 24 | -- In general, the elements of a type aligned sequence do not have to 25 | -- be functions, i.e. values of type a → b, but can be values of type 26 | -- (c a b), for some binary type constructor c. Hence, we define a type 27 | -- aligned sequence to be a sequence of elements of the type (c a_i b_i ) 28 | -- with the side-condition b_i−1 = a_i . If s is the type of a type aligned 29 | -- sequence data structure, then (s c a b) is the type of a type aligned 30 | -- sequence where the first element has type (c a x), for some x, and 31 | -- the last element has type (c y b), for some y. 32 | -- 33 | -- The simplest type aligned sequence data structure is a list, see "Data.TASequence.ConsList". The other modules 34 | -- give various other type aligned sequence data structures. The data structure "Data.TASequence.FastCatQueue" supports the most operations in worst case constant time. 35 | -- 36 | -- 37 | -- See the paper Reflection without Remorse: Revealing a hidden sequence to speed up Monadic Reflection, Atze van der Ploeg and Oleg Kiselyov, Haskell Symposium 2014 38 | -- for more details. 39 | -- 40 | -- Paper: 41 | -- Talk : 42 | ----------------------------------------------------------------------------- 43 | module Data.TASequence(TASequence(..), TAViewL(..), TAViewR(..)) where 44 | 45 | import Control.Category 46 | import Prelude hiding ((.),id) 47 | 48 | infixr 5 <| 49 | infixl 5 |> 50 | infix 5 >< 51 | {- | A type class for type aligned sequences 52 | 53 | Minimal complete defention: 'tempty' and 'tsingleton' and ('tviewl' or 'tviewr') and ('><' or '|>' or '<|') 54 | 55 | Instances should satisfy the following laws: 56 | 57 | Category laws: 58 | 59 | > tempty >< x == x 60 | > x >< tempty == x 61 | > (x >< y) >< z = x >< (y >< z) 62 | 63 | Observation laws: 64 | 65 | > tviewl (tsingleton e >< s) == e :< s 66 | > tviewl tempty == TAEmptyL 67 | 68 | The behaviour of '<|','|>', 'tmap' and 'tviewr' is implied by the above laws and their default definitions. 69 | -} 70 | #if __GLASGOW_HASKELL__ >= 706 71 | class TASequence (s :: (k -> k -> *) -> k -> k -> *) where 72 | #else 73 | class TASequence s where 74 | #endif 75 | 76 | {-# MINIMAL tempty, tsingleton, (tviewl | tviewr), ((><) | (|>) | (<|)) #-} 77 | 78 | tempty :: s c x x 79 | tsingleton :: c x y -> s c x y 80 | -- | Append two type aligned sequences 81 | (><) :: s c x y -> s c y z -> s c x z 82 | -- | View a type aligned sequence from the left 83 | tviewl :: s c x y -> TAViewL s c x y 84 | -- | View a type aligned sequence from the right 85 | -- 86 | -- Default definition: 87 | -- 88 | -- > tviewr q = case tviewl q of 89 | -- > TAEmptyL -> TAEmptyR 90 | -- > h :< t -> case tviewr t of 91 | -- > TAEmptyR -> tempty :> h 92 | -- > p :> l -> (h <| p) :> l 93 | tviewr :: s c x y -> TAViewR s c x y 94 | -- | Append a single element to the right 95 | -- 96 | -- Default definition: 97 | -- 98 | -- > l |> r = l >< tsingleton r 99 | 100 | (|>) :: s c x y -> c y z -> s c x z 101 | -- | Append a single element to the left 102 | -- 103 | -- Default definition: 104 | -- 105 | -- > l <| r = tsingleton l >< r 106 | 107 | (<|) :: c x y -> s c y z -> s c x z 108 | -- | Apply a function to all elements in a type aligned sequence 109 | -- 110 | -- Default definition: 111 | -- 112 | -- > tmap f q = case tviewl q of 113 | -- > TAEmptyL -> tempty 114 | -- > h :< t -> f h <| tmap f t 115 | tmap :: (forall x y. c x y -> d x y) -> s c x y -> s d x y 116 | 117 | l |> r = l >< tsingleton r 118 | l <| r = tsingleton l >< r 119 | l >< r = case tviewl l of 120 | TAEmptyL -> r 121 | h :< t -> h <| (t >< r) 122 | 123 | tviewl q = case tviewr q of 124 | TAEmptyR -> TAEmptyL 125 | p :> l -> case tviewl p of 126 | TAEmptyL -> l :< tempty 127 | h :< t -> h :< (t |> l) 128 | 129 | tviewr q = case tviewl q of 130 | TAEmptyL -> TAEmptyR 131 | h :< t -> case tviewr t of 132 | TAEmptyR -> tempty :> h 133 | p :> l -> (h <| p) :> l 134 | 135 | tmap f q = case tviewl q of 136 | TAEmptyL -> tempty 137 | h :< t -> f h <| tmap f t 138 | 139 | 140 | data TAViewL s c x y where 141 | TAEmptyL :: TAViewL s c x x 142 | (:<) :: c x y -> s c y z -> TAViewL s c x z 143 | 144 | data TAViewR s c x y where 145 | TAEmptyR :: TAViewR s c x x 146 | (:>) :: s c x y -> c y z -> TAViewR s c x z 147 | -------------------------------------------------------------------------------- /Data/TASequence/Any.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | #if __GLASGOW_HASKELL__ >= 706 6 | {-# LANGUAGE PolyKinds #-} 7 | #endif 8 | -- We suppress this warning because otherwise GHC complains 9 | -- about the newtype constructor not being used. 10 | #if __GLASGOW_HASKELL__ >= 800 11 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 12 | #endif 13 | 14 | -- | It's safe to coerce /to/ 'Any' as long as you don't 15 | -- coerce back. We define our own 'Any' instead of using 16 | -- the one in "GHC.Exts" directly to ensure that this 17 | -- module doesn't clash with one making the opposite 18 | -- assumption. 19 | module Data.TASequence.Any 20 | ( Any 21 | , AnyCat 22 | , toAny 23 | , toAnyConsList 24 | ) where 25 | 26 | import Data.TASequence.ConsList 27 | import Unsafe.Coerce 28 | 29 | #if __GLASGOW_HASKELL__ >= 800 30 | type family Any :: k where 31 | #elif __GLASGOW_HASKELL__ >= 706 32 | -- Closed type families used to need at least one instance. By hiding the 33 | -- family itself and only exposing the synonym, we prevent instantiation. 34 | -- It's a bit weird that this works even with TypeSynonymInstances, but 35 | -- that's a bit lucky. 36 | type Any = Any' 37 | type family Any' :: k 38 | #else 39 | type Any = Any' 40 | type family Any' 41 | #endif 42 | 43 | newtype AnyCat a b = AnyCat Any 44 | 45 | -- | Convert anything to 'AnyCat'. 46 | toAny :: c x y -> AnyCat x y 47 | toAny = unsafeCoerce 48 | 49 | -- | Convert a list of anything to a list of 'AnyCat'. 50 | toAnyConsList :: ConsList tc a c -> ConsList AnyCat d e 51 | toAnyConsList = unsafeCoerce 52 | -------------------------------------------------------------------------------- /Data/TASequence/BinaryTree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.TASequence.BinaryTree 11 | -- Copyright : (c) Atze van der Ploeg 2014 12 | -- License : BSD-style 13 | -- Maintainer : atzeus@gmail.org 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- A type aligned sequence which uses a binary tree, where the leaves are 18 | -- elements and then nodes are '><'. 19 | -- 20 | ----------------------------------------------------------------------------- 21 | module Data.TASequence.BinaryTree(module Data.TASequence, BinaryTree) where 22 | 23 | import Control.Category 24 | import Data.TASequence 25 | 26 | data BinaryTree c x y where 27 | Empty :: BinaryTree c x x 28 | Leaf :: c x y -> BinaryTree c x y 29 | Node :: BinaryTree c x y -> BinaryTree c y z -> BinaryTree c x z 30 | 31 | instance TASequence BinaryTree where 32 | tempty = Empty 33 | tsingleton c = Leaf c 34 | (><) = Node 35 | tviewl Empty = TAEmptyL 36 | tviewl (Leaf c) = c :< Empty 37 | tviewl (Node (Node l m) r) = tviewl (Node l (Node m r)) 38 | tviewl (Node (Leaf c) r) = c :< r 39 | tviewl (Node Empty r) = tviewl r 40 | 41 | tmap phi Empty = Empty 42 | tmap phi (Leaf c) = Leaf (phi c) 43 | tmap phi (Node b b') = Node (tmap phi b) (tmap phi b') 44 | 45 | instance Category (BinaryTree c) where 46 | id = tempty 47 | (.) = flip (><) 48 | -------------------------------------------------------------------------------- /Data/TASequence/ConsList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.TASequence.ConsList 12 | -- Copyright : (c) Atze van der Ploeg 2014 13 | -- License : BSD-style 14 | -- Maintainer : atzeus@gmail.org 15 | -- Stability : provisional 16 | -- Portability : portable 17 | -- 18 | -- A type aligned sequence, a head-tail list, with worst case constant time: '<|', and 'tviewl'. 19 | -- 20 | ----------------------------------------------------------------------------- 21 | module Data.TASequence.ConsList(module Data.TASequence,ConsList(..)) where 22 | import Control.Category 23 | import Data.TASequence 24 | 25 | data ConsList c x y where 26 | CNil :: ConsList c x x 27 | Cons :: c x y -> ConsList c y z -> ConsList c x z 28 | 29 | instance TASequence ConsList where 30 | tempty = CNil 31 | tsingleton c = Cons c CNil 32 | (<|) = Cons 33 | tviewl CNil = TAEmptyL 34 | tviewl (Cons h t) = h :< t 35 | 36 | instance Category (ConsList c) where 37 | id = tempty 38 | (.) = flip (><) 39 | -------------------------------------------------------------------------------- /Data/TASequence/FastCatQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 706 3 | {-# LANGUAGE PolyKinds #-} 4 | #endif 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.TASequence.FastCatQueue 9 | -- Copyright : (c) Atze van der Ploeg 2014 10 | -- License : BSD-style 11 | -- Maintainer : atzeus@gmail.org 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- A type aligned sequence, a catanable queue, with worst case constant time: '><', '|>', '<|' and 'tviewl'. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | module Data.TASequence.FastCatQueue(module Data.TASequence, FastTCQueue) where 19 | 20 | import Data.TASequence 21 | import Data.TASequence.FastQueue 22 | import Data.TASequence.ToCatQueue 23 | 24 | type FastTCQueue = ToCatQueue FastQueue 25 | -------------------------------------------------------------------------------- /Data/TASequence/FastQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs, ViewPatterns, TypeOperators #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | #if __GLASGOW_HASKELL__ >= 706 5 | {-# LANGUAGE PolyKinds #-} 6 | #endif 7 | 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.TASequence.FastQueue 12 | -- Copyright : (c) Atze van der Ploeg 2014 13 | -- License : BSD-style 14 | -- Maintainer : atzeus@gmail.org 15 | -- Stability : provisional 16 | -- Portability : portable 17 | -- 18 | -- A type aligned sequence, a queue, with worst case constant time: '|>', and 'tviewl'. 19 | -- 20 | -- Based on: "Simple and Efficient Purely Functional Queues and Deques", Chris Okasaki, 21 | -- Journal of Functional Programming 1995 22 | -- 23 | ----------------------------------------------------------------------------- 24 | 25 | module Data.TASequence.FastQueue(module Data.TASequence, FastQueue) where 26 | 27 | import Control.Category 28 | import Data.TASequence 29 | import Data.TASequence.ConsList 30 | import Data.TASequence.SnocList 31 | import Data.TASequence.Any 32 | 33 | 34 | revAppend :: ConsList tc a b -> SnocList tc b d -> ConsList tc a d 35 | revAppend l r = rotate l r CNil 36 | -- precondition : |a| = |f| - (|r| - 1) 37 | -- postcondition: |a| = |f| - |r| 38 | rotate :: ConsList tc a b -> SnocList tc b c -> ConsList tc c d -> ConsList tc a d 39 | rotate CNil (SNil `Snoc` y) r = y `Cons` r 40 | rotate (x `Cons` f) (r `Snoc` y) a = x `Cons` rotate f r (y `Cons` a) 41 | rotate f a r = error "Invariant |a| = |f| - (|r| - 1) broken" 42 | 43 | data FastQueue tc a b where 44 | -- We use Any instead of a proper existential to allow GHC to unpack 45 | -- FastQueue and to make `tmap` more efficient. Unfortunately, GHC still 46 | -- doesn't know how to unpack existentials, though it has known how to unpack 47 | -- GADTs for some time. We do this only for the schedule, so it doesn't 48 | -- weaken the correctness guarantees. 49 | RQ :: !(ConsList tc a b) -> !(SnocList tc b c) -> !(ConsList AnyCat Any b) -> FastQueue tc a c 50 | 51 | queue :: ConsList tc a b -> SnocList tc b c -> ConsList AnyCat Any b -> FastQueue tc a c 52 | queue f r CNil = let f' = revAppend f r 53 | in RQ f' SNil (toAnyConsList f') 54 | queue f r (h `Cons` t) = RQ f r (toAnyConsList t) 55 | 56 | instance TASequence FastQueue where 57 | tempty = RQ CNil SNil (toAnyConsList CNil) 58 | tsingleton x = let c = tsingleton x in RQ c SNil (toAnyConsList c) 59 | (RQ f r a) |> x = queue f (r `Snoc` x) a 60 | 61 | tviewl (RQ CNil SNil CNil) = TAEmptyL 62 | tviewl (RQ (h `Cons` t) f a) = h :< queue t f a 63 | 64 | tmap phi (RQ a b c) = RQ (tmap phi a) (tmap phi b) (toAnyConsList c) 65 | 66 | instance Category (FastQueue c) where 67 | id = tempty 68 | (.) = flip (><) 69 | -------------------------------------------------------------------------------- /Data/TASequence/FingerTree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types,GADTs #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.TASequence.FingerTree 13 | -- Copyright : (c) Atze van der Ploeg 2014 14 | -- License : BSD-style 15 | -- Maintainer : atzeus@gmail.org 16 | -- Stability : provisional 17 | -- Portability : portable 18 | -- 19 | -- A type aligned sequence, a catanable deque, with amortized /O(log n)/ constant time: '><','<|','|>', 'tviewl' and 'tviewr'. 20 | -- 21 | -- Based on: "Finger trees: a simple general-purpose data structure" 22 | -- Ralf Hinze and Ross Paterson. in Journal of Functional Programming16:2 (2006), pages 197-217. 23 | -- 24 | ----------------------------------------------------------------------------- 25 | module Data.TASequence.FingerTree (module Data.TASequence, FingerTree ) where 26 | 27 | 28 | import Control.Category 29 | import Data.TASequence 30 | 31 | 32 | data FingerTree r a b where 33 | Empty :: FingerTree r a a 34 | Single :: r a b -> FingerTree r a b 35 | Deep :: !(Digit r a b) -> FingerTree (Node r) b c -> !(Digit r c d) -> FingerTree r a d 36 | 37 | data Node r a b where 38 | Node2 :: r a b -> r b c -> Node r a c 39 | Node3 :: r a b -> r b c -> r c d -> Node r a d 40 | 41 | data Digit r a b where 42 | One :: r a b -> Digit r a b 43 | Two :: r a b -> r b c -> Digit r a c 44 | Three :: r a b -> r b c -> r c d -> Digit r a d 45 | Four :: r a b -> r b c -> r c d -> r d e -> Digit r a e 46 | 47 | instance TASequence FingerTree where 48 | tempty = Empty 49 | tsingleton = Single 50 | 51 | Empty |> a = Single a 52 | Single b |> a = Deep (One b) Empty (One a) 53 | Deep pr m (Four e d c b) |> a = m `seq` Deep pr (m |> Node3 e d c) (Two b a) 54 | Deep pr m sf |> a = Deep pr m (appendd sf (One a)) 55 | 56 | a <| Empty = Single a 57 | a <| Single b = Deep (One a) Empty (One b) 58 | a <| Deep (Four b c d e) m sf = m `seq` Deep (Two a b) (Node3 c d e <| m) sf 59 | a <| Deep pr m sf = Deep (appendd (One a) pr) m sf 60 | 61 | tviewl Empty = TAEmptyL 62 | tviewl (Single a) = a :< Empty 63 | tviewl (Deep pr m sf) = case toList pr of 64 | h ::: t -> h :< deepl t m sf 65 | 66 | tviewr Empty = TAEmptyR 67 | tviewr (Single a) = Empty :> a 68 | tviewr (Deep pr m sf) = case toListR sf of 69 | h :::< t -> deepr pr m t :> h 70 | 71 | xs >< ys = app3 xs ZNil ys 72 | 73 | tmap f Empty = Empty 74 | tmap f (Single a) = Single (f a) 75 | tmap f (Deep l m r) = Deep (mapd f l) (tmap (mapn f) m) (mapd f r) 76 | 77 | instance Category (FingerTree c) where 78 | id = tempty 79 | (.) = flip (><) 80 | 81 | toTree :: Digit r a b -> FingerTree r a b 82 | toTree (One a) = Single a 83 | toTree (Two a b) = Deep (One a) Empty (One b) 84 | toTree (Three a b c) = Deep (Two a b) Empty (One c) 85 | toTree (Four a b c d) = Deep (Two a b) Empty (Two c d) 86 | 87 | 88 | appendd :: Digit r a b -> Digit r b c -> Digit r a c 89 | appendd (One a) (One b) = Two a b 90 | appendd (One a) (Two b c) = Three a b c 91 | appendd (Two a b) (One c) = Three a b c 92 | appendd (One a) (Three b c d) = Four a b c d 93 | appendd (Two a b) (Two c d) = Four a b c d 94 | appendd (Three a b c) (One d) = Four a b c d 95 | 96 | 97 | 98 | 99 | 100 | 101 | infixr 5 ::: 102 | 103 | 104 | data ZList r a b where 105 | ZNil :: ZList r a a 106 | (:::) :: r a b -> ZList r b c -> ZList r a c 107 | 108 | toList (One a) = a ::: ZNil 109 | toList (Two a b) = a ::: b ::: ZNil 110 | toList (Three a b c) = a ::: b ::: c ::: ZNil 111 | toList (Four a b c d) = a ::: b ::: c ::: d ::: ZNil 112 | 113 | 114 | 115 | 116 | fromList :: ZList r a b -> Digit r a b 117 | fromList (a ::: ZNil) = One a 118 | fromList (a ::: b ::: ZNil) = Two a b 119 | fromList (a ::: b ::: c ::: ZNil) = Three a b c 120 | fromList (a ::: b ::: c ::: d ::: ZNil) = Four a b c d 121 | 122 | append :: ZList r a b -> ZList r b c -> ZList r a c 123 | append ZNil t = t 124 | append (h ::: t) r = h ::: append t r 125 | 126 | 127 | deepl :: ZList r a b -> FingerTree (Node r) b c -> Digit r c d -> FingerTree r a d 128 | deepl ZNil m sf = case tviewl m of 129 | TAEmptyL -> toTree sf 130 | a :< m' -> Deep (nodeToDigit a) m' sf 131 | deepl pr m sf = Deep (fromList pr) m sf 132 | 133 | infixr 5 :::< 134 | 135 | data ZListR r a b where 136 | ZNilR :: ZListR r a a 137 | (:::<) :: r b c -> ZListR r a b -> ZListR r a c 138 | 139 | toListR :: Digit r a b -> ZListR r a b 140 | toListR (One a) = a :::< ZNilR 141 | toListR (Two a b) = b :::< a :::< ZNilR 142 | toListR (Three a b c) = c :::< b :::< a :::< ZNilR 143 | toListR (Four a b c d) = d:::< c :::< b :::< a :::< ZNilR 144 | 145 | 146 | 147 | fromListR :: ZListR r a b -> Digit r a b 148 | fromListR (a :::< ZNilR) = One a 149 | fromListR (b :::< a :::< ZNilR) = Two a b 150 | fromListR (c :::< b :::< a :::< ZNilR) = Three a b c 151 | fromListR (d :::< c :::< b :::< a :::< ZNilR) = Four a b c d 152 | 153 | 154 | rev = toList Prelude.. fromListR 155 | 156 | 157 | 158 | deepr :: Digit r a b -> FingerTree (Node r) b c -> ZListR r c d -> FingerTree r a d 159 | deepr pr m ZNilR = case tviewr m of 160 | TAEmptyR -> toTree pr 161 | m' :> a -> Deep pr m' (nodeToDigit a) 162 | deepr pr m sf = Deep pr m (fromListR sf) 163 | 164 | 165 | nodeToDigit :: Node r a b -> Digit r a b 166 | nodeToDigit (Node2 a b) = Two a b 167 | nodeToDigit (Node3 a b c) = Three a b c 168 | 169 | 170 | 171 | addAlll :: ZList r a b -> FingerTree r b c -> FingerTree r a c 172 | addAlll ZNil m = m 173 | addAlll (h ::: t) m = h <| addAlll t m 174 | 175 | addAllr :: FingerTree r a b -> ZList r b c -> FingerTree r a c 176 | addAllr m ZNil = m 177 | addAllr m (h ::: t) = addAllr (m |> h) t 178 | 179 | 180 | 181 | app3 :: FingerTree r a b -> ZList r b c -> FingerTree r c d -> FingerTree r a d 182 | app3 Empty ts xs = addAlll ts xs 183 | app3 xs ts Empty = addAllr xs ts 184 | app3 (Single x) ts xs = x <| (addAlll ts xs) 185 | app3 xs ts (Single x) = (addAllr xs ts) |> x 186 | app3 (Deep pr1 m1 sf1) ts (Deep pr2 m2 sf2) = 187 | Deep pr1 188 | (app3 m1 (nodes (append (toList sf1) (append ts (toList pr2)))) m2) sf2 189 | 190 | 191 | nodes :: ZList r a b -> ZList (Node r) a b 192 | nodes (a ::: b ::: ZNil) = Node2 a b ::: ZNil 193 | nodes (a ::: b ::: c ::: ZNil) = Node3 a b c ::: ZNil 194 | nodes (a ::: b ::: c ::: d ::: ZNil) = Node2 a b ::: Node2 c d ::: ZNil 195 | nodes (a ::: b ::: c ::: xs) = Node3 a b c ::: nodes xs 196 | 197 | mapn :: (forall x y. c x y -> d x y) -> Node c x y -> Node d x y 198 | mapn phi (Node2 r s) = Node2 (phi r) (phi s) 199 | mapn phi (Node3 r s t) = Node3 (phi r) (phi s) (phi t) 200 | 201 | mapd :: (forall x y. c x y -> d x y) -> Digit c x y -> Digit d x y 202 | mapd phi (One r) = One (phi r) 203 | mapd phi (Two r s) = Two (phi r) (phi s) 204 | mapd phi (Three r s t) = Three (phi r) (phi s) (phi t) 205 | mapd phi (Four r s t u) = Four (phi r) (phi s) (phi t) (phi u) 206 | 207 | 208 | -------------------------------------------------------------------------------- /Data/TASequence/Queue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.TASequence.Queue 11 | -- Copyright : (c) Atze van der Ploeg 2014 12 | -- License : BSD-style 13 | -- Maintainer : atzeus@gmail.org 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- A type aligned sequence, a queue, with amortized constant time: '|>', and 'tviewl'. 18 | -- 19 | -- A simplified version of Okasaki's implicit recursive 20 | -- slowdown queues. 21 | -- See purely functional data structures by Chris Okasaki 22 | -- section 8.4: Queues based on implicit recursive slowdown 23 | -- 24 | ----------------------------------------------------------------------------- 25 | module Data.TASequence.Queue(module Data.TASequence,Queue) where 26 | 27 | import Control.Category 28 | import Data.TASequence 29 | 30 | data P c a b where 31 | (:*) :: c a w -> c w b -> P c a b 32 | 33 | data B c a b where 34 | B1 :: c a b -> B c a b 35 | B2 :: !(P c a b) -> B c a b 36 | 37 | data Queue c a b where 38 | Q0 :: Queue c a a 39 | Q1 :: c a b -> Queue c a b 40 | QN :: !(B c a x) -> Queue (P c) x y -> !(B c y b) -> Queue c a b 41 | 42 | instance TASequence Queue where 43 | tempty = Q0 44 | tsingleton = Q1 45 | q |> b = case q of 46 | Q0 -> Q1 b 47 | Q1 a -> QN (B1 a) Q0 (B1 b) 48 | QN l m (B1 a) -> QN l m (B2 (a :* b)) 49 | QN l m (B2 r) -> QN l (m |> r) (B1 b) 50 | 51 | tviewl q = case q of 52 | Q0 -> TAEmptyL 53 | Q1 a -> a :< Q0 54 | QN (B2 (a :* b)) m r -> a :< QN (B1 b) m r 55 | QN (B1 a) m r -> a :< shiftLeft m r 56 | where shiftLeft :: Queue (P c) a w -> B c w b -> Queue c a b 57 | shiftLeft q r = case tviewl q of 58 | TAEmptyL -> buf2queue r 59 | l :< m -> QN (B2 l) m r 60 | buf2queue (B1 a) = Q1 a 61 | buf2queue(B2 (a :* b)) = QN (B1 a) Q0 (B1 b) 62 | tmap f Q0 = Q0 63 | tmap f (Q1 x) = Q1 (f x) 64 | tmap f (QN l m r) = QN (tmapb f l) (tmap (tmapp f) m) (tmapb f r) 65 | 66 | instance Category (Queue c) where 67 | id = tempty 68 | (.) = flip (><) 69 | 70 | tmapp :: (forall x y. c x y -> d x y) -> P c x y -> P d x y 71 | tmapp phi (a :* b) = phi a :* phi b 72 | 73 | tmapb :: (forall x y. c x y -> d x y) -> B c x y -> B d x y 74 | tmapb phi (B1 c) = B1 (phi c) 75 | tmapb phi (B2 p) = B2 (tmapp phi p) 76 | -------------------------------------------------------------------------------- /Data/TASequence/SnocList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | #if __GLASGOW_HASKELL__ >= 706 4 | {-# LANGUAGE PolyKinds #-} 5 | #endif 6 | 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.TASequence.ConsList 11 | -- Copyright : (c) Atze van der Ploeg 2014 12 | -- License : BSD-style 13 | -- Maintainer : atzeus@gmail.org 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- A type aligned sequence, a snoc list, with worst case constant time: '|>', and 'tviewr'. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Data.TASequence.SnocList(module Data.TASequence,SnocList(..)) where 22 | 23 | import Control.Category 24 | import Data.TASequence 25 | 26 | data SnocList c x y where 27 | SNil :: SnocList c x x 28 | Snoc :: SnocList c x y -> c y z -> SnocList c x z 29 | 30 | instance TASequence SnocList where 31 | tempty = SNil 32 | tsingleton c = Snoc SNil c 33 | (|>) = Snoc 34 | tviewr SNil = TAEmptyR 35 | tviewr (Snoc p l) = p :> l 36 | tmap phi SNil = SNil 37 | tmap phi (Snoc s c) = Snoc (tmap phi s) (phi c) 38 | 39 | instance Category (SnocList c) where 40 | id = tempty 41 | (.) = flip (><) 42 | -------------------------------------------------------------------------------- /Data/TASequence/ToCatQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | #if __GLASGOW_HASKELL__ >= 706 5 | {-# LANGUAGE PolyKinds #-} 6 | #endif 7 | 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.TASequence.CatQueue 12 | -- Copyright : (c) Atze van der Ploeg 2013 13 | -- License : BSD-style 14 | -- Maintainer : atzeus@gmail.org 15 | -- Stability : provisional 16 | -- Portability : portable 17 | -- 18 | -- A purely functional catenable queue representation with 19 | -- that turns takes a purely functional queue and turns in it into 20 | -- a catenable queue, i.e. with the same complexity for '><' as for '|>' 21 | -- Based on Purely functional data structures by Chris Okasaki 22 | -- section 7.2: Catenable lists 23 | -- 24 | ----------------------------------------------------------------------------- 25 | 26 | module Data.TASequence.ToCatQueue(module Data.TASequence,ToCatQueue) where 27 | 28 | 29 | import Control.Category 30 | import Data.TASequence 31 | 32 | -- | The catenable queue type. The first type argument is the 33 | -- type of the queue we use (|>) 34 | data ToCatQueue q c x y where 35 | C0 :: ToCatQueue q c x x 36 | CN :: c x y -> !(q (ToCatQueue q c) y z) -> ToCatQueue q c x z 37 | 38 | instance TASequence q => TASequence (ToCatQueue q) where 39 | tempty = C0 40 | tsingleton a = CN a tempty 41 | C0 >< ys = ys 42 | xs >< C0 = xs 43 | (CN x q) >< ys = CN x (q |> ys) 44 | 45 | tviewl C0 = TAEmptyL 46 | tviewl (CN x q) = x :< case tviewl q of 47 | TAEmptyL -> C0 48 | t :< q' -> linkAll t q' 49 | where 50 | linkAll :: ToCatQueue q c x y -> q (ToCatQueue q c) y z -> ToCatQueue q c x z 51 | linkAll t@(CN x q) q' = case tviewl q' of 52 | TAEmptyL -> t 53 | h :< t' -> CN x (q |> linkAll h t') 54 | 55 | tmap phi C0 = C0 56 | tmap phi (CN c q) = CN (phi c) (tmap (tmap phi) q) 57 | 58 | instance TASequence q => Category (ToCatQueue q c) where 59 | id = tempty 60 | (.) = flip (><) 61 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Atze van der Ploeg 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | 3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /fake-test/Test.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = return () 3 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = pure () 3 | -------------------------------------------------------------------------------- /type-aligned.cabal: -------------------------------------------------------------------------------- 1 | Name: type-aligned 2 | Version: 0.9.6 3 | Synopsis: Various type-aligned sequence data structures. 4 | Description: Various data structures for type aligned sequences: heterogeneous sequences where the types enforce the element order. 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Atze van der Ploeg 8 | Maintainer: atzeus@gmail.com 9 | Homepage: https://github.com/atzeus/type-aligned 10 | Build-Type: Simple 11 | Cabal-Version: 2.0 12 | Data-files: ChangeLog 13 | Category: Data, Data Structures 14 | Tested-With: GHC ==7.4.2 GHC ==7.6.3 GHC ==7.8.4 GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.4 15 | 16 | Library 17 | Default-Language: Haskell2010 18 | Build-Depends: base >= 2 && <= 6 19 | Exposed-modules: 20 | Data.TASequence.BinaryTree 21 | , Data.TASequence 22 | , Data.TASequence.ConsList 23 | , Data.TASequence.FastCatQueue 24 | , Data.TASequence.FastQueue 25 | , Data.TASequence.FingerTree 26 | , Data.TASequence.Queue 27 | , Data.TASequence.SnocList 28 | , Data.TASequence.ToCatQueue 29 | Other-modules: Data.TASequence.Any 30 | 31 | Other-Extensions: GADTs, ViewPatterns, TypeOperators, RankNTypes, PolyKinds 32 | 33 | 34 | test-suite type-aligned-test 35 | if impl(ghc < 7.10) 36 | buildable: False 37 | type: exitcode-stdio-1.0 38 | hs-source-dirs: test 39 | default-language: Haskell2010 40 | main-is: Test.hs 41 | build-depends: base >=4.5 && < 5 42 | , type-aligned 43 | , tasty >= 1.4 44 | , QuickCheck 45 | , tasty-quickcheck 46 | 47 | test-suite do-nothing 48 | if impl(ghc >= 7.10) 49 | buildable: False 50 | type: exitcode-stdio-1.0 51 | hs-source-dirs: fake-test 52 | default-language: Haskell2010 53 | main-is: Test.hs 54 | build-depends: base >=4.5 && < 5 55 | 56 | 57 | 58 | source-repository head 59 | type: git 60 | location: https://github.com/atzeus/type-aligned 61 | --------------------------------------------------------------------------------