├── .github └── workflows │ ├── ci.yml │ └── hackage.yml ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── changelog.md ├── examples ├── ExampleMap.hs ├── ExampleSet.hs └── ExampleSet2.hs ├── src └── Data │ └── Type │ ├── Map.hs │ └── Set.hs ├── stack.yaml ├── tests ├── doctest.hs └── hspec │ ├── MapSpec.hs │ ├── SetSpec.hs │ └── Spec.hs └── type-level-sets.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | types: 9 | - opened 10 | - synchronize 11 | 12 | env: 13 | EXE_NAME: type-level-sets 14 | 15 | jobs: 16 | ubuntu-cabal-test: 17 | runs-on: ubuntu-latest 18 | name: Ubuntu / GHC ${{ matrix.ghc }}, Cabal / test 19 | strategy: 20 | fail-fast: false # don't stop if one job (= GHC version) fails 21 | matrix: 22 | cabal: ["3.6"] # ghcup recommended as of 2021-12-21 23 | ghc: 24 | - "8.10" 25 | - "9.0" 26 | - "9.2" 27 | 28 | steps: 29 | 30 | # TODO: GHC decides to recompile based on timestamp, so cache isn't used 31 | # Preferably GHC would work via hashes instead. Stack had this feature 32 | # merged in Aug 2020. 33 | # Upstream GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/16495 34 | # My issue on haskell/actions: https://github.com/haskell/actions/issues/41 35 | # This also requires us to do a deep fetch, else we don't get the Git commit 36 | # history we need to rewrite mod times. 37 | - uses: actions/checkout@v2 38 | with: 39 | fetch-depth: 0 40 | - name: Set all tracked file modification times to the time of their last commit 41 | run: | 42 | rev=HEAD 43 | for f in $(git ls-tree -r -t --full-name --name-only "$rev") ; do 44 | touch -d $(git log --pretty=format:%cI -1 "$rev" -- "$f") "$f"; 45 | done 46 | 47 | - name: Setup Haskell build environment 48 | id: setup-haskell-build-env 49 | uses: haskell/actions/setup@v1 50 | with: 51 | ghc-version: ${{ matrix.ghc }} 52 | cabal-version: ${{ matrix.cabal }} 53 | 54 | - run: cabal freeze 55 | 56 | - name: Cache Cabal build artifacts 57 | uses: actions/cache@v2 58 | with: 59 | path: | 60 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 61 | dist-newstyle 62 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 63 | restore-keys: | 64 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 65 | 66 | - run: cabal build 67 | 68 | - name: Test 69 | run: cabal test --test-show-details=streaming 70 | env: 71 | HSPEC_OPTIONS: --color 72 | 73 | mac-cabal-test: 74 | runs-on: macos-latest 75 | name: Mac / GHC ${{ matrix.ghc }}, Cabal / test 76 | strategy: 77 | fail-fast: false # don't stop if one job (= GHC version) fails 78 | matrix: 79 | cabal: ["3.6"] # ghcup recommended as of 2021-12-02 80 | ghc: ["9.0"] 81 | 82 | steps: 83 | 84 | # TODO figure out timestamp fixer on Mac (no Mac available to test) 85 | - uses: actions/checkout@v2 86 | 87 | - name: Setup Haskell build environment 88 | id: setup-haskell-build-env 89 | uses: haskell/actions/setup@v1 90 | with: 91 | ghc-version: ${{ matrix.ghc }} 92 | cabal-version: ${{ matrix.cabal }} 93 | 94 | - run: cabal freeze 95 | 96 | - name: Cache Cabal build artifacts 97 | uses: actions/cache@v2 98 | with: 99 | path: | 100 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 101 | dist-newstyle 102 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 103 | restore-keys: | 104 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 105 | 106 | - name: Test 107 | run: cabal test --test-show-details=streaming 108 | env: 109 | HSPEC_OPTIONS: --color 110 | 111 | windows-cabal-build: 112 | runs-on: windows-latest 113 | name: Windows / GHC ${{ matrix.ghc }}, Cabal / test 114 | strategy: 115 | fail-fast: false # don't stop if one job (= GHC version) fails 116 | matrix: 117 | cabal: ["3.6"] # ghcup recommended as of 2021-12-02 118 | ghc: ["9.0"] 119 | 120 | steps: 121 | 122 | # TODO can't do cache fixer on Windows b/c it's a Bash script... 123 | - uses: actions/checkout@v2 124 | with: 125 | fetch-depth: 0 126 | 127 | - name: Setup Haskell build environment 128 | id: setup-haskell-build-env 129 | uses: haskell/actions/setup@v1 130 | with: 131 | ghc-version: ${{ matrix.ghc }} 132 | cabal-version: ${{ matrix.cabal }} 133 | 134 | - run: cabal freeze 135 | 136 | - name: Cache Cabal build artifacts 137 | uses: actions/cache@v2 138 | with: 139 | path: | 140 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 141 | dist-newstyle 142 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 143 | restore-keys: | 144 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 145 | 146 | - name: Test 147 | run: cabal test --test-show-details=streaming 148 | env: 149 | HSPEC_OPTIONS: --color 150 | -------------------------------------------------------------------------------- /.github/workflows/hackage.yml: -------------------------------------------------------------------------------- 1 | # This workflow is based on the expectation that GitHub's runners install GHC 2 | # using ghcup with default settings (installs GHCs to `~/.ghcup/ghc/$VERSION`). 3 | 4 | name: Hackage artifacts 5 | 6 | on: 7 | push: 8 | branches: 9 | - main 10 | 11 | env: 12 | # ghcup needs full version string (e.g. 9.0.1, not 9.0) 13 | ghc: "9.0.1" 14 | EXE_NAME: type-level-sets 15 | 16 | jobs: 17 | hackage: 18 | runs-on: ubuntu-latest 19 | name: Hackage artifacts 20 | 21 | steps: 22 | 23 | # TODO: GHC decides to recompile based on timestamp, so cache isn't used 24 | # Preferably GHC would work via hashes instead. Stack had this feature 25 | # merged in Aug 2020. 26 | # Upstream GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/16495 27 | # My issue on haskell/actions: https://github.com/haskell/actions/issues/41 28 | # This also requires us to do a deep fetch, else we don't get the Git commit 29 | # history we need to rewrite mod times. 30 | - uses: actions/checkout@v2 31 | with: 32 | fetch-depth: 0 33 | - name: Set all tracked file modification times to the time of their last commit 34 | run: | 35 | rev=HEAD 36 | for f in $(git ls-tree -r -t --full-name --name-only "$rev") ; do 37 | touch -d $(git log --pretty=format:%cI -1 "$rev" -- "$f") "$f"; 38 | done 39 | 40 | - name: Delete preinstalled docs-stripped GHC ${{ env.ghc }} 41 | run: rm -rf $HOME/.ghcup/ghc/${{ env.ghc }} 42 | 43 | - name: Cache GHC ${{ env.ghc }} 44 | uses: actions/cache@v2 45 | with: 46 | path: ~/.ghcup/ghc/${{ env.ghc }} 47 | key: haddock-${{ env.ghc }}-ghc 48 | 49 | - name: Install GHC ${{ env.ghc }} if not present from cache 50 | run: | 51 | if [ ! -d $HOME/.ghcup/ghc/${{ env.ghc }} ]; then 52 | ghcup install ghc --force ${{ env.ghc }} 53 | fi 54 | 55 | - run: ghcup set ghc ${{ env.ghc }} 56 | 57 | - run: cabal update 58 | 59 | - run: cabal freeze 60 | 61 | - name: Cache Cabal build artifacts 62 | uses: actions/cache@v2 63 | with: 64 | path: | 65 | ~/.cabal/store 66 | dist-newstyle 67 | key: haddock-${{ env.ghc }}-cabal-${{ hashFiles('cabal.project.freeze') }} 68 | restore-keys: haddock-${{ env.ghc }}-cabal 69 | 70 | - run: cabal haddock --haddock-for-hackage --enable-documentation 71 | - run: cabal sdist 72 | 73 | - name: Upload Hackage sdist 74 | uses: actions/upload-artifact@v2 75 | with: 76 | path: dist-newstyle/sdist/${{ env.EXE_NAME }}-*.tar.gz 77 | name: ${{ env.EXE_NAME }}-sdist-${{ github.sha }}.tar.gz 78 | if-no-files-found: error 79 | 80 | - name: Upload Hackage Haddock docs 81 | uses: actions/upload-artifact@v2 82 | with: 83 | path: dist-newstyle/${{ env.EXE_NAME }}-*-docs.tar.gz 84 | name: ${{ env.EXE_NAME }}-hackage-haddocks-${{ github.sha }}.tar.gz 85 | if-no-files-found: error 86 | 87 | - name: Delete prepared tarballs (else can't extract just newest next time) 88 | run: | 89 | rm dist-newstyle/${{ env.EXE_NAME }}-*-docs.tar.gz 90 | rm dist-newstyle/sdist/${{ env.EXE_NAME }}-*.tar.gz 91 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .dist-newstyle 3 | /dist-newstyle/ 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Dominic Orchard 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 are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This library provides type-level sets and finite maps to Haskell, with value level counterpart, and operations for taking the union, computing 2 | subsets/submaps, and splitting sets/maps. 3 | 4 | This library was originally built based on "Embedding effect systems in Haskell" (Dominic Orchard, 5 | Tomas Petricek ) to embed effect sets. 6 | 7 | The following shows an example: 8 | 9 | {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, MultiParamTypeClasses #-} 10 | import Data.Type.Map 11 | 12 | -- Specifies how to combine duplicate key-value pairs for Int values 13 | type instance Combine Int Int = Int 14 | instance Combinable Int Int where 15 | combine x y = x + y 16 | 17 | foo :: Map '["x" :-> Int, "z" :-> Bool, "w" :-> Int] 18 | foo = Ext (Var :: (Var "x")) 2 19 | $ Ext (Var :: (Var "z")) True 20 | $ Ext (Var :: (Var "w")) 5 21 | Empty 22 | 23 | bar :: Map '["y" :-> Int, "w" :-> Int] 24 | bar = Ext (Var :: (Var "y")) 3 25 | $ Ext (Var :: (Var "w")) 1 26 | $ Empty 27 | 28 | -- foobar :: Map '["w" :-> Int, "x" :-> Int, "y" :-> Int, "z" :-> Bool] 29 | foobar = foo `union` bar 30 | 31 | The 'Map' type for 'foobar' here shows the normalised form (sorted with no duplicates). 32 | The type signatures is commented out as it can be infered. Running the example we get: 33 | 34 | *Main> foobar 35 | {w :-> 6, x :-> 2, y :-> 3, z :-> True} 36 | 37 | Thus, we see that values for 'w' are added. 38 | 39 | import GHC.TypeLits 40 | import Data.Type.Set 41 | type instance Cmp (Natural n) (Natural m) = CmpNat n m 42 | 43 | data Natural (a :: Nat) where 44 | Z :: Natural 0 45 | S :: Natural n -> Natural (n + 1) 46 | 47 | -- foo :: Set '[Natural 0, Natural 1, Natural 3] 48 | foo = asSet $ Ext (S Z) (Ext (S (S (S Z))) (Ext Z Empty)) 49 | 50 | -- bar :: Set '[Natural 1, Natural 2] 51 | bar = asSet $ Ext (S (S Z)) (Ext (S Z) (Ext (S Z) Empty)) 52 | 53 | -- foobar :: Set '[Natural 0, Natural 1, Natural 2, Natural 3] 54 | foobar = foo `union` bar 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # v0.9.0.0 2 | - GHC 9.2 support 3 | - Add Elem typeclass to retrieve the value at a type in a set 4 | - Fix Member typeclass (now returns False instead of failing to typecheck) 5 | - Add some more examples, tests 6 | 7 | # v0.8.9.0 8 | - GHC 8.4 and 8.6 support. 9 | - Fixed bug in the delete operation. 10 | - Non-membership predicates 11 | -------------------------------------------------------------------------------- /examples/ExampleMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, MultiParamTypeClasses #-} 2 | 3 | module ExampleMap where 4 | 5 | import GHC.TypeLits ( Nat, CmpNat, type (+) ) 6 | import Data.Type.Map 7 | 8 | -- Specify that key-value pairs on Ints combine to an Int 9 | type instance Combine Int Int = Int 10 | -- Specify that Int values for matching keys should be added 11 | instance Combinable Int Int where 12 | combine x y = x + y 13 | 14 | foo :: Map '["x" :-> Int, "z" :-> Bool, "w" :-> Int] 15 | foo = Ext (Var :: (Var "x")) 2 16 | $ Ext (Var :: (Var "z")) True 17 | $ Ext (Var :: (Var "w")) 5 18 | $ Empty 19 | 20 | foo' :: Map (AsMap '["z" :-> Bool, "x" :-> Int, "w" :-> Int]) 21 | foo' = asMap foo 22 | 23 | bar :: Map '["y" :-> Int, "w" :-> Int] 24 | bar = Ext (Var :: (Var "y")) 3 $ 25 | Ext (Var :: (Var "w")) 1 $ 26 | Empty 27 | 28 | -- GHC can easily infer this type, so an explicit signature not necessary 29 | -- foobar :: Map '["w" :-> Int, "x" :-> Int, "y" :-> Integer, "z" :-> Int] 30 | foobar = foo `union` bar 31 | 32 | foobarToFoo :: Map '["w" :-> Int, "x" :-> Int, "z" :-> Bool] 33 | foobarToFoo = submap foobar 34 | -------------------------------------------------------------------------------- /examples/ExampleSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, GADTs, StandaloneDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module ExampleSet where 5 | 6 | import GHC.TypeLits ( Nat, CmpNat, type (+) ) 7 | import Data.Type.Set 8 | 9 | type instance Cmp (Natural n) (Natural m) = CmpNat n m 10 | 11 | data Natural (a :: Nat) where 12 | Z :: Natural 0 13 | S :: Natural n -> Natural (n + 1) 14 | 15 | deriving instance Show (Natural n) 16 | 17 | -- foo :: Set '[Natural 0, Natural 1, Natural 3] 18 | foo = asSet $ Ext (S Z) (Ext (S (S (S Z))) (Ext Z Empty)) 19 | 20 | -- bar :: Set '[Natural 1, Natural 2] 21 | bar = asSet $ Ext (S (S Z)) (Ext (S Z) (Ext (S Z) Empty)) 22 | 23 | -- foobar :: Set '[Natural 0, Natural 1, Natural 2, Natural 3] 24 | foobar = foo `union` bar 25 | 26 | nonMemberTest :: NonMember (Natural 0) as => Set as -> () 27 | nonMemberTest set = () 28 | 29 | -- nonMemberTest meep is well typed 30 | meep = asSet $ Ext (S Z) (Ext (S (S Z)) Empty) 31 | -- nonMemberTest morp is ill typed 32 | morp = asSet $ Ext (S Z) (Ext (S (S Z)) (Ext Z Empty)) 33 | -------------------------------------------------------------------------------- /examples/ExampleSet2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, TypeFamilies, GADTs, StandaloneDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module ExampleSet2 where 5 | 6 | import GHC.TypeLits ( Nat, CmpNat, type (+) ) 7 | import Data.Type.Set 8 | 9 | type instance Cmp (Natural n) (Natural m) = CmpNat n m 10 | type instance Cmp String String = 'EQ 11 | type instance Cmp String (Natural _) = 'LT 12 | type instance Cmp (Natural _) String = 'GT 13 | 14 | data Natural (a :: Nat) where 15 | Z :: Natural 0 16 | S :: Natural n -> Natural (n + 1) 17 | 18 | deriving instance Show (Natural n) 19 | 20 | instance Eq (Natural n) where 21 | _ == _ = True 22 | 23 | foo :: Set '[String, Natural 1] 24 | foo = asSet $ Ext "str1" $ Ext (S Z) Empty 25 | 26 | bar :: Set '[String] 27 | bar = asSet $ Ext "str2" Empty 28 | 29 | foobar :: Set '[String, Natural 1] 30 | foobar = foo `union` bar 31 | 32 | barfoo :: Set '[String, Natural 1] 33 | barfoo = bar `union` foo 34 | 35 | fooStr :: String 36 | fooStr = project Proxy foo 37 | 38 | foobarStr :: String 39 | foobarStr = project Proxy foobar 40 | 41 | barfooStr :: String 42 | barfooStr = project Proxy barfoo 43 | 44 | fooHasNat1 :: Bool 45 | fooHasNat1 = member (Proxy :: Proxy (Natural 1)) foo 46 | 47 | barHasNat1 :: Bool 48 | barHasNat1 = member (Proxy :: Proxy (Natural 1)) bar 49 | 50 | r0_9 :: Set '[Natural 0, Natural 1, Natural 2, Natural 3, Natural 4, Natural 5, Natural 6, Natural 7, Natural 8, Natural 9] 51 | r0_9 = 52 | Ext Z $ 53 | Ext (S Z) $ 54 | Ext (S (S Z)) $ 55 | Ext (S (S (S Z))) $ 56 | Ext (S (S (S (S Z)))) $ 57 | Ext (S (S (S (S (S Z))))) $ 58 | Ext (S (S (S (S (S (S Z)))))) $ 59 | Ext (S (S (S (S (S (S (S Z))))))) $ 60 | Ext (S (S (S (S (S (S (S (S Z)))))))) $ 61 | Ext (S (S (S (S (S (S (S (S (S Z))))))))) Empty 62 | 63 | r10_19 :: Set '[Natural 10, Natural 11, Natural 12, Natural 13, Natural 14, Natural 15, Natural 16, Natural 17, Natural 18, Natural 19] 64 | r10_19 = 65 | Ext ((S . S . S . S . S . S . S . S . S . S) Z) $ 66 | Ext ((S . S . S . S . S . S . S . S . S . S . S) Z) $ 67 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 68 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 69 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 70 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 71 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 72 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 73 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) $ 74 | Ext ((S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S . S) Z) Empty 75 | -------------------------------------------------------------------------------- /src/Data/Type/Map.hs: -------------------------------------------------------------------------------- 1 | {- This module provides type-level finite maps. 2 | The implementation is similar to that shown in the paper. 3 | "Embedding effect systems in Haskell" Orchard, Petricek 2014 -} 4 | 5 | {-# LANGUAGE TypeOperators, PolyKinds, DataKinds, KindSignatures, 6 | TypeFamilies, UndecidableInstances, MultiParamTypeClasses, 7 | FlexibleInstances, GADTs, FlexibleContexts, ScopedTypeVariables, 8 | ConstraintKinds, IncoherentInstances, FunctionalDependencies #-} 9 | 10 | module Data.Type.Map (Mapping(..), Union, Unionable, union, append, Var(..), Map(..), 11 | ext, empty, mapLength, 12 | Combine, Combinable(..), Cmp, 13 | Nubable, nub, 14 | Lookup, Member, (:\), Split, split, 15 | IsMember, lookp, Updatable, update, 16 | IsMap, AsMap, asMap, 17 | Sortable, quicksort, 18 | Submap, submap) where 19 | 20 | import GHC.TypeLits 21 | import Data.Type.Bool 22 | import Data.Type.Equality 23 | import Data.Type.Set (Cmp, Proxy(..), Flag(..), Sort, Filter, Filter', (:++)) 24 | 25 | {- Throughout, type variables 26 | 'k' ranges over "keys" 27 | 'v' ranges over "values" 28 | 'kvp' ranges over "key-value-pairs" 29 | 'm', 'n' range over "maps" -} 30 | 31 | -- Mappings 32 | infixr 4 :-> 33 | {-| A key-value pair -} 34 | data Mapping k v = k :-> v 35 | 36 | {-| Union of two finite maps -} 37 | type Union m n = Nub (Sort (m :++ n)) 38 | 39 | {-| Apply 'Combine' to values with matching key (removes duplicate keys) -} 40 | type family Nub t where 41 | Nub '[] = '[] 42 | Nub '[kvp] = '[kvp] 43 | Nub ((k :-> v1) ': (k :-> v2) ': m) = Nub ((k :-> Combine v1 v2) ': m) 44 | Nub (kvp1 ': kvp2 ': s) = kvp1 ': Nub (kvp2 ': s) 45 | 46 | {-| Open type family for combining values in a map (that have the same key) -} 47 | type family Combine (a :: v) (b :: v) :: v 48 | 49 | {-| Delete elements from a map by key -} 50 | type family (m :: [Mapping k v]) :\ (c :: k) :: [Mapping k v] where 51 | '[] :\ k = '[] 52 | ((k :-> v) ': m) :\ k = m :\ k 53 | (kvp ': m) :\ k = kvp ': (m :\ k) 54 | 55 | {-| Type-level lookup of elements from a map -} 56 | type family Lookup (m :: [Mapping k v]) (c :: k) :: Maybe v where 57 | Lookup '[] k = Nothing 58 | Lookup ((k :-> v) ': m) k = Just v 59 | Lookup (kvp ': m) k = Lookup m k 60 | 61 | {-| Membership test as type function -} 62 | type family Member (c :: k) (m :: [Mapping k v]) :: Bool where 63 | Member k '[] = False 64 | Member k ((k :-> v) ': m) = True 65 | Member k (kvp ': m) = Member k m 66 | 67 | ----------------------------------------------------------------- 68 | -- Value-level map with a type-level representation 69 | 70 | {-| Pair a symbol (representing a variable) with a type -} 71 | data Var (k :: Symbol) = Var 72 | 73 | instance KnownSymbol k => Show (Var k) where 74 | show = symbolVal 75 | 76 | {-| A value-level heterogenously-typed Map (with type-level representation in terms of lists) -} 77 | data Map (n :: [Mapping Symbol *]) where 78 | Empty :: Map '[] 79 | Ext :: Var k -> v -> Map m -> Map ((k :-> v) ': m) 80 | 81 | {-| Smart constructor which normalises the representation -} 82 | ext :: (Sortable ((k :-> v) ': m), Nubable (Sort ((k :-> v) ': m))) => Var k -> v -> Map m -> Map (AsMap ((k :-> v) ': m)) 83 | ext k v m = asMap $ Ext k v m 84 | 85 | {-| Smart constructor to match `ext` (but doesn't do anything other than wrap Empty) -} 86 | empty :: Map '[] 87 | empty = Empty 88 | 89 | {-| Length function -} 90 | mapLength :: Map n -> Int 91 | mapLength Empty = 0 92 | mapLength (Ext _ _ xs) = 1 + mapLength xs 93 | 94 | {-| Membership test a type class (predicate) -} 95 | class IsMember v t m | m v -> t where 96 | {-| Value-level lookup of elements from a map, via type class predicate -} 97 | lookp :: Var v -> Map m -> t 98 | 99 | instance {-# OVERLAPS #-} IsMember v t ((v ':-> t) ': m) where 100 | lookp _ (Ext _ x _) = x 101 | 102 | instance {-# OVERLAPPABLE #-} IsMember v t m => IsMember v t (x ': m) where 103 | lookp v (Ext _ _ m) = lookp v m 104 | 105 | 106 | {-| Updatability as a type class -} 107 | class Updatable v t m n where 108 | {-| Update a map with `m` at variable `v` with a value of type `t` 109 | to produce a map of type `n` -} 110 | update :: Map m -> Var v -> t -> Map n 111 | 112 | instance {-# OVERLAPS #-} Updatable v t ((v ':-> s) ': m) ((v ':-> t) ': m) where 113 | update (Ext v _ m) _ x = Ext v x m 114 | 115 | instance Updatable v t m n => Updatable v t ((w ':-> y) ': m) ((w ':-> y) ': n) where 116 | update (Ext w y m) v x = Ext w y (update m v x) 117 | 118 | -- instance Updatable v t '[] '[v ':-> t] where 119 | -- update Empty v x = Ext v x Empty 120 | 121 | instance Updatable v t s ((v ':-> t) ': s) where 122 | update xs v x = Ext v x xs 123 | 124 | 125 | {-| Predicate to check if in normalised map form -} 126 | type IsMap s = (s ~ Nub (Sort s)) 127 | 128 | {-| At the type level, normalise the list form to the map form -} 129 | type AsMap s = Nub (Sort s) 130 | 131 | {-| At the value level, noramlise the list form to the map form -} 132 | asMap :: (Sortable s, Nubable (Sort s)) => Map s -> Map (AsMap s) 133 | asMap x = nub (quicksort x) 134 | 135 | instance Show (Map '[]) where 136 | show Empty = "{}" 137 | 138 | instance (KnownSymbol k, Show v, Show' (Map s)) => Show (Map ((k :-> v) ': s)) where 139 | show (Ext k v s) = "{" ++ show k ++ " :-> " ++ show v ++ show' s ++ "}" 140 | 141 | class Show' t where 142 | show' :: t -> String 143 | instance Show' (Map '[]) where 144 | show' Empty = "" 145 | instance (KnownSymbol k, Show v, Show' (Map s)) => Show' (Map ((k :-> v) ': s)) where 146 | show' (Ext k v s) = ", " ++ show k ++ " :-> " ++ show v ++ (show' s) 147 | 148 | instance Eq (Map '[]) where 149 | Empty == Empty = True 150 | 151 | instance (Eq v, Eq (Map s)) => Eq (Map ((k :-> v) ': s)) where 152 | (Ext Var v m) == (Ext Var v' m') = v == v' && m == m' 153 | 154 | instance Ord (Map '[]) where 155 | compare Empty Empty = EQ 156 | 157 | instance (Ord v, Ord (Map s)) => Ord (Map ((k :-> v) ': s)) where 158 | compare (Ext Var v m) (Ext Var v' m') = compare v v' `mappend` compare m m' 159 | 160 | {-| Union of two finite maps (normalising) -} 161 | union :: (Unionable s t) => Map s -> Map t -> Map (Union s t) 162 | union s t = nub (quicksort (append s t)) 163 | 164 | type Unionable s t = (Nubable (Sort (s :++ t)), Sortable (s :++ t)) 165 | 166 | {-| Append of two finite maps (non normalising) -} 167 | append :: Map s -> Map t -> Map (s :++ t) 168 | append Empty x = x 169 | append (Ext k v xs) ys = Ext k v (append xs ys) 170 | 171 | type instance Cmp (k :: Symbol) (k' :: Symbol) = CmpSymbol k k' 172 | type instance Cmp (k :-> v) (k' :-> v') = CmpSymbol k k' 173 | 174 | {-| Value-level quick sort that respects the type-level ordering -} 175 | class Sortable xs where 176 | quicksort :: Map xs -> Map (Sort xs) 177 | 178 | instance Sortable '[] where 179 | quicksort Empty = Empty 180 | 181 | instance (Sortable (Filter FMin (k :-> v) xs) 182 | , Sortable (Filter FMax (k :-> v) xs) 183 | , FilterV FMin k v xs 184 | , FilterV FMax k v xs) => Sortable ((k :-> v) ': xs) where 185 | quicksort (Ext k v xs) = 186 | quicksort (less k v xs) `append` Ext k v Empty `append` quicksort (more k v xs) 187 | where 188 | less = filterV (Proxy::(Proxy FMin)) 189 | more = filterV (Proxy::(Proxy FMax)) 190 | 191 | {- Filter out the elements less-than or greater-than-or-equal to the pivot -} 192 | class FilterV (f::Flag) k v xs where 193 | filterV :: Proxy f -> Var k -> v -> Map xs -> Map (Filter f (k :-> v) xs) 194 | 195 | instance FilterV f k v '[] where 196 | filterV _ k v Empty = Empty 197 | 198 | class FilterV' (f::Flag) k v k' v' xs (cmp :: Ordering) where 199 | filterV' :: Proxy f -> Proxy cmp -> Var k -> v -> Var k' -> v' -> Map xs -> Map (Filter' f (k :-> v) (k' :-> v') xs cmp) 200 | 201 | instance FilterV' f k v k' v' xs (Cmp k' k) => FilterV f k v ((k' :-> v') ': xs) where 202 | filterV _ _ v (Ext _ v' xs) = 203 | filterV' (Proxy :: Proxy f) (Proxy :: Proxy (Cmp k' k)) (Var :: Var k) v (Var :: Var k') v' xs 204 | 205 | instance (FilterV 'FMin k v xs) => FilterV' FMin k v k' v' xs LT where 206 | filterV' _ _ k v k' v' xs = Ext k' v' (filterV (Proxy :: Proxy FMin) k v xs) 207 | 208 | instance (FilterV 'FMin k v xs) => FilterV' FMin k v k' v' xs EQ where 209 | filterV' _ _ k v k' v' xs = filterV (Proxy :: Proxy FMin) k v xs 210 | 211 | instance (FilterV 'FMin k v xs) => FilterV' FMin k v k' v' xs GT where 212 | filterV' _ _ k v k' v' xs = filterV (Proxy :: Proxy FMin) k v xs 213 | 214 | instance (FilterV 'FMax k v xs) => FilterV' FMax k v k' v' xs LT where 215 | filterV' _ _ k v k' v' xs = filterV (Proxy :: Proxy FMax) k v xs 216 | 217 | instance (FilterV 'FMax k v xs) => FilterV' FMax k v k' v' xs EQ where 218 | filterV' _ _ k v k' v' xs = Ext k' v' (filterV (Proxy :: Proxy FMax) k v xs) 219 | 220 | instance (FilterV 'FMax k v xs) => FilterV' FMax k v k' v' xs GT where 221 | filterV' _ _ k v k' v' xs = Ext k' v' (filterV (Proxy :: Proxy FMax) k v xs) 222 | 223 | class Combinable t t' where 224 | combine :: t -> t' -> Combine t t' 225 | 226 | class Nubable t where 227 | nub :: Map t -> Map (Nub t) 228 | 229 | instance Nubable '[] where 230 | nub Empty = Empty 231 | 232 | instance Nubable '[e] where 233 | nub (Ext k v Empty) = Ext k v Empty 234 | 235 | instance {-# OVERLAPPABLE #-} 236 | (Nub (e ': f ': s) ~ (e ': Nub (f ': s)), 237 | Nubable (f ': s)) => Nubable (e ': f ': s) where 238 | nub (Ext k v (Ext k' v' s)) = Ext k v (nub (Ext k' v' s)) 239 | 240 | instance {-# OVERLAPS #-} 241 | (Combinable v v', Nubable ((k :-> Combine v v') ': s)) 242 | => Nubable ((k :-> v) ': (k :-> v') ': s) where 243 | nub (Ext k v (Ext k' v' s)) = nub (Ext k (combine v v') s) 244 | 245 | 246 | {-| Splitting a union of maps, given the maps we want to split it into -} 247 | class Split s t st where 248 | -- where st ~ Union s t 249 | split :: Map st -> (Map s, Map t) 250 | 251 | instance Split '[] '[] '[] where 252 | split Empty = (Empty, Empty) 253 | 254 | instance {-# OVERLAPPABLE #-} Split s t st => Split (x ': s) (x ': t) (x ': st) where 255 | split (Ext k v st) = let (s, t) = split st 256 | in (Ext k v s, Ext k v t) 257 | 258 | instance {-# OVERLAPS #-} Split s t st => Split (x ': s) t (x ': st) where 259 | split (Ext k v st) = let (s, t) = split st 260 | in (Ext k v s, t) 261 | 262 | instance {-# OVERLAPS #-} (Split s t st) => Split s (x ': t) (x ': st) where 263 | split (Ext k v st) = let (s, t) = split st 264 | in (s, Ext k v t) 265 | 266 | {-| Construct a submap 's' from a supermap 't' -} 267 | class Submap s t where 268 | submap :: Map t -> Map s 269 | 270 | instance Submap '[] '[] where 271 | submap xs = Empty 272 | 273 | instance {-# OVERLAPPABLE #-} Submap s t => Submap s (x ': t) where 274 | submap (Ext _ _ xs) = submap xs 275 | 276 | instance {-# OVERLAPS #-} Submap s t => Submap (x ': s) (x ': t) where 277 | submap (Ext k v xs) = Ext k v (submap xs) 278 | -------------------------------------------------------------------------------- /src/Data/Type/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators, TypeFamilies, 2 | MultiParamTypeClasses, FlexibleInstances, PolyKinds, 3 | FlexibleContexts, UndecidableInstances, ConstraintKinds, 4 | ScopedTypeVariables, TypeInType #-} 5 | 6 | module Data.Type.Set (Set(..), Union, Unionable, union, quicksort, append, 7 | Sort, Sortable, (:++), Split(..), Cmp, Filter, Filter', Flag(..), 8 | Nub, Nubable(..), AsSet, asSet, IsSet, Subset(..), 9 | Delete(..), Proxy(..), remove, Remove, (:\), 10 | Elem(..), Member(..), MemberP, NonMember) where 11 | 12 | import GHC.TypeLits 13 | import Data.Type.Bool 14 | import Data.Type.Equality 15 | 16 | data Proxy (p :: k) = Proxy 17 | 18 | -- Value-level 'Set' representation, essentially a list 19 | --type Set :: [k] -> Type 20 | data Set (n :: [k]) where 21 | {--| Construct an empty set -} 22 | Empty :: Set '[] 23 | {--| Extend a set with an element -} 24 | Ext :: e -> Set s -> Set (e ': s) 25 | 26 | instance Show (Set '[]) where 27 | show Empty = "{}" 28 | 29 | instance (Show e, Show' (Set s)) => Show (Set (e ': s)) where 30 | show (Ext e s) = "{" ++ show e ++ (show' s) ++ "}" 31 | 32 | class Show' t where 33 | show' :: t -> String 34 | instance Show' (Set '[]) where 35 | show' Empty = "" 36 | instance (Show' (Set s), Show e) => Show' (Set (e ': s)) where 37 | show' (Ext e s) = ", " ++ show e ++ (show' s) 38 | 39 | instance Eq (Set '[]) where 40 | (==) _ _ = True 41 | instance (Eq e, Eq (Set s)) => Eq (Set (e ': s)) where 42 | (Ext e m) == (Ext e' m') = e == e' && m == m' 43 | 44 | instance Ord (Set '[]) where 45 | compare _ _ = EQ 46 | instance (Ord a, Ord (Set s)) => Ord (Set (a ': s)) where 47 | compare (Ext a as) (Ext a' as') = case compare a a' of 48 | EQ -> 49 | compare as as' 50 | 51 | other -> 52 | other 53 | 54 | {-| At the type level, normalise the list form to the set form -} 55 | type AsSet s = Nub (Sort s) 56 | 57 | {-| At the value level, noramlise the list form to the set form -} 58 | asSet :: (Sortable s, Nubable (Sort s)) => Set s -> Set (AsSet s) 59 | asSet x = nub (quicksort x) 60 | 61 | {-| Predicate to check if in the set form -} 62 | type IsSet s = (s ~ Nub (Sort s)) 63 | 64 | {-| Useful properties to be able to refer to someties -} 65 | type SetProperties (f :: [k]) = 66 | ( Union f ('[] :: [k]) ~ f, 67 | Split f ('[] :: [k]) f, 68 | Union ('[] :: [k]) f ~ f, 69 | Split ('[] :: [k]) f f, 70 | Union f f ~ f, 71 | Split f f f, 72 | Unionable f ('[] :: [k]), 73 | Unionable ('[] :: [k]) f 74 | ) 75 | {-- Union --} 76 | 77 | {-| Union of sets -} 78 | type Union s t = Nub (Sort (s :++ t)) 79 | 80 | union :: (Unionable s t) => Set s -> Set t -> Set (Union s t) 81 | union s t = nub (quicksort (append s t)) 82 | 83 | type Unionable s t = (Sortable (s :++ t), Nubable (Sort (s :++ t))) 84 | 85 | {-| List append (essentially set disjoint union) -} 86 | type family (:++) (x :: [k]) (y :: [k]) :: [k] where 87 | '[] :++ xs = xs 88 | (x ': xs) :++ ys = x ': (xs :++ ys) 89 | 90 | infixr 5 :++ 91 | 92 | append :: Set s -> Set t -> Set (s :++ t) 93 | append Empty x = x 94 | append (Ext e xs) ys = Ext e (append xs ys) 95 | 96 | {-| Delete elements from a set -} 97 | type family (m :: [k]) :\ (x :: k) :: [k] where 98 | '[] :\ x = '[] 99 | (x ': xs) :\ x = xs :\ x 100 | (y ': xs) :\ x = y ': (xs :\ x) 101 | 102 | class Remove s t where 103 | remove :: Set s -> Proxy t -> Set (s :\ t) 104 | 105 | instance Remove '[] t where 106 | remove Empty Proxy = Empty 107 | 108 | instance {-# OVERLAPS #-} Remove xs x => Remove (x ': xs) x where 109 | remove (Ext _ xs) x@Proxy = remove xs x 110 | 111 | instance {-# OVERLAPPABLE #-} (((y : xs) :\ x) ~ (y : (xs :\ x)), Remove xs x) 112 | => Remove (y ': xs) x where 113 | remove (Ext y xs) (x@Proxy) = Ext y (remove xs x) 114 | 115 | {-| Splitting a union a set, given the sets we want to split it into -} 116 | class Split s t st where 117 | -- where st ~ Union s t 118 | split :: Set st -> (Set s, Set t) 119 | 120 | instance Split '[] '[] '[] where 121 | split Empty = (Empty, Empty) 122 | 123 | instance {-# OVERLAPPABLE #-} Split s t st => Split (x ': s) (x ': t) (x ': st) where 124 | split (Ext x st) = let (s, t) = split st 125 | in (Ext x s, Ext x t) 126 | 127 | instance {-# OVERLAPS #-} Split s t st => Split (x ': s) t (x ': st) where 128 | split (Ext x st) = let (s, t) = split st 129 | in (Ext x s, t) 130 | 131 | instance {-# OVERLAPS #-} (Split s t st) => Split s (x ': t) (x ': st) where 132 | split (Ext x st) = let (s, t) = split st 133 | in (s, Ext x t) 134 | 135 | {-| Remove duplicates from a sorted list -} 136 | type family Nub t where 137 | Nub '[] = '[] 138 | Nub '[e] = '[e] 139 | Nub (e ': e ': s) = Nub (e ': s) 140 | Nub (e ': f ': s) = e ': Nub (f ': s) 141 | 142 | {-| Value-level counterpart to the type-level 'Nub' 143 | Note: the value-level case for equal types is not define here, 144 | but should be given per-application, e.g., custom 'merging' behaviour may be required -} 145 | 146 | class Nubable t where 147 | nub :: Set t -> Set (Nub t) 148 | 149 | instance Nubable '[] where 150 | nub Empty = Empty 151 | 152 | instance Nubable '[e] where 153 | nub (Ext x Empty) = Ext x Empty 154 | 155 | instance Nubable (e ': s) => Nubable (e ': e ': s) where 156 | nub (Ext _ (Ext e s)) = nub (Ext e s) 157 | 158 | instance {-# OVERLAPS #-} (Nub (e ': f ': s) ~ (e ': Nub (f ': s)), 159 | Nubable (f ': s)) => Nubable (e ': f ': s) where 160 | nub (Ext e (Ext f s)) = Ext e (nub (Ext f s)) 161 | 162 | 163 | {-| Construct a subsetset 's' from a superset 't' -} 164 | class Subset s t where 165 | subset :: Set t -> Set s 166 | 167 | instance Subset '[] '[] where 168 | subset xs = Empty 169 | 170 | instance {-# OVERLAPPABLE #-} Subset s t => Subset s (x ': t) where 171 | subset (Ext _ xs) = subset xs 172 | 173 | instance {-# OVERLAPS #-} Subset s t => Subset (x ': s) (x ': t) where 174 | subset (Ext x xs) = Ext x (subset xs) 175 | 176 | 177 | {-| Type-level quick sort for normalising the representation of sets -} 178 | type family Sort (xs :: [k]) :: [k] where 179 | Sort '[] = '[] 180 | Sort (x ': xs) = ((Sort (Filter FMin x xs)) :++ '[x]) :++ (Sort (Filter FMax x xs)) 181 | 182 | data Flag = FMin | FMax 183 | 184 | type family Filter (f :: Flag) (p :: k) (xs :: [k]) :: [k] where 185 | Filter f p '[] = '[] 186 | Filter f p (x ': xs) = Filter' f p x xs (Cmp x p) 187 | 188 | type family Filter' (f :: Flag) (p :: k) (x :: k) (xs :: [k]) cmp where 189 | Filter' FMin p x xs 'LT = x ': Filter FMin p xs 190 | Filter' FMin p x xs eqOrGt = Filter FMin p xs 191 | Filter' FMax p x xs 'LT = Filter FMax p xs 192 | Filter' FMax p x xs eqOrGt = x ': Filter FMax p xs 193 | 194 | type family DeleteFromList (e :: elem) (list :: [elem]) where 195 | DeleteFromList elem '[] = '[] 196 | DeleteFromList elem (x ': xs) = If (Cmp elem x == EQ) 197 | xs 198 | (x ': DeleteFromList elem xs) 199 | 200 | type family Delete elem set where 201 | Delete elem (Set xs) = Set (DeleteFromList elem xs) 202 | 203 | {-| Value-level quick sort that respects the type-level ordering -} 204 | class Sortable xs where 205 | quicksort :: Set xs -> Set (Sort xs) 206 | 207 | instance Sortable '[] where 208 | quicksort Empty = Empty 209 | 210 | instance (Sortable (Filter FMin p xs), 211 | Sortable (Filter FMax p xs), FilterV FMin p xs, FilterV FMax p xs) => Sortable (p ': xs) where 212 | quicksort (Ext p xs) = ((quicksort (less p xs)) `append` (Ext p Empty)) `append` (quicksort (more p xs)) 213 | where less = filterV (Proxy::(Proxy FMin)) 214 | more = filterV (Proxy::(Proxy FMax)) 215 | 216 | {- Filter out the elements less-than or greater-than-or-equal to the pivot -} 217 | class FilterV (f::Flag) p xs where 218 | filterV :: Proxy f -> p -> Set xs -> Set (Filter f p xs) 219 | 220 | class FilterV' (f::Flag) p x xs (cmp :: Ordering) where 221 | filterV' :: Proxy f -> Proxy cmp -> p -> x -> Set xs -> Set (Filter' f p x xs cmp) 222 | 223 | instance FilterV f p '[] where 224 | filterV _ p Empty = Empty 225 | 226 | instance FilterV' f p x xs (Cmp x p) => FilterV f p (x ': xs) where 227 | filterV _ p (Ext x xs) = filterV' (Proxy :: Proxy f) (Proxy :: Proxy (Cmp x p)) p x xs 228 | 229 | instance (FilterV 'FMin p xs) => FilterV' FMin p x xs LT where 230 | filterV' _ _ p x xs = Ext x (filterV (Proxy :: Proxy FMin) p xs) 231 | 232 | instance (FilterV 'FMin p xs) => FilterV' FMin p x xs EQ where 233 | filterV' _ _ p x xs = filterV (Proxy :: Proxy FMin) p xs 234 | 235 | instance (FilterV 'FMin p xs) => FilterV' FMin p x xs GT where 236 | filterV' _ _ p x xs = filterV (Proxy :: Proxy FMin) p xs 237 | 238 | instance (FilterV 'FMax p xs) => FilterV' FMax p x xs LT where 239 | filterV' _ _ p x xs = filterV (Proxy :: Proxy FMax) p xs 240 | 241 | instance (FilterV 'FMax p xs) => FilterV' FMax p x xs EQ where 242 | filterV' _ _ p x xs = Ext x (filterV (Proxy :: Proxy FMax) p xs) 243 | 244 | instance (FilterV 'FMax p xs) => FilterV' FMax p x xs GT where 245 | filterV' _ _ p x xs = Ext x (filterV (Proxy :: Proxy FMax) p xs) 246 | 247 | {-| Open-family for the ordering operation in the sort -} 248 | 249 | type family Cmp (a :: k) (b :: k) :: Ordering 250 | 251 | {-| Access the value at a type present in a set. -} 252 | class Elem a s where 253 | project :: Proxy a -> Set s -> a 254 | 255 | instance {-# OVERLAPS #-} Elem a (a ': s) where 256 | project _ (Ext x _) = x 257 | 258 | instance {-# OVERLAPPABLE #-} Elem a s => Elem a (b ': s) where 259 | project p (Ext _ xs) = project p xs 260 | 261 | -- | Value level type list membership predicate: does the type 'a' show up in 262 | -- the type list 's'? 263 | class Member a s where 264 | member :: Proxy a -> Set s -> Bool 265 | 266 | instance Member a '[] where 267 | member _ Empty = False 268 | 269 | instance {-# OVERLAPS #-} Member a (a ': s) where 270 | member _ (Ext x _) = True 271 | 272 | instance {-# OVERLAPPABLE #-} Member a s => Member a (b ': s) where 273 | member p (Ext _ xs) = member p xs 274 | 275 | -- | Type level type list membership predicate: does the type 'a' show up in the 276 | -- type list 's'? 277 | --type MemberP :: k -> [k] -> Bool 278 | type family MemberP a s :: Bool where 279 | MemberP a '[] = False 280 | MemberP a (a ': s) = True 281 | MemberP a (b ': s) = MemberP a s 282 | 283 | type NonMember a s = MemberP a s ~ False 284 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/wiki/stack.yaml 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-18.10 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /tests/doctest.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest ["src"] 5 | -------------------------------------------------------------------------------- /tests/hspec/MapSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module MapSpec where 6 | 7 | import Test.Hspec 8 | import qualified ExampleMap as Example 9 | 10 | import Data.Type.Map 11 | 12 | -- Compilation test for smart constructors 13 | myMap2 :: Map '[ "w" ':-> Int, "z" ':-> Int] 14 | myMap2 = ext (Var :: (Var "w")) (2::Int) $ ext (Var :: (Var "z")) (4::Int) empty 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "Map tests" $ 19 | it "Map tests" $ do 20 | (lookp (Var @"x") Example.foo) `shouldBe` (2 :: Int) 21 | (lookp (Var @"w") Example.foo) `shouldBe` (5 :: Int) 22 | (lookp (Var @"z") Example.foo) `shouldBe` True 23 | (mapLength Example.foo) `shouldBe` 3 24 | -------------------------------------------------------------------------------- /tests/hspec/SetSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# OPTIONS_GHC -fno-pre-inlining #-} 5 | 6 | module SetSpec where 7 | 8 | import Test.Hspec 9 | import Data.Type.Set 10 | import ExampleSet2 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "Set tests" $ do 15 | it "Nub uses RHS" $ do 16 | fooStr `shouldBe` "str1" 17 | foobarStr `shouldBe` "str2" 18 | barfooStr `shouldBe` "str1" 19 | it "Assert non-membership of a type not in a set at runtime" $ do 20 | barHasNat1 `shouldBe` False 21 | it "Union of large sets should run in reasonable time" $ do 22 | (r0_9 `union` r10_19) `shouldBe` (r0_9 `append` r10_19) 23 | -------------------------------------------------------------------------------- /tests/hspec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /type-level-sets.cabal: -------------------------------------------------------------------------------- 1 | name: type-level-sets 2 | version: 0.9.0.0 3 | synopsis: Type-level sets and finite maps (with value-level counterparts) 4 | description: 5 | This package provides type-level sets (no duplicates, sorted to provide a normal form) via 'Set' and type-level 6 | finite maps via 'Map', with value-level counterparts. 7 | . 8 | Described in the paper \"Embedding effect systems in Haskell\" by Dominic Orchard 9 | and Tomas Petricek (Haskell Symposium, 2014). This version now uses Quicksort to normalise the representation. 10 | . 11 | Here is a brief example for finite maps: 12 | . 13 | > 14 | > import Data.Type.Map 15 | > 16 | > -- Specify how to combine duplicate key-value pairs for Int values 17 | > type instance Combine Int Int = Int 18 | > instance Combinable Int Int where 19 | > combine x y = x + y 20 | > 21 | > foo :: Map '["x" :-> Int, "z" :-> Bool, "w" :-> Int] 22 | > foo = Ext (Var :: (Var "x")) 2 23 | > $ Ext (Var :: (Var "z")) True 24 | > $ Ext (Var :: (Var "w")) 5 25 | > $ Empty 26 | > 27 | > bar :: Map '["y" :-> Int, "w" :-> Int] 28 | > bar = Ext (Var :: (Var "y")) 3 29 | > $ Ext (Var :: (Var "w")) 1 30 | > $ Empty 31 | > 32 | > -- foobar :: Map '["w" :-> Int, "x" :-> Int, "y" :-> Int, "z" :-> Bool] 33 | > foobar = foo `union` bar 34 | . 35 | The 'Map' type for 'foobar' here shows the normalised form (sorted with no duplicates). 36 | The type signatures is commented out as it can be infered. Running the example we get: 37 | . 38 | > >>> foobar 39 | > {w :-> 6, x :-> 2, y :-> 3, z :-> True} 40 | . 41 | Thus, we see that the values for \"w\" are added together. 42 | For sets, here is an example: 43 | . 44 | > import GHC.TypeLits 45 | > import Data.Type.Set 46 | > type instance Cmp (Natural n) (Natural m) = CmpNat n m 47 | > 48 | > data Natural (a :: Nat) where 49 | > Z :: Natural 0 50 | > S :: Natural n -> Natural (n + 1) 51 | > 52 | > -- foo :: Set '[Natural 0, Natural 1, Natural 3] 53 | > foo = asSet $ Ext (S Z) (Ext (S (S (S Z))) (Ext Z Empty)) 54 | > 55 | > -- bar :: Set '[Natural 1, Natural 2] 56 | > bar = asSet $ Ext (S (S Z)) (Ext (S Z) (Ext (S Z) Empty)) 57 | > 58 | > -- foobar :: Set '[Natural 0, Natural 1, Natural 2, Natural 3] 59 | > foobar = foo `union` bar 60 | . 61 | Note the types here are all inferred. 62 | . 63 | license: BSD3 64 | license-file: LICENSE 65 | category: Type System, Data Structures 66 | copyright: 2013-18 University of Kent 67 | author: Dominic Orchard 68 | maintainer: Dominic Orchard 69 | stability: experimental 70 | build-type: Simple 71 | cabal-version: >= 1.10 72 | tested-with: GHC >= 8.2.2 73 | 74 | extra-source-files: changelog.md 75 | 76 | 77 | source-repository head 78 | type: git 79 | location: https://github.com/dorchard/type-level-sets 80 | 81 | library 82 | hs-source-dirs: src 83 | other-extensions: TypeInType 84 | 85 | 86 | exposed-modules: Data.Type.Set 87 | Data.Type.Map 88 | 89 | build-depends: base < 5, 90 | ghc-prim 91 | 92 | test-suite tests 93 | type: exitcode-stdio-1.0 94 | main-is: Spec.hs 95 | hs-source-dirs: examples, tests/hspec 96 | other-modules: 97 | ExampleSet 98 | ExampleSet2 99 | ExampleMap 100 | MapSpec 101 | SetSpec 102 | build-tool-depends: 103 | hspec-discover:hspec-discover >=2.7 && <2.10 104 | build-depends: 105 | type-level-sets 106 | , hspec 107 | , base 108 | default-language: Haskell2010 109 | --------------------------------------------------------------------------------