├── .github └── workflows │ └── build.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── TODO.md ├── bench ├── compare.hs ├── compare.txt ├── match-list.hs ├── match-list.txt ├── match-noop.hs ├── match-noop.txt ├── match-triexpr.hs ├── match-triexpr.txt ├── pairs.hs ├── pairs.txt ├── runtime │ └── zero │ │ ├── bench │ │ ├── compare.runtime │ │ ├── match-list.runtime │ │ ├── match-noop.runtime │ │ ├── match-triexpr.runtime │ │ ├── ord.runtime │ │ ├── pairs.runtime │ │ ├── sort.runtime │ │ ├── tiers-complete.runtime │ │ └── tiers.runtime │ │ ├── eg │ │ ├── u-conjure.runtime │ │ ├── u-extrapolate.runtime │ │ └── u-speculate.runtime │ │ └── versions ├── sort.hs ├── sort.txt ├── tiers-complete.hs ├── tiers-complete.txt ├── tiers.hs ├── tiers.txt └── versions ├── changelog.md ├── doc └── express.svg ├── eg ├── u-conjure.hs ├── u-conjure.txt ├── u-extrapolate.hs ├── u-extrapolate.txt ├── u-speculate.hs └── u-speculate.txt ├── etc └── hugs-backports │ └── Data │ └── Function.hs ├── express.cabal ├── mk ├── All.hs ├── Toplibs.hs ├── depend.mk ├── ghcdeps ├── haddock-i ├── haskell.mk └── install-on ├── src └── Data │ ├── Express.hs │ └── Express │ ├── Basic.hs │ ├── Canon.hs │ ├── Core.hs │ ├── Express.hs │ ├── Express │ └── Derive.hs │ ├── Fixtures.hs │ ├── Fold.hs │ ├── Hole.hs │ ├── Instances.hs │ ├── Map.hs │ ├── Match.hs │ ├── Name.hs │ ├── Name │ └── Derive.hs │ ├── Triexpr.hs │ ├── Utils.hs │ └── Utils │ ├── List.hs │ ├── String.hs │ ├── TH.hs │ └── Typeable.hs ├── stack.yaml └── test ├── Test.hs ├── Test └── ListableExpr.hs ├── basic.hs ├── canon.hs ├── core.hs ├── express-derive.hs ├── express.hs ├── fixtures.hs ├── fold.hs ├── hole.hs ├── instances.hs ├── listable.hs ├── main.hs ├── map.hs ├── match.hs ├── name-derive.hs ├── name.hs ├── ord.hs ├── sdist ├── show.hs ├── triexpr.hs ├── typecheck.hs └── utils.hs /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | # Builds and tests this Haskell project on "GitHub Actions" 2 | # 3 | # 2021-2024 Rudy Matela 4 | # 5 | # some docs: https://github.com/haskell-actions/setup 6 | # 7 | # The official haskell docker image: https://hub.docker.com/_/haskell 8 | name: build 9 | on: [push] 10 | jobs: 11 | build-and-test: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - run: git --version 15 | - run: make --version 16 | - run: ghc --version 17 | - run: cabal --version 18 | 19 | - name: Check out repository 20 | uses: actions/checkout@v3 21 | 22 | # check out needs to happen before cache so that hashing works 23 | - name: Cache hash 24 | run: echo Cache hash = ${{ hashFiles('*.cabal') }} 25 | 26 | - name: Cache cabal (source) packages 27 | uses: actions/cache@v3 28 | with: 29 | path: | 30 | ~/.cabal/packages 31 | ~/.cache/cabal 32 | key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} 33 | restore-keys: v1-${{ runner.os }}-cabal-packages- 34 | 35 | - name: Cache installed cabal packages 36 | uses: actions/cache@v3 37 | with: 38 | path: | 39 | ~/.cabal 40 | !~/.cabal/packages 41 | ~/.config/cabal 42 | ~/.local/state/cabal 43 | ~/.ghc 44 | key: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }} 45 | restore-keys: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }} 46 | # restore with exact match has some versions of cabal have trouble updating 47 | 48 | - run: haddock --version || sudo apt-get install ghc-haddock 49 | # blank line 50 | # blank line for alignment with matrix scripts 51 | 52 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 53 | 54 | - run: ghc-pkg list 55 | - run: make install-dependencies 56 | - run: ghc-pkg list 57 | 58 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 59 | 60 | - run: make 61 | - run: make test 62 | - run: make haddock 63 | - run: make test-sdist 64 | - run: make test-via-cabal 65 | 66 | 67 | test-with-ghc: 68 | strategy: 69 | max-parallel: 6 70 | matrix: 71 | # starting with 9.10, docker/_/haskell requires -bullseye as suffix 72 | ghc: 73 | - '9.10-bullseye' 74 | - '9.8' 75 | - '9.6' 76 | - '9.4' 77 | - '9.2' 78 | - '9.0' 79 | - '8.10' 80 | - '8.8' 81 | runs-on: ubuntu-latest 82 | needs: build-and-test 83 | container: haskell:${{ matrix.ghc }} 84 | steps: 85 | - run: git --version || true # git is missing in some images 86 | - run: make --version || true # make is missing in some images 87 | - run: ghc --version 88 | - run: cabal --version 89 | 90 | - name: Check out repository 91 | uses: actions/checkout@v3 92 | 93 | # check out needs to happen before cache so that hashing works 94 | - name: Cache hash 95 | run: echo Cache hash = ${{ hashFiles('*.cabal') }} 96 | 97 | - name: Cache cabal (source) packages 98 | uses: actions/cache@v3 99 | with: 100 | path: | 101 | ~/.cabal/packages 102 | ~/.cache/cabal 103 | key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} 104 | restore-keys: v1-${{ runner.os }}-cabal-packages- 105 | 106 | - name: Cache installed cabal packages 107 | uses: actions/cache@v3 108 | with: 109 | path: | 110 | ~/.cabal 111 | !~/.cabal/packages 112 | ~/.config/cabal 113 | ~/.local/state/cabal 114 | ~/.ghc 115 | key: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }} 116 | restore-keys: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }} 117 | # restore with exact match has some versions of cabal have trouble updating 118 | 119 | - run: make --version || rm /etc/apt/sources.list.d/*.list # faster update 120 | - run: make --version || apt-get update 121 | - run: make --version || apt-get install make 122 | 123 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 124 | 125 | - run: ghc-pkg list 126 | - run: make install-dependencies 127 | - run: ghc-pkg list 128 | 129 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 130 | 131 | - run: make 132 | - run: make test 133 | - run: make haddock 134 | - run: make test-sdist 135 | - run: make test-via-cabal 136 | 137 | test-with-stack: 138 | runs-on: ubuntu-latest 139 | needs: build-and-test 140 | steps: 141 | - name: Check out repository 142 | uses: actions/checkout@v3 143 | 144 | # check out needs to happen before cache so that hashing works 145 | - name: Cache hash 146 | run: echo Cache hash = ${{ hashFiles('stack.yaml') }} 147 | 148 | - name: Cache stack folder 149 | uses: actions/cache@v3 150 | with: 151 | path: ~/.stack 152 | key: v1-${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} 153 | restore-keys: v1-${{ runner.os }}-stack- 154 | 155 | - name: Cache ghcup folder 156 | uses: actions/cache@v3 157 | with: 158 | path: | 159 | ~/.ghcup 160 | /usr/local/.ghcup/bin 161 | /usr/local/.ghcup/db 162 | /usr/local/.ghcup/ghc/9.4.8 163 | key: v1-${{ runner.os }}-ghcup-${{ hashFiles('stack.yaml') }} 164 | restore-keys: v1-${{ runner.os }}-ghcup- 165 | 166 | - name: Setup Haskell's GHC and Cabal as required by current Stackage LTS 167 | uses: haskell-actions/setup@v2 168 | with: # lts-21.25 169 | ghc-version: '9.4.8' 170 | cabal-version: '3.8' 171 | 172 | - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true 173 | 174 | - run: stack --version 175 | 176 | - run: make test-via-stack 177 | 178 | - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true 179 | 180 | test-with-hugs: 181 | runs-on: ubuntu-latest 182 | needs: build-and-test 183 | steps: 184 | - run: sudo apt-get update 185 | - run: sudo apt-get install hugs 186 | - name: Check out repository 187 | uses: actions/checkout@v3 188 | - run: make hugs-test 189 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | .stack-work 4 | idx/ 5 | dist/ 6 | dist-newstyle/ 7 | log/ 8 | *.swp 9 | *.swo 10 | *.swn 11 | *.swm 12 | *.o 13 | *.hi 14 | *.dyn_hi 15 | *.dyn_o 16 | TAGS 17 | tags 18 | eg/u-extrapolate 19 | eg/u-speculate 20 | eg/u-conjure 21 | bench/compare 22 | bench/match-noop 23 | bench/match-list 24 | bench/match-triexpr 25 | bench/pairs 26 | bench/sort 27 | bench/tiers 28 | bench/tiers-complete 29 | test/canon 30 | test/core 31 | test/basic 32 | test/express 33 | test/express-derive 34 | test/fixtures 35 | test/hole 36 | test/instances 37 | test/listable 38 | test/main 39 | test/map 40 | test/match 41 | test/name 42 | test/name-derive 43 | test/utils 44 | test/fold 45 | test/ord 46 | test/show 47 | test/triexpr 48 | doc/**/*.html 49 | doc/**/*.css 50 | doc/**/*.js 51 | doc/**/*.png 52 | doc/**/*.gif 53 | doc/**/*.json 54 | README.html 55 | mk/toplibs 56 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019-2024, Rudy Matela 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 | * Neither the name of Rudy Matela nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for express 2 | # 3 | # Copyright: (c) 2015-2024 Rudy Matela 4 | # License: 3-Clause BSD (see the file LICENSE) 5 | # Maintainer: Rudy Matela 6 | TESTS = \ 7 | test/main \ 8 | test/core \ 9 | test/basic \ 10 | test/map \ 11 | test/instances \ 12 | test/fixtures \ 13 | test/express \ 14 | test/express-derive \ 15 | test/name \ 16 | test/name-derive \ 17 | test/utils \ 18 | test/canon \ 19 | test/match \ 20 | test/hole \ 21 | test/fold \ 22 | test/show \ 23 | test/ord \ 24 | test/triexpr \ 25 | test/listable 26 | EGS = 27 | BENCHS = \ 28 | eg/u-extrapolate \ 29 | eg/u-speculate \ 30 | eg/u-conjure \ 31 | bench/compare \ 32 | bench/match-list \ 33 | bench/match-noop \ 34 | bench/match-triexpr \ 35 | bench/pairs \ 36 | bench/sort \ 37 | bench/tiers \ 38 | bench/tiers-complete \ 39 | $(EGS) 40 | GHCIMPORTDIRS = src:test 41 | GHCFLAGS = -O2 -v0 $(shell grep -q "Arch Linux" /etc/lsb-release && echo -dynamic) 42 | HUGSIMPORTDIRS = .:./src:./test:./etc/hugs-backports:/usr/lib/hugs/packages/*:../leancheck/src 43 | HUGSFLAGS = -98 -h32M 44 | RUNPARAMETERS = 45 | LIB_DEPS = base template-haskell 46 | INSTALL_DEPS = leancheck template-haskell 47 | 48 | # to run a specific test suite under a specific GHC, do: 49 | # $ make clean 50 | # $ make GHC=ghc-9.6 GHCIMPORTDIRS=src:test:../leancheck/src test/utils.run 51 | # this is useful for troubleshooting CI failures 52 | 53 | all: mk/toplibs 54 | 55 | all-all: mk/All.o 56 | 57 | test: $(patsubst %,%.run,$(TESTS)) test-sdist diff-test 58 | 59 | slow-test: RUNPARAMETERS=50400 60 | slow-test: test 61 | 62 | %.run: % 63 | ./$< $(RUNPARAMETERS) 64 | 65 | .PHONY: bench 66 | bench: $(patsubst %,%.bench,$(BENCHS)) 67 | @mkdir -p bench/runtime/$$HOSTNAME 68 | ./bench/versions | tee bench/runtime/$$HOSTNAME/versions 69 | 70 | .PHONY: %.bench 71 | %.bench: % 72 | @mkdir -p bench/runtime/$$HOSTNAME/$< 73 | @rmdir bench/runtime/$$HOSTNAME/$< 74 | @printf "%-20s " $< 75 | @/usr/bin/time -f%e ./$< 2>&1 >/dev/null | tee bench/runtime/$$HOSTNAME/$<.runtime 76 | 77 | clean: clean-hi-o clean-haddock 78 | rm -f $(TESTS) $(BENCHS) $(EGS) mk/toplibs 79 | 80 | ghci: mk/All.ghci 81 | 82 | hugs: src/Data/Express/Core.hugs 83 | 84 | hugs-test: \ 85 | test/typecheck.runhugs 86 | 87 | install: 88 | @echo "use \`cabal install' instead" 89 | 90 | test-sdist: 91 | ./test/sdist 92 | 93 | test-via-cabal: 94 | cabal configure --enable-tests --enable-benchmarks --ghc-options="$(GHCFLAGS) -O0" 95 | cabal build 96 | cabal test main 97 | 98 | test-via-stack: 99 | stack test express:test:main --ghc-options="$(GHCFLAGS) -O0" --system-ghc --no-install-ghc --no-terminal 100 | 101 | diff-test: $(patsubst %,%.diff,$(BENCHS)) 102 | 103 | txt: $(patsubst %,%.txt,$(BENCHS)) 104 | 105 | %.diff: % 106 | ./$< | diff -rud $<.txt - 107 | 108 | %.txt: % 109 | ./$< >$<.txt 110 | 111 | test-via-everything: test test-via-cabal test-via-stack 112 | 113 | test-on-ghc-9.10: 114 | make test GHC=ghc-9.10 GHCIMPORTDIRS=src:test:../leancheck/src 115 | 116 | prepare: 117 | cabal update 118 | cabal install $(ALL_DEPS) --lib 119 | 120 | hlint: ..hlint 121 | 122 | test.hlint: HLINT_EXTRA = --ignore "Redundant ==" \ 123 | --ignore "Use null" \ 124 | --ignore "Redundant $$" \ 125 | --ignore "Use isNothing" 126 | 127 | %.hlint: 128 | hlint $(HLINT_EXTRA) \ 129 | --ignore "Use import/export shortcut" \ 130 | --ignore "Redundant bracket" \ 131 | --ignore "Use lambda-case" \ 132 | --ignore "Use typeRep" \ 133 | $* 134 | 135 | markdown: README.html 136 | 137 | %.html: %.md 138 | pandoc $< -o $@ 139 | 140 | # NOTE: (very hacky!) the following target allows parallel compilation (-jN) of 141 | # eg and test programs so long as they don't share dependencies _not_ stored 142 | # in src/ and test/. Runnable binaries should depend on mk/toplibs instead of 143 | # actual Haskell source files 144 | mk/toplibs: mk/Toplibs.o 145 | touch mk/toplibs 146 | 147 | include mk/haskell.mk 148 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | TO DO list for Express 2 | ====================== 3 | 4 | Nothing planned at the moment. 5 | -------------------------------------------------------------------------------- /bench/compare.hs: -------------------------------------------------------------------------------- 1 | -- ord.hs -- prints results of the Ord Expr's instance 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | import Test 6 | import System.Environment (getArgs) 7 | 8 | main :: IO () 9 | main = do 10 | as <- getArgs 11 | let n = case as of 12 | [] -> 5040 13 | (n:_) -> read n 14 | putStrLn . unlines . map showCompare $ take n (list :: [(Expr,Expr)]) 15 | where 16 | showCompare (e1,e2) = concat 17 | [ show e1 18 | , " `compare` " 19 | , show e2 20 | , " = " 21 | , show $ e1 `compare` e2 22 | ] 23 | -------------------------------------------------------------------------------- /bench/match-list.hs: -------------------------------------------------------------------------------- 1 | -- match-list.hs -- how long it takes to match expression in a list? 2 | -- 3 | -- Copyright (c) 2021-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- This program has the same parameters as other match*.hs benchmarks. 7 | import Test 8 | 9 | 10 | 11 | showEq :: (Expr, Expr) -> String 12 | showEq (lhs, rhs) = showExpr lhs ++ " = " ++ showExpr rhs 13 | 14 | exprs :: [Expr] 15 | exprs = take 360360 list 16 | 17 | query :: Expr -> Maybe (Expr,[(Expr,Expr)],Expr) 18 | query e = listToMaybe [(e1,ms,e2) | (e1,e2) <- sort allRules, ms <- maybeToList (e `match` e1)] 19 | 20 | main :: IO () 21 | main = do 22 | putStrLn $ unlines $ map showEq allRules 23 | putStrLn $ unlines $ map show $ mapMaybe query $ take 1080 exprs 24 | print $ (== ']') $ last $ show $ mapMaybe query exprs 25 | -------------------------------------------------------------------------------- /bench/match-noop.hs: -------------------------------------------------------------------------------- 1 | -- exprs.hs -- how long it takes to enumerate expressions? 2 | -- 3 | -- Copyright (c) 2021-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- This program has the same parameters as other match*.hs benchmarks. 7 | import Test 8 | 9 | 10 | 11 | showEq :: (Expr, Expr) -> String 12 | showEq (lhs, rhs) = showExpr lhs ++ " = " ++ showExpr rhs 13 | 14 | exprs :: [Expr] 15 | exprs = take 360360 list 16 | 17 | query :: Expr -> Maybe (Expr,[(Expr,Expr)],Expr) 18 | query e = Just (e,[],e) 19 | 20 | main :: IO () 21 | main = do 22 | putStrLn $ unlines $ map showEq allRules 23 | putStrLn $ unlines $ map show $ mapMaybe query $ take 1080 exprs 24 | print $ (== ']') $ last $ show $ mapMaybe query exprs 25 | -------------------------------------------------------------------------------- /bench/match-triexpr.hs: -------------------------------------------------------------------------------- 1 | -- triexpr.hs -- how long it takes to match expressions in a Triexpr? 2 | -- 3 | -- Copyright (c) 2021-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- This program has the same parameters as other match*.hs benchmarks. 7 | import Test 8 | import Data.Express.Triexpr (Triexpr) 9 | import qualified Data.Express.Triexpr as T 10 | 11 | showEq :: (Expr, Expr) -> String 12 | showEq (lhs, rhs) = showExpr lhs ++ " = " ++ showExpr rhs 13 | 14 | exprs :: [Expr] 15 | exprs = take 360360 list 16 | 17 | query :: Expr -> Maybe (Expr,[(Expr,Expr)],Expr) 18 | query e = listToMaybe $ T.lookup e trie 19 | 20 | main :: IO () 21 | main = do 22 | putStrLn $ unlines $ map showEq allRules 23 | putStrLn $ unlines $ map show $ mapMaybe query $ take 1080 exprs 24 | print $ (== ']') $ last $ show $ mapMaybe query exprs 25 | 26 | trie :: Triexpr Expr 27 | trie = T.fromList allRules 28 | -------------------------------------------------------------------------------- /bench/pairs.hs: -------------------------------------------------------------------------------- 1 | -- pairs.hs -- a thousand pairs of expressions 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | import Test 6 | import System.Environment (getArgs) 7 | 8 | main :: IO () 9 | main = do 10 | as <- getArgs 11 | let n = case as of 12 | [] -> 1000 13 | (n:_) -> read n 14 | putStrLn . unlines . map show $ take n (list :: [(Expr,Expr)]) 15 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/compare.runtime: -------------------------------------------------------------------------------- 1 | 0.05 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/match-list.runtime: -------------------------------------------------------------------------------- 1 | 2.28 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/match-noop.runtime: -------------------------------------------------------------------------------- 1 | 1.70 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/match-triexpr.runtime: -------------------------------------------------------------------------------- 1 | 2.23 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/ord.runtime: -------------------------------------------------------------------------------- 1 | 0.16 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/pairs.runtime: -------------------------------------------------------------------------------- 1 | 0.04 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/sort.runtime: -------------------------------------------------------------------------------- 1 | 0.23 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/tiers-complete.runtime: -------------------------------------------------------------------------------- 1 | 1.24 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/bench/tiers.runtime: -------------------------------------------------------------------------------- 1 | 0.24 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/eg/u-conjure.runtime: -------------------------------------------------------------------------------- 1 | 0.37 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/eg/u-extrapolate.runtime: -------------------------------------------------------------------------------- 1 | 0.04 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/eg/u-speculate.runtime: -------------------------------------------------------------------------------- 1 | 0.35 2 | -------------------------------------------------------------------------------- /bench/runtime/zero/versions: -------------------------------------------------------------------------------- 1 | GHC 9.0.2 2 | -------------------------------------------------------------------------------- /bench/sort.hs: -------------------------------------------------------------------------------- 1 | -- ord.hs -- prints different expression sortins: 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | import Test 6 | import Data.List (intercalate, nub) 7 | import Test.LeanCheck.Tiers (showTiers) 8 | import Data.Express.Utils.List 9 | 10 | showL :: Show a => [a] -> String 11 | showL xs = " [ " ++ intercalate "\n , " (map show xs) ++ "\n ]\n" 12 | 13 | printL :: Show a => [a] -> IO () 14 | printL = putStrLn . showL 15 | 16 | main :: IO () 17 | main = do 18 | putStrLn "sort $ take 5040 $ list :: [ Expr ] =" 19 | printL (sort $ take 5040 list :: [Expr]) 20 | 21 | putStrLn "sortBy compareLexicographically $ take 5040 $ list :: [ Expr ] =" 22 | printL (sortBy compareLexicographically $ take 5040 list :: [Expr]) 23 | 24 | putStrLn "sortBy compareQuickly $ take 5040 $ list :: [ Expr ] =" 25 | printL (sortBy compareQuickly $ take 5040 list :: [Expr]) 26 | -------------------------------------------------------------------------------- /bench/tiers-complete.hs: -------------------------------------------------------------------------------- 1 | -- tiers-complete.hs -- prints tiers of complete expressions 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- Complete expressions are those without any holes _. 7 | -- 8 | -- This is closely related to tiers.hs 9 | import Test 10 | import Data.List (intercalate, nub) 11 | import Test.LeanCheck.Tiers (showTiers) 12 | import Data.Express.Utils.List 13 | 14 | showDotsLongerThan :: Show a => Int -> [a] -> String 15 | showDotsLongerThan n xs = "[" 16 | ++ intercalate "," (dotsLongerThan n $ map show xs) 17 | ++ "]" 18 | where 19 | dotsLongerThan n xs = take n xs ++ ["..." | not . null $ drop n xs] 20 | 21 | printTiers :: Show a => Int -> [[a]] -> IO () 22 | printTiers n = putStrLn . init . unlines . map (" " ++) . lines . showTiers n 23 | 24 | main :: IO () 25 | main = do 26 | putStrLn $ "isNub (filter isComplete list :: [Expr]) = " 27 | ++ show (isNub (take 5040 $ filter isComplete list)) 28 | putStrLn $ "map length (filterT isComplete tiers :: [[ Expr ]]) = " 29 | ++ showDotsLongerThan 11 (map length (filterT isComplete tiers :: [[Expr]])) 30 | putStrLn "filterT isComplete tiers :: [[ Expr ]] =" 31 | printTiers 8 (filterT isComplete tiers :: [[Expr]]) 32 | -------------------------------------------------------------------------------- /bench/tiers.hs: -------------------------------------------------------------------------------- 1 | -- tiers.hs -- prints tiers of expressions 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | 6 | 7 | 8 | 9 | import Test 10 | import Data.List (intercalate, nub) 11 | import Test.LeanCheck.Tiers (showTiers) 12 | import Data.Express.Utils.List 13 | 14 | showDotsLongerThan :: Show a => Int -> [a] -> String 15 | showDotsLongerThan n xs = "[" 16 | ++ intercalate "," (dotsLongerThan n $ map show xs) 17 | ++ "]" 18 | where 19 | dotsLongerThan n xs = take n xs ++ ["..." | not . null $ drop n xs] 20 | 21 | printTiers :: Show a => Int -> [[a]] -> IO () 22 | printTiers n = putStrLn . init . unlines . map (" " ++) . lines . showTiers n 23 | 24 | main :: IO () 25 | main = do 26 | putStrLn $ "isNub (list :: [Expr]) = " 27 | ++ show (isNub (take 5040 list :: [Expr])) 28 | putStrLn $ "map length (tiers :: [[ Expr ]]) = " 29 | ++ showDotsLongerThan 9 (map length (tiers :: [[Expr]])) 30 | putStrLn "tiers :: [[ Expr ]] =" 31 | printTiers 7 (tiers :: [[Expr]]) 32 | -------------------------------------------------------------------------------- /bench/versions: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | get-ghc-v() { 3 | ghc --version | sed -e "s/.* version/GHC/" 4 | } 5 | get-ghc-v 6 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | Changelog for Express 2 | ===================== 3 | 4 | 5 | v1.0.18 (January 2025) 6 | ---------------------- 7 | 8 | * No changes the API. 9 | 10 | * Minor improvements in Haddock documentation. 11 | 12 | * Fix build of tests on GHC >= 9.10. (Libs unaffected) 13 | 14 | * Rework CI scripts and add a couple more tests. 15 | 16 | 17 | v1.0.16 (February 2024) 18 | ----------------------- 19 | 20 | * No changes in the main API 21 | 22 | * `Data.Fixtures`: support more types in existing functions 23 | 24 | * `Data.Fixtures`: add `filter'`, `drop'`, `take'`, `foldr'`, `ff2`, `ff3`, ... 25 | 26 | 27 | v1.0.14 (January 2024) 28 | ---------------------- 29 | 30 | * `Data.Express`: add `>$$<`, `>$$` and `$$<`. 31 | 32 | * fix pretty-printing bug: 33 | an expression encoding `x:y:([] ++ _) :: [Int]` 34 | was being displayed as `[x,y,] ++ _ :: [Int]`. 35 | 36 | * `Data.Express.Fixtures`: update `-..`, `--..` and `--..-`. 37 | 38 | * improve pretty-printing 39 | 40 | * make ordering of `typesIn` consistent between GHC 9.8 and earlier versions 41 | 42 | * fix a test failure on GHC 9.6 (previous GHC versions unaffected) 43 | 44 | * simplify and improve testing, new benchmark and minor updates 45 | 46 | 47 | v1.0.12 (July 2023) 48 | ------------------- 49 | 50 | * make ordering of `typesIn` consistent between GHC 9.6 and earlier versions 51 | 52 | * fix a test failure on GHC 9.6 (previous GHC versions unaffected) 53 | 54 | * drop support for GHC 8.0, GHC 7.10 and GHC 7.8. 55 | The current version will still work in these, 56 | but these are not run on CI anymore 57 | and future versions will no longer be tested. 58 | 59 | * miscellaneous improvements in build and CI scripts 60 | 61 | 62 | v1.0.10 (April 2022) 63 | -------------------- 64 | 65 | * show function-encoded Ordering case expressions exceptionally 66 | 67 | * show function-encoded Bool case expressions exceptionally 68 | 69 | * add `caseBool` and `caseOrdering` to `Data.Express.Fixtures` 70 | 71 | * minor updates in Makefile and CI scripts 72 | 73 | 74 | v1.0.8 (September 2021) 75 | ----------------------- 76 | 77 | * `Data.Express.Express.Derive`: 78 | fix generation of `-:` and `->:` in earlier GHC's. 79 | 80 | * `Data.Express.Utils.TH`: 81 | add `unboundVars`, `toBounded` and `toBoundedQ`. 82 | 83 | 84 | v1.0.6 (September 2021) 85 | ----------------------- 86 | 87 | * fix pretty printing of unapplied infixed variable functions: 88 | use `f :: ...` instead of ``(`f`) :: ...`` 89 | 90 | * `Data.Express.Fixtures`: 91 | add `init'`, `div'`, `mod'`, `quot'`, `rem'`, `question` and `oo`. 92 | 93 | * minor fixes in README 94 | 95 | 96 | v1.0.4 (July 2021) 97 | ------------------ 98 | 99 | * deeply encode `Ratio`s 100 | * add `Express (Complex a)` instance 101 | * add several missing `Name` instances 102 | * `deriveName` now uses `x` for `Num` instances 103 | 104 | 105 | v1.0.2 (July 2021) 106 | ------------------ 107 | 108 | * more Express instances: 109 | - `Double` & `Float` 110 | - `Int*` types from `Data.Int` 111 | - `Word*` types from `Data.Word` 112 | - `GeneralCategory` from `Data.Char` 113 | 114 | * minor fix in README 115 | 116 | 117 | v1.0.0 (July 2021) 118 | ------------------ 119 | 120 | This release indicates that the `Data.Express` API is now stable. 121 | 122 | * no changes since v0.2.0 or v0.1.16. 123 | 124 | 125 | v0.2.0 (July 2021) 126 | ------------------ 127 | 128 | This release indicates that the `Data.Express` API is stable. 129 | 130 | * no changes since v0.1.16 131 | 132 | 133 | v0.1.16 (July 2021) 134 | ------------------- 135 | 136 | * add `five`, `six`, ... `twelve` to `Data.Express.Fixtures`. 137 | 138 | * add `cs_` to `Data.Express.Fixtures`. 139 | 140 | * improve backwards compatibility: 141 | `Data.Express.Core/Hole/Match/Map/Name/Triexpr/Utils` now work on Hugs. 142 | 143 | * 100% Haddock coverage on most modules including REPL examples. 144 | 145 | 146 | v0.1.14 (June 2021) 147 | ------------------- 148 | 149 | * permit and pretty-print `[..]` notations. 150 | 151 | * improve default variable names when canonicalizing 152 | - lists are named xs, ys, xss, yss, etc. 153 | - functions are named f, g, h 154 | - before they were simply x, y, z 155 | 156 | 157 | v0.1.12 (May 2021) 158 | ------------------ 159 | 160 | * `Data.Express.Fixtures`, add several symbols: 161 | - `hh` and `hhE`; 162 | - `four` and `zzs`; 163 | - `signum'` and `signumE`; 164 | - `compose` and `-.-`; 165 | - `mapE` and `map'`. 166 | 167 | * Add the experimental `Triexpr` module, including: 168 | - the `Triexpr` type; 169 | - tests; 170 | - benchmarks. 171 | 172 | * Retire Travis as the CI 173 | 174 | 175 | v0.1.10 (May 2021) 176 | ------------------ 177 | 178 | * add the `hasHole` and `isComplete` functions 179 | * add the `encompasses` function 180 | * add `appendInt` to `Data.Express.Fixtures` 181 | * add the `u-conjure` example 182 | * the `Express` typeclass now requires `Show` 183 | * improve examples in the `eg/` folder 184 | * improve tests of `hasInstanceOf` and `isInstanceOf` 185 | * improve tests 186 | * add this changelog 187 | 188 | 189 | v0.1.8 (April 2021) 190 | ------------------- 191 | 192 | * slightly change behaviour of `canonicalVariations` and related functions. 193 | * add more fixtures and improve fixtures' documentation 194 | * improve Makefile and test scripts 195 | * use GitHub actions as CI 196 | 197 | 198 | v0.1.6 (April 2021) 199 | ------------------- 200 | 201 | * add `compareLexicographically` and `compareQuickly` 202 | * define behaviour of `canonicalVariations` for some undefined cases 203 | * improve haddock documentation 204 | * improve tests 205 | 206 | 207 | v0.1.4 (April 2021) 208 | ------------------- 209 | 210 | * add the `fill` and `isFun` functions 211 | * `Data.Express.Fixtures`: more fixtures, define fixity 212 | * add fixity for some fixtures 213 | * improve documentation, tests and lint 214 | 215 | 216 | v0.1.3 (March 2020) 217 | ------------------- 218 | 219 | See the git commit log for v0.1.3 and previous versions 220 | down to as early as February 2019. 221 | -------------------------------------------------------------------------------- /doc/express.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | Express 21 | 23 | 25 | 29 | 30 | 31 | 53 | 55 | 56 | 58 | image/svg+xml 59 | 61 | Express 62 | 64 | 2019-08-03 65 | 66 | 67 | Rudy Matela 68 | 69 | 70 | https://github.com/rudymatela/express 71 | 72 | 73 | Express 74 | Haskell 75 | logo 76 | 77 | 78 | Express's logo. An X is seen in blue intersected with a lambda sign. 79 | 80 | The proportions are based on the beautiful proportions of the Thompson-Wheeler Haskell logo (2009). 81 | 82 | 84 | 86 | 88 | 90 | 92 | 94 | 96 | 97 | 98 | 99 | 104 | 110 | 115 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /eg/u-conjure.hs: -------------------------------------------------------------------------------- 1 | -- u-conjure.hs -- u-Conjure 2 | -- 3 | -- This is a prototype for Conjure, a library for conjuring code 4 | -- out of partially implemented functions. 5 | -- 6 | -- 7 | -- Copyright (C) 2021-2024 Rudy Matela 8 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 9 | -- 10 | -- 11 | -- To run this you need to have both LeanCheck and Express installed: 12 | -- 13 | -- $ cabal install leancheck 14 | -- $ cabal install express 15 | -- 16 | -- If installation fails, use v1-install: 17 | -- 18 | -- $ cabal v1-install leancheck 19 | -- $ cabal v1-install express 20 | import Data.List 21 | import Data.Maybe 22 | import Data.Express 23 | import Data.Typeable 24 | import Test.LeanCheck.Error 25 | 26 | 27 | square :: Int -> Int 28 | square 0 = 0 29 | square 1 = 1 30 | square 2 = 4 31 | square 3 = 9 32 | square 4 = 16 33 | 34 | add :: Int -> Int -> Int 35 | add 0 0 = 0 36 | add 0 1 = 1 37 | add 1 0 = 1 38 | add 1 1 = 2 39 | 40 | factorial :: Int -> Int 41 | factorial 0 = 1 42 | factorial 1 = 1 43 | factorial 2 = 2 44 | factorial 3 = 6 45 | factorial 4 = 24 46 | 47 | second :: [Int] -> Int 48 | second [x,y] = y 49 | second [x,y,z] = y 50 | second [x,y,z,w] = y 51 | 52 | -- reverse 53 | reverse' :: [Int] -> [Int] 54 | reverse' [x,y] = [y,x] 55 | reverse' [x,y,z] = [z,y,x] 56 | 57 | -- ++ 58 | (+++) :: [Int] -> [Int] -> [Int] 59 | [x] +++ [y] = [x,y] 60 | [x,y] +++ [z,w] = [x,y,z,w] 61 | 62 | 63 | main :: IO () 64 | main = do 65 | conjure "square" square primitives 66 | conjure "add" add primitives 67 | conjure "factorial" factorial primitives 68 | 69 | conjure "factorial" factorial 70 | [ val (0 :: Int) 71 | , val (1 :: Int) 72 | , value "+" ((+) :: Int -> Int -> Int) 73 | , value "*" ((*) :: Int -> Int -> Int) 74 | , value "foldr" (foldr :: (Int -> Int -> Int) -> Int -> [Int] -> Int) 75 | , value ".." (enumFromTo :: Int -> Int -> [Int]) 76 | ] 77 | 78 | conjure "second" second listPrimitives 79 | conjure "++" (+++) listPrimitives 80 | conjure "reverse" reverse' listPrimitives 81 | 82 | -- even by using fold and some cheating, 83 | -- this function is out of reach 84 | -- reverse xs = foldr (\x xs -> xs ++ [x]) [] xs 85 | -- reverse xs = foldr (flip (++) . unit) [] xs 86 | conjure "reverse" reverse' $ listPrimitives ++ 87 | [ value "unit" ((:[]) :: Int -> [Int]) 88 | , value "++" ((++) :: [Int] -> [Int] -> [Int]) 89 | -- these last two are cheats: 90 | , value "flip" (flip :: ([Int]->[Int]->[Int]) -> [Int] -> [Int] -> [Int]) 91 | , value "." ((.) :: ([Int]->[Int]->[Int]) -> (Int->[Int]) -> Int -> [Int] -> [Int]) 92 | ] 93 | 94 | where 95 | 96 | primitives :: [Expr] 97 | primitives = 98 | [ val (0 :: Int) 99 | , val (1 :: Int) 100 | , val (2 :: Int) 101 | , val (3 :: Int) 102 | , value "+" ((+) :: Int -> Int -> Int) 103 | , value "*" ((*) :: Int -> Int -> Int) 104 | , value "-" ((-) :: Int -> Int -> Int) 105 | ] 106 | 107 | listPrimitives :: [Expr] 108 | listPrimitives = 109 | [ val (0 :: Int) 110 | , val (1 :: Int) 111 | , val ([] :: [Int]) 112 | , value "head" (head :: [Int] -> Int) 113 | , value "tail" (tail :: [Int] -> [Int]) 114 | , value ":" ((:) :: Int -> [Int] -> [Int]) 115 | , value "foldr" (foldr :: (Int -> [Int] -> [Int]) -> [Int] -> [Int] -> [Int]) 116 | ] 117 | 118 | 119 | conjure :: Typeable f => String -> f -> [Expr] -> IO () 120 | conjure nm f primitives = do 121 | print (value nm f) -- prints the type signature 122 | case conjureImplementations nm f primitives of 123 | [] -> putStrLn $ "cannot conjure" 124 | -- es -> putStrLn $ unlines $ map showEq es -- uncomment to show all found variations 125 | (e:_) -> putStrLn $ showEq e 126 | putStrLn "" 127 | where 128 | showEq eq = showExpr (lhs eq) ++ " = " ++ showExpr (rhs eq) 129 | 130 | 131 | conjureImplementations :: Typeable f => String -> f -> [Expr] -> [Expr] 132 | conjureImplementations nm f primitives = 133 | [ appn -==- e 134 | | e <- candidateExprsFrom $ exs ++ primitives 135 | , isTrue (appn -==- e) 136 | ] 137 | where 138 | appn = application nm f primitives 139 | (ef:exs) = unfoldApp appn 140 | isTrue e = all (errorToFalse . eval False) . map (e //-) $ definedBinds appn 141 | 142 | 143 | definedBinds :: Expr -> [[(Expr,Expr)]] 144 | definedBinds ffxx = [bs | bs <- bss, errorToFalse . eval False $ e //- bs] 145 | where 146 | e = ffxx -==- ffxx 147 | bss = take 360 $ groundBinds ffxx 148 | 149 | 150 | application :: Typeable f => String -> f -> [Expr] -> Expr 151 | application nm f es = mostGeneralCanonicalVariation $ appn (value nm f) 152 | where 153 | appn ff | isFun ff = case [e | Just (_ :$ e) <- (map (ff $$)) es] of 154 | [] -> error "application: could not find type representative" 155 | (e:_) -> appn (ff :$ holeAsTypeOf e) 156 | | otherwise = ff 157 | 158 | 159 | candidateExprsFrom :: [Expr] -> [Expr] 160 | candidateExprsFrom = concat . take 7 . expressionsT 161 | where 162 | expressionsT ds = [ds] \/ (delay $ productMaybeWith ($$) es es) 163 | where 164 | es = expressionsT ds 165 | 166 | 167 | (-==-) :: Expr -> Expr -> Expr 168 | ex -==- ey = headOr (val False) . map (:$ ey) $ mapMaybe ($$ ex) 169 | [ value "==" ((==) :: Int -> Int -> Bool) 170 | , value "==" ((==) :: Bool -> Bool -> Bool) 171 | , value "==" ((==) :: [Int] -> [Int] -> Bool) 172 | , value "==" ((==) :: [Bool] -> [Bool] -> Bool) 173 | ] 174 | where 175 | headOr x [] = x 176 | headOr _ (x:_) = x 177 | 178 | 179 | lhs, rhs :: Expr -> Expr 180 | lhs (((Value "==" _) :$ e) :$ _) = e 181 | rhs (((Value "==" _) :$ _) :$ e) = e 182 | 183 | 184 | groundBinds :: Expr -> [[(Expr,Expr)]] 185 | groundBinds e = concat $ products [mapT ((,) v) (tiersFor v) | v <- nubVars e] 186 | 187 | 188 | tiersFor :: Expr -> [[Expr]] 189 | tiersFor e = case show (typ e) of 190 | "Int" -> mapT val (tiers `asTypeOf` [[undefined :: Int]]) 191 | "Bool" -> mapT val (tiers `asTypeOf` [[undefined :: Bool]]) 192 | "[Int]" -> mapT val (tiers `asTypeOf` [[undefined :: [Int]]]) 193 | "[Bool]" -> mapT val (tiers `asTypeOf` [[undefined :: [Bool]]]) 194 | _ -> [] 195 | -------------------------------------------------------------------------------- /eg/u-conjure.txt: -------------------------------------------------------------------------------- 1 | square :: Int -> Int 2 | square x = x * x 3 | 4 | add :: Int -> Int -> Int 5 | add x y = x + y 6 | 7 | factorial :: Int -> Int 8 | cannot conjure 9 | 10 | factorial :: Int -> Int 11 | factorial x = foldr (*) 1 [1..x] 12 | 13 | second :: [Int] -> Int 14 | second xs = head (tail xs) 15 | 16 | (++) :: [Int] -> [Int] -> [Int] 17 | xs ++ ys = foldr (:) ys xs 18 | 19 | reverse :: [Int] -> [Int] 20 | cannot conjure 21 | 22 | reverse :: [Int] -> [Int] 23 | reverse xs = foldr (foldr (:) . unit) [] xs 24 | 25 | -------------------------------------------------------------------------------- /eg/u-extrapolate.hs: -------------------------------------------------------------------------------- 1 | -- u-extrapolate.hs -- micro Extrapolate / Extrapolite 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- A small property-based testing library capable of generalizing 7 | -- counterexamples implemented in under 50 lines of code. 8 | -- 9 | -- This example works like other property-based testing libraries 10 | -- like QuickCheck, LeanCheck or SmallCheck: 11 | -- 12 | -- When given a property, it will test it for 500 test arguments. 13 | -- If no counterexample is found, "tests passed" is reported. 14 | -- If a counterexample is found, it is reported. 15 | -- 16 | -- However, when a counterexample is found, this program will try to generalize 17 | -- it by replacing subexpressions to variables. If a generalization that 18 | -- _fails_ 500 tests is found, it is reported. 19 | -- 20 | -- Limitations: 21 | -- 22 | -- * this only supports properties with one argument (uncurried). 23 | -- * this only supports generalization of Int, Bool, [Int] and [Bool] values. 24 | -- * there is no way to configure the number of test arguments. 25 | -- 26 | -- Please see Extrapolate for a full-featured version: 27 | -- 28 | -- https://github.com/rudymatela/extrapolate 29 | import Data.List 30 | import Data.Maybe 31 | import Data.Express 32 | import Test.LeanCheck hiding (counterExamples, check) 33 | 34 | main :: IO () 35 | main = do 36 | putStrLn "sort . sort = sort" 37 | check $ \xs -> sort (sort xs :: [Int]) == sort xs 38 | 39 | putStrLn "length . nub = length (incorrect when there are repeated elements)" 40 | check $ \xs -> length (nub xs :: [Int]) == length xs 41 | 42 | putStrLn "xs `union` ys == ys `union` xs (incorrect for repeated elements)" 43 | check $ \(xs,ys) -> xs `union` ys == ys `union` (xs :: [Int]) 44 | 45 | putStrLn "\\(x,y) -> x + y == y + x" 46 | check $ \(x,y) -> x + y == y + (x :: Int) 47 | 48 | putStrLn "\\x -> x == x + 1 (always incorrect)" 49 | check $ \x -> x == x + (1 :: Int) 50 | 51 | putStrLn "\\(x,y) -> x + y == x + x (incorrect)" 52 | check $ \(x,y) -> x + y == x + (x :: Int) 53 | 54 | putStrLn "\\(x,y) -> x /= y (incorrect whenever x and y are equal)" 55 | check $ \(x,y) -> x /= (y :: Int) 56 | 57 | 58 | check :: (Listable a, Express a) => (a -> Bool) -> IO () 59 | check prop = putStrLn $ case counterExampleAndGeneralizations 500 prop of 60 | [] -> "+++ Tests passed.\n" 61 | (ce:gs) -> unlines 62 | $ ("*** Falsified, counterexample: " ++ showExpr ce) 63 | : [" generalization: " ++ showExpr g | g <- gs ] 64 | 65 | counterExamples :: (Listable a, Express a) => Int -> (a -> Bool) -> [Expr] 66 | counterExamples maxTests prop = [expr x | x <- take maxTests list, not (prop x)] 67 | 68 | counterExampleAndGeneralizations :: (Listable a, Express a) 69 | => Int -> (a -> Bool) -> [Expr] 70 | counterExampleAndGeneralizations maxTests prop = 71 | case counterExamples maxTests prop of 72 | [] -> [] 73 | (ce:_) -> ce : discardLater isInstanceOf 74 | [ g | g <- candidateGeneralizations ce 75 | , all (not . prop . evl) (take maxTests $ grounds g) ] 76 | 77 | candidateGeneralizations :: Expr -> [Expr] 78 | candidateGeneralizations = concatMap canonicalVariations . gen 79 | where 80 | gen e@(e1 :$ e2) = [holeAsTypeOf e | isListable e] 81 | ++ [g1 :$ g2 | g1 <- gen e1, g2 <- gen e2] 82 | ++ map (:$ e2) (gen e1) 83 | ++ map (e1 :$) (gen e2) 84 | gen e | isVar e = [] 85 | | otherwise = [holeAsTypeOf e | isListable e] 86 | isListable = not . null . tiersFor 87 | 88 | grounds :: Expr -> [Expr] 89 | grounds e = map (e //-) 90 | . concat 91 | $ products [mapT ((,) v) (tiersFor v) | v <- nubVars e] 92 | 93 | tiersFor :: Expr -> [[Expr]] 94 | tiersFor e = case show (typ e) of 95 | "Int" -> mapT val (tiers :: [[Int]]) 96 | "Bool" -> mapT val (tiers :: [[Bool]]) 97 | "[Int]" -> mapT val (tiers :: [[ [Int] ]]) 98 | "[Bool]" -> mapT val (tiers :: [[ [Bool] ]]) 99 | _ -> [] 100 | 101 | discardLater :: (a -> a -> Bool) -> [a] -> [a] 102 | discardLater (?) = d 103 | where 104 | d [] = [] 105 | d (x:xs) = x : d (discard (? x) xs) 106 | discard p = filter (not . p) 107 | -------------------------------------------------------------------------------- /eg/u-extrapolate.txt: -------------------------------------------------------------------------------- 1 | sort . sort = sort 2 | +++ Tests passed. 3 | 4 | length . nub = length (incorrect when there are repeated elements) 5 | *** Falsified, counterexample: [0,0] 6 | generalization: x:x:xs 7 | 8 | xs `union` ys == ys `union` xs (incorrect for repeated elements) 9 | *** Falsified, counterexample: ([],[0,0]) 10 | generalization: (xs,x:x:xs) 11 | generalization: ([],x:x:xs) 12 | 13 | \(x,y) -> x + y == y + x 14 | +++ Tests passed. 15 | 16 | \x -> x == x + 1 (always incorrect) 17 | *** Falsified, counterexample: 0 18 | generalization: x 19 | 20 | \(x,y) -> x + y == x + x (incorrect) 21 | *** Falsified, counterexample: (0,1) 22 | 23 | \(x,y) -> x /= y (incorrect whenever x and y are equal) 24 | *** Falsified, counterexample: (0,0) 25 | generalization: (x,x) 26 | 27 | -------------------------------------------------------------------------------- /eg/u-speculate.hs: -------------------------------------------------------------------------------- 1 | -- u-speculate.hs -- micro Speculate / Speculite 2 | -- 3 | -- Copyright (c) 2019-2024 Rudy Matela. 4 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 5 | -- 6 | -- A small library capable of conjecturing laws about Haskell functions 7 | -- implemented in under 70 lines of code. 8 | -- 9 | -- This works like the equation conjecturing tools Speculate or QuickSpec, 10 | -- combining expressions to form equations, 11 | -- reporting any equations that passes 60 tests. 12 | -- Redundant equations are then pruned using simple rules. 13 | -- 14 | -- Limitations: 15 | -- 16 | -- * this program prints redundant equations; 17 | -- * there is no way to configure maximum number of tests to consider an 18 | -- equation true; 19 | -- * runtime is exponential as you add more symbols to speculate about. 20 | -- 21 | -- Please see Speculate for a full featured version: 22 | -- 23 | -- https://github.com/rudymatela/speculate 24 | import Data.List 25 | import Data.Maybe 26 | import Data.Express 27 | import Test.LeanCheck 28 | 29 | main :: IO () 30 | main = do 31 | printEquationsAbout 32 | [ hole (undefined :: Int) 33 | , val (0 :: Int) 34 | , value "+" ((+) :: Int -> Int -> Int) 35 | , value "abs" (abs :: Int -> Int) 36 | ] 37 | 38 | printEquationsAbout 39 | [ hole (undefined :: Bool) 40 | , val False 41 | , val True 42 | , value "not" not 43 | ] 44 | 45 | printEquationsAbout 46 | [ hole (undefined :: Int) 47 | , hole (undefined :: [Int]) 48 | , val ([] :: [Int]) 49 | , value ":" ((:) :: Int -> [Int] -> [Int]) 50 | , value "++" ((++) :: [Int] -> [Int] -> [Int]) 51 | , value "sort" (sort :: [Int] -> [Int]) 52 | ] 53 | 54 | {- 55 | printEquationsAbout 56 | [ hole (undefined :: Bool) 57 | , hole (undefined :: [Bool]) 58 | , val True 59 | , val ([] :: [Bool]) 60 | , value "foldr" (foldr :: (Bool -> Bool -> Bool) -> Bool -> [Bool] -> Bool) 61 | , value "&&" (&&) 62 | , value "and" (and :: [Bool] -> Bool) 63 | ] 64 | -} 65 | 66 | printEquationsAbout :: [Expr] -> IO () 67 | printEquationsAbout es = do 68 | putStrLn $ "Equations about " ++ intercalate ", " (map showExpr es) ++ ":" 69 | putStrLn . unlines . map showEq $ speculateAbout es 70 | where 71 | showEq eq = showExpr (lhs eq) ++ " = " ++ showExpr (rhs eq) 72 | 73 | speculateAbout :: [Expr] -> [Expr] 74 | speculateAbout = discardLater canBeSimplifiedBy 75 | . discardLater isInstanceOf 76 | . concatMap trueCanonicalVariations 77 | . discardLater (\e1 e2 -> isntIdentity e2 && e2 `isInstanceOf` e1) 78 | . sort 79 | . filter isTrue 80 | . candidateEquationsFrom 81 | where 82 | e1 `canBeSimplifiedBy` e2 = isRule e2 && e1 `hasInstanceOf` lhs e2 83 | 84 | trueCanonicalVariations :: Expr -> [Expr] 85 | trueCanonicalVariations = discardLater isInstanceOf 86 | . filter isTrue 87 | . filter isntIdentity 88 | . canonicalVariations 89 | 90 | candidateEquationsFrom :: [Expr] -> [Expr] 91 | candidateEquationsFrom es' = [e1 -==- e2 | e1 <- es, e2 <- es, e1 >= e2] 92 | where 93 | es = candidateExprsFrom es' 94 | 95 | candidateExprsFrom :: [Expr] -> [Expr] 96 | candidateExprsFrom = concat . take 5 . expressionsT 97 | where 98 | expressionsT ds = [ds] \/ (delay $ productMaybeWith ($$) es es) 99 | where 100 | es = expressionsT ds 101 | 102 | isTrue :: Expr -> Bool 103 | isTrue = all (eval False) . take 60 . grounds 104 | 105 | grounds :: Expr -> [Expr] 106 | grounds e = map (e //-) . concat $ products [mapT ((,) v) (tiersFor v) | v <- nubVars e] 107 | 108 | tiersFor :: Expr -> [[Expr]] 109 | tiersFor e = case show (typ e) of 110 | "Int" -> mapT val (tiers :: [[Int]]) 111 | "Bool" -> mapT val (tiers :: [[Bool]]) 112 | "[Int]" -> mapT val (tiers :: [[ [Int] ]]) 113 | "[Bool]" -> mapT val (tiers :: [[ [Bool] ]]) 114 | _ -> [] 115 | 116 | (-==-) :: Expr -> Expr -> Expr 117 | ex -==- ey = head $ 118 | [eqn | eq <- eqs, let eqn = eq :$ ex :$ ey, isWellTyped eqn] ++ [val False] 119 | where 120 | eqs = [ value "==" ((==) :: Int -> Int -> Bool) 121 | , value "==" ((==) :: Bool -> Bool -> Bool) 122 | , value "==" ((==) :: [Int] -> [Int] -> Bool) 123 | , value "==" ((==) :: [Bool] -> [Bool] -> Bool) 124 | ] 125 | 126 | lhs, rhs :: Expr -> Expr 127 | lhs (((Value "==" _) :$ e) :$ _) = e 128 | rhs (((Value "==" _) :$ _) :$ e) = e 129 | 130 | isntIdentity, isRule :: Expr -> Bool 131 | isntIdentity eq = lhs eq /= rhs eq 132 | isRule eq = size (lhs eq) > size (rhs eq) 133 | 134 | discardLater :: (a -> a -> Bool) -> [a] -> [a] 135 | discardLater (?) = d 136 | where 137 | d [] = [] 138 | d (x:xs) = x : d (discard (? x) xs) 139 | discard p = filter (not . p) 140 | -------------------------------------------------------------------------------- /eg/u-speculate.txt: -------------------------------------------------------------------------------- 1 | Equations about _, 0, (+), abs: 2 | abs 0 = 0 3 | x + 0 = x 4 | 0 + x = x 5 | abs (abs x) = abs x 6 | x + y = y + x 7 | abs (x + y) = abs (y + x) 8 | abs (x + abs x) = x + abs x 9 | abs (abs x + x) = x + abs x 10 | abs x + abs x = abs (x + x) 11 | x + (y + z) = x + (z + y) 12 | x + (y + z) = y + (x + z) 13 | x + (y + z) = y + (z + x) 14 | x + (y + z) = z + (x + y) 15 | x + (y + z) = z + (y + x) 16 | (x + y) + z = x + (y + z) 17 | (x + y) + z = x + (z + y) 18 | (x + y) + z = y + (x + z) 19 | (x + y) + z = y + (z + x) 20 | (x + y) + z = z + (y + x) 21 | (x + y) + z = (x + z) + y 22 | (x + y) + z = (y + x) + z 23 | (x + y) + z = (y + z) + x 24 | (x + y) + z = (z + x) + y 25 | (x + y) + z = (z + y) + x 26 | 27 | Equations about _, False, True, not: 28 | not False = True 29 | not True = False 30 | not (not p) = p 31 | 32 | Equations about _, _, [], (:), (++), sort: 33 | sort [] = [] 34 | xs ++ [] = xs 35 | [] ++ xs = xs 36 | sort (sort xs) = sort xs 37 | sort [x] = [x] 38 | [x] ++ xs = x:xs 39 | sort (xs ++ ys) = sort (ys ++ xs) 40 | sort (x:sort xs) = sort (x:xs) 41 | sort (xs ++ sort ys) = sort (xs ++ ys) 42 | sort (sort xs ++ ys) = sort (xs ++ ys) 43 | (x:xs) ++ ys = x:(xs ++ ys) 44 | (xs ++ ys) ++ zs = xs ++ (ys ++ zs) 45 | 46 | -------------------------------------------------------------------------------- /etc/hugs-backports/Data/Function.hs: -------------------------------------------------------------------------------- 1 | -- Backport of Data.Function for Hugs 2006-09. 2 | -- Only exports `on` 3 | -- 4 | -- Copyright (c) 2018-2024 Rudy Matela. 5 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 6 | module Data.Function 7 | ( on 8 | ) 9 | where 10 | 11 | on :: (b -> b -> c) -> (a -> b) -> a -> a -> c 12 | (?) `on` f = \x y -> f x ? f y 13 | infixl 0 `on` 14 | -------------------------------------------------------------------------------- /mk/All.hs: -------------------------------------------------------------------------------- 1 | module All 2 | ( module Data.Express 3 | , module Data.Express.Fixtures 4 | ) 5 | where 6 | 7 | import Data.Express 8 | import Data.Express.Fixtures 9 | import Data.Express.Triexpr () 10 | -------------------------------------------------------------------------------- /mk/Toplibs.hs: -------------------------------------------------------------------------------- 1 | -- Using ghc --make in this module triggers compilation of every library. 2 | module Toplibs () where 3 | 4 | import Data.Express () 5 | import Data.Express.Fixtures () 6 | import Data.Express.Triexpr () 7 | import Test () 8 | -------------------------------------------------------------------------------- /mk/ghcdeps: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # ghcdeps: generate Haskell make dependencies for compiling with GHC. 4 | # 5 | # Copyright (c) 2015-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | # 8 | # From a list of files provided on standard input, 9 | # generate flat make dependencies. 10 | # 11 | # Transitive relations are repeated. 12 | # 13 | # Usage: 14 | # $ ghcdeps -isomedir:someother < ... 9 | # 10 | # will print -i parameters necessary for haddock to link to Haddock 11 | # documentation installed on your system, so you can: 12 | # 13 | # $ haddock-i base template-haskell | xargs haddock 14 | err() { 15 | echo "$@" > /dev/stderr 16 | } 17 | 18 | errxit() { 19 | err "$@" 20 | exit 1 21 | } 22 | 23 | iface-for() { 24 | ghc-pkg field $1 haddock-interfaces | sort -rV | head -1 | sed "s/.*: //" 25 | } 26 | 27 | html-for() { 28 | ghc-pkg field $1 haddock-html | sort -rV | head -1 | sed "s/.*: //" 29 | } 30 | 31 | for pkg in "$@" 32 | do 33 | iface=$(iface-for $pkg) 34 | html=$(html-for $pkg) 35 | [ -d "$html" -a -f "$iface" ] && echo "-i$html,$iface" || err "haddock-i: warning: could not find interface file for $pkg" 36 | done 37 | -------------------------------------------------------------------------------- /mk/haskell.mk: -------------------------------------------------------------------------------- 1 | # Implicit rules for compiling Haskell code. 2 | # 3 | # Copyright (c) 2015-2024 Rudy Matela. 4 | # Distributed under the 3-Clause BSD licence. 5 | # 6 | # You can optionally configure the "Configuration variables" below in your main 7 | # makefile, e.g.: 8 | # 9 | # GHCIMPORTDIRS = path/to/dir:path/to/another/dir 10 | # GHCFLAGS = -O2 -dynamic 11 | # GHC = ghc-7.6 12 | # include haskell.mk 13 | 14 | 15 | 16 | # Configuration variables 17 | 18 | # GHC Parameters 19 | GHCIMPORTDIRS ?= 20 | GHCFLAGS ?= 21 | GHC ?= ghc 22 | GHCCMD = $(GHC) -i$(GHCIMPORTDIRS) $(GHCFLAGS) 23 | HADDOCK ?= haddock 24 | CABAL_INSTALL = $(shell cabal --version | grep -q "version [0-2]\." && echo 'cabal install' || echo 'cabal install --lib') 25 | 26 | # Hugs Parameters 27 | HUGSIMPORTDIRS ?= "/usr/lib/hugs/packages/*" 28 | HUGSFLAGS ?= 29 | CPPHS_HUGS ?= cpphs-hugs --noline -D__HUGS__ 30 | HUGS ?= hugs 31 | RUNHUGS ?= runhugs 32 | HUGSCMD = $(HUGS) -F"$(CPPHS_HUGS)" -P$(HUGSIMPORTDIRS) $(HUGSFLAGS) 33 | RUNHUGSCMD = $(RUNHUGS) -F"$(CPPHS_HUGS)" -P$(HUGSIMPORTDIRS) $(HUGSFLAGS) 34 | 35 | 36 | # Makefile where to keep the dependencies 37 | DEPMK ?= mk/depend.mk 38 | 39 | # LIB_HSS: all library Haskell files 40 | # ALL_HSS: all Haskell files 41 | # You can override ALL/LIB_HSS in your main Makefile 42 | LIST_LIB_HSS ?= find src -name "*.hs" 43 | LIST_ALL_HSS ?= find \( -path "./dist*" -o -path "./.stack-work" -o -path "./Setup.hs" \) -prune \ 44 | -o -name "*.*hs" -print 45 | LIB_HSS ?= $(shell $(LIST_LIB_HSS)) 46 | ALL_HSS ?= $(shell $(LIST_ALL_HSS)) 47 | 48 | LIB_DEPS ?= base 49 | ALL_DEPS ?= $(LIB_DEPS) 50 | INSTALL_DEPS ?= 51 | 52 | PKGNAME = $(shell cat *.cabal | grep "^name:" | sed -e "s/name: *//") 53 | 54 | HADDOCK_HAS = haddock --help | grep -q -- 55 | 56 | 57 | # Implicit rules 58 | %.hi %.o: %.hs 59 | $(GHCCMD) $< && touch $@ 60 | 61 | %: %.hs 62 | $(GHCCMD) $< && touch $@ 63 | 64 | .PHONY: %.ghci 65 | %.ghci: %.hs 66 | $(GHCCMD) -O0 --interactive $< 67 | 68 | .PHONY: %.hugs 69 | %.hugs: %.hs 70 | $(HUGSCMD) $< 71 | 72 | .PHONY: %.runhugs 73 | %.runhugs: %.hs 74 | $(RUNHUGSCMD) $< 75 | 76 | 77 | # Cleaning rule (add as a clean dependency) 78 | clean-hs: clean-hi-o clean-haddock clean-cabal clean-stack 79 | 80 | clean-hi-o: 81 | find $(ALL_HSS) | sed -e 's/hs$$/o/' | xargs rm -f 82 | find $(ALL_HSS) | sed -e 's/hs$$/hi/' | xargs rm -f 83 | find $(ALL_HSS) | sed -e 's/hs$$/dyn_o/' | xargs rm -f 84 | find $(ALL_HSS) | sed -e 's/hs$$/dyn_hi/' | xargs rm -f 85 | 86 | 87 | # Update dependency file 88 | .PHONY: depend 89 | depend: 90 | find $(ALL_HSS) | ./mk/ghcdeps -i$(GHCIMPORTDIRS) $(GHCFLAGS) > $(DEPMK) 91 | 92 | install-dependencies: 93 | if [ -n "$(INSTALL_DEPS)" ]; then \ 94 | cd ~ && \ 95 | cabal update && \ 96 | $(CABAL_INSTALL) $(INSTALL_DEPS) || true; \ 97 | fi 98 | # above, "|| true" is needed for cabal >= 3.10.2 99 | # Before, cabal would successfully skip installation 100 | # of already existing packages 101 | # cd ~ is needed so cabal installs only dependencies 102 | 103 | # haddock rules 104 | haddock: doc/index.html 105 | 106 | clean-haddock: 107 | rm -f doc/*.{html,css,js,png,gif,json} doc/src/* README.html 108 | 109 | upload-haddock: 110 | @echo "use \`cabal upload -d' instead" 111 | @echo "(but 1st: cabal install --only-dependencies --enable-documentation)" 112 | @echo "(to just compile docs: cabal haddock --for-hackage)" 113 | @echo "(on Arch Linux, use: cabal haddock --for-hackage --haddock-options=--optghc=-dynamic)" 114 | 115 | doc/index.html: $(LIB_HSS) 116 | ./mk/haddock-i $(LIB_DEPS) | xargs \ 117 | $(HADDOCK) --html -odoc $(LIB_HSS) \ 118 | --title=$(PKGNAME) \ 119 | $(shell $(HADDOCK_HAS) --package-name && echo "--package-name=$(PKGNAME)" ) \ 120 | $(shell $(HADDOCK_HAS) --hyperlinked-source && echo "--hyperlinked-source" ) \ 121 | $(shell $(HADDOCK_HAS) --no-print-missing-docs && echo --no-print-missing-docs ) \ 122 | $(HADDOCKFLAGS) 123 | 124 | clean-cabal: 125 | rm -rf dist/ dist-newstyle/ cabal.project.local cabal.project.local~ 126 | 127 | clean-stack: 128 | rm -rf .stack-work/ stack.yaml.lock 129 | 130 | # lists all Haskell source files 131 | list-all-hss: 132 | @find $(ALL_HSS) 133 | 134 | # lists library Haskell source files 135 | list-lib-hss: 136 | @find $(LIB_HSS) 137 | 138 | bootstrap-haskell-mk: 139 | @[ -d "$(DEST)" ] || (echo -e "error: no destination found\nusage: \`make bootstrap-haskell-mk DEST=path/to/prj'"; exit 1) 140 | mkdir -p mk 141 | cp mk/{haskell.mk,ghcdeps,haddock-i} $(DEST)/mk 142 | touch $(DEST)/mk/depend.mk 143 | 144 | show-pkgname: 145 | @echo $(PKGNAME) 146 | 147 | include $(DEPMK) 148 | -------------------------------------------------------------------------------- /mk/install-on: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # mk/install-on: install or updates the mk folder on a Haskell project 4 | # 5 | # Copyright (c) 2019-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | # 8 | # usage: ./mk/install-on path/to/project 9 | # 10 | # This script assumes that: 11 | # 12 | # * tests are stored in a "test/" folder 13 | # * sources are stored in a "src/" folder 14 | set -e 15 | 16 | errxit() { 17 | echo "$@" > /dev/stderr 18 | exit 1 19 | } 20 | 21 | src=`dirname $0`/.. 22 | dst="$1" 23 | 24 | [ -n "$dst" ] || errxit "destination folder not provided" 25 | 26 | mkdir -p $dst/mk 27 | mkdir -p $dst/test 28 | 29 | cp $src/mk/ghcdeps $dst/mk/ghcdeps 30 | cp $src/mk/haddock-i $dst/mk/haddock-i 31 | cp $src/mk/haskell.mk $dst/mk/haskell.mk 32 | cp $src/mk/install-on $dst/mk/install-on 33 | cp $src/test/sdist $dst/test/sdist 34 | -------------------------------------------------------------------------------- /src/Data/Express.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Express is a library for manipulating dynamically typed Haskell expressions. 8 | -- It's like "Data.Dynamic" but with support for encoding applications and 9 | -- variables. 10 | -- 11 | -- It provides the 'Expr' type and over a hundred functions for 12 | -- building, evaluating, comparing, folding, canonicalizing and matching 13 | -- 'Expr's. 14 | -- 15 | -- /Basics./ 16 | -- For types that are 'Show' instances, 17 | -- we can use 'val' to encode values as 'Expr's: 18 | -- 19 | -- > > let false = val False 20 | -- > > :t false 21 | -- > false :: Expr 22 | -- > > print false 23 | -- > False :: Bool 24 | -- 25 | -- As seen above, the 'Show' instance for 'Expr' produces a string with the 26 | -- encoded value and it's type. 27 | -- 28 | -- For types that aren't 'Show' instances, like functions, 29 | -- we can use 'value' to encode values as 'Expr's. 30 | -- 31 | -- > > let notE = value "not" not 32 | -- > > :t notE 33 | -- > notE :: Expr 34 | -- > > print notE 35 | -- > not :: Bool -> Bool 36 | -- 37 | -- Using ':$' we can apply function valued 'Expr's, to other Exprs. 38 | -- 39 | -- > > let notFalse = notE :$ false 40 | -- > > :t notFalse 41 | -- > notFalse :: Expr 42 | -- > > notFalse 43 | -- > not False :: Bool 44 | -- 45 | -- Using 'evaluate' or 'eval' we can evaluate 'Expr's 46 | -- back into a regular Haskell value. 47 | -- 48 | -- > > evaluate notFalse :: Maybe Bool 49 | -- > Just True 50 | -- > > evaluate notFalse :: Maybe Int 51 | -- > Nothing 52 | -- > > eval False notFalse 53 | -- > True 54 | -- > > eval (0::Int) notFalse 55 | -- > 0 56 | -- 57 | -- /Example:/ 58 | -- Like with "Data.Dynamic", we can use Express to create heterogeneous lists: 59 | -- 60 | -- > > let xs = [val False, val True, val (1::Int), val (2::Int), val (3::Integer), val "123"] 61 | -- > > :t xs 62 | -- > xs :: [Expr] 63 | -- > > xs 64 | -- > [ False :: Bool 65 | -- > , True :: Bool 66 | -- > , 1 :: Int 67 | -- > , 2 :: Int 68 | -- > , 3 :: Integer 69 | -- > , "123" :: [Char] 70 | -- > ] 71 | -- 72 | -- We can then apply 'evaluate' to select values of different types: 73 | -- 74 | -- > > import Data.Maybe 75 | -- > > mapMaybe evaluate xs :: [Bool] 76 | -- > [False,True] 77 | -- > > mapMaybe evaluate xs :: [Int] 78 | -- > [1,2] 79 | -- > > mapMaybe evaluate xs :: [Integer] 80 | -- > [3] 81 | -- > > mapMaybe evaluate xs :: [String] 82 | -- > ["123"] 83 | -- 84 | -- If we define an heterogeneous list of functions encoded as 'Expr's: 85 | -- 86 | -- > > let fs = [value "not" not, value "&&" (&&), value "abs" (abs :: Int -> Int)] 87 | -- > > :t fs 88 | -- > fs :: [Expr] 89 | -- 90 | -- Using '$$' we can list the type correct applications 91 | -- between the two previously defined lists: 92 | -- 93 | -- > > catMaybes [f $$ x | f <- fs, x <- xs] 94 | -- > [ not False :: Bool 95 | -- > , not True :: Bool 96 | -- > , (False &&) :: Bool -> Bool 97 | -- > , (True &&) :: Bool -> Bool 98 | -- > , abs 1 :: Int 99 | -- > , abs 2 :: Int 100 | -- > ] 101 | -- 102 | -- Other uses of Express include: 103 | -- 104 | -- * generalizing counter-examples of property-based testing 105 | -- in ; 106 | -- * conjecturing equations based on the results of testing 107 | -- in . 108 | -- 109 | -- In this documentation, 110 | -- the complexity of most functions is given in big O notation 111 | -- where /n/ is the size of the expression being manipulated or produced. 112 | -- There may still be a /m/ cost associated with the values stored in 'Expr's. 113 | {-# LANGUAGE CPP #-} 114 | module Data.Express 115 | ( 116 | -- -- -- Data.Express.Core exports -- -- -- 117 | 118 | -- * The Expr datatype 119 | Expr (..) 120 | 121 | -- ** Building Exprs 122 | , value 123 | , val 124 | , ($$) 125 | , var 126 | 127 | -- ** Evaluating Exprs 128 | , evaluate 129 | , eval 130 | , evl 131 | , typ 132 | , etyp 133 | , mtyp 134 | , toDynamic 135 | 136 | -- ** Boolean properties of Exprs 137 | , isValue 138 | , isApp 139 | , isVar 140 | , isConst 141 | , isIllTyped 142 | , isWellTyped 143 | , isFun 144 | , hasVar 145 | , hasHole 146 | , isGround 147 | , isComplete 148 | 149 | -- ** Comparing Exprs 150 | , compareComplexity 151 | , compareLexicographically 152 | , compareQuickly 153 | 154 | -- ** Properties of Exprs 155 | , arity 156 | , size 157 | , depth 158 | , height 159 | 160 | -- ** Showing Exprs 161 | , showExpr 162 | , showPrecExpr 163 | , showOpExpr 164 | 165 | -- * Subexpressions 166 | 167 | -- ** Listing subexpressions 168 | , subexprs 169 | , values 170 | , vars 171 | , consts 172 | , nubSubexprs 173 | , nubValues 174 | , nubVars 175 | , nubConsts 176 | 177 | -- -- -- Data.Express.Basic exports -- -- -- 178 | , (>$$<) 179 | , (>$$) 180 | , ($$<) 181 | 182 | -- -- -- Data.Express.Map exports -- -- -- 183 | 184 | -- ** Mapping subexpressions 185 | , mapValues 186 | , mapVars 187 | , mapConsts 188 | , mapSubexprs 189 | , (//-) 190 | , (//) 191 | , renameVarsBy 192 | 193 | 194 | -- -- -- Data.Express.Hole exports -- -- -- 195 | 196 | -- * Variables and holes 197 | 198 | -- ** Creating variables 199 | , varAsTypeOf 200 | , listVars 201 | , listVarsAsTypeOf 202 | 203 | -- ** Typed holes 204 | , hole 205 | , isHole 206 | , holes 207 | , nubHoles 208 | , holeAsTypeOf 209 | , fill 210 | 211 | -- -- -- Data.Express.Fold exports -- -- -- 212 | 213 | -- * Juggling Exprs 214 | 215 | -- ** Folding Exprs 216 | , fold 217 | , unfold 218 | , foldPair 219 | , unfoldPair 220 | , foldTrio 221 | , unfoldTrio 222 | , foldApp 223 | , unfoldApp 224 | 225 | -- -- -- Data.Express.Canon exports -- -- -- 226 | 227 | -- ** Canonicalizing Exprs 228 | , canonicalize 229 | , canonicalizeWith 230 | , canonicalization 231 | , canonicalizationWith 232 | , isCanonical 233 | , isCanonicalWith 234 | , canonicalVariations 235 | , mostGeneralCanonicalVariation 236 | , mostSpecificCanonicalVariation 237 | , fastCanonicalVariations 238 | , fastMostGeneralVariation 239 | , fastMostSpecificVariation 240 | 241 | -- -- -- Data.Express.Match exports -- -- -- 242 | 243 | -- ** Matching Exprs 244 | , match 245 | , matchWith 246 | , isInstanceOf 247 | , hasInstanceOf 248 | , isSubexprOf 249 | , encompasses 250 | 251 | -- -- -- Data.Express.Express exports -- -- -- 252 | 253 | -- * Typeclasses 254 | 255 | -- ** The Express typeclass 256 | , Express (..) 257 | , deriveExpress 258 | , deriveExpressCascading 259 | , deriveExpressIfNeeded 260 | 261 | -- -- -- Data.Express.Name exports -- -- -- 262 | 263 | -- ** The Name typeclass 264 | , Name (..) 265 | , names 266 | , variableNamesFromTemplate 267 | , deriveName 268 | , deriveNameCascading 269 | , deriveNameIfNeeded 270 | 271 | -- -- -- Data.Express.Instances exports -- -- -- 272 | 273 | -- ** Typeclass instances as Exprs 274 | , reifyEq 275 | , reifyOrd 276 | , reifyEqOrd 277 | , reifyName 278 | 279 | , mkEq 280 | , mkOrd 281 | , mkOrdLessEqual 282 | , mkName 283 | , mkNameWith 284 | 285 | , isEq 286 | , isOrd 287 | , isEqOrd 288 | , isEqT 289 | , isOrdT 290 | , isEqOrdT 291 | 292 | , mkEquation 293 | , mkComparisonLE 294 | , mkComparisonLT 295 | , mkComparison 296 | , lookupComparison 297 | 298 | , listVarsWith 299 | , lookupName 300 | , lookupNames 301 | 302 | , validApps 303 | , findValidApp 304 | 305 | , preludeNameInstances 306 | ) 307 | where 308 | 309 | import Data.Express.Basic 310 | import Data.Express.Canon 311 | import Data.Express.Match 312 | import Data.Express.Name 313 | import Data.Express.Name.Derive 314 | import Data.Express.Express 315 | import Data.Express.Express.Derive 316 | import Data.Express.Instances 317 | -------------------------------------------------------------------------------- /src/Data/Express/Basic.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Basic 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Defines the 'Expr' type and _basic_ utilities involving it, including: 8 | -- 9 | -- * re-export of "Data.Express.Core" 10 | -- * re-export of "Data.Express.Map" 11 | -- * re-export of "Data.Express.Fold" 12 | -- * re-export of "Data.Express.Hole" 13 | -- 14 | -- If you're a Express user, 15 | -- you're probably better of importing "Data.Express". 16 | {-# LANGUAGE CPP #-} 17 | module Data.Express.Basic 18 | ( 19 | -- * Module re-exports 20 | module Data.Express.Core 21 | , module Data.Express.Map 22 | , module Data.Express.Fold 23 | , module Data.Express.Hole 24 | 25 | -- * Additional utilities 26 | , (>$$<) 27 | , (>$$) 28 | , ($$<) 29 | ) 30 | where 31 | 32 | import Data.Express.Core 33 | import Data.Express.Map 34 | import Data.Express.Fold 35 | import Data.Express.Hole 36 | 37 | import Data.Maybe (catMaybes, mapMaybe) 38 | 39 | -- | Lists valid applications between lists of 'Expr's 40 | -- 41 | -- > > [notE, plus] >$$< [false, true, zero] 42 | -- > [not False :: Bool,not True :: Bool,(0 +) :: Int -> Int] 43 | (>$$<) :: [Expr] -> [Expr] -> [Expr] 44 | efs >$$< exs = catMaybes [ef $$ ex | ef <- efs, ex <- exs] 45 | 46 | -- | Lists valid applications between a list of 'Expr's and an 'Expr'. 47 | -- 48 | -- > > [plus, times] >$$ zero 49 | -- > [(0 +) :: Int -> Int,(0 *) :: Int -> Int] 50 | (>$$) :: [Expr] -> Expr -> [Expr] 51 | efs >$$ ex = mapMaybe ($$ ex) efs 52 | 53 | -- | Lists valid applications between an 'Expr' and a list of 'Expr's. 54 | -- 55 | -- > > notE >$$< [false, true, zero] 56 | -- > [not False :: Bool,not True :: Bool] 57 | ($$<) :: Expr -> [Expr] -> [Expr] 58 | ef $$< exs = mapMaybe (ef $$) exs 59 | -------------------------------------------------------------------------------- /src/Data/Express/Express/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | -- | 3 | -- Module : Data.Express.Express.Derive 4 | -- Copyright : (c) 2019-2024 Rudy Matela 5 | -- License : 3-Clause BSD (see the file LICENSE) 6 | -- Maintainer : Rudy Matela 7 | -- 8 | -- Allows automatic derivation of 'Express' typeclass instances. 9 | module Data.Express.Express.Derive 10 | ( deriveExpress 11 | , deriveExpressCascading 12 | , deriveExpressIfNeeded 13 | ) 14 | where 15 | 16 | import Data.Express.Core 17 | import Data.Express.Express 18 | 19 | import Control.Monad 20 | import Data.Char 21 | import Data.List 22 | import Data.Express.Utils.TH 23 | import Data.Express.Utils.List 24 | import Data.Express.Utils.String 25 | import Language.Haskell.TH.Lib 26 | 27 | -- | Derives an 'Express' instance for the given type 'Name'. 28 | -- 29 | -- This function needs the @TemplateHaskell@ extension. 30 | -- 31 | -- If '-:', '->:', '->>:', '->>>:', ... are not in scope, 32 | -- this will derive them as well. 33 | deriveExpress :: Name -> DecsQ 34 | deriveExpress = deriveWhenNeededOrWarn ''Express reallyDeriveExpress 35 | 36 | -- | Same as 'deriveExpress' but does not warn when instance already exists 37 | -- ('deriveExpress' is preferable). 38 | deriveExpressIfNeeded :: Name -> DecsQ 39 | deriveExpressIfNeeded = deriveWhenNeeded ''Express reallyDeriveExpress 40 | 41 | -- | Derives a 'Express' instance for a given type 'Name' 42 | -- cascading derivation of type arguments as well. 43 | deriveExpressCascading :: Name -> DecsQ 44 | deriveExpressCascading = deriveWhenNeeded ''Express reallyDeriveExpressCascading 45 | 46 | reallyDeriveExpress :: Name -> DecsQ 47 | reallyDeriveExpress t = do 48 | isEq <- t `isInstanceOf` ''Eq 49 | isOrd <- t `isInstanceOf` ''Ord 50 | (nt,vs) <- normalizeType t 51 | #if __GLASGOW_HASKELL__ >= 710 52 | cxt <- sequence [ [t| $(conT c) $(return v) |] 53 | #else 54 | -- template-haskell <= 2.9.0.0: 55 | cxt <- sequence [ classP c [return v] 56 | #endif 57 | | c <- ''Express:([''Eq | isEq] ++ [''Ord | isOrd]) 58 | , v <- vs] 59 | cs <- typeConstructorsArgNames t 60 | asName <- newName "x" 61 | let withTheReturnTypeOfs = deriveWithTheReturnTypeOfs $ [length ns | (_,ns) <- cs] 62 | let generalizableExpr = mergeIFns $ foldr1 mergeI 63 | [ do let retTypeOf = mkName $ "-" ++ replicate (length ns) '>' ++ ":" 64 | let exprs = [[| expr $(varE n) |] | n <- ns] 65 | let conex = [| $(varE retTypeOf) $(conE c) $(varE asName) |] 66 | let root = [| value $(stringE $ showJustName c) $(conex) |] 67 | let rhs = foldl (\e1 e2 -> [| $e1 :$ $e2 |]) root exprs 68 | [d| instance Express $(return nt) where 69 | expr $(asP asName $ conP c (map varP ns)) = $rhs |] 70 | | (c,ns) <- cs 71 | ] 72 | withTheReturnTypeOfs |++| (cxt |=>| generalizableExpr) 73 | 74 | -- Not only really derive Express instances, 75 | -- but cascade through argument types. 76 | reallyDeriveExpressCascading :: Name -> DecsQ 77 | reallyDeriveExpressCascading = reallyDeriveCascading ''Express reallyDeriveExpress 78 | 79 | deriveWithTheReturnTypeOfs :: [Int] -> DecsQ 80 | deriveWithTheReturnTypeOfs = 81 | fmap concat . mapM deriveWithTheReturnTypeOf . nubSort 82 | 83 | deriveWithTheReturnTypeOf :: Int -> DecsQ 84 | deriveWithTheReturnTypeOf n = do 85 | mf <- lookupValueName name 86 | case mf of 87 | Nothing -> reallyDeriveWithTheReturnTypeOf n 88 | Just _ -> return [] 89 | where 90 | name = "-" ++ replicate n '>' ++ ":" 91 | 92 | reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ 93 | reallyDeriveWithTheReturnTypeOf n = do 94 | td <- sigD name theT 95 | vd <- [d| $(varP name) = const |] 96 | return $ td:vd 97 | where 98 | theT = bind [t| $(theFunT) -> $(last vars) -> $(theFunT) |] 99 | theFunT = foldr1 funT vars 100 | funT t1 t2 = [t| $(t1) -> $(t2) |] 101 | vars = map (varT . mkName) . take (n+1) . primeCycle $ map (:"") ['a'..'z'] 102 | name = mkName $ "-" ++ replicate n '>' ++ ":" 103 | #if __GLASGOW_HASKELL__ >= 800 104 | bind = id -- unbound variables are automatically bound 105 | #else 106 | bind = toBoundedQ 107 | #endif 108 | -------------------------------------------------------------------------------- /src/Data/Express/Fold.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Fold 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Defines utilities for folding and unfolding 'Expr's. 8 | {-# LANGUAGE CPP #-} 9 | #if __GLASGOW_HASKELL__ == 708 10 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} 11 | #endif 12 | module Data.Express.Fold 13 | ( fold 14 | , unfold 15 | , foldPair 16 | , unfoldPair 17 | , foldTrio 18 | , unfoldTrio 19 | , foldApp 20 | , unfoldApp 21 | ) 22 | where 23 | 24 | import Data.Express.Core 25 | import Data.Express.Utils.Typeable 26 | 27 | data ExprPair = ExprPair 28 | 29 | -- | /O(n)/. 30 | -- Folds a list of 'Expr' with function application (':$'). 31 | -- This reverses the effect of 'unfoldApp'. 32 | -- 33 | -- > foldApp [e0] = e0 34 | -- > foldApp [e0,e1] = e0 :$ e1 35 | -- > foldApp [e0,e1,e2] = e0 :$ e1 :$ e2 36 | -- > foldApp [e0,e1,e2,e3] = e0 :$ e1 :$ e2 :$ e3 37 | -- 38 | -- Remember ':$' is left-associative, so: 39 | -- 40 | -- > foldApp [e0] = e0 41 | -- > foldApp [e0,e1] = (e0 :$ e1) 42 | -- > foldApp [e0,e1,e2] = ((e0 :$ e1) :$ e2) 43 | -- > foldApp [e0,e1,e2,e3] = (((e0 :$ e1) :$ e2) :$ e3) 44 | -- 45 | -- This function /may/ produce an ill-typed expression. 46 | foldApp :: [Expr] -> Expr 47 | foldApp = foldl1 (:$) 48 | 49 | -- | /O(1)/. 50 | -- Folds a pair of 'Expr' values into a single 'Expr'. 51 | -- (cf. 'unfoldPair') 52 | -- 53 | -- This /always/ generates an ill-typed expression, 54 | -- as it uses a fake pair constructor. 55 | -- 56 | -- > > foldPair (val False, val (1::Int)) 57 | -- > (False,1) :: ill-typed # ExprPair $ Bool # 58 | -- 59 | -- > > foldPair (val (0::Int), val True) 60 | -- > (0,True) :: ill-typed # ExprPair $ Int # 61 | -- 62 | -- This is useful when applying transformations on pairs of 'Expr's, such as 63 | -- 'Data.Express.Canon.canonicalize', 64 | -- 'Data.Express.Map.mapValues' or 65 | -- 'Data.Express.Canon.canonicalVariations'. 66 | -- 67 | -- > > let ii = var "i" (undefined::Int) 68 | -- > > let kk = var "k" (undefined::Int) 69 | -- > > unfoldPair $ canonicalize $ foldPair (ii,kk) 70 | -- > (x :: Int,y :: Int) 71 | foldPair :: (Expr,Expr) -> Expr 72 | foldPair (e1,e2) = value "," (undefined :: ExprPair) :$ e1 :$ e2 73 | 74 | -- | /O(1)/. 75 | -- Unfolds an 'Expr' representing a pair. 76 | -- This reverses the effect of 'foldPair'. 77 | -- 78 | -- > > value "," ((,) :: Bool->Bool->(Bool,Bool)) :$ val True :$ val False 79 | -- > (True,False) :: (Bool,Bool) 80 | -- > > unfoldPair $ value "," ((,) :: Bool->Bool->(Bool,Bool)) :$ val True :$ val False 81 | -- > (True :: Bool,False :: Bool) 82 | unfoldPair :: Expr -> (Expr,Expr) 83 | unfoldPair (Value "," _ :$ e1 :$ e2) = (e1,e2) 84 | unfoldPair (Value "(,)" _ :$ e1 :$ e2) = (e1,e2) 85 | unfoldPair e = errorOn "unfoldPair" $ "not an Expr pair: " ++ show e 86 | 87 | data ExprTrio = ExprTrio 88 | 89 | -- | /O(1)/. 90 | -- Folds a trio/triple of 'Expr' values into a single 'Expr'. 91 | -- (cf. 'unfoldTrio') 92 | -- 93 | -- This /always/ generates an ill-typed expression 94 | -- as it uses a fake trio/triple constructor. 95 | -- 96 | -- > > foldTrio (val False, val (1::Int), val 'a') 97 | -- > (False,1,'a') :: ill-typed # ExprTrio $ Bool # 98 | -- 99 | -- > > foldTrio (val (0::Int), val True, val 'b') 100 | -- > (0,True,'b') :: ill-typed # ExprTrio $ Int # 101 | -- 102 | -- This is useful when applying transformations on pairs of 'Expr's, such as 103 | -- 'Data.Express.Canon.canonicalize', 104 | -- 'Data.Express.Map.mapValues' or 105 | -- 'Data.Express.Canon.canonicalVariations'. 106 | -- 107 | -- > > let ii = var "i" (undefined::Int) 108 | -- > > let kk = var "k" (undefined::Int) 109 | -- > > let zz = var "z" (undefined::Int) 110 | -- > > unfoldPair $ canonicalize $ foldPair (ii,kk,zz) 111 | -- > (x :: Int,y :: Int,z :: Int) 112 | foldTrio :: (Expr,Expr,Expr) -> Expr 113 | foldTrio (e1,e2,e3) = value ",," (undefined :: ExprTrio) :$ e1 :$ e2 :$ e3 114 | 115 | -- | /O(1)/. 116 | -- Unfolds an 'Expr' representing a trio/triple. 117 | -- This reverses the effect of 'foldTrio'. 118 | -- 119 | -- > > value ",," ((,,) :: Bool->Bool->Bool->(Bool,Bool,Bool)) :$ val True :$ val False :$ val True 120 | -- > (True,False,True) :: (Bool,Bool,Bool) 121 | -- > > unfoldTrio $ value ",," ((,,) :: Bool->Bool->Bool->(Bool,Bool,Bool)) :$ val True :$ val False :$ val True 122 | -- > (True :: Bool,False :: Bool,True :: Bool) 123 | -- 124 | -- (cf. 'unfoldPair') 125 | unfoldTrio :: Expr -> (Expr,Expr,Expr) 126 | unfoldTrio (Value ",," _ :$ e1 :$ e2 :$ e3) = (e1,e2,e3) 127 | unfoldTrio (Value "(,,)" _ :$ e1 :$ e2 :$ e3) = (e1,e2,e3) 128 | unfoldTrio e = errorOn "unfoldTrio" $ "not an Expr trio: " ++ show e 129 | 130 | data ExprList = ExprList 131 | 132 | -- | /O(n)/. 133 | -- Folds a list of 'Expr's into a single 'Expr'. 134 | -- (cf. 'unfold') 135 | -- 136 | -- This /always/ generates an ill-typed expression. 137 | -- 138 | -- > fold [val False, val True, val (1::Int)] 139 | -- > [False,True,1] :: ill-typed # ExprList $ Bool # 140 | -- 141 | -- This is useful when applying transformations on lists of 'Expr's, such as 142 | -- 'Data.Express.Canon.canonicalize', 143 | -- 'Data.Express.Map.mapValues' or 144 | -- 'Data.Express.Canon.canonicalVariations'. 145 | -- 146 | -- > > let ii = var "i" (undefined::Int) 147 | -- > > let kk = var "k" (undefined::Int) 148 | -- > > let qq = var "q" (undefined::Bool) 149 | -- > > let notE = value "not" not 150 | -- > > unfold . canonicalize . fold $ [ii,kk,notE :$ qq, notE :$ val False] 151 | -- > [x :: Int,y :: Int,not p :: Bool,not False :: Bool] 152 | fold :: [Expr] -> Expr 153 | fold [] = value "[]" ExprList 154 | fold (e:es) = value ":" ExprList :$ e :$ fold es 155 | 156 | -- | /O(n)/. 157 | -- Unfolds an 'Expr' representing a list into a list of 'Expr's. 158 | -- This reverses the effect of 'fold'. 159 | -- 160 | -- > > expr [1,2,3::Int] 161 | -- > [1,2,3] :: [Int] 162 | -- > > unfold $ expr [1,2,3::Int] 163 | -- > [1 :: Int,2 :: Int,3 :: Int] 164 | unfold :: Expr -> [Expr] 165 | unfold (Value "\"\"" _) = [] 166 | unfold (Value "[]" _) = [] 167 | unfold (Value ":" _ :$ e :$ es) = e : unfold es 168 | unfold e = errorOn "unfold" $ "cannot unfold expression: " ++ show e 169 | 170 | #if __GLASGOW_HASKELL__ == 708 171 | deriving instance Typeable ExprPair 172 | deriving instance Typeable ExprTrio 173 | deriving instance Typeable ExprList 174 | #endif 175 | 176 | errorOn :: String -> String -> a 177 | errorOn fn msg = error $ "Data.Express." ++ fn ++ ": " ++ msg 178 | -------------------------------------------------------------------------------- /src/Data/Express/Hole.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Hole 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Utilities for manipulating variables and typed holes encoded as 'Expr's. 8 | {-# LANGUAGE CPP #-} 9 | module Data.Express.Hole 10 | ( 11 | -- * Creating variables 12 | varAsTypeOf 13 | , listVars 14 | , listVarsAsTypeOf 15 | 16 | -- * Typed holes 17 | , hole 18 | , isHole 19 | , hasHole 20 | , isComplete 21 | , holes 22 | , nubHoles 23 | , holeAsTypeOf 24 | , fill 25 | ) 26 | where 27 | 28 | import Data.Express.Core 29 | 30 | import Data.Dynamic 31 | import Data.Maybe (fromMaybe) 32 | import Data.Express.Utils.Typeable (tyArity) 33 | import Data.Express.Utils.List (nubSort) 34 | import Data.Express.Utils.String (variableNamesFromTemplate) 35 | 36 | -- | /O(1)/. 37 | -- Creates a 'var'iable with the same type as the given 'Expr'. 38 | -- 39 | -- > > let one = val (1::Int) 40 | -- > > "x" `varAsTypeOf` one 41 | -- > x :: Int 42 | -- 43 | -- > > "p" `varAsTypeOf` val False 44 | -- > p :: Bool 45 | varAsTypeOf :: String -> Expr -> Expr 46 | varAsTypeOf n e = Value ('_':n) . undefine . fromMaybe err . toDynamic $ e 47 | where 48 | err = error 49 | $ "Data.Express.varAsTypeOf: could not compile Dynamic value for `" 50 | ++ show e 51 | ++ "' with name " ++ n 52 | undefine :: Dynamic -> Dynamic 53 | #if __GLASGOW_HASKELL__ >= 806 54 | undefine (Dynamic t v) = (Dynamic t undefined) 55 | #else 56 | undefine = id -- there's no way to do this using the old Data.Dynamic API. 57 | #endif 58 | 59 | -- | /O(1)/. 60 | -- Creates an 'Expr' representing a typed hole with the type of the given 61 | -- 'Expr'. (cf. 'hole') 62 | -- 63 | -- > > val (1::Int) 64 | -- > 1 :: Int 65 | -- > > holeAsTypeOf $ val (1::Int) 66 | -- > _ :: Int 67 | holeAsTypeOf :: Expr -> Expr 68 | holeAsTypeOf = ("" `varAsTypeOf`) 69 | 70 | -- | /O(1)/. 71 | -- Creates an 'Expr' representing a typed hole of the given argument type. 72 | -- 73 | -- > > hole (undefined :: Int) 74 | -- > _ :: Int 75 | -- 76 | -- > > hole (undefined :: Maybe String) 77 | -- > _ :: Maybe [Char] 78 | -- 79 | -- A hole is represented as a variable with no name or 80 | -- a value named @"_"@: 81 | -- 82 | -- > hole x = var "" x 83 | -- > hole x = value "_" x 84 | hole :: Typeable a => a -> Expr 85 | hole a = var "" (undefined `asTypeOf` a) 86 | 87 | -- | /O(1)/. 88 | -- Checks if an 'Expr' represents a typed hole. 89 | -- (cf. 'hole') 90 | -- 91 | -- > > isHole $ hole (undefined :: Int) 92 | -- > True 93 | -- 94 | -- > > isHole $ value "not" not :$ val True 95 | -- > False 96 | -- 97 | -- > > isHole $ val 'a' 98 | -- > False 99 | isHole :: Expr -> Bool 100 | isHole (Value "_" _) = True 101 | isHole _ = False 102 | 103 | -- | /O(n)/. 104 | -- Lists all holes in an expression, in order and with repetitions. 105 | -- (cf. 'nubHoles') 106 | -- 107 | -- > > holes $ hole (undefined :: Bool) 108 | -- > [_ :: Bool] 109 | -- 110 | -- > > holes $ value "&&" (&&) :$ hole (undefined :: Bool) :$ hole (undefined :: Bool) 111 | -- > [_ :: Bool,_ :: Bool] 112 | -- 113 | -- > > holes $ hole (undefined :: Bool->Bool) :$ hole (undefined::Bool) 114 | -- > [_ :: Bool -> Bool,_ :: Bool] 115 | holes :: Expr -> [Expr] 116 | holes = filter isHole . values 117 | 118 | -- | /O(n^2)/. 119 | -- Lists all holes in an expression without repetitions. 120 | -- (cf. 'holes') 121 | -- 122 | -- > > nubHoles $ hole (undefined :: Bool) 123 | -- > [_ :: Bool] 124 | -- 125 | -- > > nubHoles $ value "&&" (&&) :$ hole (undefined :: Bool) :$ hole (undefined :: Bool) 126 | -- > [_ :: Bool] 127 | -- 128 | -- > > nubHoles $ hole (undefined :: Bool->Bool) :$ hole (undefined::Bool) 129 | -- > [_ :: Bool,_ :: Bool -> Bool] 130 | -- 131 | -- Runtime averages to 132 | -- /O(n log n)/ on evenly distributed expressions 133 | -- such as @(f x + g y) + (h z + f w)@; 134 | -- and to /O(n^2)/ on deep expressions 135 | -- such as @f (g (h (f (g (h x)))))@. 136 | nubHoles :: Expr -> [Expr] 137 | nubHoles = nubSort . holes 138 | 139 | -- | /O(n)/. 140 | -- Returns whether an expression contains a hole 141 | -- 142 | -- > > hasHole $ hole (undefined :: Bool) 143 | -- > True 144 | -- 145 | -- > > hasHole $ value "not" not :$ val True 146 | -- > False 147 | -- 148 | -- > > hasHole $ value "not" not :$ hole (undefined :: Bool) 149 | -- > True 150 | hasHole :: Expr -> Bool 151 | hasHole = any isHole . values 152 | 153 | -- | /O(n)/. 154 | -- Returns whether an expression is complete. 155 | -- A complete expression is one without holes. 156 | -- 157 | -- > > isComplete $ hole (undefined :: Bool) 158 | -- > False 159 | -- 160 | -- > > isComplete $ value "not" not :$ val True 161 | -- > True 162 | -- 163 | -- > > isComplete $ value "not" not :$ hole (undefined :: Bool) 164 | -- > False 165 | -- 166 | -- 'isComplete' is the negation of 'hasHole'. 167 | -- 168 | -- > isComplete = not . hasHole 169 | -- 170 | -- 'isComplete' is to 'hasHole' what 171 | -- 'isGround' is to 'hasVar'. 172 | isComplete :: Expr -> Bool 173 | isComplete = not . hasHole 174 | 175 | -- | 176 | -- Generate an infinite list of variables 177 | -- based on a template and a given type. 178 | -- (cf. 'listVarsAsTypeOf') 179 | -- 180 | -- > > putL 10 $ listVars "x" (undefined :: Int) 181 | -- > [ x :: Int 182 | -- > , y :: Int 183 | -- > , z :: Int 184 | -- > , x' :: Int 185 | -- > , y' :: Int 186 | -- > , z' :: Int 187 | -- > , x'' :: Int 188 | -- > , ... 189 | -- > ] 190 | -- 191 | -- > > putL 10 $ listVars "p" (undefined :: Bool) 192 | -- > [ p :: Bool 193 | -- > , q :: Bool 194 | -- > , r :: Bool 195 | -- > , p' :: Bool 196 | -- > , q' :: Bool 197 | -- > , r' :: Bool 198 | -- > , p'' :: Bool 199 | -- > , ... 200 | -- > ] 201 | listVars :: Typeable a => String -> a -> [Expr] 202 | listVars s a = map (`var` a) (variableNamesFromTemplate s) 203 | 204 | -- | 205 | -- Generate an infinite list of variables 206 | -- based on a template 207 | -- and the type of a given 'Expr'. 208 | -- (cf. 'listVars') 209 | -- 210 | -- > > let one = val (1::Int) 211 | -- > > putL 10 $ "x" `listVarsAsTypeOf` one 212 | -- > [ x :: Int 213 | -- > , y :: Int 214 | -- > , z :: Int 215 | -- > , x' :: Int 216 | -- > , ... 217 | -- > ] 218 | -- 219 | -- > > let false = val False 220 | -- > > putL 10 $ "p" `listVarsAsTypeOf` false 221 | -- > [ p :: Bool 222 | -- > , q :: Bool 223 | -- > , r :: Bool 224 | -- > , p' :: Bool 225 | -- > , ... 226 | -- > ] 227 | listVarsAsTypeOf :: String -> Expr -> [Expr] 228 | listVarsAsTypeOf s e = map (`varAsTypeOf` e) (variableNamesFromTemplate s) 229 | 230 | 231 | -- | Fill holes in an expression with the given list. 232 | -- 233 | -- > > let i_ = hole (undefined :: Int) 234 | -- > > let e1 -+- e2 = value "+" ((+) :: Int -> Int -> Int) :$ e1 :$ e2 235 | -- > > let xx = var "x" (undefined :: Int) 236 | -- > > let yy = var "y" (undefined :: Int) 237 | -- 238 | -- > > fill (i_ -+- i_) [xx, yy] 239 | -- > x + y :: Int 240 | -- 241 | -- > > fill (i_ -+- i_) [xx, xx] 242 | -- > x + x :: Int 243 | -- 244 | -- > > let one = val (1::Int) 245 | -- 246 | -- > > fill (i_ -+- i_) [one, one -+- one] 247 | -- > 1 + (1 + 1) :: Int 248 | -- 249 | -- This function silently remaining expressions: 250 | -- 251 | -- > > fill i_ [xx, yy] 252 | -- > x :: Int 253 | -- 254 | -- This function silently keeps remaining holes: 255 | -- 256 | -- > > fill (i_ -+- i_ -+- i_) [xx, yy] 257 | -- > (x + y) + _ :: Int 258 | -- 259 | -- This function silently skips remaining holes 260 | -- if one is not of the right type: 261 | -- 262 | -- > > fill (i_ -+- i_ -+- i_) [xx, val 'c', yy] 263 | -- > (x + _) + _ :: Int 264 | fill :: Expr -> [Expr] -> Expr 265 | fill e = fst . fill' e 266 | where 267 | fill' :: Expr -> [Expr] -> (Expr,[Expr]) 268 | fill' (e1 :$ e2) es = let (e1',es') = fill' e1 es 269 | (e2',es'') = fill' e2 es' 270 | in (e1' :$ e2', es'') 271 | fill' eh (e:es) | isHole eh && typ eh == typ e = (e,es) 272 | fill' e es = (e,es) 273 | -------------------------------------------------------------------------------- /src/Data/Express/Map.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Map 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Utilities for mapping or transforming 'Expr's. 8 | module Data.Express.Map 9 | ( mapValues 10 | , mapVars 11 | , mapConsts 12 | , mapSubexprs 13 | , (//-) 14 | , (//) 15 | , renameVarsBy 16 | ) 17 | where 18 | 19 | import Data.Express.Core 20 | import Data.Express.Utils.List 21 | import Data.Maybe (fromMaybe) 22 | 23 | -- | /O(n*m)/. 24 | -- Applies a function to all terminal values in an expression. 25 | -- (cf. '//-') 26 | -- 27 | -- Given that: 28 | -- 29 | -- > > let zero = val (0 :: Int) 30 | -- > > let one = val (1 :: Int) 31 | -- > > let two = val (2 :: Int) 32 | -- > > let three = val (3 :: Int) 33 | -- > > let xx -+- yy = value "+" ((+) :: Int->Int->Int) :$ xx :$ yy 34 | -- > > let intToZero e = if typ e == typ zero then zero else e 35 | -- 36 | -- Then: 37 | -- 38 | -- > > one -+- (two -+- three) 39 | -- > 1 + (2 + 3) :: Int 40 | -- 41 | -- > > mapValues intToZero $ one -+- (two -+- three) 42 | -- > 0 + (0 + 0) :: Integer 43 | -- 44 | -- Given that the argument function is /O(m)/, this function is /O(n*m)/. 45 | mapValues :: (Expr -> Expr) -> Expr -> Expr 46 | mapValues f = m 47 | where 48 | m (e1 :$ e2) = m e1 :$ m e2 49 | m e = f e 50 | 51 | -- | /O(n*m)/. 52 | -- Applies a function to all variables in an expression. 53 | -- 54 | -- Given that: 55 | -- 56 | -- > > let primeify e = if isVar e 57 | -- > | then case e of (Value n d) -> Value (n ++ "'") d 58 | -- > | else e 59 | -- > > let xx = var "x" (undefined :: Int) 60 | -- > > let yy = var "y" (undefined :: Int) 61 | -- > > let xx -+- yy = value "+" ((+) :: Int->Int->Int) :$ xx :$ yy 62 | -- 63 | -- Then: 64 | -- 65 | -- > > xx -+- yy 66 | -- > x + y :: Int 67 | -- 68 | -- > > primeify xx 69 | -- > x' :: Int 70 | -- 71 | -- > > mapVars primeify $ xx -+- yy 72 | -- > x' + y' :: Int 73 | -- 74 | -- > > mapVars (primeify . primeify) $ xx -+- yy 75 | -- > x'' + y'' :: Int 76 | -- 77 | -- Given that the argument function is /O(m)/, this function is /O(n*m)/. 78 | mapVars :: (Expr -> Expr) -> Expr -> Expr 79 | mapVars f = mapValues f' 80 | where 81 | f' e = if isVar e 82 | then f e 83 | else e 84 | 85 | -- | /O(n*m)/. 86 | -- Applies a function to all terminal constants in an expression. 87 | -- 88 | -- Given that: 89 | -- 90 | -- > > let one = val (1 :: Int) 91 | -- > > let two = val (2 :: Int) 92 | -- > > let xx -+- yy = value "+" ((+) :: Int->Int->Int) :$ xx :$ yy 93 | -- > > let intToZero e = if typ e == typ zero then zero else e 94 | -- 95 | -- Then: 96 | -- 97 | -- > > one -+- (two -+- xx) 98 | -- > 1 + (2 + x) :: Int 99 | -- 100 | -- > > mapConsts intToZero (one -+- (two -+- xx)) 101 | -- > 0 + (0 + x) :: Integer 102 | -- 103 | -- Given that the argument function is /O(m)/, this function is /O(n*m)/. 104 | mapConsts :: (Expr -> Expr) -> Expr -> Expr 105 | mapConsts f = mapValues f' 106 | where 107 | f' e = if isConst e 108 | then f e 109 | else e 110 | 111 | -- | /O(n*m)/. 112 | -- Substitute subexpressions of an expression using the given function. 113 | -- Outer expressions have more precedence than inner expressions. 114 | -- (cf. '//') 115 | -- 116 | -- With: 117 | -- 118 | -- > > let xx = var "x" (undefined :: Int) 119 | -- > > let yy = var "y" (undefined :: Int) 120 | -- > > let zz = var "z" (undefined :: Int) 121 | -- > > let plus = value "+" ((+) :: Int->Int->Int) 122 | -- > > let times = value "*" ((*) :: Int->Int->Int) 123 | -- > > let xx -+- yy = plus :$ xx :$ yy 124 | -- > > let xx -*- yy = times :$ xx :$ yy 125 | -- 126 | -- > > let pluswap (o :$ xx :$ yy) | o == plus = Just $ o :$ yy :$ xx 127 | -- > | pluswap _ = Nothing 128 | -- 129 | -- Then: 130 | -- 131 | -- > > mapSubexprs pluswap $ (xx -*- yy) -+- (yy -*- zz) 132 | -- > y * z + x * y :: Int 133 | -- 134 | -- > > mapSubexprs pluswap $ (xx -+- yy) -*- (yy -+- zz) 135 | -- > (y + x) * (z + y) :: Int 136 | -- 137 | -- Substitutions do not stack, in other words 138 | -- a replaced expression or its subexpressions are not further replaced: 139 | -- 140 | -- > > mapSubexprs pluswap $ (xx -+- yy) -+- (yy -+- zz) 141 | -- > (y + z) + (x + y) :: Int 142 | -- 143 | -- Given that the argument function is /O(m)/, this function is /O(n*m)/. 144 | mapSubexprs :: (Expr -> Maybe Expr) -> Expr -> Expr 145 | mapSubexprs f = m 146 | where 147 | m e = fromMaybe e' (f e) 148 | where 149 | e' = case e of 150 | e1 :$ e2 -> m e1 :$ m e2 151 | e -> e 152 | 153 | -- | /O(n*m)/. 154 | -- Substitute occurrences of values in an expression 155 | -- from the given list of substitutions. 156 | -- (cf. 'mapValues') 157 | -- 158 | -- Given that: 159 | -- 160 | -- > > let xx = var "x" (undefined :: Int) 161 | -- > > let yy = var "y" (undefined :: Int) 162 | -- > > let zz = var "z" (undefined :: Int) 163 | -- > > let xx -+- yy = value "+" ((+) :: Int->Int->Int) :$ xx :$ yy 164 | -- 165 | -- Then: 166 | -- 167 | -- > > ((xx -+- yy) -+- (yy -+- zz)) //- [(xx, yy), (zz, yy)] 168 | -- > (y + y) + (y + y) :: Int 169 | -- 170 | -- > > ((xx -+- yy) -+- (yy -+- zz)) //- [(yy, yy -+- zz)] 171 | -- > (x + (y + z)) + ((y + z) + z) :: Int 172 | -- 173 | -- This function does not work for substituting non-terminal subexpressions: 174 | -- 175 | -- > > (xx -+- yy) //- [(xx -+- yy, zz)] 176 | -- > x + y :: Int 177 | -- 178 | -- Please use the slower '//' if you want the above replacement to work. 179 | -- 180 | -- Replacement happens only once: 181 | -- 182 | -- > > xx //- [(xx,yy), (yy,zz)] 183 | -- > y :: Int 184 | -- 185 | -- Given that the argument list has length /m/, 186 | -- this function is /O(n*m)/. 187 | (//-) :: Expr -> [(Expr,Expr)] -> Expr 188 | e //- s = mapValues (`lookupId` s) e 189 | 190 | -- | /O(n*n*m)/. 191 | -- Substitute subexpressions in an expression 192 | -- from the given list of substitutions. 193 | -- (cf. 'mapSubexprs'). 194 | -- 195 | -- Please consider using '//-' if you are replacing just terminal values 196 | -- as it is faster. 197 | -- 198 | -- Given that: 199 | -- 200 | -- > > let xx = var "x" (undefined :: Int) 201 | -- > > let yy = var "y" (undefined :: Int) 202 | -- > > let zz = var "z" (undefined :: Int) 203 | -- > > let xx -+- yy = value "+" ((+) :: Int->Int->Int) :$ xx :$ yy 204 | -- 205 | -- Then: 206 | -- 207 | -- > > ((xx -+- yy) -+- (yy -+- zz)) // [(xx -+- yy, yy), (yy -+- zz, yy)] 208 | -- > y + y :: Int 209 | -- 210 | -- > > ((xx -+- yy) -+- zz) // [(xx -+- yy, zz), (zz, xx -+- yy)] 211 | -- > z + (x + y) :: Int 212 | -- 213 | -- Replacement happens only once with outer expressions 214 | -- having more precedence than inner expressions. 215 | -- 216 | -- > > (xx -+- yy) // [(yy,xx), (xx -+- yy,zz), (zz,xx)] 217 | -- > z :: Int 218 | -- 219 | -- Given that the argument list has length /m/, this function is /O(n*n*m)/. 220 | -- Remember that since /n/ is the size of an expression, 221 | -- comparing two expressions is /O(n)/ in the worst case, 222 | -- and we may need to compare with /n/ subexpressions in the worst case. 223 | (//) :: Expr -> [(Expr,Expr)] -> Expr 224 | e // s = mapSubexprs (`lookup` s) e 225 | 226 | -- | Rename variables in an 'Expr'. 227 | -- 228 | -- > > renameVarsBy (++ "'") (xx -+- yy) 229 | -- > x' + y' :: Int 230 | -- 231 | -- > > renameVarsBy (++ "'") (yy -+- (zz -+- xx)) 232 | -- > (y' + (z' + x')) :: Int 233 | -- 234 | -- > > renameVarsBy (++ "1") (abs' xx) 235 | -- > abs x1 :: Int 236 | -- 237 | -- > > renameVarsBy (++ "2") $ abs' (xx -+- yy) 238 | -- > abs (x2 + y2) :: Int 239 | -- 240 | -- NOTE: this will affect holes! 241 | renameVarsBy :: (String -> String) -> Expr -> Expr 242 | renameVarsBy f = mapValues f' 243 | where 244 | f' (Value ('_':n) t) = Value ('_':f n) t 245 | f' e = e 246 | -------------------------------------------------------------------------------- /src/Data/Express/Match.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Match 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Utilities for matching 'Expr's with 'var'iables. 8 | module Data.Express.Match 9 | ( match 10 | , matchWith 11 | , isInstanceOf 12 | , hasInstanceOf 13 | , isSubexprOf 14 | , encompasses 15 | ) 16 | where 17 | 18 | import Data.Express.Core 19 | import Data.Express.Utils 20 | 21 | -- | 22 | -- Given two expressions, returns a 'Just' list of matches 23 | -- of subexpressions of the first expressions 24 | -- to variables in the second expression. 25 | -- Returns 'Nothing' when there is no match. 26 | -- 27 | -- > > let zero = val (0::Int) 28 | -- > > let one = val (1::Int) 29 | -- > > let xx = var "x" (undefined :: Int) 30 | -- > > let yy = var "y" (undefined :: Int) 31 | -- > > let e1 -+- e2 = value "+" ((+)::Int->Int->Int) :$ e1 :$ e2 32 | -- 33 | -- > > (zero -+- one) `match` (xx -+- yy) 34 | -- > Just [(y :: Int,1 :: Int),(x :: Int,0 :: Int)] 35 | -- 36 | -- > > (zero -+- (one -+- two)) `match` (xx -+- yy) 37 | -- > Just [(y :: Int,1 + 2 :: Int),(x :: Int,0 :: Int)] 38 | -- 39 | -- > > (zero -+- (one -+- two)) `match` (xx -+- (yy -+- yy)) 40 | -- > Nothing 41 | -- 42 | -- In short: 43 | -- 44 | -- > (zero -+- one) `match` (xx -+- yy) = Just [(xx,zero), (yy,one)] 45 | -- > (zero -+- (one -+- two)) `match` (xx -+- yy) = Just [(xx,zero), (yy,one-+-two)] 46 | -- > (zero -+- (one -+- two)) `match` (xx -+- (yy -+- yy)) = Nothing 47 | match :: Expr -> Expr -> Maybe [(Expr,Expr)] 48 | match = matchWith [] 49 | 50 | -- | 51 | -- Like 'match' but allowing predefined bindings. 52 | -- 53 | -- > matchWith [(xx,zero)] (zero -+- one) (xx -+- yy) = Just [(xx,zero), (yy,one)] 54 | -- > matchWith [(xx,one)] (zero -+- one) (xx -+- yy) = Nothing 55 | matchWith :: [(Expr,Expr)] -> Expr -> Expr -> Maybe [(Expr,Expr)] 56 | matchWith bs e1' e2' = m e1' e2' bs 57 | where 58 | m :: Expr -> Expr -> [(Expr,Expr)] -> Maybe [(Expr,Expr)] 59 | m (f1 :$ x1) (f2 :$ x2) = m f1 f2 >=> m x1 x2 60 | m e1 e2 61 | | isVar e2 && mtyp e1 == mtyp e2 = updateAssignments (e2,e1) 62 | | e1 == e2 = Just 63 | | otherwise = const Nothing 64 | 65 | updateAssignments :: (Expr,Expr) -> [(Expr,Expr)] -> Maybe [(Expr,Expr)] 66 | updateAssignments (e,e') = \bs -> 67 | case lookup e bs of 68 | Nothing -> Just ((e,e'):bs) 69 | Just e'' -> if e'' == e' 70 | then Just bs 71 | else Nothing 72 | 73 | -- | 74 | -- Given two 'Expr's, 75 | -- checks if the first expression 76 | -- is an instance of the second 77 | -- in terms of variables. 78 | -- (cf. 'encompasses', 'hasInstanceOf') 79 | -- 80 | -- > > let zero = val (0::Int) 81 | -- > > let one = val (1::Int) 82 | -- > > let xx = var "x" (undefined :: Int) 83 | -- > > let yy = var "y" (undefined :: Int) 84 | -- > > let e1 -+- e2 = value "+" ((+)::Int->Int->Int) :$ e1 :$ e2 85 | -- 86 | -- > one `isInstanceOf` one = True 87 | -- > xx `isInstanceOf` xx = True 88 | -- > yy `isInstanceOf` xx = True 89 | -- > zero `isInstanceOf` xx = True 90 | -- > xx `isInstanceOf` zero = False 91 | -- > one `isInstanceOf` zero = False 92 | -- > (xx -+- (yy -+- xx)) `isInstanceOf` (xx -+- yy) = True 93 | -- > (yy -+- (yy -+- xx)) `isInstanceOf` (xx -+- yy) = True 94 | -- > (zero -+- (yy -+- xx)) `isInstanceOf` (zero -+- yy) = True 95 | -- > (one -+- (yy -+- xx)) `isInstanceOf` (zero -+- yy) = False 96 | -- 97 | -- This function works on ill-typed expressions 98 | -- so long as the leaf/atom types match: 99 | -- 100 | -- > > foldPair (xx -+- zero, xx) `isInstanceOf` foldPair (yy -+- zero, yy) 101 | -- > True 102 | isInstanceOf :: Expr -> Expr -> Bool 103 | e1 `isInstanceOf` e2 = isJust $ e1 `match` e2 104 | 105 | 106 | -- | 107 | -- Given two 'Expr's, 108 | -- checks if the first expression 109 | -- encompasses the second expression 110 | -- in terms of variables. 111 | -- 112 | -- This is equivalent to flipping the arguments of 'isInstanceOf'. 113 | -- 114 | -- > zero `encompasses` xx = False 115 | -- > xx `encompasses` zero = True 116 | encompasses :: Expr -> Expr -> Bool 117 | encompasses = flip isInstanceOf 118 | 119 | 120 | -- | 121 | -- Checks if any of the subexpressions of the first argument 'Expr' 122 | -- is an instance of the second argument 'Expr'. 123 | hasInstanceOf :: Expr -> Expr -> Bool 124 | e1 `hasInstanceOf` e2 = any (`isInstanceOf` e2) (subexprs e1) 125 | 126 | -- | /O(n^2)/. 127 | -- Checks if an 'Expr' is a subexpression of another. 128 | -- 129 | -- > > (xx -+- yy) `isSubexprOf` (zz -+- (xx -+- yy)) 130 | -- > True 131 | -- 132 | -- > > (xx -+- yy) `isSubexprOf` abs' (yy -+- xx) 133 | -- > False 134 | -- 135 | -- > > xx `isSubexprOf` yy 136 | -- > False 137 | isSubexprOf :: Expr -> Expr -> Bool 138 | isSubexprOf e = (e `elem`) . subexprs 139 | -------------------------------------------------------------------------------- /src/Data/Express/Name.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Name 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Defines the 'Name' type class. 8 | module Data.Express.Name 9 | ( Name (..) 10 | , names 11 | , variableNamesFromTemplate 12 | ) 13 | where 14 | 15 | import Data.Express.Utils.String 16 | 17 | import Data.List 18 | 19 | -- for instances: 20 | import Data.Int 21 | import Data.Word 22 | import Data.Ratio 23 | import Data.Complex 24 | import Data.Char 25 | 26 | -- | 27 | -- If we were to come up with a variable name for the given type 28 | -- what 'name' would it be? 29 | -- 30 | -- An instance for a given type @ Ty @ is simply given by: 31 | -- 32 | -- > instance Name Ty where name _ = "x" 33 | -- 34 | -- Examples: 35 | -- 36 | -- > > name (undefined :: Int) 37 | -- > "x" 38 | -- 39 | -- > > name (undefined :: Bool) 40 | -- > "p" 41 | -- 42 | -- > > name (undefined :: [Int]) 43 | -- > "xs" 44 | -- 45 | -- This is then used to generate an infinite list of variable 'names': 46 | -- 47 | -- > > names (undefined :: Int) 48 | -- > ["x", "y", "z", "x'", "y'", "z'", "x''", "y''", "z''", ...] 49 | -- 50 | -- > > names (undefined :: Bool) 51 | -- > ["p", "q", "r", "p'", "q'", "r'", "p''", "q''", "r''", ...] 52 | -- 53 | -- > > names (undefined :: [Int]) 54 | -- > ["xs", "ys", "zs", "xs'", "ys'", "zs'", "xs''", "ys''", ...] 55 | class Name a where 56 | -- | /O(1)./ 57 | -- 58 | -- Returns a name for a variable of the given argument's type. 59 | -- 60 | -- > > name (undefined :: Int) 61 | -- > "x" 62 | -- 63 | -- > > name (undefined :: [Bool]) 64 | -- > "ps" 65 | -- 66 | -- > > name (undefined :: [Maybe Integer]) 67 | -- > "mxs" 68 | -- 69 | -- The default definition is: 70 | -- 71 | -- > name _ = "x" 72 | name :: a -> String 73 | name _ = "x" 74 | 75 | -- | 76 | -- > name (undefined :: ()) = "u" 77 | -- > names (undefined :: ()) = ["u", "v", "w", "u'", "v'", ...] 78 | instance Name () where name _ = "u" 79 | 80 | -- | 81 | -- > name (undefined :: Bool) = "p" 82 | -- > names (undefined :: Bool) = ["p", "q", "r", "p'", "q'", ...] 83 | instance Name Bool where name _ = "p" 84 | 85 | -- | 86 | -- > name (undefined :: Int) = "x" 87 | -- > names (undefined :: Int) = ["x", "y", "z", "x'", "y'", ...] 88 | instance Name Int where name _ = "x" 89 | 90 | -- | 91 | -- > name (undefined :: Integer) = "x" 92 | -- > names (undefined :: Integer) = ["x", "y", "z", "x'", ...] 93 | instance Name Integer where name _ = "x" 94 | 95 | -- | 96 | -- > name (undefined :: Char) = "c" 97 | -- > names (undefined :: Char) = ["c", "d", "e", "c'", "d'", ...] 98 | instance Name Char where name _ = "c" 99 | 100 | -- | 101 | -- > name (undefined :: Ordering) = "o" 102 | -- > names (undefined :: Ordering) = ["o", "p", "q", "o'", ...] 103 | instance Name Ordering where name _ = "o" 104 | 105 | -- | 106 | -- > name (undefined :: Rational) = "q" 107 | -- > names (undefined :: Rational) = ["q", "r", "s", "q'", ...] 108 | instance Name (Ratio a) where name _ = "q" 109 | 110 | -- | 111 | -- > name (undefined :: Complex) = "x" 112 | -- > names (undefined :: Complex) = ["x", "y", "z", "x'", ...] 113 | instance Name (Complex a) where name _ = "x" 114 | 115 | -- | 116 | -- > name (undefined :: Float) = "x" 117 | -- > names (undefined :: Float) = ["x", "y", "z", "x'", ...] 118 | instance Name Float where name _ = "x" 119 | 120 | -- | 121 | -- > name (undefined :: Double) = "x" 122 | -- > names (undefined :: Double) = ["x", "y", "z", "x'", ...] 123 | instance Name Double where name _ = "x" 124 | 125 | -- | 126 | -- > names (undefined :: ()->()) = ["f", "g", "h", "f'", ...] 127 | -- > names (undefined :: Int->Int) = ["f", "g", "h", ...] 128 | instance Name (a -> b) where name _ = "f" 129 | 130 | -- | 131 | -- > names (undefined :: Maybe Int) = ["mx", "mx1", "mx2", ...] 132 | -- > nemes (undefined :: Maybe Bool) = ["mp", "mp1", "mp2", ...] 133 | instance Name a => Name (Maybe a) where 134 | name mx = "m" ++ name x 135 | where 136 | Just x = mx 137 | 138 | -- | 139 | -- > names (undefined :: Either Int Int) = ["exy", "exy1", ...] 140 | -- > names (undefined :: Either Int Bool) = ["exp", "exp1", ...] 141 | instance (Name a, Name b) => Name (Either a b) where 142 | name exy = "e" ++ n ++ m 143 | where 144 | Left x = exy 145 | Right y = exy 146 | n = name x 147 | (m:_) = delete n $ names y 148 | 149 | -- | 150 | -- > names (undefined :: (Int,Int)) = ["xy", "zw", "xy'", ...] 151 | -- > names (undefined :: (Bool,Bool)) = ["pq", "rs", "pq'", ...] 152 | instance (Name a, Name b) => Name (a,b) where 153 | name xy = n ++ m 154 | where 155 | (x,y) = xy 156 | n = name x 157 | (m:_) = delete n $ names y 158 | 159 | -- | 160 | -- > names (undefined :: (Int,Int,Int)) = ["xyz","uvw", ...] 161 | -- > names (undefined :: (Int,Bool,Char)) = ["xpc", "xpc1", ...] 162 | instance (Name a, Name b, Name c) => Name (a,b,c) where 163 | name xyz = n ++ m ++ o 164 | where 165 | (x,y,z) = xyz 166 | n = name x 167 | (m:_) = names y \\ [n] 168 | (o:_) = names z \\ [n,m] 169 | 170 | -- | 171 | -- > names (undefined :: ((),(),(),())) = ["uuuu", "uuuu1", ...] 172 | -- > names (undefined :: (Int,Int,Int,Int)) = ["xxxx", ...] 173 | instance (Name a, Name b, Name c, Name d) => Name (a,b,c,d) where 174 | name xyzw = name x ++ name y ++ name z ++ name w where (x,y,z,w) = xyzw 175 | 176 | -- | 177 | -- > names (undefined :: [Int]) = ["xs", "ys", "zs", "xs'", ...] 178 | -- > names (undefined :: [Bool]) = ["ps", "qs", "rs", "ps'", ...] 179 | instance Name a => Name [a] where 180 | name xs = name x ++ "s" where (x:_) = xs 181 | 182 | -- | 183 | -- Returns na infinite list of variable names from the given type: 184 | -- the result of 'variableNamesFromTemplate' after 'name'. 185 | -- 186 | -- > > names (undefined :: Int) 187 | -- > ["x", "y", "z", "x'", "y'", "z'", "x''", "y''", "z''", ...] 188 | -- 189 | -- > > names (undefined :: Bool) 190 | -- > ["p", "q", "r", "p'", "q'", "r'", "p''", "q''", "r''", ...] 191 | -- 192 | -- > > names (undefined :: [Int]) 193 | -- > ["xs", "ys", "zs", "xs'", "ys'", "zs'", "xs''", "ys''", ...] 194 | names :: Name a => a -> [String] 195 | names = variableNamesFromTemplate . name 196 | 197 | 198 | -- instances of further types and arities -- 199 | 200 | instance Name Word where name _ = "x" 201 | 202 | instance Name Int8 where name _ = "x" 203 | instance Name Int16 where name _ = "x" 204 | instance Name Int32 where name _ = "x" 205 | instance Name Int64 where name _ = "x" 206 | instance Name Word8 where name _ = "x" 207 | instance Name Word16 where name _ = "x" 208 | instance Name Word32 where name _ = "x" 209 | instance Name Word64 where name _ = "x" 210 | instance Name GeneralCategory where name _ = "c" 211 | 212 | instance (Name a, Name b, Name c, Name d, Name e) => Name (a,b,c,d,e) where 213 | name xyzwv = name x ++ name y ++ name z ++ name w ++ name v 214 | where (x,y,z,w,v) = xyzwv 215 | 216 | instance (Name a, Name b, Name c, Name d, Name e, Name f) 217 | => Name (a,b,c,d,e,f) where 218 | name xyzwvu = name x ++ name y ++ name z ++ name w ++ name v ++ name u 219 | where (x,y,z,w,v,u) = xyzwvu 220 | 221 | instance (Name a, Name b, Name c, Name d, Name e, Name f, Name g) 222 | => Name (a,b,c,d,e,f,g) where 223 | name xyzwvut = name x ++ name y ++ name z ++ name w 224 | ++ name v ++ name u ++ name t 225 | where (x,y,z,w,v,u,t) = xyzwvut 226 | 227 | instance (Name a, Name b, Name c, Name d, Name e, Name f, Name g, Name h) 228 | => Name (a,b,c,d,e,f,g,h) where 229 | name xyzwvuts = name x ++ name y ++ name z ++ name w 230 | ++ name v ++ name u ++ name t ++ name s 231 | where (x,y,z,w,v,u,t,s) = xyzwvuts 232 | 233 | instance ( Name a, Name b, Name c, Name d 234 | , Name e, Name f, Name g, Name h 235 | , Name i) 236 | => Name (a,b,c,d,e,f,g,h,i) where 237 | name xyzwvutsr = name x ++ name y ++ name z ++ name w 238 | ++ name v ++ name u ++ name t ++ name s 239 | ++ name r 240 | where (x,y,z,w,v,u,t,s,r) = xyzwvutsr 241 | 242 | instance ( Name a, Name b, Name c, Name d 243 | , Name e, Name f, Name g, Name h 244 | , Name i, Name j ) 245 | => Name (a,b,c,d,e,f,g,h,i,j) where 246 | name xyzwvutsrq = name x ++ name y ++ name z ++ name w 247 | ++ name v ++ name u ++ name t ++ name s 248 | ++ name r ++ name q 249 | where (x,y,z,w,v,u,t,s,r,q) = xyzwvutsrq 250 | 251 | instance ( Name a, Name b, Name c, Name d 252 | , Name e, Name f, Name g, Name h 253 | , Name i, Name j, Name k ) 254 | => Name (a,b,c,d,e,f,g,h,i,j,k) where 255 | name xyzwvutsrqp = name x ++ name y ++ name z ++ name w 256 | ++ name v ++ name u ++ name t ++ name s 257 | ++ name r ++ name q ++ name p 258 | where (x,y,z,w,v,u,t,s,r,q,p) = xyzwvutsrqp 259 | 260 | instance ( Name a, Name b, Name c, Name d 261 | , Name e, Name f, Name g, Name h 262 | , Name i, Name j, Name k, Name l ) 263 | => Name (a,b,c,d,e,f,g,h,i,j,k,l) where 264 | name xyzwvutsrqpo = name x ++ name y ++ name z ++ name w 265 | ++ name v ++ name u ++ name t ++ name s 266 | ++ name r ++ name q ++ name p ++ name o 267 | where (x,y,z,w,v,u,t,s,r,q,p,o) = xyzwvutsrqpo 268 | -------------------------------------------------------------------------------- /src/Data/Express/Name/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | -- | 3 | -- Module : Data.Express.Name.Derive 4 | -- Copyright : (c) 2019-2024 Rudy Matela 5 | -- License : 3-Clause BSD (see the file LICENSE) 6 | -- Maintainer : Rudy Matela 7 | -- 8 | -- Allows automatic derivation of 'Name' typeclass instances. 9 | module Data.Express.Name.Derive 10 | ( deriveName 11 | , deriveNameCascading 12 | , deriveNameIfNeeded 13 | ) 14 | where 15 | 16 | import qualified Data.Express.Name as N 17 | 18 | import Control.Monad 19 | import Data.Char 20 | import Data.List 21 | import Data.Express.Utils.TH 22 | 23 | -- | Derives a 'N.Name' instance 24 | -- for the given type 'Name'. 25 | -- 26 | -- This function needs the @TemplateHaskell@ extension. 27 | deriveName :: Name -> DecsQ 28 | deriveName = deriveWhenNeededOrWarn ''N.Name reallyDeriveName 29 | 30 | -- | Same as 'deriveName' but does not warn when instance already exists 31 | -- ('deriveName' is preferable). 32 | deriveNameIfNeeded :: Name -> DecsQ 33 | deriveNameIfNeeded = deriveWhenNeeded ''N.Name reallyDeriveName 34 | 35 | -- | Derives a 'N.Name' instance for a given type 'Name' 36 | -- cascading derivation of type arguments as well. 37 | deriveNameCascading :: Name -> DecsQ 38 | deriveNameCascading = deriveWhenNeeded ''N.Name reallyDeriveNameCascading 39 | 40 | reallyDeriveName :: Name -> DecsQ 41 | reallyDeriveName t = do 42 | (nt,vs) <- normalizeType t 43 | isNum <- t `isInstanceOf` ''Num 44 | [d| instance N.Name $(return nt) where 45 | name _ = $(stringE $ vname isNum) |] 46 | where 47 | showJustName = reverse . takeWhile (/= '.') . reverse . show 48 | vname True = "x" 49 | vname False = map toLower . take 1 $ showJustName t 50 | 51 | -- Not only really derive Name instances, 52 | -- but cascade through argument types. 53 | reallyDeriveNameCascading :: Name -> DecsQ 54 | reallyDeriveNameCascading = reallyDeriveCascading ''N.Name reallyDeriveName 55 | -------------------------------------------------------------------------------- /src/Data/Express/Triexpr.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Triexpr 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- This module is part of Express. 8 | -- 9 | -- An __experimental__ data structure for matching 'Expr's. 10 | -- 11 | -- __Warning (1):__ 12 | -- Take care when importing this module, 13 | -- the interface is experimental 14 | -- and may change at every minor version. 15 | -- 16 | -- __Warning (2):__ 17 | -- YMMV: 18 | -- Do not expect this to be faster than manually matching in a list, 19 | -- provisional experiments show that it can be slower depending 20 | -- on the set of expressions being matched. 21 | -- 22 | -- This module should be imported qualified 23 | -- as it exports definitions called 24 | -- 'map', 'lookup', 'toList', 'fromList', 'insert' and 'empty': 25 | -- 26 | -- > import Data.Express.Triexpr (Triexpr) 27 | -- > import qualified Data.Express.Triexpr as T 28 | module Data.Express.Triexpr 29 | ( Triexpr (..) 30 | , empty 31 | , unit 32 | , merge 33 | , insert 34 | , toList 35 | , fromList 36 | , map 37 | , lookup 38 | ) 39 | where 40 | 41 | import Data.Express.Core 42 | import Data.Express.Match 43 | import Data.Maybe 44 | import Prelude hiding (map, lookup) 45 | 46 | -- | A trie of 'Expr's. 47 | -- 48 | -- In the representation, 49 | -- 'Nothing' matches an App and 'Just' 'Expr' an expression. 50 | newtype Triexpr a = Triexpr [(Maybe Expr, Either (Triexpr a) (Expr,a))] 51 | deriving (Eq, Ord, Show) 52 | 53 | -- | An empty 'Triexpr'. 54 | empty :: Triexpr a 55 | empty = Triexpr [] 56 | 57 | -- | Constructs a 'Triexpr' encoding a single expression. 58 | unit :: Expr -> a -> Triexpr a 59 | unit e x = u e (Right (e,x)) 60 | where 61 | u :: Expr -> (Either (Triexpr a) (Expr,a)) -> Triexpr a 62 | u (e1 :$ e2) et = Triexpr [(Nothing, Left $ u e1 $ Left $ u e2 et)] 63 | u e et = Triexpr [(Just e, et)] 64 | 65 | -- | Merges two 'Triexpr's. 66 | merge :: Triexpr a -> Triexpr a -> Triexpr a 67 | merge (Triexpr ms1) (Triexpr ms2) = Triexpr $ m ms1 ms2 68 | where 69 | m [] ms = ms 70 | m ms [] = ms 71 | m ((e1,mt1):ms1) ((e2,mt2):ms2) = case compare e1 e2 of 72 | LT -> (e1,mt1) : m ms1 ((e2,mt2):ms2) 73 | GT -> (e2,mt2) : m ((e1,mt1):ms1) ms2 74 | EQ -> case (mt1,mt2) of 75 | (Left t1, Left t2) -> (e1, Left $ t1 `merge` t2) : m ms1 ms2 76 | (_,_) -> (e1,mt1) : (e2,mt2) : m ms1 ms2 77 | 78 | -- | Inserts an 'Expr' into a 'Triexpr'. 79 | insert :: Expr -> a -> Triexpr a -> Triexpr a 80 | insert e x t = unit e x `merge` t 81 | 82 | -- | List all 'Expr' stored in a 'Triexpr' along with their associated values. 83 | toList :: Triexpr a -> [(Expr, a)] 84 | toList (Triexpr ms) = concatMap to ms 85 | where 86 | to (_, Right ex) = [ex] 87 | to (_, Left t) = toList t 88 | 89 | -- | Constructs a 'Triexpr' form a list of key 'Expr's and associated values. 90 | fromList :: [(Expr, a)] -> Triexpr a 91 | fromList = foldr (uncurry insert) empty 92 | 93 | -- | Maps a function to the stored values in a 'Triexpr'. 94 | map :: (a -> b) -> Triexpr a -> Triexpr b 95 | map f (Triexpr ms) = Triexpr [(ex, mapEither (map f) (mapSnd f) eth) | (ex, eth) <- ms] 96 | where 97 | mapEither :: (a -> c) -> (b -> d) -> Either a b -> Either c d 98 | mapEither f g (Left x) = Left (f x) 99 | mapEither f g (Right y) = Right (g y) 100 | mapSnd :: (a -> b) -> (c,a) -> (c,b) 101 | mapSnd f (x,y) = (x, f y) 102 | 103 | -- | Performs a lookup in a 'Triexpr'. 104 | lookup :: Expr -> Triexpr a -> [ (Expr, [(Expr,Expr)], a) ] 105 | lookup e t = [(e, bs, x) | (bs, Right (e,x)) <- look (Just e) t []] 106 | where 107 | look :: Maybe Expr -> Triexpr a -> [(Expr, Expr)] -> [([(Expr,Expr)], Either (Triexpr a) (Expr,a))] 108 | look Nothing t@(Triexpr ms) bs = [(bs, mt) | (Nothing, mt) <- ms] 109 | look (Just e) t@(Triexpr ms) bs = [(bs', mt) | (Just e', mt) <- ms, bs' <- maybeToList (matchWith bs e e')] 110 | ++ [r | e1 :$ e2 <- [e] 111 | , (bs1, Left t1) <- look Nothing t bs 112 | , (bs2, Left t2) <- look (Just e1) t1 bs1 113 | , r <- look (Just e2) t2 bs2] 114 | -------------------------------------------------------------------------------- /src/Data/Express/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Utils.List 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Re-exports a few standard Haskell modules module along with additional 8 | -- functions. 9 | {-# LANGUAGE CPP #-} 10 | module Data.Express.Utils 11 | ( module Data.Express.Utils.List 12 | , module Data.Express.Utils.String 13 | , module Data.Monoid 14 | , module Data.Maybe 15 | , module Data.Either 16 | , module Data.Function 17 | , module Control.Monad 18 | #if __GLASGOW_HASKELL__ < 704 19 | , (<>) 20 | #endif 21 | #if __HUGS__ 22 | , (>=>) 23 | #endif 24 | ) 25 | where 26 | 27 | import Data.Express.Utils.List 28 | import Data.Express.Utils.String 29 | import Data.Function 30 | import Data.Maybe 31 | import Data.Either 32 | import Data.Monoid 33 | import Control.Monad 34 | 35 | #if __GLASGOW_HASKELL__ < 704 36 | -- Data.Monoid exports <> since GHC 7.4 / base 4.5.0.0 37 | -- GHC 7.2 / base 4.4.1.0 / Hugs 2006.9 do not define <> 38 | (<>) :: Monoid m => m -> m -> m 39 | (<>) = mappend 40 | infixr 6 <> 41 | #endif 42 | 43 | #if __HUGS__ 44 | (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) 45 | f >=> g = \x -> f x >>= g 46 | #endif 47 | -------------------------------------------------------------------------------- /src/Data/Express/Utils/List.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Utils.List 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Re-exports the "Data.List" module along with additional functions over 8 | -- lists. 9 | {-# LANGUAGE CPP #-} 10 | module Data.Express.Utils.List 11 | ( nubSort 12 | , nubSortBy 13 | , isPermutationOf 14 | , isSubsetOf 15 | , isNub 16 | , none 17 | , lookupId 18 | , (+++) 19 | , module Data.List 20 | #if __GLASGOW_HASKELL__ < 710 21 | , isSubsequenceOf 22 | #endif 23 | #ifdef __HUGS__ 24 | , intercalate 25 | #endif 26 | ) 27 | where 28 | 29 | import Data.Function (on) 30 | import Data.List 31 | import Data.Maybe (fromMaybe) 32 | 33 | -- | /O(n log n)/. 34 | -- Sorts and remove repetitions. 35 | -- Equivalent to @nub . sort@. 36 | -- 37 | -- > > nubSort [1,2,3] 38 | -- > [1,2,3] 39 | -- > > nubSort [3,2,1] 40 | -- > [1,2,3] 41 | -- > > nubSort [3,2,1,3,2,1] 42 | -- > [1,2,3] 43 | -- > > nubSort [3,3,1,1,2,2] 44 | -- > [1,2,3] 45 | nubSort :: Ord a => [a] -> [a] 46 | nubSort = nnub . sort 47 | where 48 | -- linear nub of adjacent values 49 | nnub [] = [] 50 | nnub [x] = [x] 51 | nnub (x:xs) = x : nnub (dropWhile (==x) xs) 52 | 53 | -- | Like 'nubSort' but allows providing a function to 'compare' values. 54 | nubSortBy :: (a -> a -> Ordering) -> [a] -> [a] 55 | nubSortBy cmp = nnub . sortBy cmp 56 | where 57 | x -==- y = x `cmp` y == EQ 58 | -- linear nub of adjacent values 59 | nnub [] = [] 60 | nnub [x] = [x] 61 | nnub (x:xs) = x : nnub (dropWhile (-==-x) xs) 62 | 63 | -- | /O(n log n)/. 64 | -- Checks that all elements of the first list are elements of the second. 65 | isSubsetOf :: Ord a => [a] -> [a] -> Bool 66 | xs `isSubsetOf` ys = nubSort xs `isSubsequenceOf` nubSort ys 67 | 68 | 69 | #if __GLASGOW_HASKELL__ < 710 70 | -- only exported from Data.List since base 4.8.0.0 71 | isSubsequenceOf :: Eq a => [a] -> [a] -> Bool 72 | isSubsequenceOf [] _ = True 73 | isSubsequenceOf (_:_) [] = False 74 | isSubsequenceOf (x:xs) (y:ys) | x == y = xs `isSubsequenceOf` ys 75 | | otherwise = (x:xs) `isSubsequenceOf` ys 76 | #endif 77 | 78 | -- | /O(n log n)/. 79 | -- Checks that all elements of the first list are elements of the second. 80 | isPermutationOf :: Ord a => [a] -> [a] -> Bool 81 | isPermutationOf = (==) `on` sort 82 | 83 | -- | /O(n log n)/. 84 | -- Checks that all elements are unique. 85 | -- This function is a faster equivalent to the following: 86 | -- 87 | -- > isNub xs = nub xs == xs 88 | -- 89 | -- Examples: 90 | -- 91 | -- > isNub [] = True 92 | -- > isNub [1,2,3] = True 93 | -- > isNub [2,1,2] = False 94 | isNub :: Ord a => [a] -> Bool 95 | isNub xs = length (nubSort xs) == length xs 96 | 97 | -- | Determines whether no element of the given list satisfies the predicate. 98 | -- 99 | -- > > none even [3,5,7,11,13] 100 | -- > True 101 | -- 102 | -- > > none even [7,5,3,2] 103 | -- > False 104 | none :: (a -> Bool) -> [a] -> Bool 105 | none p = not . any p 106 | 107 | -- | /O(n)/. 108 | -- Like 'lookup' but returns the key itself if nothing is found. 109 | -- 110 | -- > > lookupId 5 [(1,2),(3,4)] 111 | -- > 5 112 | -- 113 | -- > > lookupId 5 [(1,2),(3,4),(5,6)] 114 | -- > 6 115 | lookupId :: Eq a => a -> [(a,a)] -> a 116 | lookupId x = fromMaybe x . lookup x 117 | 118 | -- | Merges two lists discarding repeated elements. 119 | -- 120 | -- The argument lists need to be in order. 121 | -- 122 | -- > > [1,10,100] +++ [9,10,11] 123 | -- > [1,9,10,11,100] 124 | (+++) :: Ord a => [a] -> [a] -> [a] 125 | (+++) = nubMerge 126 | infixr 5 +++ 127 | 128 | -- | Like 'nubMerge' but allows providing a function to 'compare' values. 129 | nubMergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] 130 | nubMergeBy cmp (x:xs) (y:ys) = case x `cmp` y of 131 | LT -> x:nubMergeBy cmp xs (y:ys) 132 | GT -> y:nubMergeBy cmp (x:xs) ys 133 | EQ -> x:nubMergeBy cmp xs ys 134 | nubMergeBy _ xs ys = xs ++ ys 135 | 136 | -- | Merges two lists discarding repeated elements. 137 | -- 138 | -- The argument lists need to be in order. 139 | nubMerge :: Ord a => [a] -> [a] -> [a] 140 | nubMerge = nubMergeBy compare 141 | 142 | #ifdef __HUGS__ 143 | intercalate :: [a] -> [[a]] -> [a] 144 | intercalate xs xss = concat (intersperse xs xss) 145 | where 146 | intersperse :: a -> [a] -> [a] 147 | intersperse _ [] = [] 148 | intersperse sep (x:xs) = x : prependToAll sep xs 149 | where 150 | prependToAll :: a -> [a] -> [a] 151 | prependToAll _ [] = [] 152 | prependToAll sep (x:xs) = sep : x : prependToAll sep xs 153 | #endif 154 | -------------------------------------------------------------------------------- /src/Data/Express/Utils/String.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Utils.String 3 | -- Copyright : (c) 2016-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Utilities for manipulating strings. 8 | -- 9 | -- At some point, this file was part of the Speculate tool. 10 | module Data.Express.Utils.String 11 | ( module Data.Char 12 | , unquote 13 | , atomic 14 | , outernmostPrec 15 | , isNegativeLiteral 16 | , isInfix, isPrefix, isInfixedPrefix 17 | , toPrefix 18 | , prec 19 | , variableNamesFromTemplate 20 | , primeCycle 21 | ) 22 | where 23 | 24 | import Data.Char 25 | import Data.Express.Utils.List 26 | 27 | -- | Unquotes a string if possible, otherwise, this is just an identity. 28 | -- 29 | -- > > unquote "\"string\"" 30 | -- > "string" 31 | -- 32 | -- > > unquote "something else" 33 | -- > "something else" 34 | unquote :: String -> String 35 | unquote ('"':s) | last s == '"' = init s 36 | unquote s = s 37 | 38 | -- | Checks if a string-encoded Haskell expression is atomic. 39 | -- 40 | -- > > atomic "123" 41 | -- > True 42 | -- > > atomic "42 + 1337" 43 | -- > False 44 | -- > > atomic "'a'" 45 | -- > True 46 | -- > > atomic "[1,2,3,4,5]" 47 | -- > True 48 | -- > > atomic "(1,2,3,4,5)" 49 | -- > True 50 | -- 51 | -- FIXME: The current implementation may produce false positives: 52 | -- 53 | -- > > atomic "'a' < 'b'" 54 | -- > True 55 | -- > > atomic "\"asdf\" ++ \"qwer\"" 56 | -- > True 57 | -- > > atomic "[1,2,3] ++ [4,5,6]" 58 | -- > True 59 | -- 60 | -- but this does not cause problems for (all?) most cases. 61 | atomic :: String -> Bool 62 | atomic s | none isSpace s = True 63 | atomic ('\'':s) | last s == '\'' = True 64 | atomic ('"':s) | last s == '"' = True 65 | atomic ('[':s) | last s == ']' = True 66 | atomic ('(':s) | last s == ')' = True 67 | atomic _ = False 68 | 69 | -- | 70 | -- Returns the operator precedence of an infix string. 71 | -- 72 | -- > > outernmostPrec "1 + 2" 73 | -- > Just 6 74 | outernmostPrec :: String -> Maybe Int 75 | outernmostPrec s = 76 | case words s of 77 | [l,o,r] | isInfix o -> Just (prec o) 78 | _ -> Nothing 79 | 80 | -- | 81 | -- Returns whether the given 'String' represents a negative literal. 82 | -- 83 | -- > > isNegativeLiteral "1" 84 | -- > False 85 | -- > > isNegativeLiteral "-1" 86 | -- > True 87 | -- > > isNegativeLiteral "-x" 88 | -- > False 89 | -- > > isNegativeLiteral "1 - 3" 90 | -- > False 91 | isNegativeLiteral :: String -> Bool 92 | isNegativeLiteral s | not (atomic s) = False 93 | isNegativeLiteral "-" = False 94 | isNegativeLiteral ('-':cs) = all isDigit cs 95 | isNegativeLiteral _ = False 96 | 97 | -- | Check if a function / operator is infix 98 | -- 99 | -- > isInfix "foo" == False 100 | -- > isInfix "(+)" == False 101 | -- > isInfix "`foo`" == True 102 | -- > isInfix "+" == True 103 | isInfix :: String -> Bool 104 | isInfix (c:_) = c `notElem` "()'\"[_" && not (isAlphaNum c) 105 | isInfix "" = False 106 | 107 | -- | Returns the precedence of default Haskell operators 108 | prec :: String -> Int 109 | prec " " = 10 110 | prec "!!" = 9 111 | prec "." = 9 112 | prec "^" = 8 113 | prec "^^" = 8 114 | prec "**" = 8 115 | prec "*" = 7 116 | prec "/" = 7 117 | prec "%" = 7 118 | prec "+" = 6 119 | prec "-" = 6 120 | prec ":" = 5 121 | prec "++" = 5 122 | prec "\\" = 5 123 | prec ">" = 4 124 | prec "<" = 4 125 | prec ">=" = 4 126 | prec "<=" = 4 127 | prec "==" = 4 128 | prec "/=" = 4 129 | prec "`elem`" = 4 130 | prec "&&" = 3 131 | prec "||" = 2 132 | prec ">>=" = 1 133 | prec ">>" = 1 134 | prec ">=>" = 1 135 | prec "<=<" = 1 136 | prec "$" = 0 137 | prec "`seq`" = 0 138 | prec "==>" = 0 139 | prec "<==>" = 0 140 | prec _ = 9 141 | 142 | -- | Is the given string a prefix function? 143 | -- 144 | -- > > isPrefix "abs" 145 | -- > True 146 | -- 147 | -- > > isPrefix "+" 148 | -- > False 149 | isPrefix :: String -> Bool 150 | isPrefix = not . isInfix 151 | 152 | -- | Is the string of the form @\`string\`@ 153 | isInfixedPrefix :: String -> Bool 154 | isInfixedPrefix s | not (atomic s) = False 155 | isInfixedPrefix ('`':cs) = last cs == '`' 156 | isInfixedPrefix _ = False 157 | 158 | -- | Transform an infix operator into an infix function: 159 | -- 160 | -- > toPrefix "`foo`" == "foo" 161 | -- > toPrefix "+" == "(+)" 162 | toPrefix :: String -> String 163 | toPrefix ('`':cs) = init cs 164 | toPrefix cs = '(':cs ++ ")" 165 | 166 | -- | 167 | -- Cycles through a list of variable names 168 | -- priming them at each iteration. 169 | -- 170 | -- > primeCycle ["x","y","z"] 171 | -- ["x","y","z","x'","y'","z'","x''","y''","z''","x'''",...] 172 | primeCycle :: [String] -> [String] 173 | primeCycle [] = [] 174 | primeCycle ss = ss ++ map (++ "'") (primeCycle ss) 175 | 176 | -- | 177 | -- Returns an infinite list of variable names based on the given template. 178 | -- 179 | -- > > variableNamesFromTemplate "x" 180 | -- > ["x", "y", "z", "x'", "y'", ...] 181 | -- 182 | -- > > variableNamesFromTemplate "p" 183 | -- > ["p", "q", "r", "p'", "q'", ...] 184 | -- 185 | -- > > variableNamesFromTemplate "xy" 186 | -- > ["xy", "zw", "xy'", "zw'", "xy''", ...] 187 | variableNamesFromTemplate :: String -> [String] 188 | variableNamesFromTemplate = primeCycle . f 189 | where 190 | f "" = f "x" 191 | f "x" = ["x", "y", "z"] -- redundant, for clarity 192 | f "xy" = ["xy", "zw"] 193 | f "xyz" = ["xyz", "uvw"] 194 | f cs | isDigit (last cs) = map (\n -> init cs ++ show n) [digitToInt (last cs)..] 195 | f [c] | c `elem` ['a'..'x'] = let x = ord c in map ((:[]) . chr) [x,x+1,x+2] 196 | f cs | last cs == 's' = (++ "s") `map` f (init cs) 197 | f [c,d] | ord d - ord c == 1 = [[c,d], [chr $ ord c + 2, chr $ ord d + 2]] 198 | f cs | cs == "y" || cs == "z" = cs : map (\n -> cs ++ show n) [1..] 199 | f cs = [cs] 200 | -------------------------------------------------------------------------------- /src/Data/Express/Utils/Typeable.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Express.Utils.Typeable 3 | -- Copyright : (c) 2016-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- This module is part of Express. 8 | -- 9 | -- Utilities to manipulate 'TypeRep's (of 'Typeable' values). 10 | module Data.Express.Utils.Typeable 11 | ( tyArity 12 | , unFunTy 13 | , isFunTy 14 | , argumentTy 15 | , resultTy 16 | , finalResultTy 17 | , boolTy 18 | , intTy 19 | , orderingTy 20 | , mkComparisonTy 21 | , mkCompareTy 22 | , funTyCon 23 | , compareTy 24 | , elementTy 25 | , typesIn 26 | , typesInList 27 | , countListTy 28 | , (->::) 29 | , module Data.Typeable 30 | ) 31 | where 32 | 33 | import Data.Typeable 34 | import Data.Express.Utils 35 | 36 | -- | Compares two 'TypeRep's. 37 | -- 38 | -- Different versions of Typeable/GHC 39 | -- provide different orderings for 'TypeRep's. 40 | -- The following is a version independent ordering, 41 | -- with the following properties: 42 | -- 43 | -- * functional types with more arguments are larger; 44 | -- * type constructors with more arguments are larger. 45 | -- 46 | -- > > typeOf (undefined :: Int -> Int) `compareTy` typeOf (undefined :: () -> () -> ()) 47 | -- > LT 48 | -- 49 | -- > > typeOf (undefined :: Int) `compareTy` typeOf (undefined :: ()) 50 | -- > GT 51 | compareTy :: TypeRep -> TypeRep -> Ordering 52 | compareTy t1 t2 | t1 == t2 = EQ -- optional optimization 53 | compareTy t1 t2 = tyArity t1 `compare` tyArity t2 54 | <> length ts1 `compare` length ts2 55 | <> showTyCon c1 `compare` showTyCon c2 56 | <> foldr (<>) EQ (zipWith compareTy ts1 ts2) 57 | where 58 | (c1,ts1) = splitTyConApp t1 59 | (c2,ts2) = splitTyConApp t2 60 | 61 | -- | Shows a 'TyCon' consistently across different GHC versions. 62 | -- This is needed in the implementation of `compareTy`. 63 | -- 64 | -- On GHC <= 9.4: 65 | -- 66 | -- > > show listTyCon 67 | -- > "[]" 68 | -- 69 | -- On GHC >= 9.6: 70 | -- 71 | -- > > show listTyCon 72 | -- > "List" 73 | -- 74 | -- On all GHCs: 75 | -- 76 | -- > > showTyCon listTyCon 77 | -- > "[]" 78 | -- 79 | -- On GHC <= 9.6: 80 | -- 81 | -- > > show unitTyCon 82 | -- > "()" 83 | -- 84 | -- On GHC >= 9.8: 85 | -- 86 | -- > > show unitTyCon 87 | -- > "Unit" 88 | -- 89 | -- On all GHCs: 90 | -- 91 | -- > > showTyCon unitTyCon 92 | -- > "()" 93 | -- 94 | -- Further exceptions to `show :: TyCon -> String` may be added here 95 | -- on future versions. 96 | showTyCon :: TyCon -> String 97 | showTyCon con 98 | | con == listTyCon = "[]" 99 | | con == unitTyCon = "()" 100 | | otherwise = show con 101 | 102 | -- | Returns the functional arity of the given 'TypeRep'. 103 | -- 104 | -- > > tyArity $ typeOf (undefined :: Int) 105 | -- > 0 106 | -- 107 | -- > > tyArity $ typeOf (undefined :: Int -> Int) 108 | -- > 1 109 | -- 110 | -- > > tyArity $ typeOf (undefined :: (Int,Int)) 111 | -- > 0 112 | tyArity :: TypeRep -> Int 113 | tyArity t 114 | | isFunTy t = 1 + tyArity (resultTy t) 115 | | otherwise = 0 116 | 117 | -- | Returns the ultimate result type of the given 'TypeRep'. 118 | -- 119 | -- > > finalResultTy (typeOf (undefined :: Int)) 120 | -- > Int 121 | -- 122 | -- > > finalResultTy (typeOf (undefined :: Int -> Char)) 123 | -- > Char 124 | -- 125 | -- > > finalResultTy (typeOf (undefined :: Int -> Char -> Bool)) 126 | -- > Bool 127 | finalResultTy :: TypeRep -> TypeRep 128 | finalResultTy t 129 | | isFunTy t = finalResultTy (resultTy t) 130 | | otherwise = t 131 | 132 | -- | Deconstructs a functional 'TypeRep' into a pair of 'TypeRep's. 133 | -- 134 | -- > > unFunTy $ typeOf (undefined :: Int -> Char -> Bool) 135 | -- > (Int,Char -> Bool) 136 | -- 137 | -- This function raises an error on non-functional types. 138 | -- 139 | -- (cf. 'argumentTy' and 'resultTy') 140 | unFunTy :: TypeRep -> (TypeRep,TypeRep) 141 | unFunTy t 142 | | isFunTy t = let (f,[a,b]) = splitTyConApp t in (a,b) 143 | | otherwise = errorOn "unFunTy" $ "`" ++ show t ++ "' is not a function type" 144 | 145 | -- | Returns the argument 'TypeRep' of a given functional 'TypeRep'. 146 | -- 147 | -- > argumentTy $ typeOf (undefined :: Int -> Char) 148 | -- > Int 149 | -- 150 | -- This function raises an error on non-functional types. 151 | -- 152 | -- (cf. 'resultTy') 153 | argumentTy :: TypeRep -> TypeRep 154 | argumentTy = fst . unFunTy 155 | 156 | -- | Returns the result 'TypeRep' of a given functional 'TypeRep'. 157 | -- 158 | -- > > resultTy $ typeOf (undefined :: Int -> Char) 159 | -- > Char 160 | -- 161 | -- > > resultTy $ typeOf (undefined :: Int -> Char -> Bool) 162 | -- > Char -> Bool 163 | -- 164 | -- This function raises an error on non-functional types. 165 | -- 166 | -- (cf. 'argumentTy' and 'finalResultTy') 167 | resultTy :: TypeRep -> TypeRep 168 | resultTy = snd . unFunTy 169 | 170 | -- | This function returns the type of the element of a list. 171 | -- It will throw an error when not given the list type. 172 | -- 173 | -- > > > elementTy $ typeOf (undefined :: [Int]) 174 | -- > Int 175 | -- > > > elementTy $ typeOf (undefined :: [[Int]]) 176 | -- > [Int] 177 | -- > > > elementTy $ typeOf (undefined :: [Bool]) 178 | -- > Bool 179 | -- > > > elementTy $ typeOf (undefined :: Bool) 180 | -- > *** Exception: Data.Express.Utils.Typeable.elementTy: `Bool' is not a list type 181 | elementTy :: TypeRep -> TypeRep 182 | elementTy t 183 | | isListTy t = let (_,[a]) = splitTyConApp t in a 184 | | otherwise = errorOn "elementTy" $ "`" ++ show t ++ "' is not a list type" 185 | 186 | -- | The 'Bool' type encoded as a 'TypeRep'. 187 | boolTy :: TypeRep 188 | boolTy = typeOf (undefined :: Bool) 189 | 190 | -- | The 'Int' type encoded as a 'TypeRep'. 191 | intTy :: TypeRep 192 | intTy = typeOf (undefined :: Int) 193 | 194 | -- | The 'Ordering' type encoded as a 'TypeRep'. 195 | orderingTy :: TypeRep 196 | orderingTy = typeOf (undefined :: Ordering) 197 | 198 | -- | The function type constructor as a 'TyCon' 199 | funTyCon :: TyCon 200 | funTyCon = typeRepTyCon $ typeOf (undefined :: () -> ()) 201 | 202 | -- | The list type constructor as a 'TyCon' 203 | listTyCon :: TyCon 204 | listTyCon = typeRepTyCon $ typeOf (undefined :: [()]) 205 | 206 | -- | The unit type constructor as a 'TyCon' 207 | unitTyCon :: TyCon 208 | unitTyCon = typeRepTyCon $ typeOf (undefined :: ()) 209 | 210 | -- | Returns whether a 'TypeRep' is functional. 211 | -- 212 | -- > > isFunTy $ typeOf (undefined :: Int -> Int) 213 | -- > True 214 | -- > > isFunTy $ typeOf (undefined :: Int) 215 | -- > False 216 | isFunTy :: TypeRep -> Bool 217 | isFunTy t = 218 | case splitTyConApp t of 219 | (con,[_,_]) | con == funTyCon -> True 220 | _ -> False 221 | 222 | isListTy :: TypeRep -> Bool 223 | isListTy t = case splitTyConApp t of 224 | (con,[_]) | con == listTyCon -> True 225 | _ -> False 226 | 227 | -- | Return the number of outer list nestings in a 'TypeRep' 228 | -- 229 | -- > > countListTy $ typeOf (undefined :: Int) 230 | -- > 0 231 | -- 232 | -- > > countListTy $ typeOf (undefined :: [Bool]) 233 | -- > 1 234 | -- 235 | -- > > countListTy $ typeOf (undefined :: [[()]]) 236 | -- > 2 237 | -- 238 | -- > > countListTy $ typeOf (undefined :: String) 239 | -- > 1 240 | -- 241 | -- > > countListTy $ typeOf (undefined :: ([Int],[Bool])) 242 | -- > 0 243 | countListTy :: TypeRep -> Int 244 | countListTy t = case splitTyConApp t of 245 | (con,[t']) | con == listTyCon -> 1 + countListTy t' 246 | _ -> 0 247 | 248 | -- | Constructs a comparison type (@ a -> a -> Bool @) 249 | -- from the given argument type. 250 | -- 251 | -- > > mkComparisonTy $ typeOf (undefined :: Int) 252 | -- > Int -> Int -> Bool 253 | -- 254 | -- > > mkComparisonTy $ typeOf (undefined :: ()) 255 | -- > () -> () -> Bool 256 | mkComparisonTy :: TypeRep -> TypeRep 257 | mkComparisonTy a = a ->:: a ->:: boolTy 258 | 259 | -- | Constructs a "compare" type (@ a -> a -> Ordering @) 260 | -- from the given argument type. 261 | -- 262 | -- > > mkCompareTy $ typeOf (undefined :: Int) 263 | -- > Int -> Int -> Ordering 264 | -- 265 | -- > > mkCompareTy $ typeOf (undefined :: ()) 266 | -- > () -> () -> Ordering 267 | 268 | mkCompareTy :: TypeRep -> TypeRep 269 | mkCompareTy a = a ->:: a ->:: orderingTy 270 | 271 | -- | /O(n)/. 272 | -- Return all sub types of a given type including itself. 273 | -- 274 | -- > > typesIn $ typeOf (undefined :: Int) 275 | -- > [Int] 276 | -- 277 | -- > > typesIn $ typeOf (undefined :: Bool) 278 | -- > [Bool] 279 | -- 280 | -- > > typesIn $ typeOf (undefined :: [Int]) 281 | -- > [ Int 282 | -- > , [Int] 283 | -- > ] 284 | -- 285 | -- > > typesIn $ typeOf (undefined :: Int -> Int -> Int) 286 | -- > [ Int 287 | -- > , Int -> Int 288 | -- > , Int -> Int -> Int 289 | -- > ] 290 | -- 291 | -- > > typesIn $ typeOf (undefined :: Int -> [Int] -> [Int]) 292 | -- > [ Int 293 | -- > , [Int] 294 | -- > , [Int] -> [Int] 295 | -- > , Int -> [Int] -> [Int] 296 | -- > ] 297 | -- 298 | -- > > typesIn $ typeOf (undefined :: Maybe Bool) 299 | -- > [ Bool 300 | -- > , Maybe Bool 301 | -- > ] 302 | typesIn :: TypeRep -> [TypeRep] 303 | typesIn t = typesInList [t] 304 | 305 | -- | Returns types and subtypes from the given list of 'TypeRep's. 306 | -- 307 | -- > > typesInList [typeOf (undefined :: () -> Int), typeOf (undefined :: String -> String -> Bool)] 308 | -- > [(),Bool,Char,Int,[Char],() -> Int,[Char] -> Bool,[Char] -> [Char] -> Bool] 309 | -- 310 | -- > > typesInList [typeOf (undefined :: (Char,Int))] 311 | -- > [Char,Int,(Char,Int)] 312 | typesInList :: [TypeRep] -> [TypeRep] 313 | typesInList ts = nubSortBy compareTy $ tins ts [] 314 | where 315 | tin t = (t:) . tins (typeRepArgs t) 316 | tins = foldr ((.) . tin) id 317 | 318 | -- | An infix alias for 'mkFunTy'. It is right associative. 319 | (->::) :: TypeRep -> TypeRep -> TypeRep 320 | (->::) = mkFunTy 321 | infixr 9 ->:: 322 | 323 | errorOn :: String -> String -> a 324 | errorOn fn msg = error $ "Data.Express.Utils.Typeable." ++ fn ++ ": " ++ msg 325 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 # or ghc-9.4.8 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test 3 | -- Copyright : (c) 2019-2024 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- This module defines utilities used to test "Data.Express". 8 | -- 9 | -- It should never be exported in @ express.cabal @. 10 | module Test 11 | ( module Test.LeanCheck 12 | , module Test.LeanCheck.Derive 13 | , module Test.LeanCheck.Utils 14 | , module Data.Express.Fixtures 15 | , module Data.Express.Utils.List 16 | , module Data.Express.Utils.Typeable 17 | , module Test.ListableExpr 18 | , module Data.Maybe 19 | , module Data.Either 20 | , module Data.Monoid 21 | , mainTest 22 | 23 | , tyBool 24 | , tyInt 25 | , tyChar 26 | , tyInts 27 | , tyIntToInt 28 | 29 | , allRules 30 | , boolRules 31 | , intRules 32 | , listRules 33 | ) 34 | where 35 | 36 | import System.Environment (getArgs, getProgName) 37 | import System.Exit (exitFailure) 38 | import Data.List (elemIndices) 39 | import Data.Typeable (TypeRep, typeOf) 40 | 41 | import Data.Maybe 42 | import Data.Either 43 | import Data.Monoid 44 | import Test.LeanCheck 45 | import Test.LeanCheck.Utils 46 | import Test.LeanCheck.Derive 47 | import Test.ListableExpr 48 | import Data.Express.Fixtures 49 | import Data.Express.Utils.List 50 | import Data.Express.Utils.Typeable 51 | 52 | reportTests :: String -> [Bool] -> IO () 53 | reportTests s tests = 54 | case elemIndices False tests of 55 | [] -> putStrLn $ s ++ ": tests passed" 56 | is -> do putStrLn (s ++ ": failed tests:" ++ show is) 57 | exitFailure 58 | 59 | getMaxTestsFromArgs :: Int -> IO Int 60 | getMaxTestsFromArgs n = do 61 | as <- getArgs 62 | return $ case as of 63 | (s:_) -> read s 64 | _ -> n 65 | 66 | mainTest :: (Int -> [Bool]) -> Int -> IO () 67 | mainTest tests n' = do 68 | pn <- getProgName 69 | n <- getMaxTestsFromArgs n' 70 | reportTests pn (tests n) 71 | 72 | tyBool :: TypeRep 73 | tyBool = typeOf (undefined :: Bool) 74 | 75 | tyInt :: TypeRep 76 | tyInt = typeOf (undefined :: Int) 77 | 78 | tyChar :: TypeRep 79 | tyChar = typeOf (undefined :: Char) 80 | 81 | tyInts :: TypeRep 82 | tyInts = typeOf (undefined :: [Int]) 83 | 84 | tyIntToInt :: TypeRep 85 | tyIntToInt = typeOf (undefined :: Int -> Int) 86 | 87 | 88 | -- | 89 | -- To be used when testing or benchmarking 'Triexpr' 90 | allRules :: [(Expr,Expr)] 91 | allRules = boolRules ++ intRules ++ listRules ++ boolintRules ++ funRules 92 | 93 | boolRules :: [(Expr,Expr)] 94 | boolRules = 95 | [ id' pp -=- pp 96 | , pp -&&- pp -=- pp 97 | , pp -||- pp -=- pp 98 | , pp -&&- qq -=- qq -&&- pp 99 | , pp -||- qq -=- qq -||- pp 100 | , not' (not' pp) -=- pp 101 | , pp -&&- true -=- pp 102 | , true -&&- pp -=- pp 103 | , pp -&&- false -=- false 104 | , false -&&- pp -=- false 105 | , pp -||- true -=- true 106 | , true -||- pp -=- true 107 | , pp -||- false -=- pp 108 | , false -||- pp -=- pp 109 | , pp -&&- not' pp -=- false 110 | , pp -||- not' pp -=- true 111 | , not' pp -&&- pp -=- false 112 | , not' pp -||- pp -=- true 113 | , (pp -&&- qq) -&&- rr -=- pp -&&- (qq -&&- rr) 114 | , (pp -||- qq) -||- rr -=- pp -||- (qq -||- rr) 115 | , not' (pp -&&- qq) -=- not' pp -||- not' qq 116 | , not' (pp -||- qq) -=- not' pp -&&- not' qq 117 | , not' false -=- true 118 | , not' true -=- false 119 | , not' (not' pp -&&- not' qq) -=- (pp -||- qq) 120 | , not' (not' pp -||- not' qq) -=- (pp -&&- qq) 121 | , pp -&&- not' (pp -&&- qq) -=- pp -&&- not' qq 122 | --, pp -=- pp 123 | ] 124 | 125 | intRules :: [(Expr,Expr)] 126 | intRules = 127 | [ id' xx -=- xx 128 | , abs' (abs' xx) -=- abs' xx 129 | , xx -+- zero -=- xx 130 | , zero -+- xx -=- xx 131 | , xx -*- one -=- xx 132 | , one -*- xx -=- xx 133 | , xx -*- zero -=- zero 134 | , zero -*- xx -=- zero 135 | , xx -+- yy -=- yy -+- xx 136 | , xx -*- yy -=- yy -*- xx 137 | , (xx -+- yy) -+- zz -=- xx -+- (yy -+- zz) 138 | , (xx -*- yy) -*- zz -=- xx -*- (yy -*- zz) 139 | , (xx -+- xx) -*- yy -=- xx -*- (yy -+- yy) 140 | , xx -*- (yy -+- one) -=- xx -+- xx -*- yy 141 | , (xx -+- one) -*- yy -=- xx -+- xx -*- yy 142 | , xx -*- (yy -+- zz) -=- xx -*- yy -+- xx -*- zz 143 | , (xx -+- yy) -*- zz -=- xx -*- zz -+- yy -*- zz 144 | , negate' (negate' xx) -=- xx 145 | , xx -+- negate' xx -=- zero 146 | , negate' xx -+- xx -=- zero 147 | , abs' (negate' xx) -=- abs' xx 148 | , two -*- xx -=- xx -+- xx 149 | , xx -*- two -=- xx -+- xx 150 | , three -*- xx -=- xx -+- (xx -+- xx) 151 | , xx -*- three -=- xx -+- (xx -+- xx) 152 | , four -*- xx -=- xx -+- (xx -+- (xx -+- xx)) 153 | , xx -*- four -=- xx -+- (xx -+- (xx -+- xx)) 154 | , abs' (xx -*- xx) -=- xx -*- xx 155 | , abs' xx -*- abs' yy -=- abs' (xx -*- yy) 156 | , abs' xx -*- abs' xx -=- abs' (xx -+- xx) 157 | , abs' (abs' xx -+- abs' yy) -=- abs' xx -+- abs' yy 158 | , abs' (xx -+- xx) -*- yy -=- abs' xx -*- yy -+- abs' xx -*- yy 159 | , abs' xx -*- signum' xx -=- xx 160 | , signum' xx -*- abs' xx -=- xx 161 | --, xx -=- xx 162 | ] 163 | 164 | listRules :: [(Expr,Expr)] 165 | listRules = 166 | [ id' xxs -=- xxs 167 | , head' (xx -:- xxs) -=- xx 168 | , tail' (xx -:- xxs) -=- xxs 169 | , xxs -++- nil -=- xxs 170 | , nil -++- xxs -=- xxs 171 | , unit xx -++- xxs -=- xx -:- xxs 172 | , (xx -:- xxs) -++- yys -=- xx -:- (xxs -++- yys) 173 | , (xxs -++- yys) -++- zzs -=- xxs -++- (yys -++- zzs) 174 | 175 | -- insertsort stuff 176 | , elem' xx (sort' xxs) -=- elem' xx xxs 177 | , elem' xx (insert' yy xxs) -=- elem' xx (yy -:- xxs) 178 | , sort' (sort' xxs) -=- sort' xxs 179 | , insert' xx nil -=- unit xx 180 | , sort' (xxs -++- yys) -=- sort' (yys -++- xxs) 181 | , sort' (insert' xx xxs) -=- insert' xx (sort' xxs) 182 | , sort' (xx -:- xxs) -=- insert' xx (sort' xxs) 183 | , sort' (xxs -++- sort' yys) -=- sort' (xxs -++- yys) 184 | , sort' (sort' xxs -++- yys) -=- sort' (xxs -++- yys) 185 | , insert' xx (insert' yy xxs) -=- insert' yy (insert' xx xxs) 186 | , insert' xx (xx -:- xxs) -=- xx -:- xx -:- xxs 187 | , insert' xx (unit yy) -=- insert' yy (unit xx) 188 | 189 | -- length stuff 190 | , length' (xx -:- xxs) -=- length' (yy -:- xxs) 191 | , length' (xxs -++- yys) -=- length' (yys -++- xxs) 192 | , length' (xx -:- yy -:- xxs) -=- length' (zz -:- xx' -:- xxs) 193 | , length' (xx -:- (xxs -++- yys)) -=- length' (yy -:- (yys -++- xxs)) 194 | , length' (xxs -++- (yys -++- zzs)) -=- length' (xxs -++- (zzs -++- yys)) 195 | 196 | ] 197 | 198 | boolintRules :: [(Expr,Expr)] 199 | boolintRules = 200 | [ not' (odd' xx) -=- even' xx 201 | , not' (even' xx) -=- odd' xx 202 | , (xx -==- xx) -=- true 203 | , (xx -/=- xx) -=- false 204 | , (pp -==- pp) -=- true 205 | , (pp -/=- pp) -=- false 206 | ] 207 | 208 | funRules :: [(Expr,Expr)] 209 | funRules = 210 | [ ff (gg xx) -=- (ffE -.- ggE) :$ xx 211 | , map' idE xxs -=- xxs 212 | , map' (ffE -.- ggE) xxs -=- map' ffE (map' ggE xxs) 213 | , ffE -.- idE -=- ffE 214 | , idE -.- ffE -=- ffE 215 | , (ffE -.- ggE) -.- hhE -=- ffE -.- (ggE -.- hhE) 216 | , notE -.- notE -=- idBool 217 | ] 218 | 219 | (-=-) :: Expr -> Expr -> (Expr,Expr) 220 | e1 -=- e2 = (e1, e2) 221 | infix 0 -=- 222 | -------------------------------------------------------------------------------- /test/basic.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE CPP #-} 4 | import Test 5 | 6 | main :: IO () 7 | main = mainTest tests 5040 8 | 9 | tests :: Int -> [Bool] 10 | tests n = 11 | [ True 12 | 13 | , holds n $ \es e -> es >$$ e == es >$$< [e] 14 | , holds n $ \es e -> e $$< es == [e] >$$< es 15 | 16 | , [false, true, zero, one] >$$< [notE, andE, orE, plus, times] == [] 17 | 18 | , [notE, andE, orE, plus, times] >$$< [false, true, zero, one] 19 | == [ not' false 20 | , not' true 21 | , andE :$ false 22 | , andE :$ true 23 | , orE :$ false 24 | , orE :$ true 25 | , plus :$ zero 26 | , plus :$ one 27 | , times :$ zero 28 | , times :$ one 29 | ] 30 | 31 | , [notE, andE, orE, plus, times] >$$< [false, true, zero, one] >$$< [false, true, zero, one] 32 | == [ false -&&- false 33 | , false -&&- true 34 | , true -&&- false 35 | , true -&&- true 36 | , false -||- false 37 | , false -||- true 38 | , true -||- false 39 | , true -||- true 40 | , zero -+- zero 41 | , zero -+- one 42 | , one -+- zero 43 | , one -+- one 44 | , zero -*- zero 45 | , zero -*- one 46 | , one -*- zero 47 | , one -*- one 48 | ] 49 | ] 50 | -------------------------------------------------------------------------------- /test/canon.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | , canonicalize (xx -+- yy) 13 | == (xx -+- yy) 14 | , canonicalize (jj -+- (ii -+- ii)) 15 | == (xx -+- (yy -+- yy)) 16 | , canonicalize ((jj -+- ii) -+- (xx -+- xx)) 17 | == ((xx -+- yy) -+- (zz -+- zz)) 18 | 19 | -- these are just tests: 20 | -- canonicalizeWith expects the resulting list of the arg function to be infinite 21 | , canonicalizeWith (const ["i","j","k","l"]) (xx -+- yy) 22 | == (ii -+- jj) 23 | , canonicalizeWith (const ["i","j","k","l"]) (jj -+- (ii -+- ii)) 24 | == (ii -+- (jj -+- jj)) 25 | , canonicalizeWith (const ["i","j","k","l"]) ((jj -+- ii) -+- (xx -+- xx)) 26 | == ((ii -+- jj) -+- (kk -+- kk)) 27 | 28 | , canonicalize (xx -+- ord' cc) == (xx -+- ord' cc) 29 | , canonicalize (yy -+- ord' dd) == (xx -+- ord' cc) 30 | , canonicalize (ff xx -+- gg yy -+- ff yy) == (ff xx -+- gg yy -+- ff yy) 31 | , canonicalize (gg yy -+- ff xx -+- gg xx) == (ff xx -+- gg yy -+- ff yy) 32 | , canonicalizeWith (lookupNames $ reifyName (undefined :: Int -> Int -> Int) ++ preludeNameInstances) 33 | (zz -?- kk) == (var "f" (undefined :: Int -> Int -> Int) :$ xx :$ yy) 34 | 35 | -- canonicalizing holes -- 36 | , canonicalize (hole (undefined :: Int )) == xx 37 | , canonicalize (hole (undefined :: Bool )) == pp 38 | , canonicalize (hole (undefined :: Char )) == cc 39 | , canonicalize (hole (undefined :: [Int] )) == xxs 40 | , canonicalize (hole (undefined :: [Char] )) == ccs 41 | , canonicalize (hole (undefined :: () )) == var "u" () 42 | , canonicalize (hole (undefined :: Integer )) == var "x" (undefined :: Integer) 43 | , canonicalize (hole (undefined :: [Integer] )) == var "xs" (undefined :: [Integer]) 44 | , canonicalize (hole (undefined :: Maybe Int )) == var "mx" (undefined :: Maybe Int) 45 | , canonicalize (hole (undefined :: (Int,Int) )) == var "xy" (undefined :: (Int,Int)) 46 | 47 | , canonicalVariations (zero -+- xx) == [zero -+- xx] 48 | , canonicalVariations (zero -+- i_) == [zero -+- xx] 49 | , canonicalVariations (i_ -+- i_) == [xx -+- yy, xx -+- xx] 50 | , canonicalVariations (i_ -+- (i_ -+- ord' c_)) 51 | == [ xx -+- (yy -+- ord' cc) 52 | , xx -+- (xx -+- ord' cc) ] 53 | 54 | , fastCanonicalVariations (ii -+- i_) == [ii -+- xx] 55 | , canonicalVariations ((i_ -+- i_) -+- (ord' c_ -+- ord' c_)) 56 | == [ (xx -+- yy) -+- (ord' cc -+- ord' dd) 57 | , (xx -+- yy) -+- (ord' cc -+- ord' cc) 58 | , (xx -+- xx) -+- (ord' cc -+- ord' dd) 59 | , (xx -+- xx) -+- (ord' cc -+- ord' cc) ] 60 | 61 | , canonicalVariations (i_) 62 | == [ xx ] 63 | , canonicalVariations (i_ -+- i_) 64 | == [ xx -+- yy 65 | , xx -+- xx ] 66 | , canonicalVariations (i_ -+- i_ -+- i_) 67 | == [ xx -+- yy -+- zz 68 | , xx -+- yy -+- xx 69 | , xx -+- yy -+- yy 70 | , xx -+- xx -+- yy 71 | , xx -+- xx -+- xx 72 | ] 73 | , canonicalVariations (i_ -+- i_ -+- i_ -+- i_) 74 | == [ xx -+- yy -+- zz -+- xx' 75 | , xx -+- yy -+- zz -+- xx 76 | , xx -+- yy -+- zz -+- yy 77 | , xx -+- yy -+- zz -+- zz 78 | , xx -+- yy -+- xx -+- zz 79 | , xx -+- yy -+- xx -+- xx 80 | , xx -+- yy -+- xx -+- yy 81 | , xx -+- yy -+- yy -+- zz 82 | , xx -+- yy -+- yy -+- xx 83 | , xx -+- yy -+- yy -+- yy 84 | , xx -+- xx -+- yy -+- zz 85 | , xx -+- xx -+- yy -+- xx 86 | , xx -+- xx -+- yy -+- yy 87 | , xx -+- xx -+- xx -+- yy 88 | , xx -+- xx -+- xx -+- xx 89 | ] 90 | , canonicalVariations (i_ -+- ii -+- jj -+- i_) 91 | == [ xx -+- ii -+- jj -+- yy 92 | , xx -+- ii -+- jj -+- xx ] 93 | , canonicalVariations (i_ -+- xx -+- yy -+- i_) 94 | == [ zz -+- xx -+- yy -+- xx' 95 | , zz -+- xx -+- yy -+- zz ] 96 | 97 | 98 | , holds n $ \e -> let xs = map (length . nubVars) $ canonicalVariations e 99 | in (head xs >) `all` tail xs 100 | && (last xs <) `all` init xs 101 | , holds n $ \e -> all isHole (vars e) 102 | ==> isNub (vars (head (canonicalVariations e))) 103 | , holds n $ \e -> let es = canonicalVariations e 104 | in (`isInstanceOf` head es) `all` tail es 105 | && (last es `isInstanceOf`) `all` init es 106 | , holds n $ \e -> let es = canonicalVariations e 107 | in length (nub (sort es)) == length es 108 | , holds n $ \e -> length (canonicalVariations e) 109 | == product (map (bell . snd) . counts $ holes e) 110 | 111 | , holds n $ \e -> head (canonicalVariations e) == mostGeneralCanonicalVariation e 112 | , holds n $ \e -> last (canonicalVariations e) == mostSpecificCanonicalVariation e 113 | 114 | 115 | -- Behaviour on unhandled types -- 116 | , map show (canonicalVariations a_) 117 | == ["x :: A"] 118 | 119 | , map show (canonicalVariations (faa_ :$ a_ :$ a_)) 120 | == [ "f x y :: A" 121 | , "f x x :: A" 122 | ] 123 | 124 | , map show (canonicalVariations as_) 125 | == ["xs :: [A]"] 126 | 127 | , map show (canonicalVariations (appendA :$ as_ :$ as_)) 128 | == [ "xs ++ ys :: [A]" 129 | , "xs ++ xs :: [A]" 130 | ] 131 | ] 132 | 133 | a_ :: Expr 134 | a_ = hole (undefined :: A) 135 | 136 | as_ :: Expr 137 | as_ = hole (undefined :: [A]) 138 | 139 | faa_ :: Expr 140 | faa_ = hole (undefined :: A -> A -> A) 141 | 142 | appendA :: Expr 143 | appendA = value "++" ((++) :: [A] -> [A] -> [A]) 144 | 145 | -- O(1) bell number implementation 146 | -- only works up to 8 147 | -- but this is enough for testing. 148 | bell :: Int -> Int 149 | bell 0 = 1 150 | bell 1 = 1 151 | bell 2 = 2 152 | bell 3 = 5 153 | bell 4 = 15 154 | bell 5 = 52 155 | bell 6 = 203 156 | bell 7 = 877 157 | bell 8 = 4140 158 | bell _ = error "bell: argument > 8, implement me!" 159 | -------------------------------------------------------------------------------- /test/core.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | import Data.Express.Utils.List 6 | import Test.LeanCheck.Error (errorToNothing) 7 | 8 | main :: IO () 9 | main = mainTest tests 5040 10 | 11 | tests :: Int -> [Bool] 12 | tests n = 13 | [ True 14 | 15 | -- smart constructors and evaluation 16 | 17 | , holds n $ \x -> eval (undefined :: Int -> Int) (value "abs" (abs :: Int -> Int)) x == abs (x :: Int) 18 | , evl (val (10 :: Int)) == (10 :: Int) 19 | , evl (val (1337 :: Int)) == (1337 :: Int) 20 | , evl (val False) == False 21 | , holds n $ \x y -> evl (value "+" ((+) :: Int -> Int -> Int) :$ val x :$ val y) == (x + y :: Int) 22 | , holds n $ \x y -> evl (value "+" ((*) :: Int -> Int -> Int) :$ val x :$ val y) == (x * y :: Int) 23 | , holds n $ \i -> evl (val i) == (i :: Int) 24 | , show (one -+- one) == "1 + 1 :: Int" 25 | , show absE == "abs :: Int -> Int" 26 | , show notE == "not :: Bool -> Bool" 27 | , show andE == "(&&) :: Bool -> Bool -> Bool" 28 | , show (pp -&&- (not' false)) == "p && not False :: Bool" 29 | , show (one :$ one) == "1 1 :: ill-typed # Int $ Int #" 30 | , holds n $ \(IntE xx, IntE yy) -> isJust (toDynamic $ xx -+- yy) 31 | , holds n $ \(IntE xx, IntE yy) -> isGround xx && isGround yy 32 | ==> evl (xx -+- yy) =$ errorToNothing $= (evl (yy -+- xx) :: Int) 33 | 34 | -- valid applications 35 | , holds n $ \(IntToIntE ef) (IntE ex) -> isJust (ef $$ ex) 36 | , holds n $ \(BoolToBoolE ef) (BoolE ep) -> isJust (ef $$ ep) 37 | 38 | -- invalid applications 39 | , holds n $ \(IntE ex) (IntE ey) -> isNothing (ex $$ ey) 40 | , holds n $ \(BoolE ep) (BoolE eq) -> isNothing (ep $$ eq) 41 | , holds n $ \(BoolToBoolE ef) (IntE ex) -> isNothing (ef $$ ex) 42 | , holds n $ \(IntToIntE ef) (BoolE ep) -> isNothing (ef $$ ep) 43 | , holds n $ \(IntE ex) (IntE ey) (IntE ez) -> isNothing (ex $$ (ey :$ ez)) 44 | , holds n $ \(IntE ex) (IntE ey) (IntE ez) -> isNothing ((ex :$ ey) $$ ez) 45 | 46 | 47 | -- typing 48 | , typ zero == tyInt 49 | , typ one == tyInt 50 | , typ xx == tyInt 51 | , typ bee == tyChar 52 | , typ xxs == tyInts 53 | , typ (ff xx) == tyInt 54 | , typ (abs' one) == tyInt 55 | , typ true == tyBool 56 | , typ pp == tyBool 57 | 58 | , etyp zero == Right tyInt 59 | , etyp (abs' one) == Right tyInt 60 | , etyp (abs' bee) == Left (tyIntToInt, tyChar) 61 | , etyp (abs' bee :$ zero) == Left (tyIntToInt, tyChar) 62 | , etyp ((zero :$ one) :$ (bee :$ cee)) == Left (tyInt, tyInt) 63 | 64 | , etyp (xx :$ yy) == Left (tyInt, tyInt) 65 | , etyp (xx :$ (cc :$ yy)) == Left (tyChar, tyInt) 66 | , etyp (abs' xx :$ (ord' cc :$ negate' yy)) == Left (tyInt, tyInt) 67 | , holds n $ \(SameTypeE ef eg) (SameTypeE ex ey) -> (etyp (ef :$ ex) == etyp (eg :$ ey)) 68 | , holds n $ \ef eg ex ey -> (etyp ef == etyp eg && etyp ex == etyp ey) 69 | == (etyp (ef :$ ex) == etyp (eg :$ ey)) 70 | 71 | , isIllTyped (abs' zero) == False 72 | , isIllTyped (zero :$ one) == True 73 | , isWellTyped (abs' zero) == True 74 | , isWellTyped (zero :$ one) == False 75 | 76 | , isFun (value "abs" (abs :: Int -> Int)) == True 77 | , isFun (val (1::Int)) == False 78 | , isFun (value "const" (const :: Bool -> Bool -> Bool) :$ val False) == True 79 | , holds n $ \e -> (arity e /= 0) == isFun e 80 | 81 | -- eq instance 82 | , xx -+- yy == xx -+- yy 83 | , xx -+- yy /= yy -+- xx 84 | 85 | 86 | -- our Listable Expr enumeration does not produce ill typed Exprs 87 | , holds n $ isRight . etyp 88 | , holds n $ isJust . mtyp 89 | , holds n $ isWellTyped 90 | , holds n $ not . isIllTyped 91 | 92 | -- our Listable Ill enumeration only produces ill typed Exprs 93 | , holds n $ isLeft . etyp . unIll 94 | , holds n $ isNothing . mtyp . unIll 95 | , holds n $ isIllTyped . unIll 96 | , holds n $ not . isWellTyped . unIll 97 | 98 | -- we don't need the precondition here given the above 99 | -- but it's added just in case 100 | , holds n $ \e -> isRight (etyp e) ==> etyp e == Right (typ e) 101 | , holds n $ \e -> isJust (mtyp e) ==> mtyp e == Just (typ e) 102 | 103 | -- we prefer returning errors to the left 104 | , holds n $ \(Ill ef) (Ill ex) -> etyp (ef :$ ex) == etyp ef 105 | , holds n $ \ef (Ill ex) -> etyp (ef :$ ex) == etyp ex 106 | 107 | 108 | -- boolean properties 109 | 110 | , hasVar (zero -+- one) == False 111 | , hasVar (xx -+- yy) == True 112 | 113 | , isGround (zero -+- (one -*- two)) == True 114 | , isGround (xx -+- (one -*- three)) == False 115 | 116 | , holds n $ isGround === not . hasVar 117 | 118 | -- isValue and isApp 119 | , holds n $ \e1 e2 -> isValue (e1 :$ e2) == False 120 | , holds n $ \e1 e2 -> isApp (e1 :$ e2) == True 121 | , holds n $ isValue === not . isApp 122 | , holds n $ isApp === not . isValue 123 | , holds n $ \e -> isValue e == (isVar e || isConst e) 124 | , holds n $ \e -> isApp e == (not (isVar e) && not (isConst e)) 125 | 126 | , isVar xx == True 127 | , isVar yy == True 128 | , isVar ffE == True 129 | , isVar (xx -+- yy) == False 130 | , isVar (ff xx) == False 131 | , isVar one == False 132 | , isVar (one -+- two) == False 133 | 134 | , isHole i_ == True 135 | , isHole b_ == True 136 | , isHole xx == False 137 | 138 | , isConst xx == False 139 | , isConst yy == False 140 | , isConst (xx -+- yy) == False 141 | , isConst (ff xx) == False 142 | , isConst one == True 143 | , isConst two == True 144 | , isConst absE == True 145 | , isConst (one -+- two) == False 146 | 147 | , values (xx -+- yy) == [plus, xx, yy] 148 | , values (xx -+- (yy -+- zz)) == [plus, xx, plus, yy, zz] 149 | , values ((xx -+- yy) -+- zz) == [plus, plus, xx, yy, zz] 150 | , values (zero -+- (one -*- two)) == [plus, zero, times, one, two] 151 | , values (pp -&&- true) == [andE, pp, true] 152 | 153 | , subexprs (xx -+- yy) == 154 | [ xx -+- yy 155 | , plus :$ xx 156 | , plus 157 | , xx 158 | , yy 159 | ] 160 | , subexprs (pp -&&- (pp -&&- true)) == 161 | [ pp -&&- (pp -&&- true) 162 | , andE :$ pp 163 | , andE 164 | , pp 165 | , pp -&&- true 166 | , andE :$ pp 167 | , andE 168 | , pp 169 | , true 170 | ] 171 | , nubSubexprs (xx -+- yy) == 172 | [ xx 173 | , yy 174 | , plus 175 | , plus :$ xx 176 | , xx -+- yy 177 | ] 178 | , nubSubexprs (pp -&&- (pp -&&- true)) == 179 | [ pp 180 | , true 181 | , andE 182 | , andE :$ pp 183 | , pp -&&- true 184 | , pp -&&- (pp -&&- true) 185 | ] 186 | 187 | 188 | -- boolean properties 189 | , holds n $ \e -> isHole e ==> isVar e 190 | 191 | -- listing subexpressions 192 | , holds n $ \e -> isGround e ==> consts e == values e 193 | 194 | , holds n $ \e -> nubSubexprs e `isSubsetOf` subexprs e 195 | , holds n $ \e -> nubValues e `isSubsetOf` values e 196 | , holds n $ \e -> nubVars e `isSubsetOf` vars e 197 | , holds n $ \e -> nubConsts e `isSubsetOf` consts e 198 | , holds n $ \e -> values e `isSubsetOf` subexprs e 199 | , holds n $ \e -> vars e `isSubsetOf` values e 200 | , holds n $ \e -> consts e `isSubsetOf` values e 201 | , holds n $ \e -> (vars e ++ consts e) `isPermutationOf` values e 202 | , holds n $ \e -> (nubVars e ++ nubConsts e) `isPermutationOf` nubValues e 203 | 204 | -- in case implementation changes 205 | , holds n $ \e -> nubSubexprs e == nubSort (subexprs e) 206 | , holds n $ \e -> nubValues e == nubSort (values e) 207 | , holds n $ \e -> nubVars e == nubSort (vars e) 208 | , holds n $ \e -> nubConsts e == nubSort (consts e) 209 | 210 | , arity zero == 0 211 | , arity xx == 0 212 | , arity absE == 1 213 | , arity plus == 2 214 | , arity times == 2 215 | 216 | , size zero == 1 217 | , size (one -+- two) == 3 218 | , size (abs' one) == 2 219 | 220 | , depth zero == 1 221 | , depth (one -+- two) == 2 222 | , depth (abs' one -+- two) == 3 223 | 224 | , height zero == 1 225 | , height (abs' one) == 2 226 | , height ((const' one) two) == 3 227 | , height ((const' (abs' one)) two) == 4 228 | , height ((const' one) (abs' two)) == 3 229 | 230 | , holds n $ \e -> depth e <= height e 231 | , holds n $ \e -> depth e <= size e 232 | , holds n $ \e -> height e <= size e 233 | 234 | , size zero == 1 235 | , depth zero == 1 236 | , size one == 1 237 | , depth one == 1 238 | , size (zero -+- one) == 3 239 | , depth (zero -+- one) == 2 240 | , size (zero -+- (xx -+- yy)) == 5 241 | , depth (zero -+- (xx -+- yy)) == 3 242 | , size (((xx -+- yy) -*- zz) -==- ((xx -*- zz) -+- (yy -*- zz))) == 13 243 | , depth (((xx -+- yy) -*- zz) -==- ((xx -*- zz) -+- (yy -*- zz))) == 4 244 | , depth (xx -*- yy -+- xx -*- zz -==- xx -*- (yy -+- zz)) == 4 245 | , size (xx -*- yy -+- xx -*- zz -==- xx -*- (yy -+- zz)) == 13 246 | , depth (xx -*- yy -+- xx -*- zz) == 3 247 | , depth (xx -*- (yy -+- zz)) == 3 248 | 249 | , nubConsts (xx -+- yy) == [plus] 250 | , nubConsts (xx -+- (yy -+- zz)) == [plus] 251 | , nubConsts (zero -+- one) =$ sort $= [zero, one, plus] 252 | , nubConsts ((zero -+- abs' zero) -+- (ord' ae -+- ord' cc)) 253 | =$ sort $= [zero, ae, absE, plus, ordE] 254 | , holds n $ \e1 e2 -> times `elem` consts (e1 -*- e2) 255 | 256 | , vars (xx -+- yy) == [xx, yy] 257 | , nubVars (xx -+- xx) == [xx] 258 | , nubVars (xx -+- xx -+- yy) == [xx, yy] 259 | , nubVars (yy -+- xx -+- yy) == [xx, yy] 260 | ] 261 | -------------------------------------------------------------------------------- /test/express-derive.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | 6 | import Test hiding ((-:), (->:)) 7 | -- -: and ->: should be generated by deriveExpress 8 | 9 | data Choice = Ae | Bee | Cee deriving (Show, Eq, Typeable) 10 | data Peano = Zero | Succ Peano deriving (Show, Eq, Typeable) 11 | data Lst a = a :- Lst a | Nil deriving (Show, Eq, Typeable) 12 | data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq, Typeable) 13 | data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq, Typeable) 14 | 15 | deriveExpress ''Choice 16 | deriveExpress ''Peano 17 | deriveExpress ''Lst 18 | deriveExpress ''Bush 19 | deriveExpress ''Tree 20 | 21 | deriveListable ''Choice 22 | deriveListable ''Peano 23 | deriveListable ''Lst 24 | deriveListable ''Bush 25 | deriveListable ''Tree 26 | 27 | -- Nested datatype cascade 28 | data Nested = Nested N0 (N1 Int) (N2 Int Int) deriving (Eq, Show, Typeable) 29 | newtype N0 = R0 Int deriving (Eq, Show, Typeable) 30 | newtype N1 a = R1 a deriving (Eq, Show, Typeable) 31 | data N2 a b = R2 a b deriving (Eq, Show, Typeable) 32 | 33 | deriveExpressCascading ''Nested 34 | deriveListableCascading ''Nested 35 | 36 | -- Recursive nested datatype cascade 37 | data RN = RN RN0 (RN1 Int) (RN2 Int RN) deriving (Eq, Show, Typeable) 38 | data RN0 = Nest0 Int | Recurse0 RN deriving (Eq, Show, Typeable) 39 | data RN1 a = Nest1 a | Recurse1 RN deriving (Eq, Show, Typeable) 40 | data RN2 a b = Nest2 a b | Recurse2 RN deriving (Eq, Show, Typeable) 41 | -- beware: values of the above type are always infinite! 42 | -- derivation works but full evaluation does not terminate 43 | 44 | deriveExpressCascading ''RN 45 | deriveListableCascading ''RN 46 | 47 | -- Those should have no effect (instance already exists): 48 | {- uncommenting those should generate warnings 49 | deriveExpress ''Bool 50 | deriveExpress ''Maybe 51 | deriveExpress ''Either 52 | -} 53 | 54 | -- Those should not generate warnings 55 | deriveExpressIfNeeded ''Bool 56 | deriveExpressIfNeeded ''Maybe 57 | deriveExpressIfNeeded ''Either 58 | 59 | data Mutual = Mutual0 | Mutual CoMutual deriving (Eq, Show, Typeable) 60 | data CoMutual = CoMutual0 | CoMutual Mutual deriving (Eq, Show, Typeable) 61 | 62 | deriveListableCascading ''Mutual 63 | deriveExpressCascading ''Mutual 64 | 65 | 66 | main :: IO () 67 | main = mainTest tests 5040 68 | 69 | tests :: Int -> [Bool] 70 | tests n = 71 | [ True 72 | 73 | , holds n (exprIsVal :: Choice -> Bool) 74 | , fails n (exprIsVal :: Peano -> Bool) 75 | 76 | , fails n (exprIsVal :: Lst Int -> Bool) 77 | , fails n (exprIsVal :: Lst Bool -> Bool) 78 | 79 | , fails n (exprIsVal :: Bush Int -> Bool) 80 | , fails n (exprIsVal :: Bush Bool -> Bool) 81 | 82 | , fails n (exprIsVal :: Tree Int -> Bool) 83 | , fails n (exprIsVal :: Tree Bool -> Bool) 84 | 85 | , holds n (exprIsValUnderEvaluate :: Choice -> Bool) 86 | , holds n (exprIsValUnderEvaluate :: Peano -> Bool) 87 | 88 | , holds n (exprIsValUnderEvaluate :: Lst Int -> Bool) 89 | , holds n (exprIsValUnderEvaluate :: Lst Bool -> Bool) 90 | 91 | , holds n (exprIsValUnderEvaluate :: Bush Int -> Bool) 92 | , holds n (exprIsValUnderEvaluate :: Bush Bool -> Bool) 93 | 94 | , holds n (exprIsValUnderEvaluate :: Tree Int -> Bool) 95 | , holds n (exprIsValUnderEvaluate :: Tree Bool -> Bool) 96 | 97 | , holds n (exprIsValUnderEvaluate :: Nested -> Bool) 98 | , holds n (exprIsValUnderEvaluate :: N0 -> Bool) 99 | , holds n (exprIsValUnderEvaluate :: N1 Int -> Bool) 100 | , holds n (exprIsValUnderEvaluate :: N2 Int Bool -> Bool) 101 | 102 | , holds n (exprIsValUnderEvaluate :: Mutual -> Bool) 103 | , holds n (exprIsValUnderEvaluate :: CoMutual -> Bool) 104 | ] 105 | 106 | -- not true in all cases 107 | exprIsVal :: (Listable a, Express a, Show a) => a -> Bool 108 | exprIsVal x = expr x == val x 109 | 110 | exprIsValUnderEvaluate :: (Listable a, Express a, Show a, Eq a) => a -> Bool 111 | exprIsValUnderEvaluate x = evaluate (expr x) == (evaluate (val x) -: mayb x) 112 | -------------------------------------------------------------------------------- /test/express.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE CPP #-} 4 | import Test 5 | 6 | main :: IO () 7 | main = mainTest tests 5040 8 | 9 | tests :: Int -> [Bool] 10 | tests n = 11 | [ True 12 | 13 | , holds n $ \x -> expr x == val (x :: Int) 14 | , holds n $ \c -> expr c == val (c :: Char) 15 | , holds n $ \p -> expr p == val (p :: Bool) 16 | , holds n $ \x -> expr x == val (x :: ()) 17 | , fails n $ \xs -> expr xs == val (xs :: [Int]) 18 | , holds n $ expr ([] :: [Int]) == val ([] :: [Int]) 19 | , holds n $ \x xs -> expr (x:xs) /= val (x:xs :: [Int]) 20 | 21 | , holds n (okExpress :: () -> Bool) 22 | , holds n (okExpress :: Bool -> Bool) 23 | , holds n (okExpress :: Int -> Bool) 24 | , holds n (okExpress :: Integer -> Bool) 25 | , holds n (okExpress :: Char -> Bool) 26 | , holds n (okExpress :: Ordering -> Bool) 27 | 28 | , holds n (okExpress :: [Bool] -> Bool) 29 | , holds n (okExpress :: [Int] -> Bool) 30 | , holds n (okExpress :: [Integer] -> Bool) 31 | , holds n (okExpress :: [Char] -> Bool) 32 | , holds n (okExpress :: [Ordering] -> Bool) 33 | 34 | , holds n (okExpress :: ((),()) -> Bool) 35 | , holds n (okExpress :: (Bool,Bool) -> Bool) 36 | , holds n (okExpress :: (Int,Int) -> Bool) 37 | , holds n (okExpress :: ((),Bool) -> Bool) 38 | , holds n (okExpress :: (Bool,Int) -> Bool) 39 | 40 | , holds n (okExpress :: Maybe () -> Bool) 41 | , holds n (okExpress :: Maybe Bool -> Bool) 42 | , holds n (okExpress :: Maybe Int -> Bool) 43 | 44 | , holds n (okExpress :: Either () () -> Bool) 45 | , holds n (okExpress :: Either Bool Bool -> Bool) 46 | , holds n (okExpress :: Either Int Int -> Bool) 47 | , holds n (okExpress :: Either () Bool -> Bool) 48 | , holds n (okExpress :: Either Bool Int -> Bool) 49 | 50 | , holds n (okExpress :: (Int,Int,Int) -> Bool) 51 | , holds n (okExpress :: (Int,Int,Int,Int) -> Bool) 52 | , holds n (okExpress :: (Int,Int,Int,Int,Int) -> Bool) 53 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int) -> Bool) 54 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int) -> Bool) 55 | #if __GLASGOW_HASKELL__ < 710 56 | -- No 8-tuples for you: 57 | -- On GHC 7.8, 8-tuples are not Typeable instances. We could add a standalone 58 | -- deriving clause, but that may cause trouble if some other library does the 59 | -- same. User should declare Generalizable 8-tuples manually when using GHC <= 60 | -- 7.8. 61 | #else 62 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int,Int) -> Bool) 63 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int,Int,Int) -> Bool) 64 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int) -> Bool) 65 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int) -> Bool) 66 | , holds n (okExpress :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int) -> Bool) 67 | #endif 68 | 69 | -- Transforming lists into Exprs 70 | , expr ([]::[Int]) == value "[]" ([]::[Int]) 71 | , expr ([0::Int]) == zero -:- nil 72 | , expr ([0::Int,1]) == zero -:- one -:- nil 73 | , holds n $ \xs -> expr xs == foldr (-:-) nil (map expr (xs :: [Int])) 74 | , holds n $ \ps -> expr ps == foldr (-:-) nilBool (map expr (ps :: [Bool])) 75 | , expr (""::String) == value "\"\"" "" 76 | , expr (""::String) == val "" 77 | , expr ("a"::String) == unit (val 'a') 78 | , expr ("abc"::String) == val 'a' -:- val 'b' -:- unit (val 'c') 79 | 80 | -- Transforming Maybes into Exprs 81 | , expr (Nothing :: Maybe Int) == nothing 82 | , expr (Nothing :: Maybe Bool) == nothingBool 83 | , expr (Just 1 :: Maybe Int) == just one 84 | , expr (Just False :: Maybe Bool) == just false 85 | , holds n $ \x -> expr (Just x) == just (expr (x :: Int)) 86 | , holds n $ \p -> expr (Just p) == just (expr (p :: Bool)) 87 | 88 | -- Transforming tuples into Exprs 89 | , expr ((0,False) :: (Int,Bool)) == pair zero false 90 | , expr ((True,1) :: (Bool,Int)) == pair true one 91 | 92 | -- Transforming ratios into Exprs 93 | , expr (1 / 2 :: Rational) == val (1::Integer) -%- val (2::Integer) 94 | , expr (2 / 3 :: Rational) == val (2::Integer) -%- val (3::Integer) 95 | , expr (5 / 6 :: Rational) == val (5::Integer) -%- val (6::Integer) 96 | 97 | -- Showing Exprs 98 | , holds n $ \x -> show (expr x) == show (x :: ()) ++ " :: ()" 99 | , holds n $ \x -> show (expr x) == show (x :: Int) ++ " :: Int" 100 | , holds n $ \p -> show (expr p) == show (p :: Bool) ++ " :: Bool" 101 | , holds n $ \s -> show (expr s) == show (s :: String) ++ " :: [Char]" 102 | , holds n $ \x -> show (expr x) == show (x :: ((),Maybe Int,[Bool])) 103 | ++ " :: ((),(Maybe Int),[Bool])" 104 | ] 105 | 106 | -- this is true only for some types 107 | exprIsVal :: (Listable a, Express a, Show a) => a -> Bool 108 | exprIsVal x = expr x == val x 109 | 110 | -- this should be true for all types 111 | exprIsValUnderEvaluate :: (Listable a, Express a, Show a, Eq a) => a -> Bool 112 | exprIsValUnderEvaluate x = evaluate (expr x) == (evaluate (val x) -: mayb x) 113 | 114 | -- this should be true for most types 115 | showExprIsShow :: (Listable a, Express a, Show a) => a -> Bool 116 | showExprIsShow x = showExpr (expr x) == show x 117 | 118 | okExpress :: (Listable a, Express a, Show a, Eq a) => a -> Bool 119 | okExpress = exprIsValUnderEvaluate &&& showExprIsShow 120 | -------------------------------------------------------------------------------- /test/fold.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | , holds n $ \e1 e2 -> (e1,e2) == unfoldPair (foldPair (e1,e2)) 13 | , holds n $ \e123 -> e123 == unfoldTrio (foldTrio e123) 14 | 15 | -- the result of foldPair and foldTrio is always ill-typed 16 | , holds n $ \e1 e2 -> isIllTyped $ foldPair (e1,e2) 17 | , holds n $ \e123 -> isIllTyped $ foldTrio e123 18 | 19 | -- (==) works even though foldPair returns an ill-typed expression 20 | , holds n $ \e1 e2 -> foldPair (e1,e2) == foldPair (e1,e2) 21 | , fails n $ \e1 e2 -> foldPair (e1,e2) == foldPair (e2,e1) 22 | 23 | , show (foldPair (xx,yy)) == "(x,y) :: ill-typed # ExprPair $ Int #" 24 | , show (foldTrio (xx,yy,zz)) == "(x,y,z) :: ill-typed # ExprTrio $ Int #" 25 | 26 | , unfoldApp (abs' xx) == [absE, xx] 27 | , unfoldApp (abs' (xx -+- yy)) == [absE, xx -+- yy] 28 | , unfoldApp (xx -+- abs' xx) == [plus, xx, abs' xx] 29 | , unfoldApp one == [one] 30 | , unfoldApp false == [false] 31 | 32 | , holds n $ \e -> foldApp (unfoldApp e) == e 33 | 34 | , holds n $ \es -> es == unfold (fold es) 35 | ] 36 | -------------------------------------------------------------------------------- /test/hole.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | , isHole (hole (undefined :: Int)) == True 13 | , isHole (hole (undefined :: Bool)) == True 14 | , isHole (hole (undefined :: Char)) == True 15 | , holds n $ \x -> isHole (val (x :: Int)) == False 16 | , holds n $ \p -> isHole (val (p :: Bool)) == False 17 | , holds n $ \c -> isHole (val (c :: Char)) == False 18 | 19 | , holds n $ \e -> isHole e ==> isVar e 20 | , holds n $ \e1 e2 -> isHole (e1 :$ e2) == False 21 | , holds n $ \e -> isHole e ==> hasHole e 22 | , holds n $ \e1 e2 -> (hasHole e1 || hasHole e2) == hasHole (e1 :$ e2) 23 | , holds n $ \e -> hasHole e == (not . null . holes) e 24 | , holds n $ \e -> isComplete e == not (hasHole e) 25 | 26 | , holds n $ \e -> holes e `isSubsequenceOf` vars e 27 | , holds n $ \e -> nubHoles e `isSubsetOf` holes e 28 | , holds n $ \e -> nubHoles e `isSubsequenceOf` nubVars e 29 | 30 | , [xx, yy, zz, xx'] `isPrefixOf` listVars "x" (undefined :: Int) 31 | , [pp, qq, rr, pp'] `isPrefixOf` listVars "p" (undefined :: Bool) 32 | , [xx, yy, zz, xx'] `isPrefixOf` listVarsAsTypeOf "x" zero 33 | , [pp, qq, rr, pp'] `isPrefixOf` listVarsAsTypeOf "p" false 34 | 35 | -- fill unit tests 36 | , fill (i_ -+- i_) [xx, yy] == xx -+- yy 37 | , fill (i_ -+- i_) [xx, xx] == xx -+- xx 38 | , fill (i_ -+- i_) [one, one -+- one] == one -+- (one -+- one) 39 | 40 | -- silent behaviours of fill 41 | , fill (i_ -+- i_ -+- i_) [xx, yy] == xx -+- yy -+- i_ 42 | , fill (i_) [xx, yy] == xx 43 | , fill (i_ -+- i_ -+- i_) [xx, val 'c', yy] == xx -+- i_ -+- i_ 44 | 45 | -- fill properties 46 | , holds n $ \(IntE e) -> fill (zero -+- i_ -+- two) [e] == zero -+- e -+- two 47 | , holds n $ \(IntE e1, IntE e2) -> fill (i_ -+- one -+- i_) [e1, e2] == e1 -+- one -+- e2 48 | ] 49 | -------------------------------------------------------------------------------- /test/instances.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE NoMonomorphismRestriction #-} -- ACK! 4 | import Test 5 | 6 | main :: IO () 7 | main = mainTest tests 5040 8 | 9 | tests :: Int -> [Bool] 10 | tests n = 11 | [ True 12 | 13 | , eval undefined (eqFor (undefined :: Int) :$ one :$ one) == True 14 | , eval undefined (eqFor (undefined :: Int) :$ one :$ two) == False 15 | 16 | , eval undefined (lessEqFor (undefined :: Int) :$ one :$ two) == True 17 | , eval undefined (lessEqFor (undefined :: Int) :$ one :$ one) == True 18 | , eval undefined (lessEqFor (undefined :: Int) :$ two :$ one) == False 19 | 20 | , eval undefined (lessFor (undefined :: Int) :$ one :$ two) == True 21 | , eval undefined (lessFor (undefined :: Int) :$ one :$ one) == False 22 | , eval undefined (lessFor (undefined :: Int) :$ two :$ one) == False 23 | 24 | -- for the time being, compare has been removed from reifyOrd's result 25 | --, eval undefined (compareFor (undefined :: Int) :$ one :$ two) == LT 26 | --, eval undefined (compareFor (undefined :: Int) :$ one :$ one) == EQ 27 | --, eval undefined (compareFor (undefined :: Int) :$ two :$ one) == GT 28 | 29 | , eval undefined (nameFor (undefined :: Int) :$ xx) == "x" 30 | , eval undefined (nameFor (undefined :: Int) :$ yy) == "x" 31 | , eval undefined (nameFor (undefined :: Bool) :$ pp) == "p" 32 | , eval undefined (nameFor (undefined :: Bool) :$ qq) == "p" 33 | 34 | , length (validApps functions one) == 5 35 | 36 | -- when lookupName does not find a name instance, 37 | -- it defaults to x, xs, xss, xsss, ... 38 | -- depending on the number of list nestings 39 | , lookupName [] (val (0::Int)) == "x" 40 | , lookupName [] (val [0::Int]) == "xs" 41 | , lookupName [] (val [[0::Int]]) == "xss" 42 | , lookupName [] (val [[[0::Int]]]) == "xsss" 43 | 44 | , lookupName [] (val False) == "x" 45 | , lookupName [] (val [False]) == "xs" 46 | , lookupName [] (val [[False]]) == "xss" 47 | , lookupName [] (val [[[False]]]) == "xsss" 48 | 49 | , lookupName [] (val (0::A)) == "x" 50 | , lookupName [] (val [0::A]) == "xs" 51 | , lookupName [] (val [[0::A]]) == "xss" 52 | , lookupName [] (val [[[0::A]]]) == "xsss" 53 | 54 | , lookupName preludeNameInstances (val False) == "p" 55 | , lookupName preludeNameInstances (val [False]) == "ps" 56 | , lookupName preludeNameInstances (val [[False]]) == "xss" -- XXX: caveat 57 | , lookupName preludeNameInstances (val [[[False]]]) == "xsss" -- XXX: caveat 58 | 59 | , lookupName preludeNameInstances (val (0::A)) == "x" 60 | , lookupName preludeNameInstances (val [0::A]) == "xs" 61 | , lookupName preludeNameInstances (val [[0::A]]) == "xss" 62 | , lookupName preludeNameInstances (val [[[0::A]]]) == "xsss" 63 | ] 64 | where 65 | eqFor = head . reifyEq 66 | lessEqFor = head . reifyOrd 67 | lessFor = head . tail . reifyOrd 68 | --compareFor = head . reifyOrd 69 | nameFor = head . reifyName 70 | 71 | functions :: [Expr] 72 | functions = concat 73 | [ reifyEq (undefined :: Int) 74 | , reifyEq (undefined :: Bool) 75 | , reifyOrd (undefined :: Int) 76 | , reifyOrd (undefined :: Bool) 77 | , reifyName (undefined :: Int) 78 | , reifyName (undefined :: Bool) 79 | ] 80 | -------------------------------------------------------------------------------- /test/listable.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | -- Listable Expr only produces well-typed expressions 13 | , holds n $ isJust . toDynamic 14 | , holds n $ isJust . mtyp 15 | 16 | -- Listable Ill only produces ill-typed expressions 17 | , holds n $ isNothing . toDynamic . unIll 18 | , holds n $ isNothing . mtyp . unIll 19 | 20 | -- Listable TypeE produces expressions of the right type (evaluation) 21 | , holds n $ isJust . evaluateInt . unIntE 22 | , holds n $ isJust . evaluateBool . unBoolE 23 | , holds n $ isJust . evaluateInts . unIntsE 24 | , holds n $ isJust . evaluateIntToInt . unIntToIntE 25 | , holds n $ isJust . evaluateChar . unCharE 26 | , holds n $ \(IntToIntE ff) (IntE xx) -> isJust . evaluateInt $ ff :$ xx 27 | , holds n $ \(IntToIntToIntE ff) (IntE xx) (IntE yy) -> isJust . evaluateInt $ ff :$ xx :$ yy 28 | 29 | -- Listable TypeE produces expressions of the right type (typ) 30 | , holds n $ \(SameTypeE e1 e2) -> typ e1 == typ e2 31 | , holds n $ \(SameTypedPairsE ees) -> all (\(e1,e2) -> typ e1 == typ e2) ees 32 | , holds n $ \(IntE e) -> typ e == typ i_ 33 | , holds n $ \(BoolE e) -> typ e == typ b_ 34 | , holds n $ \(CharE e) -> typ e == typ c_ 35 | , holds n $ \(IntsE e) -> typ e == typ is_ 36 | 37 | -- Listable TypeE does not produce expressions of the wrong type 38 | , holds n $ isNothing . evaluateInt . unBoolE 39 | , holds n $ isNothing . evaluateBool . unIntE 40 | , holds n $ isNothing . evaluateInts . unIntE 41 | , holds n $ isNothing . evaluateIntToInt . unIntE 42 | , holds n $ isNothing . evaluateChar . unIntE 43 | 44 | -- Listable TypeE0 only returns terminal constants 45 | , holds n $ isConst . unE0 46 | , holds n $ isConst . unIntE0 47 | , holds n $ isConst . unBoolE0 48 | , holds n $ isConst . unIntsE0 49 | , holds n $ isConst . unCharE0 50 | 51 | -- Listable TypeEV only returns variables 52 | , holds n $ isVar . unEV 53 | , holds n $ isVar . unIntEV 54 | , holds n $ isVar . unBoolEV 55 | , holds n $ isVar . unIntsEV 56 | , holds n $ isVar . unCharEV 57 | 58 | -- counter-examples are of the right type 59 | , counterExample n (\(IntE xx) -> False) == Just ["_ :: Int"] 60 | 61 | , isNub (take (n`div`10) list :: [Expr]) 62 | , isNub (take (n`div`10) $ map unSameTypeE list) 63 | , isNub (take (n`div`10) $ map unIntE list) 64 | ] 65 | 66 | evaluateInt :: Expr -> Maybe Int 67 | evaluateInt = evaluate 68 | 69 | evaluateBool :: Expr -> Maybe Bool 70 | evaluateBool = evaluate 71 | 72 | evaluateInts :: Expr -> Maybe [Int] 73 | evaluateInts = evaluate 74 | 75 | evaluateIntToInt :: Expr -> Maybe (Int -> Int) 76 | evaluateIntToInt = evaluate 77 | 78 | evaluateChar :: Expr -> Maybe Char 79 | evaluateChar = evaluate 80 | -------------------------------------------------------------------------------- /test/main.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | import Data.Express.Utils.List 6 | 7 | main :: IO () 8 | main = mainTest tests 5040 9 | 10 | tests :: Int -> [Bool] 11 | tests n = 12 | [ True 13 | 14 | , evl (val (10 :: Int)) == (10 :: Int) 15 | , evl one == (1 :: Int) 16 | , holds n $ \x y -> evl (value "+" ((+) :: Int -> Int -> Int) :$ val x :$ val y) == (x + y :: Int) 17 | , values (xx -+- yy) == [plus, xx, yy] 18 | , (xx -+- yy) // [(yy,yy -+- zz),(xx,xx -+- yy)] == (xx -+- yy) -+- (yy -+- zz) 19 | ] 20 | -------------------------------------------------------------------------------- /test/map.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | import Test.LeanCheck.Function 5 | 6 | import Data.Express.Utils.List (isNub) 7 | 8 | main :: IO () 9 | main = mainTest tests 5040 10 | 11 | tests :: Int -> [Bool] 12 | tests n = 13 | [ True 14 | 15 | -- the order should not matter for // 16 | , holds n $ \e ee1 ee2 -> fst ee1 /= fst ee2 ==> e // [ee1, ee2] == e // [ee2, ee1] 17 | , holds n $ \e ees -> isNub (map fst ees) ==> e // ees == e // reverse ees 18 | 19 | -- the order should not matter for //- 20 | , holds n $ \e ee1 ee2 -> fst ee1 /= fst ee2 ==> e //- [ee1, ee2] == e //- [ee2, ee1] 21 | , holds n $ \e ees -> isNub (map fst ees) ==> e //- ees == e //- reverse ees 22 | , holds n $ \e ees' -> let ees = map (mapFst unEV) ees' in 23 | isNub (map fst ees) ==> e //- ees == e //- reverse ees 24 | 25 | -- //- and // are essentially different 26 | , exists n $ \e es -> e // es /= e //- es 27 | 28 | -- equivalences between // and //- 29 | , holds n $ \e ees -> all (isValue . fst) ees ==> e // ees == e //- ees 30 | , holds n $ \e ees -> e // filter (isValue . fst) ees == e //- ees 31 | 32 | -- //- ignores replacements of non-variable values 33 | , holds n $ \e ees -> e //- filter (not . isValue . fst) ees == e 34 | 35 | -- (in)equivalences between maps 36 | , exists n $ \f e -> mapValues f e /= (mapVars f . mapConsts f) e 37 | , exists n $ \f e -> mapValues f e /= (mapConsts f . mapVars f) e 38 | , exists n $ \f e -> (mapVars f . mapConsts f) e /= (mapConsts f . mapVars f) e 39 | , exists n $ \f e -> (mapConsts f . mapVars f) e /= (mapVars f . mapConsts f) e 40 | -- the above should fail because of the following 41 | , let f _ = id' i_ in mapValues f zero == id' i_ 42 | && mapVars f zero == zero 43 | && mapConsts f zero == id' i_ 44 | && mapVars f (mapConsts f zero) == id' (id' i_) 45 | && mapConsts f (mapVars f zero) == id' i_ 46 | 47 | -- the following do not hold in general: 48 | , exists n $ \f e -> (mapValues f . mapValues f) e /= mapValues f e 49 | , exists n $ \f e -> (mapVars f . mapVars f) e /= mapVars f e 50 | , exists n $ \f e -> (mapConsts f . mapConsts f) e /= mapConsts f e 51 | 52 | -- what actually holds is this: 53 | , holds n $ \f e -> (mapValues f . mapValues f) e == mapValues (mapValues f . f) e 54 | , holds n $ \f e -> (mapVars f . mapVars f) e == mapVars (mapVars f . f) e 55 | , holds n $ \f e -> (mapConsts f . mapConsts f) e == mapConsts (mapConsts f . f) e 56 | 57 | -- the following do not hold in general: 58 | , exists n $ \f e -> values (mapValues f e) /= map f (values e) 59 | , exists n $ \f e -> vars (mapVars f e) /= map f (vars e) 60 | , exists n $ \f e -> consts (mapConsts f e) /= map f (consts e) 61 | 62 | -- what actually holds is this: 63 | , holds n $ \f e -> values (mapValues f e) == concatMap (values . f) (values e) 64 | , holds n $ \f e -> vars (mapVars f e) == concatMap (vars . f) (vars e) 65 | , holds n $ \f e -> consts (mapConsts f e) == concatMap (consts . f) (consts e) 66 | 67 | -- tests of // and //- 68 | , ((xx -*- yy) -+- (yy -*- zz)) // [(xx,ii),(yy,jj),(zz,kk)] == 69 | (ii -*- jj) -+- (jj -*- kk) 70 | 71 | , ((xx -*- yy) -+- (yy -*- zz)) //- [(xx,ii),(yy,jj),(zz,kk)] == 72 | (ii -*- jj) -+- (jj -*- kk) 73 | 74 | , ((xx -*- yy) -+- (yy -*- zz)) // [(xx -*- yy,ii),(yy -*- zz,jj)] == 75 | ii -+- jj 76 | 77 | , ((xx -*- yy) -+- (yy -*- zz)) //- [(xx -*- yy,ii),(yy -*- zz,jj)] == 78 | (xx -*- yy) -+- (yy -*- zz) 79 | 80 | 81 | , ((xx -+- yy) -+- (yy -+- zz)) // [(yy,yy -+- zz)] 82 | == (xx -+- (yy -+- zz)) -+- ((yy -+- zz) -+- zz) 83 | 84 | , ((xx -+- yy) -+- (yy -+- zz)) //- [(yy,yy -+- zz)] 85 | == (xx -+- (yy -+- zz)) -+- ((yy -+- zz) -+- zz) 86 | 87 | , (xx -+- yy) // [(yy,yy -+- zz),(xx,xx -+- yy)] 88 | == (xx -+- yy) -+- (yy -+- zz) 89 | 90 | , (xx -+- yy) //- [(yy,yy -+- zz),(xx,xx -+- yy)] 91 | == (xx -+- yy) -+- (yy -+- zz) 92 | 93 | , ((xx -+- yy) -+- zz) // [(xx -+- yy, zero)] == (zero -+- zz) 94 | , (xx -+- (yy -+- zz)) // [(xx -+- yy, zero)] == (xx -+- (yy -+- zz)) 95 | 96 | , holds n $ \(SameTypeE e1 e2) -> e1 // [(e1,e2)] == e2 97 | , holds n $ \(IntE e1) (IntE e2) -> (e1 -+- e1) // [(e1,e2)] == (e2 -+- e2) 98 | 99 | , holds n $ \e -> renameVarsBy id e == e 100 | , holds n $ \c e -> (renameVarsBy tail . renameVarsBy (c:)) e == e 101 | , renameVarsBy (++ "1") (xx -+- yy) == (var "x1" int -+- var "y1" int) 102 | , renameVarsBy (\(c:cs) -> succ c:cs) ((xx -+- yy) -+- ord' cc) 103 | == ((yy -+- zz) -+- ord' dd) 104 | ] 105 | 106 | mapFst :: (a -> c) -> (a,b) -> (c,b) 107 | mapFst f (x,y) = (f x, y) 108 | -------------------------------------------------------------------------------- /test/match.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | , holds n $ \(IntE e) -> e `isInstanceOf` xx 13 | , holds n $ \(IntE e) -> abs' e `isInstanceOf` abs' xx 14 | , holds n $ \(IntE e) -> (e -+- e) `isInstanceOf` (xx -+- xx) 15 | , holds n $ \(IntE e1) (IntE e2) -> (e1 -+- e2) `isInstanceOf` (xx -+- yy) 16 | , holds n $ \(IntE e1) (IntE e2) -> e1 /= e2 ==> not ((e1 -+- e2) `isInstanceOf` (xx -+- xx)) 17 | , holds n $ \e -> e /= zero ==> not (e `isInstanceOf` zero) 18 | , holds n $ \e1 e2 -> e1 `encompasses` e2 == e2 `isInstanceOf` e1 19 | 20 | , (zero -+- one) `isInstanceOf` (xx -+- yy) 21 | , (zero -+- zero) `isInstanceOf` (xx -+- yy) 22 | , (yy -+- xx) `isInstanceOf` (xx -+- yy) 23 | , (zero -+- zero) `isInstanceOf` (xx -+- xx) 24 | , not $ (zero -+- one) `isInstanceOf` (xx -+- xx) 25 | , zero `isInstanceOf` xx 26 | , not $ xx `isInstanceOf` zero 27 | , (xx -+- (yy -+- xx)) `isInstanceOf` (xx -+- yy) 28 | , (xx -+- (xx -+- xx)) `isInstanceOf` (xx -+- yy) 29 | , not $ (xx -+- (xx -+- xx)) `isInstanceOf` (xx -+- xx) 30 | 31 | , foldPair (xx -+- zero, xx) `isInstanceOf` 32 | foldPair (yy -+- zero, yy) 33 | 34 | , not $ foldPair (xx -+- zero, xx) `isInstanceOf` 35 | foldPair (yy, yy -+- zero) 36 | 37 | , (xx -:- xxs) `isInstanceOf` (yy -:- yys) 38 | , not $ (xx -:- xxs) `isInstanceOf` (pp -:- pps) 39 | 40 | , holds n $ \(IntE e1) (IntE e2) -> match (e1 -+- e2) (xx -+- yy) == Just [(yy,e2),(xx,e1)] 41 | , holds n $ \(IntE e) -> match (e -+- e) (xx -+- xx) == Just [(xx,e)] 42 | , holds n $ \(IntE e1) (IntE e2) -> e1 /= e2 ==> match (e1 -+- e2) (xx -+- xx) == Nothing 43 | , holds n $ \(IntE e1) (IntE e2) (IntE e3) -> e2 /= e3 44 | ==> match ((e1 -+- e1) -+- (e2 -+- e3)) (xx -+- (yy -+- yy)) == Nothing 45 | , holds n $ \(IntE e1) (IntE e2) -> matchWith [(xx,e1)] (e1 -+- e2) (xx -+- yy) == Just [(yy,e2),(xx,e1)] 46 | , holds n $ \(IntE e1) (IntE e2) -> e1 /= e2 ==> matchWith [(xx,e2)] (e1 -+- e2) (xx -+- yy) == Nothing 47 | , holds n $ \e1 e2 -> e1 `match` e2 == matchWith [] e1 e2 48 | , holds n $ \(SameTypeE e1 e2) (SameTypeE e3 e4) -> 49 | not (isFunTy $ typ e1) && not (isFunTy $ typ e3) 50 | ==> 51 | (e1 -==- e2) `match` (e3 -==- e4) == foldPair (e1,e2) `match` foldPair (e3,e4) 52 | 53 | -- tests for isSubexprOf -- 54 | , holds n $ \e1 e2 -> e1 `isSubexprOf` e2 == (e1 `elem` subexprs e2) 55 | , holds n $ \e -> e `isSubexprOf` e 56 | , (xx -+- yy) `isSubexprOf` (zz -+- (xx -+- yy)) == True 57 | , (xx -+- yy) `isSubexprOf` abs' (yy -+- xx) == False 58 | , xx `isSubexprOf` yy == False 59 | , xx `isSubexprOf` xx == True 60 | 61 | -- tests of hasInstanceOf -- 62 | , holds n $ \e1 e2 -> e1 `isInstanceOf` e2 ==> e1 `hasInstanceOf` e2 63 | , holds n $ \ef ex e -> ((ef :$ ex) `hasInstanceOf` e) 64 | == ((ef :$ ex) `isInstanceOf` e || ef `hasInstanceOf` e 65 | || ex `hasInstanceOf` e) 66 | , holds n $ \e1 e2 -> e1 `hasInstanceOf` e2 == any (`isInstanceOf` e2) (subexprs e1) 67 | 68 | -- isInstanceOf is reflexive and transitive 69 | -- but not antisymmetric nor asymmetric 70 | -- so is no order 71 | , holds n $ isReflexive isInstanceOf 72 | , holds n $ isTransitive isInstanceOf 73 | , fails n $ isAntisymmetric isInstanceOf -- structural equality 74 | , fails n $ isAsymmetric isInstanceOf 75 | , fails n $ isTotalOrder isInstanceOf 76 | , fails n $ isPartialOrder isInstanceOf 77 | 78 | -- the same goes for hasInstanceOf 79 | , holds n $ isReflexive hasInstanceOf 80 | , holds n $ isTransitive hasInstanceOf 81 | , fails n $ isAntisymmetric hasInstanceOf 82 | , fails n $ isAsymmetric hasInstanceOf 83 | , fails n $ isTotalOrder hasInstanceOf 84 | , fails n $ isPartialOrder hasInstanceOf 85 | 86 | -- one can construct the following equivalence 87 | , holds n $ isEquivalence (isInstanceOf &&&& flip isInstanceOf) 88 | 89 | -- the following is not an equivalence 90 | , fails n $ isEquivalence (isInstanceOf |||| flip isInstanceOf) 91 | -- so it cannot be used as an argument to nubBy 92 | -- which requires equivalence according to the Haskell 2010 Report. 93 | ] 94 | -------------------------------------------------------------------------------- /test/name-derive.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | import Test 6 | 7 | import Data.Express.Utils.List 8 | 9 | data Peano = Zero | Succ Peano deriving Show 10 | data Lst a = a :- Lst a | Nil deriving Show 11 | data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq) 12 | data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq) 13 | 14 | instance Num Peano where 15 | Zero + n = n 16 | (Succ n) + m = Succ (n + m) 17 | Zero * n = Zero 18 | (Succ n) * m = m + n * m 19 | abs = id 20 | signum Zero = 0 21 | signum (Succ n) = 1 22 | fromInteger n = iterate Succ Zero !! fromInteger n 23 | Zero - m = Zero 24 | n - Zero = Zero 25 | Succ n - Succ m = n - m 26 | 27 | deriveName ''Peano 28 | deriveName ''Lst 29 | deriveName ''Bush 30 | deriveName ''Tree 31 | 32 | -- Recursive nested datatype cascade 33 | data RN = RN RN0 (RN1 Int) (RN2 Int RN) 34 | data RN0 = Nest0 Int | Recurse0 RN 35 | data RN1 a = Nest1 a | Recurse1 RN 36 | data RN2 a b = Nest2 a b | Recurse2 RN 37 | deriveNameCascading ''RN 38 | 39 | -- Those should have no effect (instance already exists): 40 | {- uncommenting those should generate warnings 41 | deriveName ''Bool 42 | deriveName ''Maybe 43 | deriveName ''Either 44 | -} 45 | 46 | -- Those should not generate warnings 47 | deriveNameIfNeeded ''Bool 48 | deriveNameIfNeeded ''Maybe 49 | deriveNameIfNeeded ''Either 50 | 51 | main :: IO () 52 | main = mainTest tests 5040 53 | 54 | tests :: Int -> [Bool] 55 | tests n = 56 | [ True 57 | 58 | , name (undefined :: Peano) == "x" 59 | , name (undefined :: Lst Int) == "l" 60 | , name (undefined :: Bush Int) == "b" 61 | , name (undefined :: Tree Int) == "t" 62 | , name (undefined :: Lst Bool) == "l" 63 | , name (undefined :: Bush Bool) == "b" 64 | , name (undefined :: Tree Bool) == "t" 65 | 66 | , name (undefined :: RN) == "r" 67 | , name (undefined :: RN0) == "r" 68 | , name (undefined :: RN1 Int) == "r" 69 | , name (undefined :: RN2 Bool Int) == "r" 70 | ] 71 | -------------------------------------------------------------------------------- /test/name.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | import Data.Express.Utils.List 6 | 7 | main :: IO () 8 | main = mainTest tests 5040 9 | 10 | tests :: Int -> [Bool] 11 | tests n = 12 | [ True 13 | 14 | -- simple types 15 | , name (undefined :: Int) == "x" 16 | , name (undefined :: Integer) == "x" 17 | , name (undefined :: Char) == "c" 18 | , name (undefined :: Bool) == "p" 19 | , name (undefined :: Int -> Int) == "f" 20 | , name (undefined :: Double) == "x" 21 | 22 | -- lists 23 | , name (undefined :: [Int]) == "xs" 24 | , name (undefined :: [[Int]]) == "xss" 25 | , name (undefined :: [Bool]) == "ps" 26 | , name (undefined :: [[Bool]]) == "pss" 27 | 28 | -- eithers 29 | , name (undefined :: Either Bool Bool) == "epq" 30 | , name (undefined :: Either Int Int) == "exy" 31 | , name (undefined :: Either Bool Char) == "epc" 32 | 33 | -- maybes 34 | , name (undefined :: Maybe Int) == "mx" 35 | , name (undefined :: Maybe [Int]) == "mxs" 36 | , name (undefined :: Maybe [[Int]]) == "mxss" 37 | 38 | -- pairs 39 | , name (undefined :: (Int,Int)) == "xy" 40 | , name (undefined :: (Bool,Bool)) == "pq" 41 | , name (undefined :: (Char,Char)) == "cd" 42 | , name (undefined :: (Bool,Int)) == "px" 43 | , name (undefined :: (Int,Bool)) == "xp" 44 | 45 | -- triples 46 | , name (undefined :: (Int,Int,Int)) == "xyz" 47 | , name (undefined :: (Bool,Bool,Bool)) == "pqr" 48 | , name (undefined :: (Char,Char,Char)) == "cde" 49 | , name (undefined :: (Int,Bool,Char)) == "xpc" 50 | 51 | -- tuples 52 | , name (undefined :: (Int,Int,Int,Int)) == "xxxx" 53 | , name (undefined :: (Int,Int,Int,Int,Int)) == "xxxxx" 54 | , name (undefined :: (Int,Int,Int,Int,Int,Int)) == "xxxxxx" 55 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxx" 56 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxxx" 57 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxxxx" 58 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxxxxx" 59 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxxxxxx" 60 | , name (undefined :: (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) == "xxxxxxxxxxxx" 61 | 62 | , name (undefined :: (Bool,Bool,Bool,Bool)) == "pppp" 63 | , name (undefined :: (Bool,Bool,Bool,Bool,Bool)) == "ppppp" 64 | , name (undefined :: (Bool,Bool,Bool,Bool,Bool,Bool)) == "pppppp" 65 | ] 66 | -------------------------------------------------------------------------------- /test/ord.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2019-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | main :: IO () 6 | main = mainTest tests 5040 7 | 8 | tests :: Int -> [Bool] 9 | tests n = 10 | [ True 11 | 12 | , holds n $ (okEqOrd :: Expr -> Expr -> Expr -> Bool) 13 | , holds n $ \(Ill e0) (Ill e1) (Ill e2) -> okEqOrd e0 e1 e2 14 | , holds n $ compare ==== compareComplexity <> compareLexicographically 15 | 16 | , holds n $ isComparison (compare :: Expr -> Expr -> Ordering) 17 | , holds n $ isComparison compareLexicographically 18 | , holds n $ isComparison compareQuickly 19 | 20 | , exists n $ \e1 e2 -> e1 `compare` e2 /= e1 `compareLexicographically` e2 21 | , exists n $ \e1 e2 -> e1 `compare` e2 /= e1 `compareQuickly` e2 22 | , exists n $ \e1 e2 -> e1 `compareQuickly` e2 /= e1 `compareLexicographically` e2 23 | 24 | -- Holes < Values < Apps 25 | , xx < zero 26 | , zero < zero -+- one 27 | , xx < xx -+- yy 28 | , zero < xx -+- yy 29 | 30 | -- Less arity is less 31 | , zero < absE 32 | , absE < times 33 | , ae < ordE 34 | , ordE < times 35 | , value "id" (id -:> int) < value "id" (id -:> [int]) 36 | , value "id" (id -:> [int]) < value "id" (id -:> [[int]]) 37 | , value "id" (id -:> int) < value "sum" (sum -:> [int]) 38 | , value "id" (id -:> int) < value "(:[])" ((:[]) -:> int) 39 | 40 | -- precedent types 41 | , pp < xx 42 | , cc < xx 43 | , pp < cc 44 | , xx < xxs 45 | , ae < zero 46 | , true < zero 47 | , true < ae 48 | , zero < nil 49 | 50 | -- other precedence rules 51 | , (xx -+- xx) < (xx -+- (xx -+- xx)) 52 | , ((xx -+- xx) -+- xx) > (xx -+- (xx -+- xx)) 53 | , xx < yy 54 | , zero < one 55 | , xx < zero 56 | ] 57 | -------------------------------------------------------------------------------- /test/sdist: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # test/sdist: tests the package generated by "cabal sdist". 4 | # 5 | # Copyright (c) 2015-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | 8 | set -xe 9 | 10 | export LC_ALL=C # consistent sort 11 | 12 | pkgver=` cat *.cabal | grep "^version:" | sed -e "s/version: *//"` 13 | pkgname=`cat *.cabal | grep "^name:" | sed -e "s/name: *//"` 14 | pkgbase=$pkgname-$pkgver 15 | 16 | cabal sdist 17 | 18 | # Try to find the package generated by cabal. 19 | pkg=`find dist* -name $pkgbase.tar.gz` 20 | [ -f "$pkg" ] 21 | # If the script fails here, either: 22 | # * no package was generated 23 | # * there are packages in both dist and dist-newstyle folders. 24 | 25 | tmp=`mktemp -d /tmp/test-sdist-XXXXXXXXXX` 26 | 27 | # Test if our file is compatible with case-insensitive filesystems. 28 | tar -tf $pkg | sort --ignore-case > $tmp/ls-cabal-i 29 | tar -tf $pkg | sort --ignore-case --unique > $tmp/ls-cabal-iu 30 | diff -rud $tmp/ls-cabal-i $tmp/ls-cabal-iu 31 | 32 | # Check if we have a clone of the repo and git is available 33 | # The check that we can run git ls-files is needed to avoid: 34 | # fatal: detected dubious ownership in repository at '/__w/.../hello-haskell' 35 | # on CI. 36 | if [ -d .git ] && git --version && git ls-files >/dev/null 37 | then 38 | # Test if files included by cabal are the same as files tracked in git. 39 | git ls-files | sort > $tmp/ls-git 40 | tar -tf $pkg | grep -v "/$" | sed -e "s,$pkgbase/,," | sort > $tmp/ls-cabal 41 | diff -rud $tmp/ls-git $tmp/ls-cabal 42 | fi 43 | 44 | rm -r $tmp 45 | -------------------------------------------------------------------------------- /test/show.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | import Data.Express.Utils.List 6 | 7 | main :: IO () 8 | main = mainTest tests 5040 9 | 10 | tests :: Int -> [Bool] 11 | tests n = 12 | [ True 13 | 14 | -- showing expressions 15 | 16 | , show zero == "0 :: Int" 17 | , show two == "2 :: Int" 18 | , show minusOne == "-1 :: Int" 19 | , show (one -+- two -*- three) == "1 + 2 * 3 :: Int" 20 | , show ((one -+- two) -*- three) == "(1 + 2) * 3 :: Int" 21 | 22 | , show plus == "(+) :: Int -> Int -> Int" 23 | , show times == "(*) :: Int -> Int -> Int" 24 | 25 | , show (plus :$ one) == "(1 +) :: Int -> Int" 26 | , show (times :$ (minusOne -+- two)) == "(((-1) + 2) *) :: Int -> Int" 27 | 28 | , show ffE == "f :: Int -> Int" 29 | , show (ff xx) == "f x :: Int" 30 | , show (var "f" (undefined :: Int -> Int -> Int)) == "f :: Int -> Int -> Int" 31 | , show (var "f" (undefined :: Int -> Int -> Int) :$ one) == "f 1 :: Int -> Int" 32 | , show (var "f" (undefined :: Int -> Int -> Int) :$ one :$ two) == "f 1 2 :: Int" 33 | , show (var "`f`" (undefined :: Int -> Int -> Int)) == "f :: Int -> Int -> Int" 34 | , show (var "`f`" (undefined :: Int -> Int -> Int) :$ one) == "(1 `f`) :: Int -> Int" 35 | , show (var "`f`" (undefined :: Int -> Int -> Int) :$ one :$ two) == "1 `f` 2 :: Int" 36 | , show (one -?- two) == "1 ? 2 :: Int" 37 | , show (value "`compare`" (compare :: Int->Int->Ordering) :$ one) == "(1 `compare`) :: Int -> Ordering" 38 | , show (value "`compare`" (compare :: Int->Int->Ordering) :$ one :$ two) == "1 `compare` 2 :: Ordering" 39 | 40 | , holds n $ show . mapVars (\(Value ('_':s) d) -> Value (if null s then "_" else s) d) === show 41 | 42 | , show emptyString == "\"\" :: [Char]" 43 | , show (space -:- emptyString) == "\" \" :: [Char]" 44 | , show (space -:- ccs) == "' ':cs :: [Char]" 45 | , show (ae -:- bee -:- emptyString) == "\"ab\" :: [Char]" 46 | , show (ae -:- bee -:- nilChar) == "['a','b'] :: [Char]" 47 | , show (ae -:- cc -:- nilChar) == "['a',c] :: [Char]" 48 | , show (ae -:- bee -:- ccs) == "'a':'b':cs :: [Char]" 49 | , show (ae -:- space -:- bee -:- lineBreak -:- emptyString) == "\"a b\\n\" :: [Char]" 50 | , show (cc -:- space -:- dd -:- lineBreak -:- emptyString) == "c:' ':d:\"\\n\" :: [Char]" 51 | , show (cc -:- space -:- dd -:- lineBreak -:- ccs) == "c:' ':d:'\\n':cs :: [Char]" 52 | , show (cc -:- ae -:- bee -:- emptyString) == "c:\"ab\" :: [Char]" 53 | , show (cc -:- ae -:- bee -:- space -:- ae -:- bee -:- emptyString) == "c:\"ab ab\" :: [Char]" 54 | 55 | , show one == "1 :: Int" 56 | , show (minusOne) == "-1 :: Int" 57 | , show (one -+- one) == "1 + 1 :: Int" 58 | , show (minusOne -+- minusOne) == "(-1) + (-1) :: Int" 59 | 60 | , show (zero -|- one) == "(0,1) :: (Int,Int)" 61 | , show (minusOne -|- minusOne) == "(-1,-1) :: (Int,Int)" 62 | , show (triple zero one two) == "(0,1,2) :: (Int,Int,Int)" 63 | , show (quadruple minusOne zero one two) == "(-1,0,1,2) :: (Int,Int,Int,Int)" 64 | , show (quintuple minusOne zero one two three) == "(-1,0,1,2,3) :: (Int,Int,Int,Int,Int)" 65 | , show (sixtuple minusTwo minusOne zero one two three) == "(-2,-1,0,1,2,3) :: (Int,Int,Int,Int,Int,Int)" 66 | 67 | , show (one -:- nil) == "[1] :: [Int]" 68 | , show (zero -:- one -:- nil) == "[0,1] :: [Int]" 69 | , show (minusOne -:- nil) == "[-1] :: [Int]" 70 | , show (minusOne -:- minusTwo -:- nil) == "[-1,-2] :: [Int]" 71 | , show (xx -:- minusTwo -:- yy -:- nil) == "[x,-2,y] :: [Int]" 72 | , show (xx -:- minusTwo -:- yy -:- xxs) == "x:(-2):y:xs :: [Int]" 73 | 74 | , show (ffE -$- zero) == "f $ 0 :: Int" 75 | , show (ggE -$- xx) == "g $ x :: Int" 76 | , show (ffE -$- minusOne) == "f $ (-1) :: Int" 77 | 78 | , holds n $ \e -> showExpr e `isPrefixOf` show e 79 | 80 | , show (if' pp xx yy) == "(if p then x else y) :: Int" 81 | , show (if' false zero one) == "(if False then 0 else 1) :: Int" 82 | , show (if' true two three) == "(if True then 2 else 3) :: Int" 83 | , show (if' pp false true) == "(if p then False else True) :: Bool" 84 | , show (not' (if' pp false true)) == "not (if p then False else True) :: Bool" 85 | , show (if' pp xx yy -*- zz) == "(if p then x else y) * z :: Int" 86 | , show (zz -*- if' pp xx yy) == "z * (if p then x else y) :: Int" 87 | , show (if' pp false true -||- if' qq true false) 88 | == "(if p then False else True) || (if q then True else False) :: Bool" 89 | , show (if' (null' xxs) zero (head' xxs -+- value "sum" (sum :: [Int] -> Int) :$ tail' xxs)) 90 | == "(if null xs then 0 else head xs + sum (tail xs)) :: Int" 91 | , show (if' (xx -<- yy) (ff xx) (yy -*- zz)) == "(if x < y then f x else y * z) :: Int" 92 | 93 | , show (caseBool pp xx yy) == "(case p of False -> x; True -> y) :: Int" 94 | , show (caseBool false zero one) == "(case False of False -> 0; True -> 1) :: Int" 95 | , show (caseBool true two three) == "(case True of False -> 2; True -> 3) :: Int" 96 | , show (caseBool pp false true) == "(case p of False -> False; True -> True) :: Bool" 97 | , show (not' (caseBool pp false true)) == "not (case p of False -> False; True -> True) :: Bool" 98 | , show (caseBool pp xx yy -*- zz) == "(case p of False -> x; True -> y) * z :: Int" 99 | , show (zz -*- caseBool pp xx yy) == "z * (case p of False -> x; True -> y) :: Int" 100 | 101 | , showExpr (if' pp xx yy) == "if p then x else y" 102 | , showExpr (if' false zero one) == "if False then 0 else 1" 103 | , showExpr (if' true two three) == "if True then 2 else 3" 104 | , showExpr (if' pp false true) == "if p then False else True" 105 | , showExpr (if' (xx -<- yy) (ff xx) (yy -*- zz)) == "if x < y then f x else y * z" 106 | 107 | , showExpr (caseBool pp xx yy) == "case p of False -> x; True -> y" 108 | , showExpr (caseBool false zero one) == "case False of False -> 0; True -> 1" 109 | , showExpr (caseBool true two three) == "case True of False -> 2; True -> 3" 110 | , showExpr (caseBool pp false true) == "case p of False -> False; True -> True" 111 | , showExpr (caseBool pp true false) == "case p of False -> True; True -> False" 112 | 113 | , show (caseOrdering (compare' xx yy) xx zz yy) == "(case compare x y of LT -> x; EQ -> z; GT -> y) :: Int" 114 | , show (caseOrdering (val LT) zero one two) == "(case LT of LT -> 0; EQ -> 1; GT -> 2) :: Int" 115 | , show (caseOrdering (val GT) three four five) == "(case GT of LT -> 3; EQ -> 4; GT -> 5) :: Int" 116 | , show (caseOrdering (compare' xx yy) (ff xx) zz (yy -+- zz)) == "(case compare x y of LT -> f x; EQ -> z; GT -> y + z) :: Int" 117 | 118 | , showExpr (caseOrdering (compare' xx yy) xx zz yy) == "case compare x y of LT -> x; EQ -> z; GT -> y" 119 | , showExpr (caseOrdering (val LT) zero one two) == "case LT of LT -> 0; EQ -> 1; GT -> 2" 120 | , showExpr (caseOrdering (val GT) three four five) == "case GT of LT -> 3; EQ -> 4; GT -> 5" 121 | , showExpr (caseOrdering (compare' xx yy) (ff xx) zz (yy -+- zz)) == "case compare x y of LT -> f x; EQ -> z; GT -> y + z" 122 | 123 | -- showing holes -- 124 | , show (hole (undefined :: Int -> Int) :$ one) == "_ 1 :: Int" 125 | , show (hole (undefined :: Int -> Int) :$ xx) == "_ x :: Int" 126 | , show (hole (undefined :: Int -> Int -> Int) :$ one :$ xx) == "_ 1 x :: Int" 127 | , show (hole (undefined :: Int -> Int -> Int) :$ i_ :$ i_) == "_ _ _ :: Int" 128 | 129 | -- A type -- 130 | , show (hole (undefined :: A)) == "_ :: A" 131 | , show (val (0 :: A)) == "0 :: A" 132 | , show (val (1 :: A)) == "1 :: A" 133 | , show (val (2 :: A)) == "2 :: A" 134 | , show (var "x" (undefined :: A)) == "x :: A" 135 | , show (value "id" (id :: A -> A) :$ var "x" (undefined :: A)) == "id x :: A" 136 | 137 | -- B type -- 138 | , show (hole (undefined :: B)) == "_ :: B" 139 | , show (val (0 :: B)) == "0 :: B" 140 | , show (val (1 :: B)) == "1 :: B" 141 | , show (val (2 :: B)) == "2 :: B" 142 | , show (var "x" (undefined :: B)) == "x :: B" 143 | , show (value "id" (id :: B -> B) :$ var "x" (undefined :: B)) == "id x :: B" 144 | 145 | -- [A] type -- 146 | , show (hole (undefined :: [A])) == "_ :: [A]" 147 | , show (val ([0] :: [A])) == "[0] :: [A]" 148 | , show (val ([3,1] :: [A])) == "[3,1] :: [A]" 149 | , show (val ([0,1,2] :: [A])) == "[0,1,2] :: [A]" 150 | , show (var "xs" (undefined :: [A])) == "xs :: [A]" 151 | , show (value "id" (id :: [A] -> [A]) :$ var "xs" (undefined :: [A])) == "id xs :: [A]" 152 | 153 | , show (xx -:- nil -++- is_) == "x:([] ++ _) :: [Int]" 154 | , show (xx -:- yy -:- nil -++- is_) == "x:y:([] ++ _) :: [Int]" 155 | 156 | , show (cc -:- emptyString -++- cs_) == "c:(\"\" ++ _) :: [Char]" 157 | , show (cc -:- dd -:- emptyString -++- cs_) == "c:d:(\"\" ++ _) :: [Char]" 158 | , show (ae -:- bee -:- emptyString -++- cs_) == "'a':'b':(\"\" ++ _) :: [Char]" 159 | 160 | -- list pretty-printing only works with explicit val [] terminator 161 | -- other terminating consts are not unpacked 162 | , show (zero -:- one -:- two -:- nil) == "[0,1,2] :: [Int]" 163 | , show (zero -:- val [1,2::Int]) == "0:[1,2] :: [Int]" 164 | , show (xx -:- yy -:- three -:- four -:- nil) == "[x,y,3,4] :: [Int]" 165 | , show (xx -:- yy -:- val [3,4::Int]) == "x:y:[3,4] :: [Int]" 166 | ] 167 | -------------------------------------------------------------------------------- /test/triexpr.hs: -------------------------------------------------------------------------------- 1 | import Test 2 | import Data.Express.Triexpr (Triexpr) 3 | import qualified Data.Express.Triexpr as T 4 | 5 | 6 | trie :: Triexpr Expr 7 | trie = T.fromList allRules 8 | 9 | 10 | main :: IO () 11 | main = mainTest tests 10000 12 | 13 | 14 | tests :: Int -> [Bool] 15 | tests n = 16 | [ True 17 | 18 | , length allRules == 99 19 | , all (isWellTyped . fst) allRules 20 | , all (isWellTyped . snd) allRules 21 | 22 | , T.lookup zero trie == [] 23 | , T.lookup one trie == [] 24 | , T.lookup two trie == [] 25 | , T.lookup false trie == [] 26 | , T.lookup true trie == [] 27 | 28 | , T.lookup (one -+- two) trie 29 | == [ (xx -+- yy, [(yy, two), (xx, one)], yy -+- xx) 30 | ] 31 | 32 | , T.lookup ((one -+- two) -+- three) trie 33 | == [ (xx -+- yy, [(yy, three), (xx, one -+- two)], yy -+- xx) 34 | , ((xx -+- yy) -+- zz, [(zz, three), (yy, two), (xx, one)], xx -+- (yy -+- zz)) 35 | ] 36 | 37 | , T.lookup ((false -&&- false) -&&- true) trie 38 | == [ (pp -&&- qq, [(qq,true),(pp,false -&&- false)], qq -&&- pp) 39 | , (pp -&&- true, [(pp,false -&&- false)], pp) 40 | , ((pp -&&- qq) -&&- rr, [(rr,true),(qq,false),(pp,false)], pp -&&- (qq -&&- rr)) 41 | ] 42 | 43 | , T.lookup (not' true) trie 44 | == [ (not' true, [], false) ] 45 | 46 | , T.lookup (true -||- true) trie 47 | == [ (pp -||- pp, [(pp,true)], pp) 48 | , (pp -||- qq, [(qq,true),(pp,true)], qq -||- pp) 49 | , (pp -||- true, [(pp,true)], true) 50 | , (true -||- pp, [(pp,true)], true) 51 | ] 52 | 53 | , holds n $ \ees -> (sort . T.toList $ T.fromList ees) == sort (ees :: [(Expr,Int)]) 54 | , holds n $ \ees -> (sort . T.toList $ T.fromList ees) == sort (ees :: [(Expr,Expr)]) 55 | 56 | , holds n $ \e ees -> [(e1,ms,e2 :: Expr) | (e1,e2) <- ees, ms <- maybeToList (e `match` e1)] 57 | =$ sort $= T.lookup e (T.fromList ees) 58 | 59 | , holds n $ \e eus -> [(e1,ms,()) | (e1,()) <- sort eus, ms <- maybeToList (e `match` e1)] 60 | == (T.lookup e (T.fromList eus)) 61 | 62 | , holds n $ \e -> [(e1,ms,e2) | (e1,e2) <- allRules, ms <- maybeToList (e `match` e1)] 63 | =$ sort $= T.lookup e trie 64 | ] 65 | -------------------------------------------------------------------------------- /test/typecheck.hs: -------------------------------------------------------------------------------- 1 | -- test/typecheck.hs: imports Express and does nothing 2 | -- 3 | -- to be used for triggering typechecking using runhugs 4 | -- 5 | -- Copyright (c) 2019-2024 Rudy Matela. 6 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 7 | import Data.Express.Core 8 | import Data.Express.Hole 9 | import Data.Express.Map 10 | import Data.Express.Match 11 | 12 | import Data.Express.Name 13 | import Data.Express.Triexpr 14 | 15 | import Data.Express.Utils 16 | import Data.Express.Utils.Typeable 17 | 18 | main :: IO () 19 | main = return () 20 | -------------------------------------------------------------------------------- /test/utils.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017-2024 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import Test 4 | 5 | import Data.Express.Utils.List 6 | import Data.Express.Utils.String 7 | import Data.Express.Utils.Typeable 8 | 9 | main :: IO () 10 | main = mainTest tests 5040 11 | 12 | tests :: Int -> [Bool] 13 | tests n = 14 | [ True 15 | 16 | , holds n $ \xs -> nubSort xs == nub (sort xs :: [Int]) 17 | , holds n $ \xs -> nubSort xs == sort (nub xs :: [Int]) 18 | 19 | , holds n $ isSubsetOf ==== (\xs ys -> all (`elem` ys) (xs :: [Int])) 20 | 21 | , elementTy (typeOf [True]) == boolTy 22 | , elementTy (elementTy (typeOf [[False]])) == boolTy 23 | , show (mkComparisonTy boolTy) == "Bool -> Bool -> Bool" 24 | , show (mkComparisonTy intTy) == "Int -> Int -> Bool" 25 | , show (mkCompareTy boolTy) == "Bool -> Bool -> Ordering" 26 | , show (mkCompareTy intTy) == "Int -> Int -> Ordering" 27 | 28 | , showTypesInTypeOf (u :: Int) == ["Int"] 29 | , showTypesInTypeOf (u :: Bool) == ["Bool"] 30 | , showTypesInTypeOf (u :: [Int]) == ["Int", "[Int]"] 31 | , showTypesInTypeOf (u :: [Bool]) == ["Bool", "[Bool]"] 32 | , showTypesInTypeOf (u :: (Int,Int)) == ["Int", "(Int,Int)"] 33 | , showTypesInTypeOf (u :: (Bool,Bool)) == ["Bool", "(Bool,Bool)"] 34 | , showTypesInTypeOf (u :: (Int,Bool)) == ["Bool", "Int", "(Int,Bool)"] 35 | , showTypesInTypeOf (u :: Maybe Integer) == ["Integer", "Maybe Integer"] 36 | , showTypesInTypeOf (u :: Int -> Int) == ["Int", "Int -> Int"] 37 | , showTypesInTypeOf (u :: Int -> Bool) == ["Bool", "Int", "Int -> Bool"] 38 | 39 | , showTypesInTypeOf (u :: Int -> Int -> Int) 40 | == [ "Int" 41 | , "Int -> Int" 42 | , "Int -> Int -> Int" 43 | ] 44 | 45 | , showTypesInTypeOf (u :: Either String ()) 46 | == [ "()" 47 | , "Char" 48 | , "[Char]" 49 | , "Either [Char] ()" 50 | ] 51 | 52 | , showTypesInTypeOf (u :: Either String Bool -> Maybe Int -> Int -> Bool) 53 | == [ "Bool" 54 | , "Char" 55 | , "Int" 56 | , "Maybe Int" 57 | , "[Char]" 58 | , "Either [Char] Bool" 59 | , "Int -> Bool" 60 | , "Maybe Int -> Int -> Bool" 61 | , "Either [Char] Bool -> Maybe Int -> Int -> Bool" 62 | ] 63 | 64 | , map show (typesInList [typeOf (u :: Int), typeOf (u :: Bool)]) 65 | == [ "Bool" 66 | , "Int" 67 | ] 68 | 69 | , map show (typesInList [typeOf (u :: Int), typeOf (u :: Int -> Bool)]) 70 | == [ "Bool" 71 | , "Int" 72 | , "Int -> Bool" 73 | ] 74 | 75 | , primeCycle [] == [] 76 | , ["x", "y", "z", "x'", "y'", "z'", "x''"] `isPrefixOf` primeCycle ["x","y","z"] 77 | , ["x","x'","x''","x'''","x''''","x'''''"] `isPrefixOf` primeCycle ["x"] 78 | , ["i", "j", "k", "i'", "j'", "k'", "i''"] `isPrefixOf` primeCycle ["i","j","k"] 79 | , ["xy", "zw", "xy'", "zw'", "xy''"] `isPrefixOf` primeCycle ["xy","zw"] 80 | 81 | , ["x","y","z","x'","y'"] `isPrefixOf` variableNamesFromTemplate "x" 82 | , ["xs","ys","zs","xs'"] `isPrefixOf` variableNamesFromTemplate "xs" 83 | , ["xss","yss","zss","xss'"] `isPrefixOf` variableNamesFromTemplate "xss" 84 | , ["c","d","e","c'","d'"] `isPrefixOf` variableNamesFromTemplate "c" 85 | , ["s","t","u","s'","t'"] `isPrefixOf` variableNamesFromTemplate "s" 86 | , ["0","1","2","3","4"] `isPrefixOf` variableNamesFromTemplate "0" 87 | , ["1","2","3","4","5"] `isPrefixOf` variableNamesFromTemplate "1" 88 | , ["z","z1","z2","z3","z4"] `isPrefixOf` variableNamesFromTemplate "z" 89 | , ["y","y1","y2","y3","y4"] `isPrefixOf` variableNamesFromTemplate "y" 90 | , ["x1","x2","x3","x4"] `isPrefixOf` variableNamesFromTemplate "x1" 91 | , ["a0","a1","a2","a3"] `isPrefixOf` variableNamesFromTemplate "a0" 92 | , ["e1","e2","e3","e4"] `isPrefixOf` variableNamesFromTemplate "e1" 93 | , ["xs1","xs2","xs3"] `isPrefixOf` variableNamesFromTemplate "xs1" 94 | , ["xy","zw","xy'","zw'"] `isPrefixOf` variableNamesFromTemplate "xy" 95 | , ["ab","cd","ab'","cd'"] `isPrefixOf` variableNamesFromTemplate "ab" 96 | , ["xys","zws","xys'"] `isPrefixOf` variableNamesFromTemplate "xys" 97 | , ["xyz","uvw","xyz'","uvw'"] `isPrefixOf` variableNamesFromTemplate "xyz" 98 | , ["thing1", "thing2", "thing3"] `isPrefixOf` variableNamesFromTemplate "thing1" 99 | , ["thingAndThing", "thingAndThing'", "thingAndThing''", "thingAndThing'''"] 100 | `isPrefixOf` variableNamesFromTemplate "thingAndThing" 101 | ] 102 | 103 | u :: a 104 | u = undefined 105 | 106 | showTypesInTypeOf :: Typeable a => a -> [String] 107 | showTypesInTypeOf = map show . typesIn . typeOf 108 | --------------------------------------------------------------------------------