From 35010ad07874d30a958982d55cc8cbdd2df8678c Mon Sep 17 00:00:00 2001 From: Tony Morris Date: Tue, 12 Mar 2019 16:18:16 +1000 Subject: [PATCH] data61/fp-course --- .editorconfig | 8 + .ghci | 1 + .gitignore | 16 +- .travis.yml | 146 +++- CHEATSHEET.md | 231 ++++++ README.markdown | 242 ++++-- Setup.lhs | 44 +- Vagrantfile | 13 + cabal.project | 2 + ci/ci.nix | 30 + ci/jobsets.json | 16 + ci/jobsets.nix | 27 + course.cabal | 67 +- course.lkshf | 17 + default.nix | 36 + fp-course.nix | 15 + ops/README.md | 38 + ops/ansible.yaml | 54 ++ ops/emacs.d/init.el | 34 + ops/haskell.yaml | 36 + ops/sublime.yaml | 27 + ops/vs-code.yaml | 27 + .../haskell/network-server.cabal | 14 +- .../haskell/src/Data/TicTacToe.hs | 6 +- .../haskell/src/Network/TicTacToe/Accept.hs | 44 -- .../haskell/src/Network/TicTacToe/Command.hs | 152 ---- .../haskell/src/Network/TicTacToe/Env.hs | 60 -- .../haskell/src/Network/TicTacToe/Game.hs | 296 -------- .../src/Network/TicTacToe/HandleLens.hs | 42 -- .../haskell/src/Network/TicTacToe/Lens.hs | 96 --- .../TicTacToe-net/haskell/tictactoe-net.cabal | 88 --- projects/TicTacToe/agda/TicTacToe.agda | 96 --- projects/TicTacToe/haskell/.ghci | 6 - projects/TicTacToe/haskell/.gitignore | 22 - projects/TicTacToe/haskell/LICENSE | 28 - projects/TicTacToe/haskell/Setup.lhs | 44 -- projects/TicTacToe/haskell/changelog | 9 - projects/TicTacToe/haskell/src/TicTacToe.hs | 17 - .../haskell/src/TicTacToe/AsOccupied.hs | 37 - .../TicTacToe/haskell/src/TicTacToe/AsOr.hs | 38 - .../TicTacToe/haskell/src/TicTacToe/AsWin.hs | 25 - .../TicTacToe/haskell/src/TicTacToe/Back.hs | 71 -- .../haskell/src/TicTacToe/Console.hs | 154 ---- .../TicTacToe/haskell/src/TicTacToe/Draw.hs | 35 - .../TicTacToe/haskell/src/TicTacToe/Move.hs | 688 ------------------ .../TicTacToe/haskell/src/TicTacToe/MoveOr.hs | 479 ------------ .../haskell/src/TicTacToe/OccupiedOr.hs | 82 --- .../TicTacToe/haskell/src/TicTacToe/Player.hs | 64 -- .../haskell/src/TicTacToe/Position.hs | 179 ----- .../haskell/src/TicTacToe/WinOccupiedOr.hs | 85 --- .../haskell/src/TicTacToe/Winpaths.hs | 28 - .../haskell/src/TicTacToe/WithPosition.hs | 129 ---- projects/TicTacToe/haskell/test/.gitignore | 8 - projects/TicTacToe/haskell/test/doctests.hs | 32 - projects/TicTacToe/haskell/tictactoe.cabal | 106 --- projects/TicTacToe/idris/TicTacToe.idr | 220 ------ .../TicTacToe/java/src/tictactoe/Board.java | 185 ----- .../java/src/tictactoe/BoardLike.java | 53 -- .../java/src/tictactoe/GameResult.java | 50 -- .../TicTacToe/java/src/tictactoe/Main.java | 163 ----- .../java/src/tictactoe/MoveResult.java | 59 -- .../TicTacToe/java/src/tictactoe/Player.java | 26 - .../java/src/tictactoe/Position.java | 50 -- .../java/src/tictactoe/TakenBack.java | 26 - projects/TicTacToe/java/tictactoe.iml | 14 - projects/TicTacToe/scala/TicTacToe.scala | 370 ---------- shell.nix | 7 + src/.ghci | 1 + src/Course.hs | 2 +- src/Course/.ghci | 3 + src/Course/Anagrams.hs | 8 +- src/Course/Applicative.hs | 153 ++-- src/Course/Cheque.hs | 94 +-- src/Course/Comonad.hs | 17 +- src/Course/Compose.hs | 14 +- src/Course/Core.hs | 4 - src/Course/Extend.hs | 16 +- src/Course/FastAnagrams.hs | 12 +- src/Course/FileIO.hs | 88 ++- src/Course/Functor.hs | 16 +- src/Course/Interactive.hs | 27 +- src/Course/JsonParser.hs | 59 +- src/Course/JsonValue.hs | 2 +- src/Course/List.hs | 178 ++--- src/Course/ListZipper.hs | 320 ++++---- src/Course/Monad.hs | 115 ++- src/Course/MonadTutorial.hs | 10 +- src/Course/MoreParser.hs | 96 ++- src/Course/Optional.hs | 42 +- src/Course/Parser.hs | 508 ++++++------- src/Course/Person.hs | 18 +- src/Course/State.hs | 137 ++-- src/Course/StateT.hs | 203 ++++-- src/Course/Traversable.hs | 80 +- src/Course/Validation.hs | 12 +- test/Course/ApplicativeTest.hs | 244 +++++++ test/Course/ChequeTest.hs | 71 ++ test/Course/ComonadTest.hs | 28 + test/Course/ExtendTest.hs | 70 ++ test/Course/FunctorTest.hs | 70 ++ test/Course/Gens.hs | 91 +++ test/Course/JsonParserTest.hs | 132 ++++ test/Course/ListTest.hs | 218 ++++++ test/Course/ListZipperTest.hs | 463 ++++++++++++ test/Course/MonadTest.hs | 94 +++ test/Course/MoreParserTest.hs | 304 ++++++++ test/Course/OptionalTest.hs | 73 ++ test/Course/ParserTest.hs | 323 ++++++++ test/Course/StateTTest.hs | 207 ++++++ test/Course/StateTest.hs | 134 ++++ test/Course/TraversableTest.hs | 139 ++++ test/Course/ValidationTest.hs | 99 +++ test/TastyLoader.hs | 45 ++ test/doctests.hs | 83 --- 114 files changed, 4822 insertions(+), 5911 deletions(-) create mode 100644 .editorconfig create mode 100644 CHEATSHEET.md create mode 100644 Vagrantfile create mode 100644 cabal.project create mode 100644 ci/ci.nix create mode 100644 ci/jobsets.json create mode 100644 ci/jobsets.nix create mode 100644 course.lkshf create mode 100644 default.nix create mode 100644 fp-course.nix create mode 100644 ops/README.md create mode 100644 ops/ansible.yaml create mode 100644 ops/emacs.d/init.el create mode 100644 ops/haskell.yaml create mode 100644 ops/sublime.yaml create mode 100644 ops/vs-code.yaml delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/Accept.hs delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/Command.hs delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/Env.hs delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/Game.hs delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/HandleLens.hs delete mode 100644 projects/NetworkServer/haskell/src/Network/TicTacToe/Lens.hs delete mode 100644 projects/TicTacToe-net/haskell/tictactoe-net.cabal delete mode 100644 projects/TicTacToe/agda/TicTacToe.agda delete mode 100755 projects/TicTacToe/haskell/.ghci delete mode 100644 projects/TicTacToe/haskell/.gitignore delete mode 100644 projects/TicTacToe/haskell/LICENSE delete mode 100644 projects/TicTacToe/haskell/Setup.lhs delete mode 100644 projects/TicTacToe/haskell/changelog delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/AsOccupied.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/AsOr.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/AsWin.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Back.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Console.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Draw.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Move.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/MoveOr.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/OccupiedOr.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Player.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Position.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/WinOccupiedOr.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/Winpaths.hs delete mode 100644 projects/TicTacToe/haskell/src/TicTacToe/WithPosition.hs delete mode 100644 projects/TicTacToe/haskell/test/.gitignore delete mode 100644 projects/TicTacToe/haskell/test/doctests.hs delete mode 100644 projects/TicTacToe/haskell/tictactoe.cabal delete mode 100644 projects/TicTacToe/idris/TicTacToe.idr delete mode 100644 projects/TicTacToe/java/src/tictactoe/Board.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/BoardLike.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/GameResult.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/Main.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/MoveResult.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/Player.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/Position.java delete mode 100644 projects/TicTacToe/java/src/tictactoe/TakenBack.java delete mode 100644 projects/TicTacToe/java/tictactoe.iml delete mode 100644 projects/TicTacToe/scala/TicTacToe.scala create mode 100644 shell.nix create mode 120000 src/.ghci create mode 100644 src/Course/.ghci create mode 100644 test/Course/ApplicativeTest.hs create mode 100644 test/Course/ChequeTest.hs create mode 100644 test/Course/ComonadTest.hs create mode 100644 test/Course/ExtendTest.hs create mode 100644 test/Course/FunctorTest.hs create mode 100644 test/Course/Gens.hs create mode 100644 test/Course/JsonParserTest.hs create mode 100644 test/Course/ListTest.hs create mode 100644 test/Course/ListZipperTest.hs create mode 100644 test/Course/MonadTest.hs create mode 100644 test/Course/MoreParserTest.hs create mode 100644 test/Course/OptionalTest.hs create mode 100644 test/Course/ParserTest.hs create mode 100644 test/Course/StateTTest.hs create mode 100644 test/Course/StateTest.hs create mode 100644 test/Course/TraversableTest.hs create mode 100644 test/Course/ValidationTest.hs create mode 100644 test/TastyLoader.hs delete mode 100644 test/doctests.hs diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..61ffc1fcd --- /dev/null +++ b/.editorconfig @@ -0,0 +1,8 @@ +[*] +end_of_line = lf +insert_final_newline = true +charset = utf-8 + +[*.{hs,yaml}] +indent_style = space +indent_size = 2 diff --git a/.ghci b/.ghci index 9b24c10f3..ddc27e892 100644 --- a/.ghci +++ b/.ghci @@ -1,4 +1,5 @@ :set -isrc +:set -itest :l src/Course.hs :set prompt ">> " :set -Wall diff --git a/.gitignore b/.gitignore index 03e5b9a06..07e1d72fe 100644 --- a/.gitignore +++ b/.gitignore @@ -2,12 +2,13 @@ *#* # CABAL -/dist -/dist-newstyle -/cabal-dev -/.cabal-sandbox -/cabal.sandbox.config -/cabal.project.local +dist +dist-newstyle +cabal-dev +.cabal-sandbox +cabal.sandbox.config +cabal.project.local +.ghc.environment.* # Haskell Program Coverage /.hpc @@ -33,3 +34,6 @@ TAGS # Stack .stack-work/ +# Vagrant +.vagrant +ops/*.retry diff --git a/.travis.yml b/.travis.yml index 2b01c586e..b06287f84 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,40 +1,120 @@ -notifications: - email: - on_success: change - on_failure: change +# This Travis job script has been generated by a script via +# +# haskell-ci 'course.cabal' '--output' '.travis.yml' +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +language: c +dist: xenial -# The following enables several GHC versions to be tested; often it's enough to -# test only against the last release in a major GHC version. Feel free to omit -# lines listings versions you don't need/want testing for. -env: - - CABALVER=1.18 GHCVER=7.6.3 +git: + submodules: false # whether to recursively clone submodules + +cache: + directories: + - $HOME/.cabal/packages + - $HOME/.cabal/store + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + + - rm -rfv $HOME/.cabal/packages/head.hackage + +matrix: + include: + - compiler: "ghc-8.6.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}} + - compiler: "ghc-8.4.4" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.0.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} + - compiler: "ghc-7.10.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}} before_install: - # If $GHCVER is the one travis has, don't bother reinstalling it. - # We can also have faster builds by installing some libraries with - # `apt`. If it isn't, install the GHC we want from hvr's PPA along - # with cabal-1.18. - - | - if [ $GHCVER = `ghc --numeric-version` ]; then - travis/cabal-apt-install --enable-tests $MODE - export CABAL=cabal - else - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - fi + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - ROOTDIR=$(pwd) + - mkdir -p $HOME/.local/bin + - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - travis_retry cabal update - - cabal install --only-dependencies --enable-tests --enable-benchmarks + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - UNCONSTRAINED=${UNCONSTRAINED-true} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" + - rm -fv cabal.project cabal.project.local + - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + - rm -f cabal.project + - touch cabal.project + - "printf 'packages: \".\"\\n' >> cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" + - touch cabal.project.local + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(course)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi + - rm -f cabal.project.freeze + - cabal new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry + - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm "cabal.project.freeze" + - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all + - rm -rf .ghc.environment.* "."/dist + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) -# Here starts the actual work to be performed for the package under test; any -# command which exits with a non-zero exit code causes the build to fail. +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. script: - - cabal configure --enable-tests --enable-benchmarks -v2 - - cabal build - - cabal test - + # test that source-distributions can be generated + - cabal new-sdist all + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; + - rm -f cabal.project + - touch cabal.project + - "printf 'packages: \"course-*/*.cabal\"\\n' >> cabal.project" + - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" + - touch cabal.project.local + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(course)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # this builds all libraries and executables (without tests/benchmarks) + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all + + # build & run tests, build benchmarks + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + # MODIFIED - build the tests but don't run them + #- if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi + + # cabal check + - (cd course-* && cabal check) + + # haddock + - cabal new-haddock -w ${HC} ${TEST} ${BENCH} all + + # Build without installed constraints for packages in global-db + - if $UNCONSTRAINED; then rm -f cabal.project.local; cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi + +# REGENDATA ["course.cabal","--output",".travis.yml"] +# EOF diff --git a/CHEATSHEET.md b/CHEATSHEET.md new file mode 100644 index 000000000..3fa791718 --- /dev/null +++ b/CHEATSHEET.md @@ -0,0 +1,231 @@ +## Cheatsheet + +### Vocabulary + +|**Symbol**|**Pronunciation** |**Notes** | +|----------|---------------------|------------------------------------------------| +|`:.` |cons |Adds an element to the front of a list | +|`<$>` |eff-map |Member of the Functor type class | +|`<*>` |app, apply, spaceship|Member of the Applicative type class | +|`>>=` |bind |Member of the Monad type class | +|`bool` |bool |if/then/else with arguments in the reverse order| + +### Equivalent expressions + +Here are some expressions and their neater, more idiomatic alternatives. + +**Function application** + +`\x -> f x` may be replaced with `f` + +**Composition** + +`\x -> f (g x)` may be replaced with `f . g` + +### Follow the types + +Rather than thinking operationally, focus on finding values for the types that the compiler is telling you you need. +Once you have a compiling program it's easier to look at what you have and decide if it solves your problem. + +### Use type holes + +Following on from the previous point, use type holes to discover the types of the values you need to +provide. A type hole is an underscore, or a name prefixed by an underscore (`_`). When GHC sees a +type hole, it will produce a compiler error that tells you the type of the value that should be in +its place. + +As an example, let's assume we're attempting to write a definition for `List.product` using +`foldRight`, but we're not sure how to apply `foldRight` to get our solution. We can start by adding +some type holes. + +```haskell +product :: + List Int + -> Int +product ns = + foldRight _f _n ns +``` + +We can now reload the course code in GHCi and see what it tells us. + +``` +λ> :r +[ 5 of 26] Compiling Course.List ( src/Course/List.hs, interpreted ) + +src/Course/List.hs:95:13: error: + • Found hole: _f :: Int -> Int -> Int + Or perhaps ‘_f’ is mis-spelled, or not in scope + • In the first argument of ‘foldRight’, namely ‘_f’ + In the expression: foldRight _f _n ns + In an equation for ‘product’: product ns = foldRight _f _n ns + • Relevant bindings include + ns :: List Int (bound at src/Course/List.hs:94:9) + product :: List Int -> Int (bound at src/Course/List.hs:94:1) + +src/Course/List.hs:95:16: error: + • Found hole: _n :: Int + Or perhaps ‘_n’ is mis-spelled, or not in scope + • In the second argument of ‘foldRight’, namely ‘_n’ + In the expression: foldRight _f _n ns + In an equation for ‘product’: product ns = foldRight _f _n ns + • Relevant bindings include + ns :: List Int (bound at src/Course/List.hs:94:9) + product :: List Int -> Int (bound at src/Course/List.hs:94:1) +Failed, modules loaded: Course.Core, Course.ExactlyOne, Course.Optional, Course.Validation. +``` + +GHC is telling us a few helpful things here for each of our holes: + +- The type of the hole: `Found hole: _f :: Int -> Int -> Int` +- Where it found the hole: + ``` + In the first argument of ‘foldRight’, namely ‘_f’ + In the expression: foldRight _f _n ns + In an equation for ‘product’: product ns = foldRight _f _n ns + ``` +- Bindings that are relevant to working out the type of the hole: + ``` + Relevant bindings include + ns :: List Int (bound at src/Course/List.hs:94:9) + product :: List Int -> Int (bound at src/Course/List.hs:94:1) + ``` + +Armed with this information we now have two smaller sub-problems to solve: choosing a function of +type `Int -> Int -> Int`, and choosing a value of type `Int`. + +Keep in mind that this example is just for demonstrating the mechanics of type holes. The pay off +from deploying them increases as the difficulty and complexity of your problem increases, as they +allow you to break your problem into pieces while telling you the type of each piece. + +### Use `:type` to ask GHC the type of expressions + +If you've forgotten the type of an expression, or want to check if part of a solution type checks +and has the type that you expect, use `:type` or `:t` in GHCi. + +``` +λ> :t (:.) +(:.) :: t -> List t -> List t +λ> :t (:.) 5 +(:.) 5 :: Num t => List t -> List t +λ> :t Nil +Nil :: List t +λ> :t (:.) 5 Nil +(:.) 5 Nil :: Num t => List t +λ> (:.) 5 Nil +[5] +``` + +### Use `:info` to ask GHC questions + +If you ever want to know what an identifier is, you can ask GHCi using `:info` or just `:i`. For +example, if you see `List` somewhere in your code and want to know more about it, enter `:i List` in +GHCi. As shown below, it will print the constructors for values of that type, as well as the +instances for any type classes that are in scope. + +``` +λ> :i List +data List t = Nil | t :. (List t) + -- Defined at src/Course/List.hs:34:1 +instance [safe] Eq t => Eq (List t) + -- Defined at src/Course/List.hs:37:13 +instance [safe] Ord t => Ord (List t) + -- Defined at src/Course/List.hs:37:17 +instance [safe] Show t => Show (List t) + -- Defined at src/Course/List.hs:42:10 +instance [safe] IsString (List Char) + -- Defined at src/Course/List.hs:662:10 +instance [safe] Functor List + -- Defined at src/Course/Functor.hs:54:10 +instance [safe] Extend List + -- Defined at src/Course/Extend.hs:49:10 +instance [safe] Applicative List + -- Defined at src/Course/Applicative.hs:65:10 +instance [safe] Monad List -- Defined at src/Course/Monad.hs:46:10 +instance [safe] Traversable List + -- Defined at src/Course/Traversable.hs:33:10 +``` + +### Providing functions + +If you're ever stuck providing a function as an argument or return value, insert a lambda with a +type hole. Continue this process recursively until you need to provide a simple value, then follow +the definitions back out. + +Following on from our type holes example, if we're trying to solve `product` with `foldRight` and we +know the first argument to `foldRight` is a function, start by inserting the lambda. + +```haskell +product :: + List Int + -> Int +product ns = + foldRight (\a b -> _c) _n ns +``` + +After reloading this code, GHCi will tell us the type of `_c`, which in this case is `Int`. From the +previous type hole example, we know that both `a` and `b` are type `Int` (`_f :: Int -> Int -> +Int`), so it looks like we should do something with two `Int`s to produce an `Int`. A few operations +come to mind, but given we're defining `product`, let's go with multiplication. + +```haskell +product ns = + foldRight (\a b -> a * b) _n ns +``` + +It type checks. From here we'd need to pick an `Int` to replace `_n` and we'd have a solution that +at least type checks. + +If `_c` had the type of another function, we'd simply insert another lambda in its place and +continue recursing. Alternatively, if `_c` had type `WhoosyWhatsits` and we didn't know anything +about that type or how to construct it, we could just ask GHCi using `:i WhoosyWhatsits` and +continue from there. + +### Handling arguments + +When you're not sure what to do with a function argument, try pattern matching it and looking at the +values that are brought into scope. + +```haskell +data Bar = Bar Chars Int Chars + +foo :: Bar -> Int +foo (Bar _ n _) = n +``` + +If your argument is a sum type that has multiple constructors, use `case` to pattern match and +handle each case individually. + +```haskell +data Baz = + C1 Int + | C2 Chars Int + +quux :: Baz -> Int +quux baz = + case baz of + C1 n -> n + C2 _ n -> n +``` + +You can also nest pattern matches as needed. + +```haskell +data Thingo = + X Int + | Y (Optional Int) + +f :: Thingo -> List Int +f t = + case t of + X n -> n :. Nil + Y (Full n) -> n :. Nil + Y Empty -> Nil +``` + +Finally, when you're not sure how to pattern match the argument because you don't know what its +constructors are, use `:info` as described above to find out. + +``` +λ> :i Baz +data Baz = C1 Int | C2 Chars Int +``` diff --git a/README.markdown b/README.markdown index f83ed8039..bbb5a22ae 100644 --- a/README.markdown +++ b/README.markdown @@ -8,16 +8,16 @@ #### Special note 1 -If you have arrived here by https://github.com/tonymorris/fp-course and you are -looking for the *exercises* (not the answers, please go to -https://github.com/data61/fp-course) +If you have arrived here by https://github.com/data61/fp-course and you are +looking for the *answers* (not the exercises), please go to https://github.com/tonymorris/fp-course #### Special note 2 -Since February 2017, this repository is no longer hosted at -https://github.com/NICTA/course which is deprecated. Data61 replaces what was -NICTA since July 2016. The new repository is located at -https://github.com/data61/fp-course +As of February 2017, this repository is taking the place of the repository hosted at +https://github.com/NICTA/course which is deprecated. + +Data61 replaces what was NICTA since July 2016. The new repository is located at +https://github.com/data61/fp-course. #### Introduction @@ -47,28 +47,35 @@ however, your first post might be moderated. This is simply to prevent spam. 2. [[haskell-exercises]](https://groups.google.com/forum/#!forum/haskell-exercises) is a Google Group for queries related specifically to this Data61 functional programming course material. This mailing list is not owned by Data61, but is - run by others who are keen to share ideas relating to the course. + run by others who are keen to share ideas relating to the course. + +3. \#nicta-course [on Freenode](irc://irc.freenode.net/#nicta-course) is an IRC channel that + is operated by others who are going through this course material on their + own time and effort. + +4. \#qfpl [on Freenode](irc://irc.freenode.net/#qfpl) is the IRC channel of the + Queensland Functional Programming Lab - the team that runs the course in Brisbane. -3. \#scalaz [on Freenode](irc://irc.freenode.net/#scalaz) is an IRC channel that is operated +5. \#scalaz [on Freenode](irc://irc.freenode.net/#scalaz) is an IRC channel that is operated by others who are keen to share ideas relating to functional programming in - general. Most of the participants of this channel have completed the Data61 + general. Most of the participants of this channel have completed the Data61 functional programming course to some extent. They are in various timezones and share a passion for functional programming, so may be able to provide relatively quick assistance with questions. -4. \#nicta-course [on Freenode](irc://irc.freenode.net/#nicta-course) is an IRC channel that - is operated by others who are going through this course material on their - own time and effort. - ### Getting Started -1. Install the Glasgow Haskell Compiler (GHC) version 7.6 or higher. +**NOTE** If you do not wish to install these dependencies, you may use a virtual machine +instead. [Instructions](ops/README.md) for automatically building a virtual machine are +available in this repository for your convenience. + +1. Install the Glasgow Haskell Compiler (GHC) version 7.10 or higher. 2. Change to the directory containing this document. 3. Execute the command `ghci`, which will compile and load all the source code. You may need to set permissions on the root directory and the ghci configuration - file, `chmod 600 .ghci ./`. + file, `chmod go-w .ghci ./`. 4. Inspect the introductory modules to get a feel for Haskell's syntax, then move on to the exercises starting with `Course.Optional`. The @@ -148,31 +155,73 @@ however, your first post might be moderated. This is simply to prevent spam. Your instructor must guide you where types fall short, but you should also take the first step. Do it. -#### Running the tests +5. Do not use tab characters + + Set up your text editor to use space characters rather than tabs. + Using tab characters in Haskell can lead to confusing error messages. + GHC will give you a warning if your program contains a tab character. + +6. Do not use the stack build tool. It does not work. -Some exercises include examples and properties, which appear in a comment above -the code for that exercise. Examples begin with `>>>` while properties begin -with `prop>`. +### Running the tests -The solution to the exercise must satisfy these tests. You can check if you have -satisfied all tests with cabal-install and doctest. From the base directory of -this source code: +Tests are available as a [tasty](https://hackage.haskell.org/package/tasty) +test suite. + +#### tasty + +Tasty tests are stored under the `test/` directory. Each module from the course +that has tests has a corresponding `Test.hs` file. Within each test +module, tests for each function are grouped using the `testGroup` function. +Within each test group there are test cases (`testCase` function), and +properties (`testProperty` function). + +Before running the tests, ensure that you have an up-to-date installation +of GHC and cabal-install from your system package manager or use the minimal +installers found at [haskell.org](https://www.haskell.org/downloads#minimal). + +To run the full test suite, build the project as follows: > cabal update - > cabal install cabal-install - > cabal install --only-dependencies + > cabal install --only-dependencies --enable-tests > cabal configure --enable-tests > cabal build > cabal test -Alternatively, you may run the tests in a single source file by using `doctest` -explicitly. From the base directory of this source code: +Tasty will also allow you to run only those tests whose description match a +pattern. Tests are organised in nested groups named after the relevant module +and function, so pattern matching should be intuitive. For example, to run the +tests for the `List` module you could run: + + > cabal test tasty --show-detail=direct --test-option=--pattern="Tests.List." + +Likewise, to run only the tests for the `headOr` function in the `List` module, you could use: + + > cabal test tasty --show-detail=direct --test-option=--pattern="List.headOr" + +In addition, GHCi may be used to run tasty tests. Assuming you have run `ghci` +from the root of the project, you may do the following. Remember that GHCi has +tab completion, so you can save yourself some typing. + + > -- import the defaultMain function from Tasty - runs something of type TestTree + > import Test.Tasty (defaultMain) + > + > -- Load the test module you'd like to run tests for + > :l test/Course/ListTest.hs + > + > -- Browse the contents of the loaded module - anything of type TestTree + > -- may be run + > :browse Course.ListTest + > + > -- Run test for a particular function + > defaultMain headOrTest + - > doctest -isrc -Wall -fno-warn-type-defaults +#### doctest -Note: There is a [bug in GHC 7.4.1](http://ghc.haskell.org/trac/ghc/ticket/5820) -where for some configurations, running the tests will cause an unjustified -compiler error. +The doctest tests are a mirror of the tasty tests that reside in comments +alongside the code. They are not executable, but examples can be copied into +GHCI. Examples begin with `>>>` while properties begin with `prop>`. ### Progression @@ -214,7 +263,7 @@ others. For example, in the progression, `Course.Functor` to `Course.Monad`, the exercises repeat a similar theme. Instead, a participant may wish to do different exercises, such as `Course.Parser`. In this case, the remaining answers are filled out, so that progress on to `Course.Parser` can begin -(which depends on correct answers up to `Course.Monad`). It is recommended to +(which depends on correct answers up to `Course.Monad`). It is recommended to take this deviation if it is felt that there is more reward in doing so. Answers for the exercises can be found here: @@ -227,11 +276,28 @@ After these are completed, complete the exercises in the `projects` directory. If you choose to use the [Leksah IDE for Haskell](http://leksah.org/), the following tips are recommended: -* Clone the git repo use Package -> Add to add course.cabal. -* Click on the green tick on the toolbar to include `cabal test` - in each build and list the failures in the Errors pane. -* Choose Package -> Configure to make sure `--enable-tests` - is used (just building may cause cabal to configure without). +* [Install Leksah from github](https://github.com/leksah/leksah#getting-leksah). + If you are using Nix to install Leksah launch it with `./leksah-nix.sh ghc822` + as the Nix files for this course use GHC 8.2.2. +* Clone this fp-course git repo use File -> Open Project to open the cabal.project file. +* Mouse over the toolbar items near the middle of toolbar to see the names of them. + Set the following items on/off: + * `Build in the background and report errors` ON - unless you prefer to triger builds + manualy with Ctrl + B to build (Command + B on OS X) + * `Use GHC to compile` ON + * `Use GHCJS to compile` OFF + * `Use GHCi debugger to build and run` ON + * `Make documentation while building` OFF + * `Run unit tests when building` ON + * `Run benchmakrs when building` OFF + * `Make dependent packages` ON +* If you are using Nix, click on the nix button on the toolbar (tool tip is "Refresh + Leksah's cached nix environment variables for the active project"). This will use + `nix-shell` to build an environment for running the builds in. If `nix-shell` has + not been run before for the `fp-course` repo it may take some time to complete. + When it is finished a line of green '-' characters should be printed in the Panes -> Log. +* Restart Leksah as there is a bug in the metadata collection that + will prevent it from indexing the new project without a restart. * Ctrl + B to build (Command + B on OS X). * The test failures should show up in Panes -> Errors. * Pane -> Log often has useful error messages. @@ -240,12 +306,9 @@ following tips are recommended: to go to previous item). * Ctrl + Enter on a line starting "-- >>>" will run the selected expression in GHCi (Ctrl + Enter on OS X too). - The output goes to Panes -> Log and Panes -> Output. + The output goes to Panes -> Log (on Linux it will also show up in Panes -> Output). * The last GHCi expression is reevaluated after each :reload triggered by changes in the code. -* Uncheck Debug -> GHCi when you are done with GHCi and - Leksah will go back to running cabal build and cabal test - instead. ### Introducing Haskell @@ -311,7 +374,102 @@ covered first. * always lower-case 'a'..'z' * aka generics, templates C++, parametric polymorphism * running the tests - * `doctest` + * `cabal test` + +### Parser grammar assistance + +The exercises in `Parser.hs` can be assisted by stating problems in a specific way, with a conversion to code. + +| English | Parser library | +|-----------|-----------------------------------| +| and then | `bindParser` `>>=` | +| always | `valueParser` `pure` | +| or | `\|\|\|` | +| 0 or many | `list` | +| 1 or many | `list1` | +| is | `is` | +| exactly n | `thisMany n` | +| fail | `failed` | +| call it x | `\x ->` | + +### Monad comprehension + +##### do-notation + +* insert the word `do` +* turn `>>=` into `<-` +* delete `->` +* delete `\` +* swap each side of `<-` + +##### LINQ + +* write `from` on each line +* turn `>>=` into in +* delete `->` +* delete `\` +* swap each side of `in` +* turn value into `select` + +### Demonstrate IO maintains referential transparency + +Are these two programs, the same program? + + p1 :: + IO () + p1 = + let file = "/tmp/file" + in do _ <- writeFile file "abcdef" + x <- readFile file + _ <- putStrLn x + _ <- writeFile file "ghijkl" + y <- readFile file + putStrLn (show (x, y)) + + p2 :: + IO () + p2 = + let file = "/tmp/file" + expr = readFile file + in do _ <- writeFile file "abcdef" + x <- expr + _ <- putStrLn x + _ <- writeFile file "ghijkl" + y <- expr + putStrLn (show (x, y)) + +What about these two programs? + + def writeFile(filename, contents): + with open(filename, "w") as f: + f.write(contents) + + def readFile(filename): + contents = "" + with open(filename, "r") as f: + contents = f.read() + return contents + + def p1(): + file = "/tmp/file" + + writeFile(file, "abcdef") + x = readFile(file) + print(x) + writeFile(file, "ghijkl") + y = readFile(file) + print (x + y) + + def p2(): + file = "/tmp/file" + expr = readFile(file) + + writeFile(file, "abcdef") + x = expr + print(x) + writeFile(file, "ghijkl") + y = expr + print (x + y) ### One-day diff --git a/Setup.lhs b/Setup.lhs index 0832aa53c..ce3bdaa46 100644 --- a/Setup.lhs +++ b/Setup.lhs @@ -1,44 +1,4 @@ -#!/usr/bin/env runhaskell \begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - +import Distribution.Simple +main = defaultMain \end{code} diff --git a/Vagrantfile b/Vagrantfile new file mode 100644 index 000000000..36aca224c --- /dev/null +++ b/Vagrantfile @@ -0,0 +1,13 @@ +Vagrant.configure("2") do |config| + config.vm.box = "ubuntu/xenial64" + + config.vm.provider 'virtualbox' do |vbox| + vbox.memory = 4096 + vbox.cpus = 2 + vbox.gui = true + end + + config.vm.provision 'ansible' do |ansible| + ansible.playbook = 'ops/ansible.yaml' + end +end diff --git a/cabal.project b/cabal.project new file mode 100644 index 000000000..cd3c7be20 --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: + ./ diff --git a/ci/ci.nix b/ci/ci.nix new file mode 100644 index 000000000..e02890023 --- /dev/null +++ b/ci/ci.nix @@ -0,0 +1,30 @@ +{ supportedSystems ? ["x86_64-linux"] +, supportedCompilers ? [ "ghc802" "ghc822" "ghc843" ] +}: + +with (import { inherit supportedSystems; }); + +let + pkgs = import {}; + + configurations = + pkgs.lib.listToAttrs ( + pkgs.lib.concatMap (compiler: + pkgs.lib.concatMap (system: + [{name = "fp-course_" + compiler + "_" + system; value = {inherit compiler system;};}] + ) supportedSystems + ) supportedCompilers + ); + + jobs = + pkgs.lib.mapAttrs (name: configuration: + let + compiler = configuration.compiler; + system = configuration.system; + nixpkgs = { pkgs = pkgsFor system; }; + course = import ../default.nix { inherit nixpkgs compiler; }; + in + course + ) configurations; +in + jobs diff --git a/ci/jobsets.json b/ci/jobsets.json new file mode 100644 index 000000000..f849a081a --- /dev/null +++ b/ci/jobsets.json @@ -0,0 +1,16 @@ +{ + "enabled": 1, + "hidden": false, + "description": "jobsets", + "nixexprinput": "fp-course", + "nixexprpath": "ci/jobsets.nix", + "checkinterval": 300, + "schedulingshares": 1, + "enableemail": false, + "emailoverride": "", + "keepnr": 5, + "inputs": { + "fp-course": { "type": "git", "value": "https://github.com/data61/fp-course.git master", "emailresponsible": false }, + "nixpkgs": { "type": "git", "value": "https://github.com/NixOS/nixpkgs.git release-18.09", "emailresponsible": false } + } +} diff --git a/ci/jobsets.nix b/ci/jobsets.nix new file mode 100644 index 000000000..7cd49d122 --- /dev/null +++ b/ci/jobsets.nix @@ -0,0 +1,27 @@ +{ nixpkgs, declInput }: let pkgs = import nixpkgs {}; in { + jobsets = pkgs.runCommand "spec.json" {} '' + cat < $out < -author: Mark Hibberd -author: Ben Sinclair -author: James Earl Douglas -author: Eric Torreborre + Mark Hibberd + Ben Sinclair + James Earl Douglas + Eric Torreborre maintainer: Tony Morris copyright: Copyright (C) 2010-2013 Tony Morris -copyright: Copyright (C) 2012-2015 National ICT Australia Limited -copyright: Copyright (C) 2012 James Earl Douglas -copyright: Copyright (C) 2012 Ben Sinclair + Copyright (C) 2012-2015 National ICT Australia Limited + Copyright (C) 2012 James Earl Douglas + Copyright (C) 2012 Ben Sinclair + Copyright (C) 2016-2017 Data61 synopsis: Source code for a functional programming course category: Education description: Source code for a course in functional programming using Haskell -homepage: https://github.com/NICTA/course -bug-reports: https://github.com/NICTA/course/issues +homepage: https://github.com/data61/fp-course +bug-reports: https://github.com/data61/fp-course/issues cabal-version: >= 1.10 -build-type: Custom +build-type: Simple +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 extra-source-files: etc/CONTRIBUTORS, - etc/CREDITS, changelog source-repository head type: git - location: git@github.com:NICTA/course.git - -flag small_base - description: Choose the new, split-up base package. + location: git@github.com:data61/fp-course.git library default-language: Haskell2010 build-depends: base < 5 && >= 4 - , containers >= 0.4.0.0 + , containers >= 0.4 + , array >= 0.4 ghc-options: -Wall + -fwarn-incomplete-uni-patterns -fno-warn-unused-binds -fno-warn-unused-do-bind -fno-warn-unused-imports @@ -77,23 +77,44 @@ library Course.Traversable Course.Validation -test-suite doctests + +test-suite tasty type: exitcode-stdio-1.0 main-is: - doctests.hs + TastyLoader.hs + other-modules: + Course.ApplicativeTest + Course.ChequeTest + Course.ComonadTest + Course.ExtendTest + Course.FunctorTest + Course.Gens + Course.JsonParserTest + Course.ListTest + Course.ListZipperTest + Course.MonadTest + Course.MoreParserTest + Course.OptionalTest + Course.ParserTest + Course.StateTest + Course.StateTTest + Course.TraversableTest + Course.ValidationTest default-language: Haskell2010 build-depends: base < 5 && >= 3 - , doctest >= 0.9.7 - , filepath >= 1.3 - , directory >= 1.1 - , QuickCheck >= 2.0 - , template-haskell >= 2.8 + , containers >= 0.4 + , course + , HUnit >= 1.5 + , QuickCheck >= 2.9 + , tasty >= 1 + , tasty-hunit >= 0.9 + , tasty-quickcheck >= 0.8 ghc-options: -Wall diff --git a/course.lkshf b/course.lkshf new file mode 100644 index 000000000..1a9d43629 --- /dev/null +++ b/course.lkshf @@ -0,0 +1,17 @@ +{ + "configFlags": [ + "--enable-tests" + ], + "benchmarkFlags": [], + "sdistFlags": [], + "registerFlags": [], + "installFlags": [], + "exeFlags": [], + "unregisterFlags": [], + "haddockFlags": [], + "testFlags": [ + "--doctest-options=-package=QuickCheck", + "--doctest-options=-package=template-haskell" + ], + "buildFlags": [] +} \ No newline at end of file diff --git a/default.nix b/default.nix new file mode 100644 index 000000000..4d2924571 --- /dev/null +++ b/default.nix @@ -0,0 +1,36 @@ +{ nixpkgs ? import {}, compiler ? "default" }: + +let + inherit (nixpkgs) pkgs; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + sources = { + tasty = pkgs.fetchFromGitHub { + owner = "feuerbach"; + repo = "tasty"; + rev = "core-1.1.0.1"; + sha256 = "03fcc75l5mrn5dwh6xix5ggn0qkp8kj7gzamb6n2m42ir6j7x60l"; + }; + }; + + modifiedHaskellPackages = haskellPackages.override { + overrides = self: super: { + tasty = super.callCabal2nix "tasty" "${sources.tasty}/core" {}; + tasty-hunit = super.callCabal2nix "tasty" "${sources.tasty}/hunit" {}; + tasty-quickcheck = super.callCabal2nix "tasty" "${sources.tasty}/quickcheck" {}; + }; + }; + + fp-course = modifiedHaskellPackages.callPackage ./fp-course.nix {}; + modified-fp-course = pkgs.haskell.lib.overrideCabal fp-course (drv: { + # Dodgy fun times, make sure that + # - the tests compile + # - the tests failing doesn't cause the build to fail + checkPhase = "true"; + }); +in + modified-fp-course + diff --git a/fp-course.nix b/fp-course.nix new file mode 100644 index 000000000..076383c8e --- /dev/null +++ b/fp-course.nix @@ -0,0 +1,15 @@ +{ mkDerivation, array, base, containers, HUnit, QuickCheck, stdenv +, tasty, tasty-hunit, tasty-quickcheck, doctest +}: +mkDerivation { + pname = "course"; + version = "0.1.4"; + src = ./.; + libraryHaskellDepends = [ array base containers ]; + testHaskellDepends = [ + base HUnit QuickCheck tasty tasty-hunit tasty-quickcheck doctest + ]; + homepage = "https://github.com/data61/fp-course"; + description = "Source code for a functional programming course"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/ops/README.md b/ops/README.md new file mode 100644 index 000000000..33b72b544 --- /dev/null +++ b/ops/README.md @@ -0,0 +1,38 @@ +# Vagrant Box + +If you'd rather use a pre-configured haskell development environment, then these instructions will +get you up and running in a VirtualBox virtual machine. The machine includes: + + - A Xubuntu desktop environment + - GHC 8.0.2 installed + - doctest + - emacs with haskell-mode + - vim + - sublime + - VS Code + +**NOTE**: The VM's default user is `ubuntu` and their password is `ubuntu` + +**WARNING**: Building the environment might take a while and download gigabytes of pacakges over the internet. + +## Prerequisites + + - Install [VirtualBox](https://www.virtualbox.org/) + - Install [Vagrant](https://www.vagrantup.com/) + - Install [ansible](https://www.ansible.com/) + +## Make it so + +The following will download a VM image of Ubuntu and then provision it to build a desktop +environment for Haskell development. Once it's provisioned, reload the machine, which will log you +straight into a graphical environment. + +``` +cd fp-course +vagrant up +# go have lunch - this could take a while +vagrant reload +``` + +You should now see a virtual machine running Xubuntu. The course materials are checked out to +`~/fp-course` and you should have all required binaries on your PATH. diff --git a/ops/ansible.yaml b/ops/ansible.yaml new file mode 100644 index 000000000..d27021ee6 --- /dev/null +++ b/ops/ansible.yaml @@ -0,0 +1,54 @@ +--- +- name: "Install ansible deps (Python 2.7 stuff)" + hosts: all + user: ubuntu + gather_facts: false + tasks: + - name: "Install ansible requirements" + raw: apt-get update && apt-get install -y python2.7 python-simplejson + become: yes + +- name: "Setup Ubuntu 16.04" + hosts: all + user: ubuntu + + tasks: + - name: "Set ubuntu user's password to 'ubuntu'" + user: + name: ubuntu + password: $6$hVCglTDqXKLR45$b4M1N30zbQmieXbHpqm3z1yYCZKNq1jF554WU7AwiBI/z8DkbV1zyE.aYeZvOkCgxsWIJv63IBEwB9riNmdyY/ + become: yes + + - name: "Install packages" + apt: + name: "{{ item }}" + update_cache: yes + state: present + become: yes + with_items: + - emacs + - git + - vim + - xubuntu-desktop + - virtualbox-guest-x11 + + - name: "Automatically login as ubuntu user" + lineinfile: + line: autologin-user=ubuntu + dest: /usr/share/lightdm/lightdm.conf.d/60-xubuntu.conf + become: yes + + - name: "Checkout course repo" + git: + repo: https://github.com/data61/fp-course + dest: ~/fp-course + + - include: haskell.yaml + - include: vs-code.yaml + - include: sublime.yaml + + - name: "Copy emacs.d" + copy: + src: emacs.d/ + dest: ~/.emacs.d/ + mode: 0755 diff --git a/ops/emacs.d/init.el b/ops/emacs.d/init.el new file mode 100644 index 000000000..78bc09b71 --- /dev/null +++ b/ops/emacs.d/init.el @@ -0,0 +1,34 @@ +;; Pull in Marmalade packages +(require 'package) +(add-to-list 'package-archives + '("marmalade" . "http://marmalade-repo.org/packages/")) +(add-to-list 'package-archives + '("melpa" . "http://melpa.milkbox.net/packages/")) +(package-initialize) + +;; Ensure our preferred packages are all loaded in this install - taken from +;; http://batsov.com/articles/2012/02/19/package-management-in-emacs-the-good-the-bad-and-the-ugly/ +(defvar my-packages + '(markdown-mode + auto-complete + haskell-mode) + "A list of packages to ensure are installed at launch.") + +(require 'cl) +(defun my-packages-installed-p () + (loop for p in my-packages + when (not (package-installed-p p)) do (return nil) + finally (return t))) + +(unless (my-packages-installed-p) + ;; check for new packages (package versions) + (message "%s" "Emacs is now refreshing its package database...") + (package-refresh-contents) + (message "%s" " done.") + ;; install the missing packages + (dolist (p my-packages) + (when (not (package-installed-p p)) + (package-install p)))) + +;; Show column numbers in mode line +(column-number-mode t) diff --git a/ops/haskell.yaml b/ops/haskell.yaml new file mode 100644 index 000000000..be80f8cc6 --- /dev/null +++ b/ops/haskell.yaml @@ -0,0 +1,36 @@ +--- + +- name: Add ghc PPA + apt_repository: + repo: ppa:hvr/ghc + become: yes + +- name: Install ghc-8.0.2 + apt: + name: "{{ item }}" + update_cache: yes + state: present + with_items: + - ghc-8.0.2 + - cabal-install-1.24 + become: yes + +- name: Add cabal bin directory to PATH + lineinfile: + line: export PATH="{{ ansible_env.HOME }}/.cabal/bin:$PATH" + dest: ~/.profile + +- name: Add /opt/ghc/bin to the path + lineinfile: + line: export PATH=/opt/ghc/bin:$PATH + dest: ~/.profile + +- name: Update cabal + command: cabal update + environment: + PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" + +- name: Insall cabal packages + command: cabal install doctest + environment: + PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" diff --git a/ops/sublime.yaml b/ops/sublime.yaml new file mode 100644 index 000000000..92fd3b8cd --- /dev/null +++ b/ops/sublime.yaml @@ -0,0 +1,27 @@ +--- +- name: "Check if Sublime installed" + command: which subl + ignore_errors: true + register: haz_sublime + +- name: "Add apt key for sublime" + apt_key: + url: https://download.sublimetext.com/sublimehq-pub.gpg + state: present + become: yes + when: haz_sublime|failed + +- name: "Add source for sublime" + apt_repository: + repo: deb https://download.sublimetext.com/ apt/stable/ + state: present + become: yes + when: haz_sublime|failed + +- name: "Install sublime" + apt: + name: sublime-text + update_cache: yes + state: present + become: yes + when: haz_sublime|failed diff --git a/ops/vs-code.yaml b/ops/vs-code.yaml new file mode 100644 index 000000000..9d6d64780 --- /dev/null +++ b/ops/vs-code.yaml @@ -0,0 +1,27 @@ +--- +- name: "Check if VS Code is installed" + command: which code + ignore_errors: true + register: haz_code + +- name: "Download VS code" + get_url: + url: https://go.microsoft.com/fwlink/?LinkID=760868 + dest: /tmp/vs-code.deb + when: haz_code|failed + +# So the recommended install method is to install a thing with broken/missing +# dependencies, and then fix it. +- name: "Install VS Code deb" + command: dpkg -i /tmp/vs-code.deb + become: yes + ignore_errors: true + when: haz_code|failed + +- name: "Fix VS code installation" + command: apt-get install -fy + become: yes + when: haz_code|failed + +- name: "Install haskell syntax highlighting for VS Code" + command: code --install-extension justusadam.language-haskell diff --git a/projects/NetworkServer/haskell/network-server.cabal b/projects/NetworkServer/haskell/network-server.cabal index a64a8a2d3..96f543c62 100644 --- a/projects/NetworkServer/haskell/network-server.cabal +++ b/projects/NetworkServer/haskell/network-server.cabal @@ -8,17 +8,19 @@ copyright: Copyright (C) 2013 National ICT Australia Limited 2013 synopsis: A network server category: Education description: A network server -homepage: https://github.com/NICTA/course -bug-reports: https://github.com/NICTA/course/issues +homepage: https://github.com/data61/fp-course +bug-reports: https://github.com/data61/fp-course/issues cabal-version: >= 1.10 build-type: Custom +custom-setup + setup-depends: Cabal >= 1.24 && < 2 + , base >= 4.8 && < 5 + , filepath >= 1.4 && < 1.5 + source-repository head type: git - location: git@github.com:NICTA/course.git - -flag small_base - description: Choose the new, split-up base package. + location: git@github.com:data61/fp-course.git executable network-tictactoe default-language: Haskell2010 diff --git a/projects/NetworkServer/haskell/src/Data/TicTacToe.hs b/projects/NetworkServer/haskell/src/Data/TicTacToe.hs index 8f79be700..e4b442086 100644 --- a/projects/NetworkServer/haskell/src/Data/TicTacToe.hs +++ b/projects/NetworkServer/haskell/src/Data/TicTacToe.hs @@ -41,7 +41,7 @@ instance Show FinishedBoard where data Position = N | E | S | W | NE | NW | SE | SW | C - deriving (Enum, Bounded, Ord, Eq, Show) + deriving (Ord, Eq, Show) data Outcome = InvalidMove @@ -144,7 +144,7 @@ move board@(Board m h) p = ] allEqual (a:b:t) = a == b && allEqual (b:t) allEqual _ = True - isDraw = all (`M.member` m') [minBound..] + isDraw = M.size m' >= 9 isWin = any (\(a, b, c) -> any allEqual $ mapM (`M.lookup` m') [a, b, c]) wins player = whoseTurn board b' = Board m' ((p, player):h) @@ -193,7 +193,7 @@ instance Arbitrary Blah where player <- arbitrary position <- arbitrary n <- choose (1, 9) - return $ Blah player position n + return $ Blah player position n prop_eqp :: Position -> Bool prop_eqp n = n == n diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/Accept.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/Accept.hs deleted file mode 100644 index 8b4544acb..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/Accept.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Network.TicTacToe.Accept where - -import Network.TicTacToe.Lens -import Network.TicTacToe.HandleLens(HandleLens(..)) -import Network.TicTacToe.Ref(Ref(..)) -import Network(HostName, Socket, PortNumber, accept) - -data Accept = - Accept - Ref - HostName - PortNumber - deriving (Eq, Ord, Show) - -refL :: - Lens Accept Ref -refL = - Lens - (\(Accept _ nam num) hd -> Accept hd nam num) - (\(Accept hd _ _) -> hd) - -hostNameL :: - Lens Accept HostName -hostNameL = - Lens - (\(Accept hd _ num) nam -> Accept hd nam num) - (\(Accept _ nam _) -> nam) - -portNumberL :: - Lens Accept PortNumber -portNumberL = - Lens - (\(Accept hd nam _) num -> Accept hd nam num) - (\(Accept _ _ num) -> num) - -instance HandleLens Accept where - handleL = - refL .@ handleL - -accept' :: - Socket - -> IO Accept -accept' = - fmap (\(hd, nam, num) -> Accept (Ref hd) nam num) . accept diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/Command.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/Command.hs deleted file mode 100644 index 70dd05bb3..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/Command.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Network.TicTacToe.Command where - -import Prelude hiding (elem) -import Data.TicTacToe -import Data.Char(toUpper, isSpace, toLower) -import Data.Function(on) -import Data.Maybe(fromMaybe) -import Data.Foldable(msum, find, elem) -import Control.Applicative((<$), (<$>)) - -data Command = - Move Position - | Current - | Finished - | Chat String - | Turn - | At Position - | Unknown String - deriving (Eq, Show) - --- | --- --- >>> command "MOVE ne" --- Move NE --- --- >>> command "MOVE 2" --- Move N --- --- >>> command "GAME" --- Current --- --- >>> command "FiniSHED" --- Finished --- --- >>> command "CHAT hi" --- Chat "hi" --- --- >>> command "Turn" --- Turn --- --- >>> command "At 4" --- At W --- --- >>> command "At C" --- At C --- --- >>> command "At X" --- Unknown "At X" --- --- >>> command "Move i" --- Unknown "Move i" -command :: - String - -> Command -command z = - let p l = reverse . dropWhile isSpace . reverse . dropWhile isSpace <$> prefixThen ((==) `on` toLower) l z - in Unknown z `fromMaybe` msum [ - do m <- p "MOVE " - q <- sPosition m - return (Move q) - , Current <$ p "GAME" - , Finished <$ p "FINISHED" - , Chat <$> p "CHAT" - , Turn <$ p "TURN" - , do a <- p "AT" - q <- sPosition a - return (At q) - ] - --- | --- --- >>> sPosition "1" --- Just NW --- --- > sPosition "E" --- Just E --- --- > sPosition "sw" --- Just SW --- --- > sPosition "x" --- Nothing -sPosition :: - String - -> Maybe Position -sPosition s = - let table = [ - ( - ["1", "NW"] - , NW - ) - , ( - ["2", "N"] - , N - ) - , ( - ["3", "NE"] - , NE - ) - , ( - ["4", "W"] - , W - ) - , ( - ["5", "C"] - , C - ) - , ( - ["6", "E"] - , E - ) - , ( - ["7", "SW"] - , SW - ) - , ( - ["8", "S"] - , S - ) - , ( - ["9", "SE"] - , SE - ) - ] - toUppers = map toUpper - in fmap snd . find (\(t, _) -> elem (toUppers s) (toUppers <$> t)) $ table - --- | --- --- >>> prefixThen (==) "ABC" "AB" --- Nothing --- --- >>> prefixThen (==) "ABC" "ABC" --- Just "" --- --- >>> prefixThen (==) "ABC" "ABCDEF" --- Just "DEF" -prefixThen :: - (a -> a -> Bool) - -> [a] - -> [a] - -> Maybe [a] -prefixThen _ [] r = - Just r -prefixThen _ _ [] = - Nothing -prefixThen e (a:b) (c:d) = - if e a c - then - prefixThen e b d - else - Nothing diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/Env.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/Env.hs deleted file mode 100644 index 82903b1cc..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/Env.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Network.TicTacToe.Env where - -import Data.TicTacToe -import Network.TicTacToe.Lens -import Network.TicTacToe.HandleLens(HandleLens(..)) -import Network.TicTacToe.Accept(Accept) -import Network.TicTacToe.Ref(Ref) -import Data.IORef(IORef) -import Data.Set(Set) - -type FinishedGames = - [FinishedBoard] - -data Env = - Env - Accept - Unfinished - (IORef Unfinished) - (IORef (Set Ref)) - FinishedGames - deriving Eq - -acceptL :: - Lens Env Accept -acceptL = - Lens - (\(Env _ e b s f) a -> Env a e b s f) - (\(Env a _ _ _ _) -> a) - -boardL :: - Lens Env Unfinished -boardL = - Lens - (\(Env a _ b s f) e -> Env a e b s f) - (\(Env _ e _ _ _) -> e) - -boardrefL :: - Lens Env (IORef Unfinished) -boardrefL = - Lens - (\(Env a e _ s f) b -> Env a e b s f) - (\(Env _ _ b _ _) -> b) - -clientsL :: - Lens Env (IORef (Set Ref)) -clientsL = - Lens - (\(Env a e b _ f) s -> Env a e b s f) - (\(Env _ _ _ s _) -> s) - -finishedGamesL :: - Lens Env FinishedGames -finishedGamesL = - Lens - (\(Env a e b s _) f -> Env a e b s f) - (\(Env _ _ _ _ f) -> f) - -instance HandleLens Env where - handleL = - acceptL .@ handleL diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/Game.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/Game.hs deleted file mode 100644 index a2e9c91e0..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/Game.hs +++ /dev/null @@ -1,296 +0,0 @@ -module Network.TicTacToe.Game where - -import Prelude hiding (elem, mapM_, concat, catch) - -import Network.TicTacToe.Lens -import Data.TicTacToe -import qualified Data.TicTacToe as T - -import Network(PortID(..), sClose, withSocketsDo, listenOn) -import System.IO(BufferMode(..), hSetBuffering, hClose, hPutStrLn, hGetLine) -import Data.Maybe(fromMaybe) -import Data.IORef(IORef, readIORef, newIORef, atomicModifyIORef) -import Control.Concurrent(forkIO) -import Control.Monad(forever, liftM) -import Control.Monad.Trans(MonadTrans(..), MonadIO(..)) -import Control.Applicative(Applicative(..)) -import Control.Exception(IOException, Exception, finally, catch, try) -import Data.Foldable(Foldable, mapM_, concat) -import Data.Set(Set) -import qualified Data.Set as S - -import Network.TicTacToe.HandleLens(HandleLens(..), lGetLine, lPutStrLn, lSetBuffering) -import Network.TicTacToe.Accept(accept', refL) -import Network.TicTacToe.Command -import Network.TicTacToe.Ref(Ref) -import Network.TicTacToe.Env(FinishedGames, Env(..), boardrefL, boardL, finishedGamesL, clientsL, acceptL) - -newtype Game f a = - Game (Env -> f (a, Unfinished, FinishedGames)) - -fGame :: - Functor f => - (Env -> f (a, Unfinished)) - -> Game f a -fGame f = - Game (\env -> fmap (\(a, b) -> (a, b, finishedGamesL `getL` env)) . f $ env) - -fGame' :: - Monad f => - (Env -> f (a, Unfinished)) - -> Game f a -fGame' f = - Game (\env -> liftM (\(a, b) -> (a, b, finishedGamesL `getL` env)) . f $ env) - -rGame :: - Functor f => - (Env -> f a) - -> Game f a -rGame f = - fGame (\env -> fmap (\a -> (a, boardL `getL` env)) (f env)) - -rGame' :: - Monad f => - (Env -> f a) - -> Game f a -rGame' f = - fGame' (\env -> liftM (\a -> (a, boardL `getL` env)) . f $ env) - -idGame :: - Applicative f => - Game f Env -idGame = - rGame pure - -instance Functor f => Functor (Game f) where - fmap f (Game k) = - Game (fmap (\(a, b, g) -> (f a, b, g)) . k) - -instance Monad f => Monad (Game f) where - return = - rGame' . return . return - Game k >>= f = - Game (\env -> k env >>= \(a, b, g) -> let Game l = f a - in l (setL finishedGamesL (setL boardL env b) g)) - -instance MonadTrans Game where - lift = - rGame' . const - -instance MonadIO f => MonadIO (Game f) where - liftIO = - lift . liftIO - -xprint :: - IOException - -> Game IO () -xprint = - liftIO . print - -atomicModifyIORef_ :: - IORef a - -> (a -> a) - -> IO () -atomicModifyIORef_ r f = - atomicModifyIORef r (\a -> (f a, ())) - -data AtomicMove = - IsOccupied - | OutOfDate - | MoveMade Board - | GameOver FinishedBoard - deriving (Eq, Show) - - --- Control.Monad.CatchIO -ecatch :: - Exception e => - Game IO a - -> (e -> Game IO a) - -> Game IO a -ecatch (Game k) f = - Game $ \env -> k env `catch` (\e -> let Game l = f e in l env) - -etry :: - Exception e => - (Env -> IO a) - -> Game IO (Either e a) -etry k = - rGame $ try . k - -allClients :: - Game IO (Set Ref) -allClients = - rGame $ \env -> (readIORef (clientsL `getL` env)) - -allClientsButThis :: - Game IO (Set Ref) -allClientsButThis = - rGame $ \env -> - fmap (S.delete ((acceptL .@ refL) `getL` env)) (readIORef (clientsL `getL` env)) - -modifyClients :: - (Set Ref -> Set Ref) - -> Game IO () -modifyClients f = - rGame $ \env -> - atomicModifyIORef_ (clientsL `getL` env) f - -modifyFinishedGames :: - Applicative f => - (FinishedGames -> FinishedGames) - -> Game f () -modifyFinishedGames f = - Game $ \env -> pure ((), boardL `getL` env, f (finishedGamesL `getL` env)) - -finishedGames :: - Applicative f => - Game f FinishedGames -finishedGames = - rGame $ \env -> pure (finishedGamesL `getL` env) - -(!) :: - Foldable t => - Game IO (t Ref) - -> String - -> Game IO () -clients ! msg = - clients >>= purgeClients (\y -> liftIO (lPutStrLn y msg)) - -infixl 2 ! - -purgeClients :: - Foldable t => - (Ref -> Game IO ()) - -> t Ref - -> Game IO () -purgeClients a = - mapM_ (\y -> - ecatch (a y) - (\x -> do _ <- modifyClients (S.delete y) - xprint x) - ) - -currentBoard :: - Game IO Unfinished -currentBoard = - rGame $ \env -> - readIORef (boardrefL `getL` env) - -withCurrentBoard :: - (Unfinished -> (Unfinished, a)) - -> Game IO a -withCurrentBoard f = - rGame $ \env -> - atomicModifyIORef (boardrefL `getL` env) f - -lastBoard :: - Applicative f => - Game f Unfinished -lastBoard = - rGame $ \env -> - pure (boardL `getL` env) - -putBoard :: - Applicative f => - Unfinished - -> Game f () -putBoard = - fGame . pure . pure . (,) () - -eGetLine :: - Game IO String -eGetLine = - rGame (hGetLine . getL handleL) - -ePutStrLn :: - String - -> Game IO () -ePutStrLn s = - rGame (\env -> (hPutStrLn (handleL `getL` env) s)) - -eClose :: - Game IO () -eClose = - rGame (hClose . getL handleL) - -eSetBuffering :: - BufferMode - -> Game IO () -eSetBuffering s = - rGame (\env -> (hSetBuffering (handleL `getL` env) s)) - -processCommand :: - Command - -> Game IO () -processCommand (Move p) = - do l <- lastBoard - r <- withCurrentBoard $ \b -> - if isOccupied b p - then - (b, IsOccupied) - else - if b == l - then - let r = p --> b - in case r of UnemptyBoard b' -> (UnfinishedBoard b', MoveMade b') - UnemptyFinished f -> (UnfinishedEmpty T.empty, GameOver f) - else - (b, OutOfDate) - case r of IsOccupied -> - ePutStrLn (concat ["MOVE ", show p, " is occupied"]) - OutOfDate -> - ePutStrLn "MOVE board is out of date" - MoveMade b -> - do putBoard (UnfinishedBoard b) - ePutStrLn (showBoard b) - GameOver b -> - do modifyFinishedGames (b:) - putBoard (UnfinishedEmpty T.empty) - allClients ! "MOVE GAME OVER " ++ show (getResult b) -processCommand Current = - do b <- currentBoard - putBoard b - ePutStrLn (showBoard b) -processCommand Finished = - do g <- finishedGames - mapM_ (ePutStrLn . showBoard) g -processCommand (Chat m) = - allClientsButThis ! "CHAT " ++ m -processCommand Turn = - do b <- currentBoard - putBoard b - ePutStrLn [toSymbol (whoseTurn b)] -processCommand (At p) = - do b <- currentBoard - putBoard b - ePutStrLn [fromMaybe '?' . fmap toSymbol . playerAt b $ p] -processCommand (Unknown s) = - ePutStrLn ("UNKNOWN " ++ s) - -server :: - Game IO () - -> IO () -server (Game g) = - let hand s b c = forever $ - do q <- accept' s - lSetBuffering q NoBuffering - _ <- atomicModifyIORef_ c (S.insert (refL `getL` q)) - e <- readIORef b - forkIO (fmap (\(a, _, _) -> a) $ g (Env q e b c [])) - in withSocketsDo $ do - s <- listenOn (PortNumber 6060) - b <- newIORef (UnfinishedEmpty T.empty) - c <- newIORef S.empty - hand s b c `finally` sClose s - -game :: - Game IO () -game = - let loop = do k <- etry lGetLine - case k of Left e -> xprint e - Right [] -> loop - Right l -> processCommand (command l) >> loop - in do b <- lastBoard - ePutStrLn (showBoard b) - loop diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/HandleLens.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/HandleLens.hs deleted file mode 100644 index 6167cbe51..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/HandleLens.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Network.TicTacToe.HandleLens where - -import Network.TicTacToe.Lens(Lens, identityL, getL) -import System.IO(Handle, BufferMode, hGetLine, hPutStrLn, hClose, hSetBuffering) - -class HandleLens a where - handleL :: - Lens a Handle - -instance HandleLens Handle where - handleL = - identityL - -lGetLine :: - HandleLens h => - h - -> IO String -lGetLine h = - hGetLine (handleL `getL` h) - -lPutStrLn :: - HandleLens h => - h - -> String - -> IO () -lPutStrLn h = - hPutStrLn (handleL `getL` h) - -lClose :: - HandleLens h => - h - -> IO () -lClose h = - hClose (handleL `getL` h) - -lSetBuffering :: - HandleLens h => - h - -> BufferMode - -> IO () -lSetBuffering h = - hSetBuffering (handleL `getL` h) diff --git a/projects/NetworkServer/haskell/src/Network/TicTacToe/Lens.hs b/projects/NetworkServer/haskell/src/Network/TicTacToe/Lens.hs deleted file mode 100644 index ea874d95b..000000000 --- a/projects/NetworkServer/haskell/src/Network/TicTacToe/Lens.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Network.TicTacToe.Lens where - --- | A lens is a pair of set and get. --- --- The type parameter 'a' denotes the target object. --- The type parameter 'b' denotes the field object. -data Lens a b = - Lens (a -> b -> a) (a -> b) - --- | Given a lens and a target object, return its field object. -getL :: - Lens a b - -> a - -> b -getL (Lens _ g) = - g - --- | Given a lens, a target object and a field object, return a new target object with the field set. -setL :: - Lens a b - -> a - -> b - -> a -setL (Lens s _) = - s - --- | Produce the lens for the first element of a pair. --- --- >>> getL fstL ("hi", 3) --- "hi" --- --- >>> setL fstL ("hi", 3) "bye" --- ("bye",3) -fstL :: - Lens (a, b) a -fstL = - Lens (\(_, b) a -> (a, b)) fst - --- | Produce the lens for the second element of a pair. --- --- >>> getL sndL ("hi", 3) --- 3 --- --- >>> setL sndL ("hi", 3) 4 --- ("hi",4) -sndL :: - Lens (a, b) b -sndL = - Lens (\(a, _) b -> (a, b)) snd - --- | Lens composition. --- Given lens (a to b) and lens (b to c), produce lens (a to c). --- --- >>> getL (fstL .@ sndL) (("hi", 3), [7,8,9]) --- 3 --- --- >>> setL (fstL .@ sndL) (("hi", 3), [7,8,9]) 4 --- (("hi",4),[7,8,9]) -(.@) :: - Lens a b - -> Lens b c - -> Lens a c -Lens s1 g1 .@ Lens s2 g2 = - Lens (\a -> s1 a . s2 (g1 a)) (g2 . g1) - --- | Lens identity. --- Produce lens that /does nothing/. --- --- prop> getL identityL (x :: Int) == x --- --- prop> setL identityL x (y :: Int) == y -identityL :: - Lens a a -identityL = - Lens (const id) id - --- | Lens modification. --- Given a lens and a modification function on the field object --- and a target object, return a target with the function applied at that field. --- --- >>> modify fstL (+10) (4, "hi") --- (14,"hi") -modify :: - Lens a b - -> (b -> b) - -> a - -> a -modify (Lens s g) f a = - s a (f (g a)) - -iso :: - (a -> b) - -> (b -> a) - -> Lens a b -iso f g = - Lens (const g) f diff --git a/projects/TicTacToe-net/haskell/tictactoe-net.cabal b/projects/TicTacToe-net/haskell/tictactoe-net.cabal deleted file mode 100644 index 26383ebb0..000000000 --- a/projects/TicTacToe-net/haskell/tictactoe-net.cabal +++ /dev/null @@ -1,88 +0,0 @@ -name: tictactoe-net -version: 0.0.1 -license: BSD3 -license-File: etc/LICENCE -author: Tony Morris -maintainer: Tony Morris -copyright: Copyright (C) 2010-2013 Tony Morris -copyright: Copyright (C) 2012,2013 National ICT Australia Limited 2012, 2013 -copyright: Copyright (C) 2012 James Earl Douglas -copyright: Copyright (C) 2012 Ben Sinclair -synopsis: A network server to play the game of Tic-Tac-Toe -category: Education -description: A network server to play the game of Tic-Tac-Toe using IORef -homepage: https://github.com/NICTA/course -bug-reports: https://github.com/NICTA/course/issues -cabal-version: >= 1.10 -build-type: Custom - -source-repository head - type: git - location: git@github.com:NICTA/course.git - -flag small_base - description: Choose the new, split-up base package. - -executable tictactoe-net - default-language: Haskell2010 - - main-is: Network/TicTacToe/Main.hs - - hs-source-dirs: src - - build-depends: base < 5 && >= 4 - , tictactoe - , mtl - , containers - , network - - ghc-options: -Wall - - other-modules: Network.TicTacToe - -library - default-language: Haskell2010 - - build-depends: base < 5 && >= 4 - , tictactoe - , mtl - , containers - , network - - ghc-options: -Wall - - hs-source-dirs: src - - exposed-modules: - Network.TicTacToe - , Network.TicTacToe.Accept - , Network.TicTacToe.Command - , Network.TicTacToe.Env - , Network.TicTacToe.Game - , Network.TicTacToe.HandleLens - , Network.TicTacToe.Lens - , Network.TicTacToe.Ref - -test-suite doctests - type: - exitcode-stdio-1.0 - - main-is: - doctests.hs - - default-language: - Haskell2010 - - build-depends: - base < 5 && >= 3, - doctest >= 0.9.7, - filepath >= 1.3, - directory >= 1.1, - QuickCheck >= 2.0 - - ghc-options: - -Wall - -threaded - - hs-source-dirs: - test diff --git a/projects/TicTacToe/agda/TicTacToe.agda b/projects/TicTacToe/agda/TicTacToe.agda deleted file mode 100644 index 466710ab3..000000000 --- a/projects/TicTacToe/agda/TicTacToe.agda +++ /dev/null @@ -1,96 +0,0 @@ -{- sent by user napping via IRC 20110629 licence unknown -} - -module tictactoe where -open import Data.Bool hiding (_≟_) -open import Data.Vec -open import Data.Fin -open import Data.Nat -open import Data.Maybe -open import Category.Monad -open import Relation.Nullary.Core -open import Data.Product hiding (map) - -data Cell : Set where - X O b : Cell -cell-eqb : Cell → Cell → Bool -cell-eqb X X = true -cell-eqb O O = true -cell-eqb b b = true -cell-eqb _ _ = false - -Board = Vec Cell 9 - -startBoard : Board -startBoard = tabulate (λ _ → b) - -triple-winner : Cell → Cell → Cell → Maybe Cell -triple-winner X X X = just X -triple-winner O O O = just O -triple-winner _ _ _ = nothing - -winner : Board → Maybe Cell -winner (ul ∷ uc ∷ ur ∷ ml ∷ mc ∷ mr ∷ bl ∷ bc ∷ br ∷ nil) = - triple-winner ul uc ur ∣ triple-winner ml mc mr ∣ triple-winner bl bc br - ∣ triple-winner ul ml bl ∣ triple-winner uc mc bc ∣ triple-winner ur mr br - ∣ triple-winner ul mc br ∣ triple-winner ur mc bl - where open RawMonadPlus monadPlus - -next-player : Board → Cell -next-player board with sum (map Xs board) | sum (map Os board) - where Xs : Cell → ℕ - Xs X = 1 - Xs _ = 0 - Os : Cell → ℕ - Os O = 1 - Os _ = 0 -next-player board | xs | os with xs ≟ os | xs ≟ suc os -next-player board | xs | os | yes _ | _ = X -next-player board | xs | os | _ | yes _ = O -next-player board | xs | os | _ | _ = b - -validMove : Fin 9 → Cell → Board → Bool -validMove p v board = cell-eqb b (lookup p board) - ∧ maybe′ (λ _ → false) true (winner board) - ∧ cell-eqb v (next-player board) - -data Game : Board → Set where - startGame : Game startBoard - move : (pos : Fin 9) → (val : Cell) → - ∀ {board} → {ev : T (validMove pos val board)} → Game board - → Game (board [ pos ]≔ val) - -started : Board → Bool -started = foldr _ blank false - where blank : Cell → Bool → Bool - blank b f = f - blank _ _ = true - - -prevBoard : ∀ {board} → {ev : T (started board)} → (g : Game board) → Board -prevBoard {ev = ()} startGame -prevBoard (move pos val {board} y) = board - -takeBack : ∀ {board} → {ev : T (started board)} → (g : Game board) → - Game (prevBoard {ev = ev} g) -takeBack {ev = ()} startGame -takeBack (move pos val {board} y) = y - -getBoard : ∀ {board} → Game board → Board -getBoard {board} _ = board - --- example - -state0 = startGame --- state0' = takeBack state0 -- not started -state1 = move (# 4) X state0 -state2 = move (# 1) O state1 --- state2' = move (# 0) X state1 -- out of turn -state3 = takeBack state2 -state4 = move (# 0) O state3 -state5 = move (# 2) X state4 --- state5' = move (# 0) X state4 -- already occupied -state6 = move (# 6) O state5 -state7 = move (# 5) X state6 -state8 = move (# 3) O state7 --- state9 = move (# 8) X state8 -- already finished - diff --git a/projects/TicTacToe/haskell/.ghci b/projects/TicTacToe/haskell/.ghci deleted file mode 100755 index 402c4db6c..000000000 --- a/projects/TicTacToe/haskell/.ghci +++ /dev/null @@ -1,6 +0,0 @@ -:set -isrc -idist/build/autogen -:set -optP-include -optPdist/build/autogen/cabal_macros.h -:load src/TicTacToe/Console.hs -:set prompt ">> " -:set -Wall - diff --git a/projects/TicTacToe/haskell/.gitignore b/projects/TicTacToe/haskell/.gitignore deleted file mode 100644 index 16942ccdd..000000000 --- a/projects/TicTacToe/haskell/.gitignore +++ /dev/null @@ -1,22 +0,0 @@ -*~ -*#* - -# CABAL -/dist -/.cabal-sandbox -/cabal.sandbox.config - -# Haskell Program Coverage -/.hpc -/*.tix - -# Leksah -*.lkshs - -# Intellij IDEA -/.idea -*.iml - -# ctags -TAGS - diff --git a/projects/TicTacToe/haskell/LICENSE b/projects/TicTacToe/haskell/LICENSE deleted file mode 100644 index 0ab5f871d..000000000 --- a/projects/TicTacToe/haskell/LICENSE +++ /dev/null @@ -1,28 +0,0 @@ -Copyright 2010-2013 Tony Morris -Copyright 2012-2015 National ICT Australia Limited - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/projects/TicTacToe/haskell/Setup.lhs b/projects/TicTacToe/haskell/Setup.lhs deleted file mode 100644 index 0832aa53c..000000000 --- a/projects/TicTacToe/haskell/Setup.lhs +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - -\end{code} diff --git a/projects/TicTacToe/haskell/changelog b/projects/TicTacToe/haskell/changelog deleted file mode 100644 index 62959fa8a..000000000 --- a/projects/TicTacToe/haskell/changelog +++ /dev/null @@ -1,9 +0,0 @@ -0.0.1 - -* Initial version - -0.1.0 - -* Solution now uses lens -* Enforces more invariants - diff --git a/projects/TicTacToe/haskell/src/TicTacToe.hs b/projects/TicTacToe/haskell/src/TicTacToe.hs deleted file mode 100644 index e21c65a56..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe.hs +++ /dev/null @@ -1,17 +0,0 @@ -module TicTacToe( - module T -) where - -import TicTacToe.AsOccupied as T -import TicTacToe.AsOr as T -import TicTacToe.AsWin as T -import TicTacToe.Back as T -import TicTacToe.Draw as T -import TicTacToe.Move as T -import TicTacToe.MoveOr as T -import TicTacToe.Player as T -import TicTacToe.Position as T -import TicTacToe.OccupiedOr as T -import TicTacToe.WinOccupiedOr as T -import TicTacToe.Winpaths as T -import TicTacToe.WithPosition as T diff --git a/projects/TicTacToe/haskell/src/TicTacToe/AsOccupied.hs b/projects/TicTacToe/haskell/src/TicTacToe/AsOccupied.hs deleted file mode 100644 index b30df352c..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/AsOccupied.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module TicTacToe.AsOccupied( - AsOccupied(_Occupied) -, occupied -) where - -import Control.Applicative(Applicative) -import Control.Category(id) -import Control.Lens(Optic', Choice, (#), _Empty, _Nothing) -import Data.Functor.Identity(Identity) -import Data.Maybe(Maybe) -import Data.Tagged(Tagged) - -class AsOccupied p f s where - _Occupied :: - Optic' p f s () - -instance AsOccupied p f () where - _Occupied = - id - -instance (Choice p, Applicative f) => AsOccupied p f (Maybe a) where - _Occupied = - _Nothing - -instance (Choice p, Applicative f) => AsOccupied p f [a] where - _Occupied = - _Empty - -occupied :: - AsOccupied Tagged Identity a => a -occupied = - _Occupied # () diff --git a/projects/TicTacToe/haskell/src/TicTacToe/AsOr.hs b/projects/TicTacToe/haskell/src/TicTacToe/AsOr.hs deleted file mode 100644 index 148e4f343..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/AsOr.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.AsOr( - AsOr(_Or) -) where - -import Control.Applicative(Applicative) -import Control.Lens(Optic, Profunctor, Choice, iso, _Right, _Just) -import Data.Either(Either) -import Data.Functor(Functor) -import Data.Functor.Identity(Identity(runIdentity, Identity)) -import Data.Maybe(Maybe) -import Data.Traversable(traverse) - -class AsOr p f o where - _Or :: - Optic p f (o a) (o b) a b - -instance (Profunctor p, Functor f) => AsOr p f Identity where - _Or = - iso - runIdentity - Identity - -instance (Choice p, Applicative f) => AsOr p f Maybe where - _Or = - _Just - -instance (Choice p, Applicative f) => AsOr p f (Either t) where - _Or = - _Right - -instance (p ~ (->), Applicative f) => AsOr p f [] where - _Or = - traverse diff --git a/projects/TicTacToe/haskell/src/TicTacToe/AsWin.hs b/projects/TicTacToe/haskell/src/TicTacToe/AsWin.hs deleted file mode 100644 index 0990c3099..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/AsWin.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.AsWin( - AsWin(_Win) -) where - -import Control.Applicative(Applicative) -import Control.Lens(Optic, Choice, _1, _Left) -import Data.Either(Either) -import Data.Functor(Functor) - -class AsWin p f o where - _Win :: - Optic p f (o w a) (o x a) w x - -instance (Choice p, Applicative f) => AsWin p f Either where - _Win = - _Left - -instance (p ~ (->), Functor f) => AsWin p f (,) where - _Win = - _1 diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Back.hs b/projects/TicTacToe/haskell/src/TicTacToe/Back.hs deleted file mode 100644 index 70e71e157..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Back.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - -module TicTacToe.Back( - Back(back) -) where - -import Control.Lens((^.)) -import TicTacToe.Move(Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, Move9, _Move1, _Move2, _Move3, _Move4, _Move5, _Move6, _Move7, _Move8, Win5, Win6, Win7, Win8, Win9) - -class Back g f | g -> f where - back :: - g - -> f - -instance Back Move9 Move8 where - back = - (^. _Move8) - -instance Back Win9 Move8 where - back = - (^. _Move8) - -instance Back Move8 Move7 where - back = - (^. _Move7) - -instance Back Win8 Move7 where - back = - (^. _Move7) - -instance Back Move7 Move6 where - back = - (^. _Move6) - -instance Back Win7 Move6 where - back = - (^. _Move6) - -instance Back Move6 Move5 where - back = - (^. _Move5) - -instance Back Win6 Move5 where - back = - (^. _Move5) - -instance Back Move5 Move4 where - back = - (^. _Move4) - -instance Back Win5 Move4 where - back = - (^. _Move4) - -instance Back Move4 Move3 where - back = - (^. _Move3) - -instance Back Move3 Move2 where - back = - (^. _Move2) - -instance Back Move2 Move1 where - back = - (^. _Move1) - -instance Back Move1 () where - back _ = - () diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Console.hs b/projects/TicTacToe/haskell/src/TicTacToe/Console.hs deleted file mode 100644 index 5172579de..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Console.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Main( - main -) where - -import Control.Applicative(Const) -import Control.Category((.)) -import Control.Lens(( # ), (^?), (%~)) - -import Data.Foldable(mapM_) -import Data.Function(const) -import Data.Int(Int) -import Data.List(intercalate, concat, elem, (++)) -import Data.Maybe -import Data.Monoid(Endo, First) -import Data.String(String) -import System.IO(hSetBuffering, stdin, BufferMode(NoBuffering), putStrLn, getChar, print, IO) -import TicTacToe(Position(P1, P2, P3, P4, P5, P6, P7, P8, P9), AsWin(_Win), AsPlayer(_Player), Player, AsPosition(_Position), IndexingN, whoseTurn, WinOccupiedOr(IsOccupiedOr, Win), OccupiedOr(Occupied, Or), positionPlayer, start, move2, move3, move4, move5, move6, move7, move8, move9, Win5, Win6, Win7, Win8, Win9, Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, Move9) -import Prelude(show) - -main :: - IO () -main = - do hSetBuffering stdin NoBuffering - let moveto5 :: - (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => - (Position -> g -> OccupiedOr t) - -> (t -> IO ()) - -> g - -> IO () - moveto5 = - pernextmove IsOccupiedOr - - movefrom5 :: - (AsPosition (->) (Const (Endo (Endo Int))) h, AsPosition (->) (IndexingN Player (Const (First Player))) g, AsPosition (->) (IndexingN Player (Const (First Player))) h) => - (Position -> h -> WinOccupiedOr g t) - -> (t -> IO ()) - -> h - -> IO () - movefrom5 = - pernextmove (_Win %~ (\a t -> do putStrLn (showWithoutPositions a) - putStrLn (showPlayer (whoseTurn t) ++ " wins"))) - - play (permove . const) moveto5 moveto5 moveto5 movefrom5 movefrom5 movefrom5 movefrom5 movefrom5 print - -play :: - ((Position -> c) -> () -> t) - -> ((Position -> Move1 -> OccupiedOr Move2) -> t1 -> Move1 -> c) - -> ((Position -> Move2 -> OccupiedOr Move3) -> t2 -> t1) - -> ((Position -> Move3 -> OccupiedOr Move4) -> t3 -> t2) - -> ((Position -> Move4 -> WinOccupiedOr Win5 Move5) -> t4 -> t3) - -> ((Position -> Move5 -> WinOccupiedOr Win6 Move6) -> t5 -> t4) - -> ((Position -> Move6 -> WinOccupiedOr Win7 Move7) -> t6 -> t5) - -> ((Position -> Move7 -> WinOccupiedOr Win8 Move8) -> t7 -> t6) - -> ((Position -> Move8 -> WinOccupiedOr Win9 Move9) -> t8 -> t7) - -> t8 - -> t -play pm m1 m2 m3 m4 m5 m6 m7 m8 m9 = - pm (m1 move2 (m2 move3 (m3 move4 (m4 move5 (m5 move6 (m6 move7 (m7 move8 (m8 move9 m9))))))) . start) () - -pernextmove :: - (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => - (b -> WinOccupiedOr (g -> IO ()) t) - -> (Position -> g -> b) - -> (t -> IO ()) - -> g - -> IO () -pernextmove k fr j g = - permove (\t p -> case k (fr p g) of - Win w -> w t - IsOccupiedOr Occupied -> do putStrLn "That position is already occupied. Please try again." - pernextmove k fr j g - IsOccupiedOr (Or m) -> j m) g - -permove :: - (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => - (g -> Position -> IO ()) - -> g - -> IO () -permove k g = - let t = whoseTurn g - in do putStrLn (showWithoutPositions g) - mapM_ putStrLn - [ - showPlayer t ++ " to move" - , " * [1-9] to Move" - , " * q to Quit" - , " * v to view positions" - ] - c <- getChar - putStrLn [] - putStrLn "--------------------------------" - putStrLn [] - if c `elem` "vV" - then - do putStrLn (showWithPositions g) - permove k g - else - if c `elem` "qQ" - then - putStrLn "Cheerio" - else - case c ^? _Position of - Nothing -> do putStrLn ("Invalid selection '" ++ c : "'. Please try again.") - permove k g - Just p -> k g p - -showPlayer :: - Player - -> String -showPlayer t = - "Player " ++ show (_Player # t :: Int) ++ " [" ++ show t ++ "]" - -showPositionsUnoccupied :: - AsPosition (->) (IndexingN Player (Const (First Player))) g => - (Position -> String) - -> g - -> String -showPositionsUnoccupied f g = - showEachPosition (\p -> case positionPlayer p g of - Nothing -> f p - Just q -> show q) - -showWithPositions :: - AsPosition (->) (IndexingN Player (Const (First Player))) g => - g - -> String -showWithPositions = - showPositionsUnoccupied (\p -> show (_Position # p :: Int)) - -showWithoutPositions :: - AsPosition (->) (IndexingN Player (Const (First Player))) g => - g - -> String -showWithoutPositions = - showPositionsUnoccupied (const " ") - --- | Shows a board using ASCII notation and substituting the returned string for each position. -showEachPosition :: - (Position -> String) -- ^ The function returning the string to substitute each position. - -> String -showEachPosition k = - let z = ".===.===.===." - e = [ - z - , concat ["| ", k P1, " | ", k P2, " | ", k P3, " |"] - , z - , concat ["| ", k P4, " | ", k P5, " | ", k P6, " |"] - , z - , concat ["| ", k P7, " | ", k P8, " | ", k P9, " |"] - , z - ] - in intercalate "\n" e diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Draw.hs b/projects/TicTacToe/haskell/src/TicTacToe/Draw.hs deleted file mode 100644 index cbfbefbb7..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Draw.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.Draw( - Draw(isDraw) -) where - -import Control.Category -import Control.Lens.Extras(is) -import Data.Bool(Bool) -import Prelude() -import TicTacToe.AsOr(AsOr(_Or)) -import TicTacToe.Move(Win9, Move9) -import TicTacToe.MoveOr(Move9Or(Move9Or)) -import TicTacToe.WinOccupiedOr(WinOccupiedOr) - -class Draw g where - isDraw :: - g - -> Bool - -instance Draw (WinOccupiedOr Win9 Move9) where - isDraw = - is _Or - -instance Draw Move9Or where - isDraw (Move9Or m) = - isDraw m - -instance Draw Bool where - isDraw = - id diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Move.hs b/projects/TicTacToe/haskell/src/TicTacToe/Move.hs deleted file mode 100644 index e90133b24..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Move.hs +++ /dev/null @@ -1,688 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.Move( - Move1 -, AsMove1(_Move1) -, start -, Move2 -, AsMove2(_Move2) -, move2 -, Move3 -, AsMove3(_Move3) -, move3 -, Move4 -, AsMove4(_Move4) -, move4 -, Move5 -, AsMove5(_Move5) -, Win5 -, AsWin5(_Win5) -, move5 -, Move6 -, AsMove6(_Move6) -, Win6 -, AsWin6(_Win6) -, move6 -, Move7 -, AsMove7(_Move7) -, Win7 -, AsWin7(_Win7) -, move7 -, Move8 -, AsMove8(_Move8) -, Win8 -, AsWin8(_Win8) -, move8 -, Move9 -, AsMove9(_Move9) -, Win9 -, AsWin9(_Win9) -, move9 -) where - -import Control.Applicative(Applicative((<*>)), Const) -import Control.Category((.), id) -import Control.Lens(Optic', Profunctor, lens, iso, from, elemOf, (#)) -import Data.Bool(bool) -import Data.Eq(Eq) -import Data.Functor(Functor, (<$>)) -import Data.Functor.Identity(Identity) -import Data.Monoid(Any) -import Data.Ord(Ord) -import Data.Tagged(Tagged) -import Prelude(Show) -import TicTacToe.AsOccupied(AsOccupied, occupied) -import TicTacToe.AsOr(AsOr(_Or)) -import TicTacToe.AsWin(AsWin(_Win)) -import TicTacToe.OccupiedOr(OccupiedOr) -import TicTacToe.Position(AsPosition(_Position), Position) -import TicTacToe.WinOccupiedOr(WinOccupiedOr) -import TicTacToe.Winpaths(Winpaths(winpaths), hasWin) - -newtype Move1 = - Move1 Position - deriving (Eq, Ord, Show) - -class AsMove1 p f s where - _Move1 :: - Optic' p f s Move1 - -instance AsMove1 p f Move1 where - _Move1 = - id - -instance (Profunctor p, Functor f) => AsMove1 p f Position where - _Move1 = - iso - Move1 - (\(Move1 p) -> p) - -instance (Profunctor p, Functor f) => AsPosition p f Move1 where - _Position = - from _Move1 - -move :: - (AsPosition (->) (Const Data.Monoid.Any) s, AsOccupied Tagged Identity (o a), AsOr Tagged Identity o) => - (Position -> s -> a) - -> Position - -> s - -> o a -move f p m = - bool (_Or # f p m) occupied (elemOf _Position p m) - -wmove :: - (AsPosition (->) (Const Any) s, AsOccupied Tagged Identity (o w a), AsWin Tagged Identity o, Winpaths s, AsOr Tagged Identity (o w)) => - (Position -> s -> w) - -> (Position -> s -> a) - -> Position - -> s - -> o w a -wmove f g p m = - bool - (bool (_Or # g p m) (_Win # f p m) (hasWin p m)) - occupied - (elemOf _Position p m) - -start :: - Position - -> Move1 -start = - Move1 - -data Move2 = - Move2 Position Move1 - deriving (Eq, Ord, Show) - -class AsMove2 p f s where - _Move2 :: - Optic' p f s Move2 - -instance AsMove2 p f Move2 where - _Move2 = - id - -instance (p ~ (->), Functor f) => AsMove1 p f Move2 where - _Move1 = - lens - (\(Move2 _ m) -> m) - (\(Move2 p _) m -> Move2 p m) - -instance (p ~ (->), Applicative f) => AsPosition p f Move2 where - _Position f (Move2 p2 (Move1 p1)) = - (\q1 q2 -> Move2 q2 (Move1 q1)) <$> f p1 <*> f p2 - -move2 :: - Position - -> Move1 - -> OccupiedOr Move2 -move2 = - move Move2 - -data Move3 = - Move3 Position Move2 - deriving (Eq, Ord, Show) - -class AsMove3 p f s where - _Move3 :: - Optic' p f s Move3 - -instance AsMove3 p f Move3 where - _Move3 = - id - -instance (p ~ (->), Functor f) => AsMove2 p f Move3 where - _Move2 = - lens - (\(Move3 _ m) -> m) - (\(Move3 p _) m -> Move3 p m) - -instance (p ~ (->), Functor f) => AsMove1 p f Move3 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move3 where - _Position f (Move3 p3 (Move2 p2 (Move1 p1))) = - (\q1 q2 q3 -> Move3 q3 (Move2 q2 (Move1 q1))) <$> f p1 <*> f p2 <*> f p3 - -move3 :: - Position - -> Move2 - -> OccupiedOr Move3 -move3 = - move Move3 - -data Move4 = - Move4 Position Move3 - deriving (Eq, Ord, Show) - -class AsMove4 p f s where - _Move4 :: - Optic' p f s Move4 - -instance AsMove4 p f Move4 where - _Move4 = - id - -instance (p ~ (->), Functor f) => AsMove3 p f Move4 where - _Move3 = - lens - (\(Move4 _ m) -> m) - (\(Move4 p _) m -> Move4 p m) - -instance (p ~ (->), Functor f) => AsMove2 p f Move4 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move4 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move4 where - _Position f (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1)))) = - (\q1 q2 q3 q4 -> Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1)))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 - -instance Winpaths Move4 where - winpaths (Move4 _ (Move3 m3 (Move2 _ (Move1 m1)))) = - [(m3, m1)] - -move4 :: - Position - -> Move3 - -> OccupiedOr Move4 -move4 = - move Move4 - -data Move5 = - Move5 Position Move4 - deriving (Eq, Ord, Show) - -class AsMove5 p f s where - _Move5 :: - Optic' p f s Move5 - -instance AsMove5 p f Move5 where - _Move5 = - id - -instance (p ~ (->), Functor f) => AsMove4 p f Move5 where - _Move4 = - lens - (\(Move5 _ m) -> m) - (\(Move5 p _) m -> Move5 p m) - -instance (p ~ (->), Functor f) => AsMove3 p f Move5 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Move5 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move5 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move5 where - _Position f (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))) = - (\q1 q2 q3 q4 q5 -> Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 - -instance Winpaths Move5 where - winpaths (Move5 _ (Move4 m4 (Move3 _ (Move2 m2 (Move1 _))))) = - [(m4, m2)] - -data Win5 = - Win5 Position Move4 - deriving (Eq, Ord, Show) - -class AsWin5 p f s where - _Win5 :: - Optic' p f s Win5 - -instance AsWin5 p f Win5 where - _Win5 = - id - -instance (p ~ (->), Functor f) => AsMove4 p f Win5 where - _Move4 = - lens - (\(Win5 _ m) -> m) - (\(Win5 p _) m -> Win5 p m) - -instance (p ~ (->), Functor f) => AsMove3 p f Win5 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Win5 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Win5 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Win5 where - _Position f (Win5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))) = - (\q1 q2 q3 q4 q5 -> Win5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 - -move5 :: - Position - -> Move4 - -> WinOccupiedOr Win5 Move5 -move5 = - wmove Win5 Move5 - -data Move6 = - Move6 Position Move5 - deriving (Eq, Ord, Show) - -class AsMove6 p f s where - _Move6 :: - Optic' p f s Move6 - -instance AsMove6 p f Move6 where - _Move6 = - id - -instance (p ~ (->), Functor f) => AsMove5 p f Move6 where - _Move5 = - lens - (\(Move6 _ m) -> m) - (\(Move6 p _) m -> Move6 p m) - -instance (p ~ (->), Functor f) => AsMove4 p f Move6 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Move6 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Move6 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move6 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move6 where - _Position f (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1)))))) = - (\q1 q2 q3 q4 q5 q6 -> Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1)))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 - -instance Winpaths Move6 where - winpaths (Move6 _ (Move5 m5 (Move4 _ (Move3 m3 (Move2 _ (Move1 m1)))))) = - [(m5, m3), (m5, m1), (m3, m1)] - -data Win6 = - Win6 Position Move5 - deriving (Eq, Ord, Show) - -class AsWin6 p f s where - _Win6 :: - Optic' p f s Win6 - -instance AsWin6 p f Win6 where - _Win6 = - id - -instance (p ~ (->), Functor f) => AsMove5 p f Win6 where - _Move5 = - lens - (\(Win6 _ m) -> m) - (\(Win6 p _) m -> Win6 p m) - -instance (p ~ (->), Functor f) => AsMove4 p f Win6 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Win6 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Win6 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Win6 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Win6 where - _Position f (Win6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1)))))) = - (\q1 q2 q3 q4 q5 q6 -> Win6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1)))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 - -move6 :: - Position - -> Move5 - -> WinOccupiedOr Win6 Move6 -move6 = - wmove Win6 Move6 - -data Move7 = - Move7 Position Move6 - deriving (Eq, Ord, Show) - -class AsMove7 p f s where - _Move7 :: - Optic' p f s Move7 - -instance AsMove7 p f Move7 where - _Move7 = - id - -instance (p ~ (->), Functor f) => AsMove6 p f Move7 where - _Move6 = - lens - (\(Move7 _ m) -> m) - (\(Move7 p _) m -> Move7 p m) - -instance (p ~ (->), Functor f) => AsMove5 p f Move7 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Move7 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Move7 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Move7 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move7 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move7 where - _Position f (Move7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))))) = - (\q1 q2 q3 q4 q5 q6 q7 -> Move7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 - -instance Winpaths Move7 where - winpaths (Move7 _ (Move6 m6 (Move5 _ (Move4 m4 (Move3 _ (Move2 m2 (Move1 _))))))) = - [(m6, m4), (m6, m2), (m4, m2)] - -data Win7 = - Win7 Position Move6 - deriving (Eq, Ord, Show) - -class AsWin7 p f s where - _Win7 :: - Optic' p f s Win7 - -instance AsWin7 p f Win7 where - _Win7 = - id - -instance (p ~ (->), Functor f) => AsMove6 p f Win7 where - _Move6 = - lens - (\(Win7 _ m) -> m) - (\(Win7 p _) m -> Win7 p m) - -instance (p ~ (->), Functor f) => AsMove5 p f Win7 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Win7 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Win7 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Win7 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Win7 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Win7 where - _Position f (Win7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))))) = - (\q1 q2 q3 q4 q5 q6 q7 -> Win7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 - -move7 :: - Position - -> Move6 - -> WinOccupiedOr Win7 Move7 -move7 = - wmove Win7 Move7 - -data Move8 = - Move8 Position Move7 - deriving (Eq, Ord, Show) - -class AsMove8 p f s where - _Move8 :: - Optic' p f s Move8 - -instance AsMove8 p f Move8 where - _Move8 = - id - -instance (p ~ (->), Functor f) => AsMove7 p f Move8 where - _Move7 = - lens - (\(Move8 _ m) -> m) - (\(Move8 p _) m -> Move8 p m) - -instance (p ~ (->), Functor f) => AsMove6 p f Move8 where - _Move6 = - _Move7 . _Move6 - -instance (p ~ (->), Functor f) => AsMove5 p f Move8 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Move8 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Move8 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Move8 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move8 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move8 where - _Position f (Move8 p8 (Move7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1)))))))) = - (\q1 q2 q3 q4 q5 q6 q7 q8 -> Move8 q8 (Move7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1)))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 <*> f p8 - -instance Winpaths Move8 where - winpaths (Move8 _ (Move7 m7 (Move6 _ (Move5 m5 (Move4 _ (Move3 m3 (Move2 _ (Move1 m1)))))))) = - [(m7, m5), (m7, m3), (m7, m1), (m5, m3), (m5, m1), (m3, m1)] - -data Win8 = - Win8 Position Move7 - deriving (Eq, Ord, Show) - -class AsWin8 p f s where - _Win8 :: - Optic' p f s Win8 - -instance AsWin8 p f Win8 where - _Win8 = - id - -instance (p ~ (->), Functor f) => AsMove7 p f Win8 where - _Move7 = - lens - (\(Win8 _ m) -> m) - (\(Win8 p _) m -> Win8 p m) - -instance (p ~ (->), Functor f) => AsMove6 p f Win8 where - _Move6 = - _Move7 . _Move6 - -instance (p ~ (->), Functor f) => AsMove5 p f Win8 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Win8 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Win8 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Win8 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Win8 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Win8 where - _Position f (Win8 p8 (Move7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1)))))))) = - (\q1 q2 q3 q4 q5 q6 q7 q8 -> Win8 q8 (Move7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1)))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 <*> f p8 - -move8 :: - Position - -> Move7 - -> WinOccupiedOr Win8 Move8 -move8 = - wmove Win8 Move8 - -data Move9 = - Move9 Position Move8 - deriving (Eq, Ord, Show) - -class AsMove9 p f s where - _Move9 :: - Optic' p f s Move9 - -instance AsMove9 p f Move9 where - _Move9 = - id - -instance (p ~ (->), Functor f) => AsMove8 p f Move9 where - _Move8 = - lens - (\(Move9 _ m) -> m) - (\(Move9 p _) m -> Move9 p m) - -instance (p ~ (->), Functor f) => AsMove7 p f Move9 where - _Move7 = - _Move8 . _Move7 - -instance (p ~ (->), Functor f) => AsMove6 p f Move9 where - _Move6 = - _Move7 . _Move6 - -instance (p ~ (->), Functor f) => AsMove5 p f Move9 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Move9 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Move9 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Move9 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Move9 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Move9 where - _Position f (Move9 p9 (Move8 p8 (Move7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))))))) = - (\q1 q2 q3 q4 q5 q6 q7 q8 q9 -> Move9 q9 (Move8 q8 (Move7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 <*> f p8 <*> f p9 - -data Win9 = - Win9 Position Move8 - deriving (Eq, Ord, Show) - -class AsWin9 p f s where - _Win9 :: - Optic' p f s Win9 - -instance AsWin9 p f Win9 where - _Win9 = - id - -instance (p ~ (->), Functor f) => AsMove8 p f Win9 where - _Move8 = - lens - (\(Win9 _ m) -> m) - (\(Win9 p _) m -> Win9 p m) - -instance (p ~ (->), Functor f) => AsMove7 p f Win9 where - _Move7 = - _Move8 . _Move7 - -instance (p ~ (->), Functor f) => AsMove6 p f Win9 where - _Move6 = - _Move7 . _Move6 - -instance (p ~ (->), Functor f) => AsMove5 p f Win9 where - _Move5 = - _Move6 . _Move5 - -instance (p ~ (->), Functor f) => AsMove4 p f Win9 where - _Move4 = - _Move5 . _Move4 - -instance (p ~ (->), Functor f) => AsMove3 p f Win9 where - _Move3 = - _Move4 . _Move3 - -instance (p ~ (->), Functor f) => AsMove2 p f Win9 where - _Move2 = - _Move3 . _Move2 - -instance (p ~ (->), Functor f) => AsMove1 p f Win9 where - _Move1 = - _Move2 . _Move1 - -instance (p ~ (->), Applicative f) => AsPosition p f Win9 where - _Position f (Win9 p9 (Move8 p8 (Move7 p7 (Move6 p6 (Move5 p5 (Move4 p4 (Move3 p3 (Move2 p2 (Move1 p1))))))))) = - (\q1 q2 q3 q4 q5 q6 q7 q8 q9 -> Win9 q9 (Move8 q8 (Move7 q7 (Move6 q6 (Move5 q5 (Move4 q4 (Move3 q3 (Move2 q2 (Move1 q1))))))))) <$> f p1 <*> f p2 <*> f p3 <*> f p4 <*> f p5 <*> f p6 <*> f p7 <*> f p8 <*> f p9 - -move9 :: - Position - -> Move8 - -> WinOccupiedOr Win9 Move9 -move9 = - wmove Win9 Move9 diff --git a/projects/TicTacToe/haskell/src/TicTacToe/MoveOr.hs b/projects/TicTacToe/haskell/src/TicTacToe/MoveOr.hs deleted file mode 100644 index 2c7d10c37..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/MoveOr.hs +++ /dev/null @@ -1,479 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.MoveOr ( - Move2Or(Move2Or) -, AsMove2Or(_Move2Or) -, Move3Or(Move3Or) -, AsMove3Or(_Move3Or) -, Move4Or(Move4Or) -, AsMove4Or(_Move4Or) -, Move5Or(Move5Or) -, AsMove5Or(_Move5Or) -, Move6Or(Move6Or) -, AsMove6Or(_Move6Or) -, Move7Or(Move7Or) -, AsMove7Or(_Move7Or) -, Move8Or(Move8Or) -, AsMove8Or(_Move8Or) -, Move9Or(Move9Or) -, AsMove9Or(_Move9Or) -, MoveOr6Or(MoveOr6OrWin5, MoveOr6Or) -, MoveOr7Or(MoveOr7OrWin5, MoveOr7OrWin6, MoveOr7Or) -, MoveOr8Or(MoveOr8OrWin5, MoveOr8OrWin6, MoveOr8OrWin7, MoveOr8Or) -, MoveOr9Or(MoveOr9OrWin5, MoveOr9OrWin6, MoveOr9OrWin7, MoveOr9OrWin8, MoveOr9Or) -) where - -import Control.Applicative(Applicative) -import Control.Category((.), id) -import Control.Lens(Profunctor, Choice, Prism', Optic', prism', failing, iso, from) -import Data.Eq(Eq) -import Data.Functor(Functor) -import Data.Maybe(Maybe(Nothing, Just)) -import Data.Ord(Ord) -import Prelude(Show) -import TicTacToe.Move(Move2, Move3, Move4, Move5, Move6, Move7, Move8, Move9, Win5, Win6, Win7, Win8, Win9, AsMove2(_Move2), AsMove3(_Move3), AsMove4(_Move4), AsMove5(_Move5), AsMove6(_Move6), AsMove7(_Move7), AsMove8(_Move8), AsMove9(_Move9), AsWin5(_Win5), AsWin6(_Win6), AsWin7(_Win7), AsWin8(_Win8)) -import TicTacToe.AsOccupied(AsOccupied(_Occupied)) -import TicTacToe.OccupiedOr(OccupiedOr) -import TicTacToe.AsOr(AsOr(_Or)) -import TicTacToe.WinOccupiedOr(WinOccupiedOr) -import TicTacToe.Position(AsPosition(_Position)) - -newtype Move2Or = - Move2Or (OccupiedOr Move2) - deriving (Eq, Ord, Show) - -class AsMove2Or p f s where - _Move2Or :: - Optic' p f s Move2Or - -instance AsMove2Or p f Move2Or where - _Move2Or = - id - -instance (Profunctor p, Functor f) => AsMove2Or p f (OccupiedOr Move2) where - _Move2Or = - iso - Move2Or - (\(Move2Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move2Or where - _Occupied = - _Move2Or . _Occupied - -instance (Choice p, Applicative f) => AsMove2 p f Move2Or where - _Move2 = - from _Move2Or . (_Or :: Prism' (OccupiedOr Move2) Move2) - -instance (p ~ (->), Applicative f) => AsPosition p f Move2Or where - _Position = - _Move2 . _Position - -newtype Move3Or = - Move3Or (OccupiedOr Move3) - deriving (Eq, Ord, Show) - -class AsMove3Or p f s where - _Move3Or :: - Optic' p f s Move3Or - -instance AsMove3Or p f Move3Or where - _Move3Or = - id - -instance (Profunctor p, Functor f) => AsMove3Or p f (OccupiedOr Move3) where - _Move3Or = - iso - Move3Or - (\(Move3Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move3Or where - _Occupied = - _Move3Or . _Occupied - -instance (Choice p, Applicative f) => AsMove3 p f Move3Or where - _Move3 = - from _Move3Or . (_Or :: Prism' (OccupiedOr Move3) Move3) - -instance (p ~ (->), Applicative f) => AsPosition p f Move3Or where - _Position = - _Move3 . _Position - -newtype Move4Or = - Move4Or (OccupiedOr Move4) - deriving (Eq, Ord, Show) - -class AsMove4Or p f s where - _Move4Or :: - Optic' p f s Move4Or - -instance AsMove4Or p f Move4Or where - _Move4Or = - id - -instance (Profunctor p, Functor f) => AsMove4Or p f (OccupiedOr Move4) where - _Move4Or = - iso - Move4Or - (\(Move4Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move4Or where - _Occupied = - _Move4Or . _Occupied - -instance (Choice p, Applicative f) => AsMove4 p f Move4Or where - _Move4 = - from _Move4Or . (_Or :: Prism' (OccupiedOr Move4) Move4) - -instance (p ~ (->), Applicative f) => AsPosition p f Move4Or where - _Position = - _Move4 . _Position - -newtype Move5Or = - Move5Or (WinOccupiedOr Win5 Move5) - deriving (Eq, Ord, Show) - -class AsMove5Or p f s where - _Move5Or :: - Optic' p f s Move5Or - -instance AsMove5Or p f Move5Or where - _Move5Or = - id - -instance (Profunctor p, Functor f) => AsMove5Or p f (WinOccupiedOr Win5 Move5) where - _Move5Or = - iso - Move5Or - (\(Move5Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move5Or where - _Occupied = - _Move5Or . _Occupied - -instance (Choice p, Applicative f) => AsMove5 p f Move5Or where - _Move5 = - from _Move5Or . (_Or :: Prism' (WinOccupiedOr Win5 Move5) Move5) - -instance (p ~ (->), Applicative f) => AsPosition p f Move5Or where - _Position = - _Move5 . _Position - -newtype Move6Or = - Move6Or (WinOccupiedOr Win6 Move6) - deriving (Eq, Ord, Show) - -class AsMove6Or p f s where - _Move6Or :: - Optic' p f s Move6Or - -instance AsMove6Or p f Move6Or where - _Move6Or = - id - -instance (Profunctor p, Functor f) => AsMove6Or p f (WinOccupiedOr Win6 Move6) where - _Move6Or = - iso - Move6Or - (\(Move6Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move6Or where - _Occupied = - _Move6Or . _Occupied - -instance (Choice p, Applicative f) => AsMove6 p f Move6Or where - _Move6 = - from _Move6Or . (_Or :: Prism' (WinOccupiedOr Win6 Move6) Move6) - -instance (p ~ (->), Applicative f) => AsPosition p f Move6Or where - _Position = - _Move6 . _Position - -newtype Move7Or = - Move7Or (WinOccupiedOr Win7 Move7) - deriving (Eq, Ord, Show) - -class AsMove7Or p f s where - _Move7Or :: - Optic' p f s Move7Or - -instance AsMove7Or p f Move7Or where - _Move7Or = - id - -instance (Profunctor p, Functor f) => AsMove7Or p f (WinOccupiedOr Win7 Move7) where - _Move7Or = - iso - Move7Or - (\(Move7Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move7Or where - _Occupied = - _Move7Or . _Occupied - -instance (Choice p, Applicative f) => AsMove7 p f Move7Or where - _Move7 = - from _Move7Or . (_Or :: Prism' (WinOccupiedOr Win7 Move7) Move7) - -instance (p ~ (->), Applicative f) => AsPosition p f Move7Or where - _Position = - _Move7 . _Position - -newtype Move8Or = - Move8Or (WinOccupiedOr Win8 Move8) - deriving (Eq, Ord, Show) - -class AsMove8Or p f s where - _Move8Or :: - Optic' p f s Move8Or - -instance AsMove8Or p f Move8Or where - _Move8Or = - id - -instance (Profunctor p, Functor f) => AsMove8Or p f (WinOccupiedOr Win8 Move8) where - _Move8Or = - iso - Move8Or - (\(Move8Or m) -> m) - -instance (Choice p, Applicative f) => AsOccupied p f Move8Or where - _Occupied = - _Move8Or . _Occupied - -instance (Choice p, Applicative f) => AsMove8 p f Move8Or where - _Move8 = - from _Move8Or . (_Or :: Prism' (WinOccupiedOr Win8 Move8) Move8) - -instance (p ~ (->), Applicative f) => AsPosition p f Move8Or where - _Position = - _Move8 . _Position - -newtype Move9Or = - Move9Or (WinOccupiedOr Win9 Move9) - deriving (Eq, Ord, Show) - -class AsMove9Or p f s where - _Move9Or :: - Optic' p f s Move9Or - -instance AsMove9Or p f Move9Or where - _Move9Or = - id - -instance (Choice p, Applicative f) => AsOccupied p f Move9Or where - _Occupied = - _Move9Or . _Occupied - -instance (Profunctor p, Functor f) => AsMove9Or p f (WinOccupiedOr Win9 Move9) where - _Move9Or = - iso - Move9Or - (\(Move9Or m) -> m) - -instance (Choice p, Applicative f) => AsMove9 p f Move9Or where - _Move9 = - from _Move9Or . (_Or :: Prism' (WinOccupiedOr Win9 Move9) Move9) - -instance (p ~ (->), Applicative f) => AsPosition p f Move9Or where - _Position = - _Move9 . _Position - -data MoveOr6Or = - MoveOr6OrWin5 Win5 - | MoveOr6Or Move6Or - deriving (Eq, Ord, Show) - -instance (Choice p, Applicative f) => AsWin5 p f MoveOr6Or where - _Win5 = - prism' - MoveOr6OrWin5 - (\m -> case m of - MoveOr6OrWin5 w -> Just w - MoveOr6Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsMove6Or p f MoveOr6Or where - _Move6Or = - prism' - MoveOr6Or - (\m -> case m of - MoveOr6OrWin5 _ -> Nothing - MoveOr6Or r -> Just r) - -instance (Choice p, Applicative f) => AsOccupied p f MoveOr6Or where - _Occupied = - _Move6Or . _Occupied - -instance (p ~ (->), Applicative f) => AsPosition p f MoveOr6Or where - _Position = - failing (_Win5 . _Position) (_Move6Or . _Position) - -data MoveOr7Or = - MoveOr7OrWin5 Win5 - | MoveOr7OrWin6 Win6 - | MoveOr7Or Move7Or - deriving (Eq, Ord, Show) - -instance (Choice p, Applicative f) => AsWin5 p f MoveOr7Or where - _Win5 = - prism' - MoveOr7OrWin5 - (\m -> case m of - MoveOr7OrWin5 w -> Just w - MoveOr7OrWin6 _ -> Nothing - MoveOr7Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin6 p f MoveOr7Or where - _Win6 = - prism' - MoveOr7OrWin6 - (\m -> case m of - MoveOr7OrWin5 _ -> Nothing - MoveOr7OrWin6 w -> Just w - MoveOr7Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsMove7Or p f MoveOr7Or where - _Move7Or = - prism' - MoveOr7Or - (\m -> case m of - MoveOr7OrWin5 _ -> Nothing - MoveOr7OrWin6 _ -> Nothing - MoveOr7Or r -> Just r) - -instance (Choice p, Applicative f) => AsOccupied p f MoveOr7Or where - _Occupied = - _Move7Or . _Occupied - -instance (p ~ (->), Applicative f) => AsPosition p f MoveOr7Or where - _Position = - failing (_Win5 . _Position) (failing (_Win6 . _Position) (_Move7Or . _Position)) - -data MoveOr8Or = - MoveOr8OrWin5 Win5 - | MoveOr8OrWin6 Win6 - | MoveOr8OrWin7 Win7 - | MoveOr8Or Move8Or - deriving (Eq, Ord, Show) - -instance (Choice p, Applicative f) => AsWin5 p f MoveOr8Or where - _Win5 = - prism' - MoveOr8OrWin5 - (\m -> case m of - MoveOr8OrWin5 w -> Just w - MoveOr8OrWin6 _ -> Nothing - MoveOr8OrWin7 _ -> Nothing - MoveOr8Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin6 p f MoveOr8Or where - _Win6 = - prism' - MoveOr8OrWin6 - (\m -> case m of - MoveOr8OrWin5 _ -> Nothing - MoveOr8OrWin6 w -> Just w - MoveOr8OrWin7 _ -> Nothing - MoveOr8Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin7 p f MoveOr8Or where - _Win7 = - prism' - MoveOr8OrWin7 - (\m -> case m of - MoveOr8OrWin5 _ -> Nothing - MoveOr8OrWin6 _ -> Nothing - MoveOr8OrWin7 w -> Just w - MoveOr8Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsMove8Or p f MoveOr8Or where - _Move8Or = - prism' - MoveOr8Or - (\m -> case m of - MoveOr8OrWin5 _ -> Nothing - MoveOr8OrWin6 _ -> Nothing - MoveOr8OrWin7 _ -> Nothing - MoveOr8Or r -> Just r) - -instance (Choice p, Applicative f) => AsOccupied p f MoveOr8Or where - _Occupied = - _Move8Or . _Occupied - -instance (p ~ (->), Applicative f) => AsPosition p f MoveOr8Or where - _Position = - failing (_Win5 . _Position) (failing (_Win6 . _Position) (failing (_Win7 . _Position) (_Move8Or . _Position))) - -data MoveOr9Or = - MoveOr9OrWin5 Win5 - | MoveOr9OrWin6 Win6 - | MoveOr9OrWin7 Win7 - | MoveOr9OrWin8 Win8 - | MoveOr9Or Move9Or - deriving (Eq, Ord, Show) - -instance (Choice p, Applicative f) => AsWin5 p f MoveOr9Or where - _Win5 = - prism' - MoveOr9OrWin5 - (\m -> case m of - MoveOr9OrWin5 w -> Just w - MoveOr9OrWin6 _ -> Nothing - MoveOr9OrWin7 _ -> Nothing - MoveOr9OrWin8 _ -> Nothing - MoveOr9Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin6 p f MoveOr9Or where - _Win6 = - prism' - MoveOr9OrWin6 - (\m -> case m of - MoveOr9OrWin5 _ -> Nothing - MoveOr9OrWin6 w -> Just w - MoveOr9OrWin7 _ -> Nothing - MoveOr9OrWin8 _ -> Nothing - MoveOr9Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin7 p f MoveOr9Or where - _Win7 = - prism' - MoveOr9OrWin7 - (\m -> case m of - MoveOr9OrWin5 _ -> Nothing - MoveOr9OrWin6 _ -> Nothing - MoveOr9OrWin7 w -> Just w - MoveOr9OrWin8 _ -> Nothing - MoveOr9Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsWin8 p f MoveOr9Or where - _Win8 = - prism' - MoveOr9OrWin8 - (\m -> case m of - MoveOr9OrWin5 _ -> Nothing - MoveOr9OrWin6 _ -> Nothing - MoveOr9OrWin7 _ -> Nothing - MoveOr9OrWin8 w -> Just w - MoveOr9Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsMove9Or p f MoveOr9Or where - _Move9Or = - prism' - MoveOr9Or - (\m -> case m of - MoveOr9OrWin5 _ -> Nothing - MoveOr9OrWin6 _ -> Nothing - MoveOr9OrWin7 _ -> Nothing - MoveOr9OrWin8 _ -> Nothing - MoveOr9Or r -> Just r) - -instance (Choice p, Applicative f) => AsOccupied p f MoveOr9Or where - _Occupied = - _Move9Or . _Occupied - -instance (p ~ (->), Applicative f) => AsPosition p f MoveOr9Or where - _Position = - failing (_Win5 . _Position) (failing (_Win6 . _Position) (failing (_Win7 . _Position) (failing (_Win8 . _Position) (_Move9Or . _Position)))) diff --git a/projects/TicTacToe/haskell/src/TicTacToe/OccupiedOr.hs b/projects/TicTacToe/haskell/src/TicTacToe/OccupiedOr.hs deleted file mode 100644 index de80188f5..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/OccupiedOr.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module TicTacToe.OccupiedOr( - OccupiedOr(Occupied, Or) -, AsOccupiedOr(_OccupiedOr) -) where - -import Control.Applicative(Applicative((<*>), pure)) -import Control.Category(id) -import Control.Lens(Optic, Profunctor, Choice, prism', prism, iso) -import Control.Monad(Monad((>>=), return)) -import Data.Either(Either(Left, Right)) -import Data.Eq(Eq) -import Data.Functor(Functor(fmap)) -import Data.Maybe(Maybe(Nothing, Just), maybe) -import Data.Ord(Ord) -import Prelude(Show) -import TicTacToe.AsOccupied(AsOccupied(_Occupied)) -import TicTacToe.AsOr(AsOr(_Or)) - -data OccupiedOr a = - Occupied - | Or a - deriving (Eq, Ord, Show) - -class AsOccupiedOr p f o where - _OccupiedOr :: - Optic p f (o a) (o b) (OccupiedOr a) (OccupiedOr b) - -instance AsOccupiedOr p f OccupiedOr where - _OccupiedOr = - id - -instance (Profunctor p, Functor f) => AsOccupiedOr p f Maybe where - _OccupiedOr = - iso - (maybe Occupied Or) - (\o -> case o of - Occupied -> Nothing - Or a -> Just a) - -instance Functor OccupiedOr where - fmap _ Occupied = - Occupied - fmap f (Or a) = - Or (f a) - -instance Applicative OccupiedOr where - pure = - Or - Occupied <*> _ = - Occupied - Or _ <*> Occupied = - Occupied - Or f <*> Or a = - Or (f a) - -instance Monad OccupiedOr where - return = - Or - Occupied >>= _ = - Occupied - Or a >>= f = - f a - -instance (Choice p, Applicative f) => AsOccupied p f (OccupiedOr a) where - _Occupied = - prism' - (\() -> Occupied) - (\o -> case o of - Occupied -> Just () - Or _ -> Nothing) - -instance (Choice p, Applicative f) => AsOr p f OccupiedOr where - _Or = - prism - Or - (\o -> case o of - Occupied -> Left Occupied - Or a -> Right a) diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Player.hs b/projects/TicTacToe/haskell/src/TicTacToe/Player.hs deleted file mode 100644 index f5c0dab2d..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Player.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module TicTacToe.Player( - Player(X, O) -, AsPlayer(_Player) -, playerswap -) where - -import Control.Applicative(Applicative) -import Control.Category(id) -import Control.Lens(Choice, Optic', Profunctor, Iso', iso, prism') -import Data.Bool(Bool(False, True), bool) -import Data.Eq(Eq) -import Data.Functor(Functor) -import Data.Maybe -import Data.Int(Int) -import Data.Ord(Ord) -import Prelude(Show) - -data Player = - X - | O - deriving (Eq, Ord, Show) - -class AsPlayer p f s where - _Player :: - Optic' p f s Player - -instance AsPlayer p f Player where - _Player = - id - -instance (Profunctor p, Functor f) => AsPlayer p f Bool where - _Player = - iso - (bool O X) - (\p -> case p of - X -> True - O -> False) - -instance (Choice p, Applicative f) => AsPlayer p f Int where - _Player = - prism' - (\p -> case p of - X -> 1 - O -> 2) - (\n -> case n of - 1 -> Just X - 2 -> Just O - _ -> Nothing) - -playerswap :: - Iso' - Player - Player -playerswap = - let swap X = O - swap O = X - in iso - swap - swap - diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Position.hs b/projects/TicTacToe/haskell/src/TicTacToe/Position.hs deleted file mode 100644 index ac911766b..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Position.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -module TicTacToe.Position( - Position(P1, P2, P3, P4, P5, P6, P7, P8, P9) -, AsPosition(_Position) -, magic -, positionIndex -, positionPlayer -, whoseTurn -, IndexingN(IndexingN, runIndexingN) -) where - -import Control.Applicative(Applicative((<*>), pure), Const) -import Control.Category(id, (.)) -import Control.Lens(Iso', Optic', Choice, Indexable(indexed), (^.), ( # ), iso, prism', elemIndexOf, lengthOf, _2) -import Data.Char(Char) -import Data.Eq(Eq) -import Data.Functor(Functor(fmap)) -import Data.Int(Int) -import Data.Maybe(Maybe(Just, Nothing)) -import Data.Monoid(First, Endo) -import Data.Ord(Ord) -import Prelude(Show, Num((+)), seq, even) -import TicTacToe.Player(Player(X), _Player, playerswap) - -data Position = - P1 - | P2 - | P3 - | P4 - | P5 - | P6 - | P7 - | P8 - | P9 - deriving (Eq, Ord, Show) - -magic :: - Iso' - Position - Position -magic = - iso - (\p -> case p of - P1 -> P2 - P2 -> P9 - P3 -> P4 - P4 -> P7 - P5 -> P5 - P6 -> P3 - P7 -> P6 - P8 -> P1 - P9 -> P8) - (\p -> case p of - P1 -> P8 - P2 -> P1 - P3 -> P6 - P4 -> P3 - P5 -> P5 - P6 -> P7 - P7 -> P4 - P8 -> P9 - P9 -> P2) - -class AsPosition p f s where - _Position :: - Optic' p f s Position - -instance AsPosition p f Position where - _Position = - id - -instance (p ~ (->), Applicative f) => AsPosition p f () where - _Position _ () = - pure () - -instance (Choice p, Applicative f) => AsPosition p f Int where - _Position = - prism' - (\p -> case p of - P1 -> 1 - P2 -> 2 - P3 -> 3 - P4 -> 4 - P5 -> 5 - P6 -> 6 - P7 -> 7 - P8 -> 8 - P9 -> 9) - (\p -> case p of - 1 -> Just P1 - 2 -> Just P2 - 3 -> Just P3 - 4 -> Just P4 - 5 -> Just P5 - 6 -> Just P6 - 7 -> Just P7 - 8 -> Just P8 - 9 -> Just P9 - _ -> Nothing) - -instance (Choice p, Applicative f) => AsPosition p f Char where - _Position = - prism' - (\p -> case p of - P1 -> '1' - P2 -> '2' - P3 -> '3' - P4 -> '4' - P5 -> '5' - P6 -> '6' - P7 -> '7' - P8 -> '8' - P9 -> '9') - (\p -> case p of - '1' -> Just P1 - '2' -> Just P2 - '3' -> Just P3 - '4' -> Just P4 - '5' -> Just P5 - '6' -> Just P6 - '7' -> Just P7 - '8' -> Just P8 - '9' -> Just P9 - _ -> Nothing) - -newtype IndexingN n f a = - IndexingN { - runIndexingN :: n -> (n, f a) - } - -instance Functor f => Functor (IndexingN n f) where - fmap f (IndexingN m) = - IndexingN (fmap (fmap f) . m) - -instance Applicative f => Applicative (IndexingN n f) where - pure x = - IndexingN (\i -> (i, pure x)) - IndexingN f <*> IndexingN a = - IndexingN (\i -> let (o, g) = f i - ~(p, b) = a o - in (p, g <*> b)) - -indexingN :: - Indexable i p => - a - -> (i -> i) - -> ((d -> IndexingN i g c) -> t -> IndexingN a f b) - -> p d (g c) - -> t - -> f b -indexingN x k l iafb s = - runIndexingN (l (\a -> IndexingN (\i -> i `seq` (k i, indexed iafb i a))) s) x ^. _2 - -positionIndex :: - (Num i, AsPosition (->) (IndexingN i (Const (First i))) a) => - Position - -> a - -> Maybe i -positionIndex = - elemIndexOf (indexingN 0 (+1) _Position) - -positionPlayer :: - AsPosition (->) (IndexingN Player (Const (First Player))) a => - Position - -> a - -> Maybe Player -positionPlayer = - elemIndexOf (indexingN X (playerswap #) _Position) - -whoseTurn :: - AsPosition (->) (Const (Endo (Endo Int))) g => - g - -> Player -whoseTurn x = - even (lengthOf _Position x) ^. _Player diff --git a/projects/TicTacToe/haskell/src/TicTacToe/WinOccupiedOr.hs b/projects/TicTacToe/haskell/src/TicTacToe/WinOccupiedOr.hs deleted file mode 100644 index ebd4f13bd..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/WinOccupiedOr.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module TicTacToe.WinOccupiedOr( - WinOccupiedOr(Win, IsOccupiedOr) -, AsWinOccupiedOr(_WinOccupiedOr) -) where - -import Control.Applicative(Applicative(pure, (<*>))) -import Control.Category((.), id) -import Control.Lens(Optic, Choice, prism) -import Control.Monad(Monad((>>=), return)) -import Data.Either(Either(Left, Right)) -import Data.Eq(Eq) -import Data.Ord(Ord) -import Data.Functor(Functor(fmap)) -import TicTacToe.AsOccupied(AsOccupied(_Occupied)) -import TicTacToe.AsOr(AsOr(_Or)) -import TicTacToe.OccupiedOr(OccupiedOr(Occupied, Or), AsOccupiedOr(_OccupiedOr)) -import TicTacToe.AsWin(AsWin(_Win)) -import Prelude(Show) - -data WinOccupiedOr w a = - Win w - | IsOccupiedOr (OccupiedOr a) - deriving (Eq, Ord, Show) - -class AsWinOccupiedOr p f o where - _WinOccupiedOr :: - Optic p f (o w a) (o x b) (WinOccupiedOr w a) (WinOccupiedOr x b) - -instance AsWinOccupiedOr p f WinOccupiedOr where - _WinOccupiedOr = - id - -instance Functor (WinOccupiedOr w) where - fmap _ (Win w) = - Win w - fmap f (IsOccupiedOr m) = - IsOccupiedOr (fmap f m) - -instance Applicative (WinOccupiedOr w) where - pure = - IsOccupiedOr . pure - Win w <*> _ = - Win w - IsOccupiedOr _ <*> Win w = - Win w - IsOccupiedOr f <*> IsOccupiedOr a = - IsOccupiedOr (f <*> a) - -instance Monad (WinOccupiedOr w) where - return = - IsOccupiedOr . return - Win w >>= _ = - Win w - IsOccupiedOr m >>= f = - case m of - Occupied -> IsOccupiedOr Occupied - Or a -> f a - -instance (Choice p, Applicative f) => AsWin p f WinOccupiedOr where - _Win = - prism - Win - (\b -> case b of - Win w -> Right w - IsOccupiedOr m -> Left (IsOccupiedOr m)) - -instance (Choice p, Applicative f) => AsOccupiedOr p f (WinOccupiedOr w) where - _OccupiedOr = - prism - IsOccupiedOr - (\b -> case b of - Win w -> Left (Win w) - IsOccupiedOr m -> Right m) - -instance (Choice p, Applicative f) => AsOccupied p f (WinOccupiedOr w a) where - _Occupied = - _OccupiedOr . _Occupied - -instance (Choice p, Applicative f) => AsOr p f (WinOccupiedOr w) where - _Or = - _OccupiedOr . _Or diff --git a/projects/TicTacToe/haskell/src/TicTacToe/Winpaths.hs b/projects/TicTacToe/haskell/src/TicTacToe/Winpaths.hs deleted file mode 100644 index 778379fd7..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/Winpaths.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module TicTacToe.Winpaths( - Winpaths(winpaths) -, hasWin -) where - -import Control.Category((.)) -import Control.Lens((#)) -import Data.Bool(Bool) -import Data.Eq((==)) -import Data.Foldable(any, sum) -import Data.Functor(fmap) -import Data.Int(Int) -import TicTacToe.Position(Position, _Position, magic) - -class Winpaths w where - winpaths :: - w - -> [(Position, Position)] - -hasWin :: - Winpaths w => - Position - -> w - -> Bool -hasWin p m = - any (\(p2, p3) -> sum (fmap (_Position . magic #) [p, p2, p3]) == (15 :: Int)) (winpaths m) diff --git a/projects/TicTacToe/haskell/src/TicTacToe/WithPosition.hs b/projects/TicTacToe/haskell/src/TicTacToe/WithPosition.hs deleted file mode 100644 index 72b52388e..000000000 --- a/projects/TicTacToe/haskell/src/TicTacToe/WithPosition.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - -module TicTacToe.WithPosition( - WithPosition((-->)) -) where - -import Control.Category((.)) -import Control.Monad((>>=)) -import TicTacToe.Position(Position) -import TicTacToe.MoveOr(Move2Or(Move2Or), Move3Or(Move3Or), Move4Or(Move4Or), Move5Or(Move5Or), Move6Or(Move6Or), Move7Or(Move7Or), Move8Or(Move8Or), Move9Or(Move9Or), MoveOr6Or(MoveOr6OrWin5, MoveOr6Or), MoveOr7Or(MoveOr7OrWin5, MoveOr7OrWin6, MoveOr7Or), MoveOr8Or(MoveOr8OrWin5, MoveOr8OrWin6, MoveOr8OrWin7, MoveOr8Or), MoveOr9Or(MoveOr9OrWin5, MoveOr9OrWin6, MoveOr9OrWin7, MoveOr9OrWin8, MoveOr9Or)) -import Control.Lens(( # )) -import TicTacToe.Move(Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, start, move2, move3, move4, move5, move6, move7, move8, move9) -import TicTacToe.OccupiedOr(OccupiedOr(Occupied, Or), AsOccupiedOr(_OccupiedOr)) -import TicTacToe.AsOr(AsOr(_Or)) -import TicTacToe.WinOccupiedOr(WinOccupiedOr(IsOccupiedOr, Win)) - -class WithPosition f g | f -> g where - (-->) :: - Position - -> f - -> g - -infixr 6 --> - -instance WithPosition () Move1 where - p --> () = - start p - -instance WithPosition Move1 Move2Or where - p --> m = - Move2Or (move2 p m) - -instance WithPosition Move2Or Move3Or where - p --> Move2Or m = - Move3Or (m >>= move3 p) - -instance WithPosition Move2 Move3Or where - (-->) p = - (-->) p . Move2Or . (#) _Or - -instance WithPosition Move3Or Move4Or where - p --> Move3Or m = - Move4Or (m >>= move4 p) - -instance WithPosition Move3 Move4Or where - (-->) p = - (-->) p . Move3Or . (#) _Or - -instance WithPosition Move4Or Move5Or where - p --> Move4Or m = - Move5Or ((_OccupiedOr # m) >>= move5 p) - -instance WithPosition Move4 Move5Or where - (-->) p = - (-->) p . Move4Or . (#) _Or - -instance WithPosition Move5Or MoveOr6Or where - _ --> Move5Or (Win w) = - MoveOr6OrWin5 w - _ --> Move5Or (IsOccupiedOr Occupied) = - MoveOr6Or (Move6Or (IsOccupiedOr Occupied)) - p --> Move5Or (IsOccupiedOr (Or m)) = - MoveOr6Or (p --> m) - -instance WithPosition Move5 Move6Or where - p --> m = - Move6Or (move6 p m) - -instance WithPosition Move6 Move7Or where - p --> m = - Move7Or (move7 p m) - -instance WithPosition Move6Or MoveOr7Or where - _ --> Move6Or (Win w) = - MoveOr7OrWin6 w - _ --> Move6Or (IsOccupiedOr Occupied) = - MoveOr7Or (Move7Or (IsOccupiedOr Occupied)) - p --> Move6Or (IsOccupiedOr (Or m)) = - MoveOr7Or (p --> m) - -instance WithPosition MoveOr6Or MoveOr7Or where - _ --> MoveOr6OrWin5 w = - MoveOr7OrWin5 w - p --> MoveOr6Or m = - p --> m - -instance WithPosition Move7 Move8Or where - p --> m = - Move8Or (move8 p m) - -instance WithPosition Move7Or MoveOr8Or where - _ --> Move7Or (Win w) = - MoveOr8OrWin7 w - _ --> Move7Or (IsOccupiedOr Occupied) = - MoveOr8Or (Move8Or (IsOccupiedOr Occupied)) - p --> Move7Or (IsOccupiedOr (Or m)) = - MoveOr8Or (p --> m) - -instance WithPosition MoveOr7Or MoveOr8Or where - _ --> MoveOr7OrWin5 w = - MoveOr8OrWin5 w - _ --> MoveOr7OrWin6 w = - MoveOr8OrWin6 w - p --> MoveOr7Or m = - p --> m - -instance WithPosition Move8 Move9Or where - p --> m = - Move9Or (move9 p m) - -instance WithPosition Move8Or MoveOr9Or where - _ --> Move8Or (Win w) = - MoveOr9OrWin8 w - _ --> Move8Or (IsOccupiedOr Occupied) = - MoveOr9Or (Move9Or (IsOccupiedOr Occupied)) - p --> Move8Or (IsOccupiedOr (Or m)) = - MoveOr9Or (p --> m) - -instance WithPosition MoveOr8Or MoveOr9Or where - _ --> MoveOr8OrWin5 w = - MoveOr9OrWin5 w - _ --> MoveOr8OrWin6 w = - MoveOr9OrWin6 w - _ --> MoveOr8OrWin7 w = - MoveOr9OrWin7 w - p --> MoveOr8Or m = - p --> m diff --git a/projects/TicTacToe/haskell/test/.gitignore b/projects/TicTacToe/haskell/test/.gitignore deleted file mode 100644 index 4c8920aaa..000000000 --- a/projects/TicTacToe/haskell/test/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -# cabal -/dist - -# cabal-dev -/cabal-dev - -# Haskell Program Coverage -/.hpc diff --git a/projects/TicTacToe/haskell/test/doctests.hs b/projects/TicTacToe/haskell/test/doctests.hs deleted file mode 100644 index 6f6b78c86..000000000 --- a/projects/TicTacToe/haskell/test/doctests.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: - IO () -main = - getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/projects/TicTacToe/haskell/tictactoe.cabal b/projects/TicTacToe/haskell/tictactoe.cabal deleted file mode 100644 index c08e18362..000000000 --- a/projects/TicTacToe/haskell/tictactoe.cabal +++ /dev/null @@ -1,106 +0,0 @@ -name: tictactoe -version: 0.1.0 -license: BSD3 -license-file: LICENSE -author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> -maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> -copyright: Copyright (C) 2010-2013 Tony Morris -copyright: Copyright (C) 2012-2015 NICTA Limited -synopsis: A model of the game of Tic-Tac-Toe -category: Data -description: - <> - . - A model of the game of Tic-Tac-Toe enforcing game properties with types - -homepage: https://github.com/NICTA/course -bug-reports: https://github.com/NICTA/course/issues -cabal-version: >= 1.10 -build-type: Custom -extra-source-files: changelog - -source-repository head - type: git - location: git@github.com:NICTA/course.git - -flag small_base - description: Choose the new, split-up base package. - -library - default-language: - Haskell2010 - - build-depends: - base >= 4 && < 5 - , lens >= 4 && < 5 - , tagged >= 0.8 && < 0.9 - - ghc-options: - -Wall - - default-extensions: - NoImplicitPrelude - - hs-source-dirs: - src - - exposed-modules: - TicTacToe - TicTacToe.AsOccupied - TicTacToe.AsOr - TicTacToe.AsWin - TicTacToe.Back - TicTacToe.Draw - TicTacToe.Move - TicTacToe.MoveOr - TicTacToe.Player - TicTacToe.Position - TicTacToe.OccupiedOr - TicTacToe.WinOccupiedOr - TicTacToe.Winpaths - TicTacToe.WithPosition - -executable tictactoe - default-language: - Haskell2010 - - build-depends: - base >= 4 && < 5 - , lens >= 4 && < 5 - , tagged >= 0.8 && < 0.9 - , ansi-terminal - - hs-source-dirs: - src - - main-is: - TicTacToe/Console.hs - - ghc-options: - -Wall - - -test-suite doctests - type: - exitcode-stdio-1.0 - - main-is: - doctests.hs - - default-language: - Haskell2010 - - build-depends: - base < 5 && >= 3 - , doctest >= 0.9.7 - , filepath >= 1.3 - , directory >= 1.1 - , QuickCheck >= 2.0 - , template-haskell >= 2.8 - - ghc-options: - -Wall - -threaded - - hs-source-dirs: - test diff --git a/projects/TicTacToe/idris/TicTacToe.idr b/projects/TicTacToe/idris/TicTacToe.idr deleted file mode 100644 index f1454df62..000000000 --- a/projects/TicTacToe/idris/TicTacToe.idr +++ /dev/null @@ -1,220 +0,0 @@ --- idris v0.12.1 -module Main - -import Data.So -import Data.Vect - -%default total - --- A player is either an X or an O -data Player = X | O - -Show Player where - show X = "X" - show O = "O" - -Eq Player where - X == X = True - O == O = True - _ == _ = False - --- A grid is a Vect of 3 rows, which are each Vects of 3 cells -Grid : Type -Grid = Vect 3 (Vect 3 (Maybe Player)) - --- Given x < 3 and y < 3, get the cell at (x,y) -get : Grid - -> (x : Fin 3) - -> (y : Fin 3) - -> Maybe Player -get g x y = index x (index y g) - --- Given x < 3 and y < 3, update the cell at (x,y) -set : Grid - -> (x : Fin 3) - -> (y : Fin 3) - -> Maybe Player - -> Grid -set g x y a = replaceAt y (replaceAt x a $ index y g) g - --- A game of tic tac toe is either won by a player, or drawn -data Result = Draw | Win Player - --- A game is always either in play or finished. If a game is finished, it will have a result -data Status = InPlay | Finished Result - --- Is the cell at (x,y) occupied? -occupied : Grid -> Fin 3 -> Fin 3 -> Bool -occupied g x y = case get g x y of - Nothing => False - _ => True - --- A position on the board --- Lifts x and y to type level allow them to be used in proofs -data Position : Fin 3 -> Fin 3 -> Type where - MkPosition : (x : Fin 3) -> (y : Fin 3) -> Position x y - -toggle : Player -> Player -toggle X = O -toggle O = X - --- A board consists of a Grid, the current Player, and the number of moves played --- --- A valid empty board can always be constructed --- The result of a turn is only valid if the previous board was valid, and the Position --- to play at was not occupied -data Board : Grid -> Player -> Nat -> Type where - NewBoard : Board (replicate 3 (replicate 3 Nothing)) X 0 - Turn : Board g p m - -> Position x y - -> {notOccupied : So (not (occupied g x y))} - -> Board (set g x y (Just p)) (toggle p) (S m) - --- A board has a previous state if it was contructed with Turn -data HasPrevious : Board g p m -> Type where - MkHasPrevious : HasPrevious (Turn b pos) - --- Determine the status of a Board -status : Board g p m -> Status -status b {g} {m} = case choice . map winner $ conditions g of - Nothing => if m == 9 - then Finished Draw - else InPlay - Just p => Finished $ Win p - where - -- Win conditions - conditions : Grid -> List (Vect 3 (Maybe Player)) - conditions g = let g' = sequence g in [ - index 0 g -- First row of g - , index 1 g -- Second row of g - , index 2 g -- Third row of g - , index 0 g' -- First column of g (first row of transpose of g) - , index 1 g' -- Second column of g (second row of transpose of g) - , index 2 g' -- Third column of g (third row of transpose of g) - , [get g 0 0, get g 1 1, get g 2 2] -- Top left to bottom right - , [get g 2 0, get g 1 1, get g 0 2] -- Bottom left to top right - ] - - winner : Vect 3 (Maybe Player) -> Maybe Player - winner (Nothing :: b :: c ::[]) = Nothing - winner (a :: b :: c ::[]) = if a == b && b == c then a else Nothing - --- Lift a valid Board to a Game and calculate the Status of the Game -data Game : Board g p m -> Status -> Type where - MkGame : (b : Board g p m) -> Game b (status b) - --- --- API Functions --- - --- Cannot be called on a game that is Finished, and cannot be called with a position --- that is occpuied --- --- Returns a new Game which has a Status that is known at runtime -move : {b : Board g p m} - -> Game b InPlay - -> (pos : Position x y) - -> {notOccupied : So (not (occupied g x y))} - -> (s' : Status ** Game (Turn b pos {notOccupied=notOccupied}) s') -move game pos {b} {notOccupied} = (_ ** MkGame (Turn b pos {notOccupied=notOccupied})) - --- Can only be called on a game that is Finshed -whoWon : Game b (Finished res) -> Result -whoWon game {res} = res - --- Can be called on any Game -playerAt : {b : Board g p m} -> Game b s -> Position x y -> Maybe Player -playerAt game (MkPosition x y) {g} = get g x y - --- Can only be called on a Game that is Finished and has exactly 9 moves played -isDraw : {b : Board g p 9} -> Game b (Finished res) -> Bool -isDraw game {res = Draw} = True -isDraw game {res = (Win x)} = False - --- Can only be called on a Game that has a previous state --- --- Returns a Board that has a Grid, Player and number of moves that are known at runtime -takeMoveBack : (b : Board g p m) -> {hasPrev : HasPrevious b} -> (g' : Grid ** p' : Player ** m' : Nat ** Board g' p' m') -takeMoveBack (Turn b pos) {hasPrev=MkHasPrevious} = (_ ** _ ** _ ** b) - -data Command = Place (x : Fin 3 ** y : Fin 3 ** Position x y) - | Back - -parseInput : String -> Either String Command -parseInput str = case str of - "tl" => Right . Place $ (_ ** _ ** MkPosition 0 0) - "tc" => Right . Place $ (_ ** _ ** MkPosition 1 0) - "tr" => Right . Place $ (_ ** _ ** MkPosition 2 0) - "ml" => Right . Place $ (_ ** _ ** MkPosition 0 1) - "mc" => Right . Place $ (_ ** _ ** MkPosition 1 1) - "mr" => Right . Place $ (_ ** _ ** MkPosition 2 1) - "bl" => Right . Place $ (_ ** _ ** MkPosition 0 2) - "bc" => Right . Place $ (_ ** _ ** MkPosition 1 2) - "br" => Right . Place $ (_ ** _ ** MkPosition 2 2) - "back" => Right Back - _ => Left "Invalid command" - -showGrid : Grid -> String -showGrid (t :: m :: b :: []) = "\n" ++ showRow t ++ "\n\n" ++ showRow m ++ "\n\n" ++ showRow b ++ "\n" - where - showCell : Maybe Player -> String - showCell Nothing = "-" - showCell (Just p) = show p - - showRow : Vect 3 (Maybe Player) -> String - showRow (l :: c :: r :: []) = showCell l ++ " " ++ showCell c ++ " " ++ showCell r - --- Proof that NewBoard does not have a previous state -Uninhabited (HasPrevious NewBoard) where - uninhabited MkHasPrevious impossible - --- Decide if a Board has a previous state and return the proof -decHasPrevious : (b : Board g p m) -> Dec (HasPrevious b) -decHasPrevious NewBoard = No uninhabited -decHasPrevious (Turn z w) = Yes MkHasPrevious - -mutual - partial - runGame : {b : Board g p m} -> Game b InPlay -> IO Result - runGame game {g} = do - putStrLn $ showGrid g - getInput game - - partial - gameStep : {b' : Board g' p' m'} -> (s' : Status ** Game b' s') -> IO Result - gameStep (InPlay ** game) = runGame game - gameStep {g'} (Finished x ** game) = do - putStrLn $ showGrid g' - return x - - partial - getInput : {b : Board g p m} -> Game b InPlay -> IO Result - getInput game {b} {g} {p} = do - putStr $ show p ++ "> " - input <- getLine - case parseInput input of - Right (Place (x ** y ** pos)) => case choose $ occupied g x y of - Right prf => do - putStrLn "" - gameStep $ move game pos {notOccupied=prf} - Left _ => do - putStrLn "That position is occupied" - getInput game - Right Back => case decHasPrevious b of - Yes prf => let (_ ** _ ** _ ** b') = takeMoveBack b {hasPrev=prf} in gameStep (_ ** MkGame b') - No _ => do - putStrLn "Can't go back" - getInput game - Left err => do - putStrLn err - getInput game - -showResult : Result -> String -showResult Draw = "The game was a draw." -showResult (Win p) = show p ++ " won." - -partial -main : IO () -main = do - res <- runGame $ MkGame NewBoard - putStrLn $ showResult res diff --git a/projects/TicTacToe/java/src/tictactoe/Board.java b/projects/TicTacToe/java/src/tictactoe/Board.java deleted file mode 100644 index 3d2f01632..000000000 --- a/projects/TicTacToe/java/src/tictactoe/Board.java +++ /dev/null @@ -1,185 +0,0 @@ -package tictactoe; - -import fj.*; -import fj.data.List; -import fj.data.Option; -import fj.data.TreeMap; - -import static fj.P.p; -import static fj.data.List.list; -import static fj.data.List.nil; -import static fj.data.Option.none; -import static tictactoe.GameResult.Draw; -import static tictactoe.GameResult.win; -import static tictactoe.Player.Player1; -import static tictactoe.Player.toSymbol; -import static tictactoe.Position.*; - -public final class Board extends BoardLike { - private final List> moves; - private final TreeMap m; - - private static final Ord positionOrder = Ord.comparableOrd(); - - private Board(final List> moves, final TreeMap m) { - this.moves = moves; - this.m = m; - } - - public Player whoseTurn() { - return moves.head()._2().alternate(); - } - - public boolean isEmpty() { - return false; - } - - public List occupiedPositions() { - return m.keys(); - } - - public int nmoves() { - return m.size(); - } - - public Option playerAt(Position p) { - return m.get(p); - } - - public TakenBack takeBack() { - return moves.isEmpty() ? - TakenBack.isEmpty() : - TakenBack.isBoard(new Board(moves.tail(), m.delete(moves.head()._1()))); - } - - @SuppressWarnings("unchecked") - public MoveResult moveTo(final Position p) { - final Player wt = whoseTurn(); - final Option j = m.get(p); - final TreeMap mm = m.set(p, wt); - final Board bb = new Board(moves.cons(P.p(p, wt)), mm); - final List> wins = - list( - P.p(NW, W, SW) - , P.p(N, C, S) - , P.p(NE, E, SE) - , P.p(NW, N, NE) - , P.p(W, C, E) - , P.p(SW, S, SE) - , P.p(NW, C, SE) - , P.p(SW, C, NE) - ); - final boolean isWin = wins.exists(new F, Boolean>() { - public Boolean f(final P3 abc) { - return list(abc._1(), abc._2(), abc._3()).mapMOption(mm.get()).exists(new F, Boolean>() { - public Boolean f(final List ps) { - return ps.allEqual(Equal.anyEqual()); - } - }); - } - }); - - final boolean isDraw = Position.positions().forall(new F() { - public Boolean f(final Position p) { - return m.contains(p); - } - }); - - return j.isSome() ? - MoveResult.positionAlreadyOccupied() : - isWin ? - MoveResult.gameOver(new FinishedBoard(bb, GameResult.win(wt))) : - isDraw ? - MoveResult.gameOver(new FinishedBoard(bb, Draw)) : - MoveResult.keepPlaying(bb); - } - - @Override - public String toString() { - return toString(new F2, Position, Character>() { - public Character f(final Option p, final Position _) { - return p.option(P.p(' '), toSymbol); - } - }) + "\n[ " + whoseTurn().toString() + " to move ]"; - } - - public static final class EmptyBoard extends BoardLike { - private EmptyBoard() {} - - @SuppressWarnings("unchecked") - public Board moveTo(final Position p) { - return new Board(list(p(p, Player1)), TreeMap.empty(positionOrder).set(p, Player1)); - } - - private static final EmptyBoard e = new EmptyBoard(); - public static EmptyBoard empty() { - return e; - } - - public Player whoseTurn() { - return Player1; - } - - public boolean isEmpty() { - return true; - } - - public List occupiedPositions() { - return nil(); - } - - public int nmoves() { - return 0; - } - - public Option playerAt(Position p) { - return none(); - } - } - - public static final class FinishedBoard extends BoardLike { - private final Board b; - private final GameResult r; - - private FinishedBoard(final Board b, final GameResult r) { - this.b = b; - this.r = r; - } - - public Board takeBack() { - return b.takeBack().fold( - Bottom.error_("Broken invariant: board in-play with empty move list. This is a program bug") - , Function.identity() - ); - } - - public Player whoseTurn() { - return b.whoseTurn(); - } - - public boolean isEmpty() { - return false; - } - - public List occupiedPositions() { - return b.occupiedPositions(); - } - - public int nmoves() { - return b.nmoves(); - } - - public Option playerAt(final Position p) { - return b.playerAt(p); - } - - public GameResult result() { - return r; - } - - @Override - public String toString() { - return b.toString() + "\n[[" + r.toString() + " ]]"; - } - } -} diff --git a/projects/TicTacToe/java/src/tictactoe/BoardLike.java b/projects/TicTacToe/java/src/tictactoe/BoardLike.java deleted file mode 100644 index 6fa22cd0d..000000000 --- a/projects/TicTacToe/java/src/tictactoe/BoardLike.java +++ /dev/null @@ -1,53 +0,0 @@ -package tictactoe; - -import fj.F; -import fj.F2; -import fj.P1; -import fj.data.List; -import fj.data.Option; - -import static fj.Monoid.stringMonoid; -import static fj.data.List.list; -import static tictactoe.Position.*; - -public abstract class BoardLike { - public abstract Player whoseTurn(); - public final Player whoseNotTurn() { - return whoseTurn().alternate(); - } - public abstract boolean isEmpty(); - public abstract List occupiedPositions(); - public abstract int nmoves(); - public abstract Option playerAt(Position p); - public final Player playerAtOr(final Position p, final P1 or) { - return playerAt(p).orSome(or); - } - public final boolean isOccupied(final Position p) { - return playerAt(p).isSome(); - } - public final boolean isNotOccupied(final Position p) { - return !isOccupied(p); - } - public final String toString(final F2, Position, Character> f) { - final String z = ".===.===.===."; - final F k = new F() { - public String f(final Position p) { - return f.f(playerAt(p), p).toString(); - } - }; - - - final List i = - list( - z - , stringMonoid.sumLeft().f(list("| ", k.f(NW), " | ", k.f(N ), " | ", k.f(NE), " |")) - , z - , stringMonoid.sumLeft().f(list("| ", k.f( W), " | ", k.f(C ), " | ", k.f( E), " |")) - , z - , stringMonoid.sumLeft().f(list("| ", k.f(SW), " | ", k.f(S ), " | ", k.f(SE), " |")) - , z - ).intersperse("\n"); - - return stringMonoid.sumLeft().f(i); - } -} diff --git a/projects/TicTacToe/java/src/tictactoe/GameResult.java b/projects/TicTacToe/java/src/tictactoe/GameResult.java deleted file mode 100644 index 4c10cb684..000000000 --- a/projects/TicTacToe/java/src/tictactoe/GameResult.java +++ /dev/null @@ -1,50 +0,0 @@ -package tictactoe; - -import fj.F; -import fj.data.Option; - -import static fj.data.Option.some; -import static tictactoe.Player.Player1; -import static tictactoe.Player.Player2; - -public enum GameResult { - Player1Wins, Player2Wins, Draw; - - public boolean isWin() { - return this == Player1Wins || this == Player2Wins; - } - - public boolean isDraw() { - return !isWin(); - } - - public Option winner() { - return this == Player1Wins ? - some(Player1) : - this == Player2Wins ? - some(Player2) : - Option.none(); - } - - public X strictFold(final X player1Wins, final X player2Wins, final X draw) { - return this == Player1Wins ? - player1Wins : - this == Player2Wins ? - player2Wins : - draw; - } - - @Override - public String toString() { - return winner().option("draw", new F() { - @Override - public String f(final Player p) { - return p.toString() + " wins"; - } - }); - } - - public static GameResult win(final Player p) { - return p == Player1 ? Player1Wins : Player2Wins; - } -} diff --git a/projects/TicTacToe/java/src/tictactoe/Main.java b/projects/TicTacToe/java/src/tictactoe/Main.java deleted file mode 100644 index 0c037f605..000000000 --- a/projects/TicTacToe/java/src/tictactoe/Main.java +++ /dev/null @@ -1,163 +0,0 @@ -package tictactoe; - -import fj.*; -import fj.data.Option; - -import static fj.Unit.unit; -import static fj.data.Option.some; -import static java.lang.System.out; - -public final class Main { - private Main() {} - - private static void surround(P1 e) { - out.println(); - out.println(); - e._1(); - out.println(); - } - - private static void printBoard(final F inheritance, final B b, final F empty) { - surround(new P1() { - public Unit _1() { - out.println(inheritance.f(b).toString(new F2, Position, Character>() { - public Character f(final Option pl, final Position pos) { - return pl.option(empty.f(pos), Player.toSymbol); - } - })); - return unit(); - } - }); - } - - private static void printBoardSpaces(final F inheritance, final B b) { - printBoard(inheritance, b, Function.constant(' ')); - } - - private static Option readChar() { - final String line = System.console().readLine(); - return line.isEmpty() ? Option.none() : some(line.charAt(0)); - } - - private static void gameLoop(final F inheritance, final F2 move, final B b) { - final Player p = inheritance.f(b).whoseTurn(); - out.println(p + " to move [" + p.toSymbol() + "]"); - out.println(" [1-9] to Move"); - out.println(" q to Quit"); - out.println(" v to view board positions"); - out.print(" > "); - - readChar().option(new P1() { - public Unit _1() { - out.println("Please make a selection."); - gameLoop(inheritance, move, b); - return unit(); - } - }, new F() { - public Unit f(final Character c) { - if(c == 'v' || c == 'V') { - printBoard(inheritance, b, Position.toChar); - gameLoop(inheritance, move, b); - return unit(); - } else { - return Position.fromChar(c).option(new P1() { - public Unit _1() { - if(c == 'q' || c == 'Q') - out.println("Bye!"); - else { - out.println("Invalid selection. Please try again."); - gameLoop(inheritance, move, b); - } - return unit(); - } - }, new F() { - public Unit f(final Position d) { - return move.f(d, b); - } - }); - } - } - }); - - } - - private static final F boardInheritance = new F() { - public BoardLike f(final Board board) { - return board; - } - }; - - private static final F finishedBoardInheritance = new F() { - public BoardLike f(final Board.FinishedBoard board) { - return board; - } - }; - - private static final F emptyBoardInheritance = new F() { - public BoardLike f(final Board.EmptyBoard board) { - return board; - } - }; - - private static void tictactoeBoard(final Board b) { - gameLoop(boardInheritance, new F2() { - public Unit f(final Position p, final Board bb) { - return bb.moveTo(p).fold( - new P1() { - public Unit _1() { - out.println("That position is already taken. Try again."); - printBoardSpaces(boardInheritance, bb); - out.println(); - tictactoeBoard(bb); - return unit(); - } - } - , new F() { - public Unit f(final Board bbb) { - surround(new P1() { - public Unit _1() { - printBoardSpaces(boardInheritance, bbb); - return unit(); - } - }); - tictactoeBoard(bbb); - return unit(); - } - } - , new F() { - public Unit f(final Board.FinishedBoard bbb) { - surround(new P1() { - public Unit _1() { - printBoardSpaces(finishedBoardInheritance, bbb); - out.println(bbb.result().strictFold("Player 1 Wins!", "Player 2 Wins!", "Draw")); - return unit(); - } - }); - return unit(); - } - } - ); - } - }, b); - } - - public static void main(final String... args) { - gameLoop( - emptyBoardInheritance - , new F2() { - public Unit f(final Position p, final Board.EmptyBoard b) { - final Board bb = b.moveTo(p); - surround(new P1() { - public Unit _1() { - printBoardSpaces(boardInheritance, bb); - return unit(); - } - }); - tictactoeBoard(bb); - return unit(); - } - } - , Board.EmptyBoard.empty() - ); - } -} diff --git a/projects/TicTacToe/java/src/tictactoe/MoveResult.java b/projects/TicTacToe/java/src/tictactoe/MoveResult.java deleted file mode 100644 index 1603a614a..000000000 --- a/projects/TicTacToe/java/src/tictactoe/MoveResult.java +++ /dev/null @@ -1,59 +0,0 @@ -package tictactoe; - -import fj.F; -import fj.Function; -import fj.P; -import fj.P1; -import fj.data.Option; - -import static fj.P.p; - -public abstract class MoveResult { - private MoveResult() {} - - public abstract X fold(P1 positionAlreadyOccupied, F keepPlaying, F gameOver); - - public Option keepPlaying() { - return fold( - p(Option.none()) - , Option.some_() - , Function.>constant(Option.none()) - ); - } - - public A keepPlayingOr(final P1 els, final F board) { - return keepPlaying().option(els, board); - } - - public MoveResult tryMove(final Position p) { - return keepPlayingOr(P.p(this), new F() { - public MoveResult f(final Board board) { - return board.moveTo(p); - } - }); - } - - public static MoveResult positionAlreadyOccupied() { - return new MoveResult() { - public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { - return positionAlreadyOccupied._1(); - } - }; - } - - public static MoveResult keepPlaying(final Board b) { - return new MoveResult() { - public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { - return keepPlaying.f(b); - } - }; - } - - public static MoveResult gameOver(final Board.FinishedBoard b) { - return new MoveResult() { - public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { - return gameOver.f(b); - } - }; - } -} diff --git a/projects/TicTacToe/java/src/tictactoe/Player.java b/projects/TicTacToe/java/src/tictactoe/Player.java deleted file mode 100644 index bd1d5cfd8..000000000 --- a/projects/TicTacToe/java/src/tictactoe/Player.java +++ /dev/null @@ -1,26 +0,0 @@ -package tictactoe; - -import fj.F; - -public enum Player { - Player1, Player2; - - public Player alternate() { - return this == Player1 ? Player2 : Player1; - } - - public char toSymbol() { - return this == Player1 ? 'X' : 'O'; - } - - @Override - public String toString() { - return this == Player1 ? "Player 1" : "Player 2"; - } - - public static final F toSymbol = new F() { - public Character f(final Player p) { - return p.toSymbol(); - } - }; -} diff --git a/projects/TicTacToe/java/src/tictactoe/Position.java b/projects/TicTacToe/java/src/tictactoe/Position.java deleted file mode 100644 index 5cd95c01b..000000000 --- a/projects/TicTacToe/java/src/tictactoe/Position.java +++ /dev/null @@ -1,50 +0,0 @@ -package tictactoe; - -import fj.F; -import fj.data.List; -import fj.data.Option; - -import static fj.data.List.list; -import static fj.data.Option.none; -import static fj.data.Option.some; - -public enum Position { - NW, N, NE, W, C, E, SW, S, SE; - - public int toInt() { - return ordinal() + 1; - } - - public char toChar() { - return (char)(toInt() + '0'); - } - - public static List positions() { - return list(NW, N, NE, W, C, E, SW, S, SE); - } - - public static Option fromInt(final int n) { - switch(n) { - case 1: return some(NW); - case 2: return some(N ); - case 3: return some(NE); - case 4: return some(W ); - case 5: return some(C ); - case 6: return some(E ); - case 7: return some(SW); - case 8: return some(S); - case 9: return some(SE); - default: return none(); - } - } - - public static Option fromChar(final char c) { - return fromInt(c - 48); - } - - public final static F toChar = new F() { - public Character f(final Position p) { - return p.toChar(); - } - }; -} diff --git a/projects/TicTacToe/java/src/tictactoe/TakenBack.java b/projects/TicTacToe/java/src/tictactoe/TakenBack.java deleted file mode 100644 index 83d09e32f..000000000 --- a/projects/TicTacToe/java/src/tictactoe/TakenBack.java +++ /dev/null @@ -1,26 +0,0 @@ -package tictactoe; - -import fj.F; -import fj.P1; - -public abstract class TakenBack { - private TakenBack() {} - - public abstract X fold(P1 isEmpty, F isBoard); - - public static TakenBack isEmpty() { - return new TakenBack() { - public X fold(final P1 isEmpty, final F isBoard) { - return isEmpty._1(); - } - }; - } - - public static TakenBack isBoard(final Board b) { - return new TakenBack() { - public X fold(final P1 isEmpty, final F isBoard) { - return isBoard.f(b); - } - }; - } -} diff --git a/projects/TicTacToe/java/tictactoe.iml b/projects/TicTacToe/java/tictactoe.iml deleted file mode 100644 index 87fe15f9a..000000000 --- a/projects/TicTacToe/java/tictactoe.iml +++ /dev/null @@ -1,14 +0,0 @@ - - - - - - - - - - - - - - diff --git a/projects/TicTacToe/scala/TicTacToe.scala b/projects/TicTacToe/scala/TicTacToe.scala deleted file mode 100644 index 84fe23fbf..000000000 --- a/projects/TicTacToe/scala/TicTacToe.scala +++ /dev/null @@ -1,370 +0,0 @@ -import collection.immutable.{Map => M} - -sealed trait Position { - def toInt = this match { - case NW => 1 - case N => 2 - case NE => 3 - case W => 4 - case C => 5 - case E => 6 - case SW => 7 - case S => 8 - case SE => 9 - } - - def toChar: Char = (toInt + '0'.toInt).toChar -} -case object N extends Position -case object NE extends Position -case object E extends Position -case object SE extends Position -case object S extends Position -case object SW extends Position -case object W extends Position -case object NW extends Position -case object C extends Position - -object Position { - def positions = Set(N, NE, E, SE, S, SW, W, NW, C) - - def fromInt(n: Int) = n match { - case 1 => Some(NW) - case 2 => Some(N ) - case 3 => Some(NE) - case 4 => Some(W ) - case 5 => Some(C ) - case 6 => Some(E ) - case 7 => Some(SW) - case 8 => Some(S ) - case 9 => Some(SE) - case _ => None - } - - def fromChar(c: Char) = fromInt(c.toInt - 48) -} - -sealed trait Player { - def isPlayer1 = this == Player1 - def isPlayer2 = !isPlayer1 - - def alternate = if(isPlayer1) Player2 else Player1 - - def toSymbol = if(isPlayer1) 'X' else 'O' - - override def toString = if(isPlayer1) "Player 1" else "Player 2" -} -case object Player1 extends Player -case object Player2 extends Player - -sealed trait GameResult { - def isWin = this == Player1Wins || this == Player2Wins - def isDraw = !isWin - def winner = this match { - case Player1Wins => Some(Player1) - case Player2Wins => Some(Player2) - case Draw => None - } - - override def toString = winner match { - case Some(p) => p.toString + " wins" - case None => "draw" - } -} -case object Player1Wins extends GameResult -case object Player2Wins extends GameResult -case object Draw extends GameResult - -object GameResult { - def win(p: Player) = - p match { - case Player1 => Player1Wins - case Player2 => Player2Wins - } -} - -sealed trait EmptyBoard extends BoardLike { - def -->(p: Position): Board = MapBoard(List((p, Player1)), Map((p, Player1))) - - def whoseTurn = Player1 - def isEmpty = true - def nmoves = 0 - def occupiedPositions = Set.empty - - def playerAt(p: Position) = None - -} -private case object EmptyBoardB extends EmptyBoard - -object EmptyBoard { - def empty: EmptyBoard = EmptyBoardB -} - -trait BoardLike { - def whoseTurn: Player - def whoseNotTurn: Player = whoseTurn.alternate - def isEmpty: Boolean - def occupiedPositions: collection.Set[Position] - def nmoves: Int - def playerAt(p: Position): Option[Player] - def playerAtOr(p: Position, pl: => Player) = playerAt(p) getOrElse pl - def isOccupied(p: Position): Boolean = playerAt(p).isDefined - def isNotOccupied(p: Position) = !isOccupied(p) - def toString(f: (Option[Player], Position) => Char) = { - val z = ".===.===.===." - def k(p: Position) = f(playerAt(p), p).toString - - List( - z - , List("| ", k(NW), " | ", k(N), " | ", k(NE), " |").mkString - , z - , List("| ", k( W), " | ", k(C), " | ", k( E), " |").mkString - , z - , List("| ", k(SW), " | ", k(S), " | ", k(SE), " |").mkString - , z - ) mkString "\n" - } -} - -sealed trait TakenBack { - def fold[X](isEmpty: => X, isBoard: Board => X): X -} - -object TakenBack { - def isEmpty: TakenBack = new TakenBack { - def fold[X](isEmpty: => X, isBoard: Board => X) = isEmpty - } - - def isBoard(b: Board): TakenBack = new TakenBack { - def fold[X](isEmpty: => X, isBoard: Board => X) = isBoard(b) - } -} - -sealed trait Board extends BoardLike { - private def moves = this match { - case MapBoard(x, _) => x - } - - private def map = this match { - case MapBoard(_, x) => x - } - - def takeBack = moves match { - case Nil => TakenBack.isEmpty - case (p, _) :: t => TakenBack.isBoard(Board.board(t, map - p)) - } - - def isEmpty = false - - def occupiedPositions = map.keySet - - def nmoves = map.size - - def playerAt(p: Position) = map get p - - def whoseTurn = moves.head._2.alternate - - def -->(p: Position): MoveResult = { - val j = map get p - val mm = map + ((p, whoseTurn)) - val bb = Board.board((p, whoseTurn) :: moves, mm) - val wins = List( - (NW, W , SW) - , (N , C , S ) - , (NE, E , SE) - , (NW, N , NE) - , (W , C , E ) - , (SW, S , SE) - , (NW, C , SE) - , (SW, C , NE) - ) - - def allEq[A](x: List[A]): Boolean = x match { - case d :: e :: t => d == e && allEq(e::t) - case _ => true - } - - // Dammit Scala and your missing libraries. - // This is not Java where inadequacy is the norm. Stop copying the losers! - def mapMOption[A, B](f: A => Option[B], as: List[A]): Option[List[B]] = - as.map(f).foldRight[Option[List[B]]](Some(Nil))((o, z) => - for(oo <- o; - zz <- z) - yield oo :: zz) - - val isWin = wins exists { - case (a, b, c) => mapMOption((p: Position) => mm get p, List(a, b, c)) exists (allEq(_)) - } - - val isDraw = Position.positions forall (mm contains _) - - j match { - case Some(_) => MoveResult.positionAlreadyOccupied - case None => if(isWin) MoveResult.gameOver(FinishedBoardB(bb, GameResult.win(whoseTurn))) - else if(isDraw) MoveResult.gameOver(FinishedBoardB(bb, Draw)) - else MoveResult.keepPlaying(bb) - } - } - - override def toString = toString((p, _) => p match { - case None => ' ' - case Some(p) => p.toSymbol - }) + "\n" + List("[ ", whoseTurn.toString, " to move ]").mkString -} -private final case class MapBoard(moves: List[(Position, Player)], m: collection.immutable.Map[Position, Player]) extends Board - -object Board { - private def board(moves: List[(Position, Player)], m: M[Position, Player]): Board = - MapBoard(moves, m) - - def empty = board(Nil, Map.empty) -} - -sealed trait FinishedBoard extends BoardLike { - private def board = - this match { - case FinishedBoardB(b, _) => b - } - - def result = - this match { - case FinishedBoardB(_, r) => r - } - - def takeBack = board.takeBack.fold( - sys.error("Broken invariant: board in-play with empty move list. This is a program bug") - , b => b) - - def whoseTurn = board.whoseTurn - - def isEmpty = board.isEmpty - - def nmoves = board.nmoves - - def occupiedPositions = board.occupiedPositions - - def playerAt(p: Position) = board playerAt p - - override def toString = board.toString + "\n" + List("[[ ", result.toString, " ]]").mkString -} - -private final case class FinishedBoardB(b: Board, r: GameResult) extends FinishedBoard - -sealed trait MoveResult { - def fold[X](positionAlreadyOccupied: => X, - keepPlaying: Board => X, - gameOver: FinishedBoard => X): X = - this match { - case PositionAlreadyOccupied => positionAlreadyOccupied - case KeepPlaying(b) => keepPlaying(b) - case GameOver(b) => gameOver(b) - } - - def keepPlaying: Option[Board] = fold(None, Some(_), _ => None) - - def keepPlayingOr[A](els: => A, board: Board => A): A = keepPlaying match { - case None => els - case Some(b) => board(b) - } - - def -?->(p: Position): MoveResult = keepPlayingOr(this, _ --> p) -} -private case object PositionAlreadyOccupied extends MoveResult -private case class KeepPlaying(b: Board) extends MoveResult -private case class GameOver(b: FinishedBoard) extends MoveResult - -object MoveResult { - def positionAlreadyOccupied: MoveResult = PositionAlreadyOccupied - def keepPlaying(b: Board): MoveResult = KeepPlaying(b) - def gameOver(b: FinishedBoard): MoveResult = GameOver(b) -} - -object Main { - def main(args: Array[String]) { - def surround(e: => Unit) { - println - println - e - println - } - - def printBoard[B](inheritance: B => BoardLike, b: B, empty: Position => Char = _ => ' ') = - surround(println(inheritance(b) toString ((pl, pos) => pl match { - case Some(z) => z.toSymbol - case None => empty(pos) - }))) - - // Scala's readChar is trivially broken. - def readChar: Option[Char] = { - val line = java.lang.System.console.readLine - if(line.isEmpty) None else Some(line(0)) - } - - @annotation.tailrec - def gameLoop[B]( - inheritance: B => BoardLike - , move: (Position, B) => Unit - , b: B) { - - val p = inheritance(b).whoseTurn - List( - p + " to move [" + p.toSymbol + "]" - , " [1-9] to Move" - , " q to Quit" - , " v to view board positions" - ) foreach println - print(" > ") - - readChar match { - case None => { - println("Please make a selection.") - gameLoop(inheritance, move, b) - } - case Some(c) => - if("vV" contains c) { - printBoard(inheritance, b, _.toChar) - gameLoop(inheritance, move, b) - } else Position.fromChar(c) match { - case None => if("qQ" contains c) println("Bye!") - else { - println("Invalid selection. Please try again.") - gameLoop(inheritance, move, b) - } - case Some(d) => move(d, b) - } - } - } - - def tictactoeBoard(b: Board) { - gameLoop[Board]( - v => v - , (p, bb) => bb --> p fold ( - { - println("That position is already taken. Try again.") - printBoard[Board](v => v, bb) - println - tictactoeBoard(bb) - } - , bbb => { - surround(printBoard[Board](v => v, bbb)) - tictactoeBoard(bbb) - } - , bbb => { - surround(printBoard[FinishedBoard](v => v, bbb)) - println(bbb.result match { - case Player1Wins => "Player 1 Wins!" - case Player2Wins => "Player 2 Wins!" - case Draw => "Draw" - }) - } - ) - , b) - } - - gameLoop[EmptyBoard](v => v, (p, b) => { - val bb = b --> p - surround(printBoard[Board](v => v, bb)) - tictactoeBoard(bb) - }, EmptyBoard.empty) - } -} diff --git a/shell.nix b/shell.nix new file mode 100644 index 000000000..f3c040aef --- /dev/null +++ b/shell.nix @@ -0,0 +1,7 @@ +{ nixpkgs ? import {}, compiler ? "default"}: +let + inherit (nixpkgs) pkgs; + drv = import ./default.nix { inherit nixpkgs compiler; }; + drvWithTools = pkgs.haskell.lib.addBuildDepends drv [ pkgs.cabal-install ]; +in + if pkgs.lib.inNixShell then drvWithTools.env else drvWithTools diff --git a/src/.ghci b/src/.ghci new file mode 120000 index 000000000..91065daa5 --- /dev/null +++ b/src/.ghci @@ -0,0 +1 @@ +Course/.ghci \ No newline at end of file diff --git a/src/Course.hs b/src/Course.hs index 5b07c8e62..1e03d4a5f 100644 --- a/src/Course.hs +++ b/src/Course.hs @@ -6,7 +6,7 @@ module Course (module X) where import Course.Anagrams as X import Course.Applicative as X import Course.Cheque as X -import Course.Comonad as X +import Course.Comonad as X (Comonad (..)) import Course.Compose as X import Course.Core as X import Course.ExactlyOne as X diff --git a/src/Course/.ghci b/src/Course/.ghci new file mode 100644 index 000000000..b41f1c38a --- /dev/null +++ b/src/Course/.ghci @@ -0,0 +1,3 @@ +:! echo -e "\033[0;31m\033[47mYOU ARE IN THE WRONG DIRECTORY\033[0m" +:set prompt "\ESC[1;40m\STX%s\n\ESC[0;41m\STXYOU ARE IN THE WRONG DIRECTORY> \ESC[m\STX" +kill \ No newline at end of file diff --git a/src/Course/Anagrams.hs b/src/Course/Anagrams.hs index 4cb57afd2..439113147 100644 --- a/src/Course/Anagrams.hs +++ b/src/Course/Anagrams.hs @@ -30,10 +30,10 @@ Functions that might help -- that appear in the given dictionary file. anagrams :: Chars - -> Filename + -> FilePath -> IO (List Chars) -anagrams name = - (<$>) (intersectBy equalIgnoringCase (permutations name) . lines) . readFile +anagrams = + error "todo: Course.Anagrams#anagrams" -- Compare two strings for equality, ignoring case equalIgnoringCase :: @@ -41,4 +41,4 @@ equalIgnoringCase :: -> Chars -> Bool equalIgnoringCase = - (==) `on` map toLower + error "todo: Course.Anagrams#equalIgnoringCase" diff --git a/src/Course/Applicative.hs b/src/Course/Applicative.hs index 1d84df4ec..de0facfb2 100644 --- a/src/Course/Applicative.hs +++ b/src/Course/Applicative.hs @@ -3,39 +3,30 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RebindableSyntax #-} -module Course.Applicative( - Applicative(..) -, lift2 -, lift3 -, lift4 -, (*>) -, (<*) -, sequence -, replicateA -, filtering -, return -, fail -, (>>) -) where +module Course.Applicative where import Course.Core import Course.ExactlyOne -import Course.Functor hiding ((<$>)) +import Course.Functor import Course.List import Course.Optional import qualified Prelude as P(fmap, return, (>>=)) --- | All instances of the `Applicative` type-class must satisfy three laws. +-- | All instances of the `Applicative` type-class must satisfy four laws. -- These laws are not checked by the compiler. These laws are given as: -- --- * The law of associative composition --- `∀a b c. ((.) <$> a <*> b <*> c) ≅ (a <*> (b <*> c))` +-- * The law of identity +-- `∀x. pure id <*> x = x` -- --- * The law of left identity --- `∀x. pure id <*> x ≅ x` +-- * The law of composition +-- `∀u v w. pure (.) <*> u <*> v <*> w = u <*> (v <*> w)` -- --- * The law of right identity --- `∀x. x <*> pure id ≅ x` +-- * The law of homomorphism +-- `∀f x. pure f <*> pure x = pure (f x)` +-- +-- * The law of interchange +-- `∀u y. u <*> pure y = pure ($ y) <*> u` + class Functor f => Applicative f where pure :: a -> f a @@ -46,27 +37,9 @@ class Functor f => Applicative f where infixl 4 <*> --- | Witness that all things with (<*>) and pure also have (<$>). --- --- >>> (+1) <$> (ExactlyOne 2) --- ExactlyOne 3 --- --- >>> (+1) <$> Nil --- [] --- --- >>> (+1) <$> (1 :. 2 :. 3 :. Nil) --- [2,3,4] -(<$>) :: - Applicative f => - (a -> b) - -> f a - -> f b -(<$>) = - (<*>) . pure - -- | Insert into ExactlyOne. -- --- prop> pure x == ExactlyOne x +-- prop> \x -> pure x == ExactlyOne x -- -- >>> ExactlyOne (+10) <*> ExactlyOne 8 -- ExactlyOne 18 @@ -75,17 +48,17 @@ instance Applicative ExactlyOne where a -> ExactlyOne a pure = - ExactlyOne - (<*>) :: + error "todo: Course.Applicative pure#instance ExactlyOne" + (<*>) :: ExactlyOne (a -> b) -> ExactlyOne a -> ExactlyOne b - ExactlyOne f <*> ExactlyOne a = - ExactlyOne (f a) + (<*>) = + error "todo: Course.Applicative (<*>)#instance ExactlyOne" -- | Insert into a List. -- --- prop> pure x == x :. Nil +-- prop> \x -> pure x == x :. Nil -- -- >>> (+1) :. (*2) :. Nil <*> 1 :. 2 :. 3 :. Nil -- [2,3,4,2,4,6] @@ -94,17 +67,17 @@ instance Applicative List where a -> List a pure = - (:. Nil) + error "todo: Course.Applicative pure#instance List" (<*>) :: List (a -> b) -> List a -> List b - f <*> a = - flatMap (`map` a) f + (<*>) = + error "todo: Course.Apply (<*>)#instance List" -- | Insert into an Optional. -- --- prop> pure x == Full x +-- prop> \x -> pure x == Full x -- -- >>> Full (+8) <*> Full 7 -- Full 15 @@ -119,13 +92,13 @@ instance Applicative Optional where a -> Optional a pure = - Full + error "todo: Course.Applicative pure#instance Optional" (<*>) :: Optional (a -> b) -> Optional a -> Optional b - f <*> a = - bindOptional (`mapOptional` a) f + (<*>) = + error "todo: Course.Apply (<*>)#instance Optional" -- | Insert into a constant function. -- @@ -144,19 +117,20 @@ instance Applicative Optional where -- >>> ((*) <*> (+2)) 3 -- 15 -- --- prop> pure x y == x +-- prop> \x y -> pure x y == x instance Applicative ((->) t) where pure :: a -> ((->) t a) pure = - const + error "todo: Course.Applicative pure#((->) t)" (<*>) :: ((->) t (a -> b)) -> ((->) t a) -> ((->) t b) - f <*> g = - \t -> f t (g t) + (<*>) = + error "todo: Course.Apply (<*>)#instance ((->) t)" + -- | Apply a binary function in the environment. -- @@ -183,10 +157,11 @@ lift2 :: -> f a -> f b -> f c -lift2 f a b = - f <$> a <*> b +lift2 = + error "todo: Course.Applicative#lift2" -- | Apply a ternary function in the environment. +-- /can be written using `lift2` and `(<*>)`./ -- -- >>> lift3 (\a b c -> a + b + c) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) -- ExactlyOne 24 @@ -215,10 +190,11 @@ lift3 :: -> f b -> f c -> f d -lift3 f a b c = - lift2 f a b <*> c +lift3 = + error "todo: Course.Applicative#lift3" -- | Apply a quaternary function in the environment. +-- /can be written using `lift3` and `(<*>)`./ -- -- >>> lift4 (\a b c d -> a + b + c + d) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) (ExactlyOne 10) -- ExactlyOne 34 @@ -248,8 +224,35 @@ lift4 :: -> f c -> f d -> f e -lift4 f a b c d = - lift3 f a b c <*> d +lift4 = + error "todo: Course.Applicative#lift4" + +-- | Apply a nullary function in the environment. +lift0 :: + Applicative f => + a + -> f a +lift0 = + error "todo: Course.Applicative#lift0" + +-- | Apply a unary function in the environment. +-- /can be written using `lift0` and `(<*>)`./ +-- +-- >>> lift1 (+1) (ExactlyOne 2) +-- ExactlyOne 3 +-- +-- >>> lift1 (+1) Nil +-- [] +-- +-- >>> lift1 (+1) (1 :. 2 :. 3 :. Nil) +-- [2,3,4] +lift1 :: + Applicative f => + (a -> b) + -> f a + -> f b +lift1 = + error "todo: Course.Applicative#lift1" -- | Apply, discarding the value of the first argument. -- Pronounced, right apply. @@ -266,16 +269,16 @@ lift4 f a b c d = -- >>> Full 7 *> Full 8 -- Full 8 -- --- prop> (a :. b :. c :. Nil) *> (x :. y :. z :. Nil) == (x :. y :. z :. x :. y :. z :. x :. y :. z :. Nil) +-- prop> \a b c x y z -> (a :. b :. c :. Nil) *> (x :. y :. z :. Nil) == (x :. y :. z :. x :. y :. z :. x :. y :. z :. Nil) -- --- prop> Full x *> Full y == Full y +-- prop> \x y -> Full x *> Full y == Full y (*>) :: Applicative f => f a -> f b -> f b (*>) = - lift2 (const id) + error "todo: Course.Applicative#(*>)" -- | Apply, discarding the value of the second argument. -- Pronounced, left apply. @@ -292,16 +295,16 @@ lift4 f a b c d = -- >>> Full 7 <* Full 8 -- Full 7 -- --- prop> (x :. y :. z :. Nil) <* (a :. b :. c :. Nil) == (x :. x :. x :. y :. y :. y :. z :. z :. z :. Nil) +-- prop> \x y z a b c -> (x :. y :. z :. Nil) <* (a :. b :. c :. Nil) == (x :. x :. x :. y :. y :. y :. z :. z :. z :. Nil) -- --- prop> Full x <* Full y == Full x +-- prop> \x y -> Full x <* Full y == Full x (<*) :: Applicative f => f b -> f a -> f b (<*) = - lift2 const + error "todo: Course.Applicative#(<*)" -- | Sequences a list of structures to a structure of list. -- @@ -324,10 +327,12 @@ sequence :: List (f a) -> f (List a) sequence = - foldRight (lift2 (:.)) (pure Nil) + error "todo: Course.Applicative#sequence" -- | Replicate an effect a given number of times. -- +-- /Tip:/ Use `Course.List#replicate`. +-- -- >>> replicateA 4 (ExactlyOne "hi") -- ExactlyOne ["hi","hi","hi","hi"] -- @@ -347,8 +352,8 @@ replicateA :: Int -> f a -> f (List a) -replicateA n = - sequence . replicate n +replicateA = + error "todo: Course.Applicative#replicateA" -- | Filter a list with a predicate that produces an effect. -- @@ -375,8 +380,8 @@ filtering :: (a -> f Bool) -> List a -> f (List a) -filtering p = - foldRight (\a -> lift2 (\b -> if b then (a:.) else id) (p a)) (pure Nil) +filtering = + error "todo: Course.Applicative#filtering" ----------------------- -- SUPPORT LIBRARIES -- diff --git a/src/Course/Cheque.hs b/src/Course/Cheque.hs index a83ffd88a..f880f2cd6 100644 --- a/src/Course/Cheque.hs +++ b/src/Course/Cheque.hs @@ -187,7 +187,7 @@ data Digit = | Seven | Eight | Nine - deriving (Eq, Enum, Bounded) + deriving (Eq, Ord) showDigit :: Digit @@ -247,82 +247,6 @@ fromChar '9' = fromChar _ = Empty -showDigit3 :: - Digit3 - -> List Char -showDigit3 d = - let showd x = toLower <$> showDigit x - x .++. y = x ++ if y == Zero then Nil else '-' :. showd y - in case d of - D1 a -> showd a - D2 Zero b -> showd b - D2 One b -> case b of - Zero -> "ten" - One -> "eleven" - Two -> "twelve" - Three -> "thirteen" - Four -> "fourteen" - Five -> "fifteen" - Six -> "sixteen" - Seven -> "seventeen" - Eight -> "eighteen" - Nine -> "nineteen" - D2 Two b -> "twenty" .++. b - D2 Three b -> "thirty" .++. b - D2 Four b -> "forty" .++. b - D2 Five b -> "fifty" .++. b - D2 Six b -> "sixty" .++. b - D2 Seven b -> "seventy" .++. b - D2 Eight b -> "eighty" .++. b - D2 Nine b -> "ninety" .++. b - D3 Zero Zero Zero -> "" - D3 Zero b c -> showDigit3 (D2 b c) - D3 a Zero Zero -> showd a ++ " hundred" - D3 a b c -> showd a ++ " hundred and " ++ showDigit3 (D2 b c) - -toDot :: - Chars - -> (List Digit, Chars) -toDot = - let toDot' x Nil = - (x, Nil) - toDot' x (h:.t) = - let move = case fromChar h of - Full n -> toDot' . (:.) n - Empty -> if h == '.' - then - (,) - else - toDot' - in move x t - in toDot' Nil - -illionate :: - List Digit - -> Chars -illionate = - let space "" = - "" - space x = - ' ' :. x - todigits acc _ Nil = - acc - todigits _ Nil _ = - error "unsupported illion" - todigits acc (_:.is) (Zero:.Zero:.Zero:.t) = - todigits acc is t - todigits acc (i:.is) (q:.r:.s:.t) = - todigits ((showDigit3 (D3 s r q) ++ space i) :. acc) is t - todigits acc (_:.is) (Zero:.Zero:.t) = - todigits acc is t - todigits acc (i:._) (r:.s:._) = - (showDigit3 (D2 s r) ++ space i) :. acc - todigits acc (_:.is) (Zero:.t) = - todigits acc is t - todigits acc (i:._) (s:._) = - (showDigit3 (D1 s) ++ space i) :. acc - in unwords . todigits Nil illion - -- | Take a numeric value and produce its English output. -- -- >>> dollars "0" @@ -399,17 +323,5 @@ illionate = dollars :: Chars -> Chars -dollars x = - let (d, c) = toDot (dropWhile (`notElem` ('.':.listh ['1'..'9'])) x) - c' = - case listOptional fromChar c of - Nil -> "zero cents" - (Zero:.One:.Nil) -> "one cent" - (a:.b:._) -> showDigit3 (D2 a b) ++ " cents" - (a:._) -> showDigit3 (D2 a Zero) ++ " cents" - d' = - case d of - Nil -> "zero dollars" - (One:.Nil) -> "one dollar" - _ -> illionate d ++ " dollars" - in d' ++ " and " ++ c' +dollars = + error "todo: Course.Cheque#dollars" diff --git a/src/Course/Comonad.hs b/src/Course/Comonad.hs index 6f3dd1055..e74fca7f6 100644 --- a/src/Course/Comonad.hs +++ b/src/Course/Comonad.hs @@ -2,10 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE InstanceSigs #-} -module Course.Comonad -( - Comonad(..) -) where +module Course.Comonad where import Course.Core import Course.ExactlyOne @@ -32,17 +29,17 @@ instance Comonad ExactlyOne where copure :: ExactlyOne a -> a - copure (ExactlyOne a) = - a + copure = + error "todo: Course.Comonad copure#instance ExactlyOne" -- | Witness that all things with (<<=) and copure also have (<$>). -- --- >>> (+10) <$> ExactlyOne 7 +-- >>> (+10) <$$> ExactlyOne 7 -- ExactlyOne 17 -(<$>) :: +(<$$>) :: Comonad f => (a -> b) -> f a -> f b -f <$> a = - f . copure <<= a +(<$$>) = + error "todo: Course.Comonad#(<$>)" diff --git a/src/Course/Compose.hs b/src/Course/Compose.hs index 52ffd4ecc..ad29e6c32 100644 --- a/src/Course/Compose.hs +++ b/src/Course/Compose.hs @@ -11,25 +11,25 @@ import Course.Monad -- Exactly one of these exercises will not be possible to achieve. Determine which. newtype Compose f g a = - Compose (f (g a)) + Compose (f (g a)) deriving (Show, Eq) -- Implement a Functor instance for Compose instance (Functor f, Functor g) => Functor (Compose f g) where - f <$> Compose g = - Compose ((f <$>) <$> g) + (<$>) = + error "todo: Course.Compose (<$>)#instance (Compose f g)" instance (Applicative f, Applicative g) => Applicative (Compose f g) where -- Implement the pure function for an Applicative instance for Compose pure = - Compose . pure . pure + error "todo: Course.Compose pure#instance (Compose f g)" -- Implement the (<*>) function for an Applicative instance for Compose - Compose f <*> Compose a = - Compose (lift2 (<*>) f a) + (<*>) = + error "todo: Course.Compose (<*>)#instance (Compose f g)" instance (Monad f, Monad g) => Monad (Compose f g) where -- Implement the (=<<) function for a Monad instance for Compose (=<<) = - error "impossible" + error "todo: Course.Compose (<<=)#instance (Compose f g)" diff --git a/src/Course/Core.hs b/src/Course/Core.hs index c31731bc0..c5185c28a 100644 --- a/src/Course/Core.hs +++ b/src/Course/Core.hs @@ -6,9 +6,7 @@ module Course.Core( Eq(..) , Ord(..) , Show(..) -, Enum(..) , Integral(..) -, Bounded(..) , RealFrac(..) , Num(..) , Fractional(..) @@ -53,9 +51,7 @@ import Prelude( Eq(..) , Ord(..) , Show(..) - , Enum(..) , Integral(..) - , Bounded(..) , RealFrac(..) , Num(..) , Fractional(..) diff --git a/src/Course/Extend.hs b/src/Course/Extend.hs index 6d90265cc..40b5be1eb 100644 --- a/src/Course/Extend.hs +++ b/src/Course/Extend.hs @@ -33,8 +33,8 @@ instance Extend ExactlyOne where (ExactlyOne a -> b) -> ExactlyOne a -> ExactlyOne b - f <<= i = - ExactlyOne (f i) + (<<=) = + error "todo: Course.Extend (<<=)#instance ExactlyOne" -- | Implement the @Extend@ instance for @List@. -- @@ -51,10 +51,8 @@ instance Extend List where (List a -> b) -> List a -> List b - _ <<= Nil = - Nil - f <<= x@(_:.t) = - f x :. (f <<= t) + (<<=) = + error "todo: Course.Extend (<<=)#instance List" -- | Implement the @Extend@ instance for @Optional@. -- @@ -68,8 +66,8 @@ instance Extend Optional where (Optional a -> b) -> Optional a -> Optional b - f <<= o = - f . Full <$> o + (<<=) = + error "todo: Course.Extend (<<=)#instance Optional" -- | Duplicate the functor using extension. -- @@ -89,4 +87,4 @@ cojoin :: f a -> f (f a) cojoin = - (<<=) id + error "todo: Course.Extend#cojoin" diff --git a/src/Course/FastAnagrams.hs b/src/Course/FastAnagrams.hs index 580d34e11..09f133d2e 100644 --- a/src/Course/FastAnagrams.hs +++ b/src/Course/FastAnagrams.hs @@ -12,10 +12,10 @@ import qualified Data.Set as S -- that appear in the given dictionary file. fastAnagrams :: Chars - -> Filename + -> FilePath -> IO (List Chars) -fastAnagrams name f = - (flip (filter . flip S.member) (permutations name) . S.fromList . hlist . lines) <$> readFile f +fastAnagrams = + error "todo: Course.FastAnagrams#fastAnagrams" newtype NoCaseString = NoCaseString { @@ -23,9 +23,7 @@ newtype NoCaseString = } instance Eq NoCaseString where - (==) = - (==) `on` (<$>) toLower . ncString + (==) = (==) `on` map toLower . ncString instance Show NoCaseString where - show = - show . ncString + show = show . ncString diff --git a/src/Course/FileIO.hs b/src/Course/FileIO.hs index 3b649c241..46312f379 100644 --- a/src/Course/FileIO.hs +++ b/src/Course/FileIO.hs @@ -17,7 +17,7 @@ Useful Functions -- getArgs :: IO (List Chars) putStrLn :: Chars -> IO () - readFile :: Chars -> IO Chars + readFile :: FilePath -> IO Chars lines :: Chars -> List Chars void :: IO a -> IO () @@ -26,11 +26,20 @@ Abstractions -- <$>, <*>, >>=, =<<, pure +Tuple Functions that could help -- + + fst :: (a, b) -> a + snd :: (a, b) -> b + (,) :: a -> b -> (a, b) + Problem -- Given a single argument of a file name, read that file, each line of that file contains the name of another file, read the referenced file and print out its name and contents. +Consideration -- + Try to avoid repetition. Factor out any common expressions. + Example -- Given file files.txt, containing: a.txt @@ -52,7 +61,7 @@ To test this module, load ghci in the root of the project directory, and do Example output: $ ghci -GHCi, version ... +GHCi, version ... Loading package... Loading ... [ 1 of 28] Compiling (etc... @@ -70,51 +79,56 @@ the contents of c -} --- /Tip:/ use @getArgs@ and @run@ -main :: - IO () -main = - getArgs >>= \args -> - case args of - filename :. Nil -> run filename - _ -> putStrLn "usage: runhaskell io.hs filename" - -type FilePath = - Chars - --- /Tip:/ Use @getFiles@ and @printFiles@. -run :: +-- Given the file name, and file contents, print them. +-- Use @putStrLn@. +printFile :: FilePath + -> Chars -> IO () -run filename = - do - content <- readFile filename - results <- getFiles (lines content) - printFiles results +printFile = + error "todo: Course.FileIO#printFile" -getFiles :: - List FilePath - -> IO (List (FilePath, Chars)) -getFiles = - sequence . (<$>) getFile +-- Given a list of (file name and file contents), print each. +-- Use @printFile@. +printFiles :: + List (FilePath, Chars) + -> IO () +printFiles = + error "todo: Course.FileIO#printFiles" +-- Given a file name, return (file name and file contents). +-- Use @readFile@. getFile :: FilePath -> IO (FilePath, Chars) getFile = - lift2 (<$>) (,) readFile + error "todo: Course.FileIO#getFile" -printFiles :: - List (FilePath, Chars) - -> IO () -printFiles = - void . sequence . (<$>) (uncurry printFile) +-- Given a list of file names, return list of (file name and file contents). +-- Use @getFile@. +getFiles :: + List FilePath + -> IO (List (FilePath, Chars)) +getFiles = + error "todo: Course.FileIO#getFiles" -printFile :: +-- Given a file name, read it and for each line in that file, read and print contents of each. +-- Use @getFiles@ and @printFiles@. +run :: FilePath - -> Chars -> IO () -printFile name content = - putStrLn ("============ " ++ name) >> - putStrLn content +run = + error "todo: Course.FileIO#run" + +-- /Tip:/ use @getArgs@ and @run@ +main :: + IO () +main = + error "todo: Course.FileIO#main" + +---- +-- Was there was some repetition in our solution? +-- ? `sequence . (<$>)` +-- ? `void . sequence . (<$>)` +-- Factor it out. diff --git a/src/Course/Functor.hs b/src/Course/Functor.hs index b5503fbc1..9ad73f5d2 100644 --- a/src/Course/Functor.hs +++ b/src/Course/Functor.hs @@ -42,7 +42,7 @@ instance Functor ExactlyOne where -> ExactlyOne a -> ExactlyOne b (<$>) = - mapExactlyOne + error "todo: Course.Functor (<$>)#instance ExactlyOne" -- | Maps a function on the List functor. -- @@ -57,7 +57,7 @@ instance Functor List where -> List a -> List b (<$>) = - map + error "todo: Course.Functor (<$>)#instance List" -- | Maps a function on the Optional functor. -- @@ -72,7 +72,7 @@ instance Functor Optional where -> Optional a -> Optional b (<$>) = - mapOptional + error "todo: Course.Functor (<$>)#instance Optional" -- | Maps a function on the reader ((->) t) functor. -- @@ -84,23 +84,23 @@ instance Functor ((->) t) where -> ((->) t a) -> ((->) t b) (<$>) = - (.) + error "todo: Course.Functor (<$>)#((->) t)" -- | Anonymous map. Maps a constant value on a functor. -- -- >>> 7 <$ (1 :. 2 :. 3 :. Nil) -- [7,7,7] -- --- prop> x <$ (a :. b :. c :. Nil) == (x :. x :. x :. Nil) +-- prop> \x a b c -> x <$ (a :. b :. c :. Nil) == (x :. x :. x :. Nil) -- --- prop> x <$ Full q == Full x +-- prop> \x q -> x <$ Full q == Full x (<$) :: Functor f => a -> f b -> f a (<$) = - (<$>) . const + error "todo: Course.Functor#(<$)" -- | Anonymous map producing unit value. -- @@ -120,7 +120,7 @@ void :: f a -> f () void = - (<$) () + error "todo: Course.Functor#void" ----------------------- -- SUPPORT LIBRARIES -- diff --git a/src/Course/Interactive.hs b/src/Course/Interactive.hs index 3e58d5b83..e19b48db1 100644 --- a/src/Course/Interactive.hs +++ b/src/Course/Interactive.hs @@ -83,10 +83,7 @@ data Op = convertInteractive :: IO () convertInteractive = - putStr "Enter a String to upper-case: " >- - getLine >>= \l -> - putStrLn (toUpper <$> l) >- - putStrLn "" + error "todo: Course.Interactive#convertInteractive" -- | -- @@ -114,13 +111,7 @@ convertInteractive = reverseInteractive :: IO () reverseInteractive = - putStr "Enter a file name to reverse: " >- - getLine >>= \infile -> - putStr "Enter a file name to output: " >- - getLine >>= \outfile -> - readFile infile >>= \i -> - writeFile outfile (reverse i) >- - putStrLn "" + error "todo: Course.Interactive#reverseInteractive" -- | -- @@ -146,19 +137,7 @@ reverseInteractive = encodeInteractive :: IO () encodeInteractive = - let encode :: - Chars - -> Chars - encode url = - url >>= \c -> case c of - ' ' -> "%20" - '\t' -> "%09" - '"' -> "%22" - _ -> c :. Nil - in putStr "Enter a URL to encode: " >- - getLine >>= \l -> - putStrLn (encode l) >- - putStrLn "" + error "todo: Course.Interactive#encodeInteractive" interactive :: IO () diff --git a/src/Course/JsonParser.hs b/src/Course/JsonParser.hs index 001509a4c..d55942ffa 100644 --- a/src/Course/JsonParser.hs +++ b/src/Course/JsonParser.hs @@ -79,7 +79,7 @@ toSpecialCharacter c = ('\\', Backslash) :. Nil in snd <$> find ((==) c . fst) table - + -- | Parse a JSON string. Handle double-quotes, special characters, hexadecimal characters. See http://json.org for the full list of control characters in JSON. -- -- /Tip:/ Use `hex`, `fromSpecialCharacter`, `between`, `is`, `charTok`, `toSpecialCharacter`. @@ -110,27 +110,7 @@ toSpecialCharacter c = jsonString :: Parser Chars jsonString = - let str = - do c1 <- character - if c1 == '\\' - then - do c2 <- character - if c2 == 'u' - then - hex - else - case toSpecialCharacter c2 of - Empty -> - unexpectedCharParser c2 - Full d -> - return (fromSpecialCharacter d) - else - if c1 == '"' - then - unexpectedCharParser '"' - else - return c1 - in between (is '"') (charTok '"') (list str) + error "todo: Course.JsonParser#jsonString" -- | Parse a JSON rational. -- @@ -159,9 +139,7 @@ jsonString = jsonNumber :: Parser Rational jsonNumber = - P (\i -> case readFloats i of - Empty -> ErrorResult Failed - Full (n, z) -> Result z n) + error "todo: Course.JsonParser#jsonNumber" -- | Parse a JSON true literal. -- @@ -175,7 +153,7 @@ jsonNumber = jsonTrue :: Parser Chars jsonTrue = - stringTok "true" + error "todo: Course.JsonParser#jsonTrue" -- | Parse a JSON false literal. -- @@ -189,7 +167,7 @@ jsonTrue = jsonFalse :: Parser Chars jsonFalse = - stringTok "false" + error "todo: Course.JsonParser#jsonFalse" -- | Parse a JSON null literal. -- @@ -203,7 +181,7 @@ jsonFalse = jsonNull :: Parser Chars jsonNull = - stringTok "null" + error "todo: Course.JsonParser#jsonNull" -- | Parse a JSON array. -- @@ -226,7 +204,7 @@ jsonNull = jsonArray :: Parser (List JsonValue) jsonArray = - betweenSepbyComma '[' ']' jsonValue + error "todo: Course.JsonParser#jsonArray" -- | Parse a JSON object. -- @@ -246,8 +224,7 @@ jsonArray = jsonObject :: Parser Assoc jsonObject = - let field = (,) <$> (jsonString <* charTok ':') <*> jsonValue - in betweenSepbyComma '{' '}' field + error "todo: Course.JsonParser#jsonObject" -- | Parse a JSON value. -- @@ -257,28 +234,20 @@ jsonObject = -- Result >< JsonTrue -- -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] }" --- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational False (7 % 1),JsonFalse])] +-- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational (7 % 1),JsonFalse])] -- -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] , \"key3\" : { \"key4\" : null } }" --- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational False (7 % 1),JsonFalse]),("key3",JsonObject [("key4",JsonNull)])] +-- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational (7 % 1),JsonFalse]),("key3",JsonObject [("key4",JsonNull)])] jsonValue :: Parser JsonValue jsonValue = - spaces *> - (JsonNull <$ jsonNull - ||| JsonTrue <$ jsonTrue - ||| JsonFalse <$ jsonFalse - ||| JsonArray <$> jsonArray - ||| JsonString <$> jsonString - ||| JsonObject <$> jsonObject - ||| JsonRational False <$> jsonNumber) + error "todo: Course.JsonParser#jsonValue" -- | Read a file into a JSON value. -- -- /Tip:/ Use @System.IO#readFile@ and `jsonValue`. readJsonValue :: - Filename + FilePath -> IO (ParseResult JsonValue) -readJsonValue p = - do c <- readFile p - pure (jsonValue `parse` c) +readJsonValue = + error "todo: Course.JsonParser#readJsonValue" diff --git a/src/Course/JsonValue.hs b/src/Course/JsonValue.hs index fcd61fd01..0e4a054f8 100644 --- a/src/Course/JsonValue.hs +++ b/src/Course/JsonValue.hs @@ -10,7 +10,7 @@ type Assoc = List (Chars, JsonValue) data JsonValue = JsonString Chars - | JsonRational Bool !Rational + | JsonRational Rational | JsonObject Assoc | JsonArray (List JsonValue) | JsonTrue diff --git a/src/Course/List.hs b/src/Course/List.hs index 3a549af75..866d1b290 100644 --- a/src/Course/List.hs +++ b/src/Course/List.hs @@ -40,7 +40,7 @@ data List t = infixr 5 :. instance Show t => Show (List t) where - show = show . foldRight (:) [] + show = show . hlist -- The list of integers from zero to infinity. infinity :: @@ -68,15 +68,15 @@ foldLeft f b (h :. t) = let b' = f b h in b' `seq` foldLeft f b' t -- >>> headOr 3 Nil -- 3 -- --- prop> x `headOr` infinity == 0 +-- prop> \x -> x `headOr` infinity == 0 -- --- prop> x `headOr` Nil == x +-- prop> \x -> x `headOr` Nil == x headOr :: a -> List a -> a headOr = - foldRight const + error "todo: Course.List#headOr" -- | The product of the elements of a list. -- @@ -92,7 +92,7 @@ product :: List Int -> Int product = - foldLeft (*) 1 + error "todo: Course.List#product" -- | Sum the elements of the list. -- @@ -102,75 +102,75 @@ product = -- >>> sum (1 :. 2 :. 3 :. 4 :. Nil) -- 10 -- --- prop> foldLeft (-) (sum x) x == 0 +-- prop> \x -> foldLeft (-) (sum x) x == 0 sum :: List Int -> Int sum = - foldLeft (+) 0 + error "todo: Course.List#sum" -- | Return the length of the list. -- -- >>> length (1 :. 2 :. 3 :. Nil) -- 3 -- --- prop> sum (map (const 1) x) == length x +-- prop> \x -> sum (map (const 1) x) == length x length :: List a -> Int length = - foldLeft (const . succ) 0 + error "todo: Course.List#length" -- | Map the given function on each element of the list. -- -- >>> map (+10) (1 :. 2 :. 3 :. Nil) -- [11,12,13] -- --- prop> headOr x (map (+1) infinity) == 1 +-- prop> \x -> headOr x (map (+1) infinity) == 1 -- --- prop> map id x == x +-- prop> \x -> map id x == x map :: (a -> b) -> List a -> List b -map f = - foldRight (\a b -> f a :. b) Nil +map = + error "todo: Course.List#map" -- | Return elements satisfying the given predicate. -- -- >>> filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) -- [2,4] -- --- prop> headOr x (filter (const True) infinity) == 0 +-- prop> \x -> headOr x (filter (const True) infinity) == 0 -- --- prop> filter (const True) x == x +-- prop> \x -> filter (const True) x == x -- --- prop> filter (const False) x == Nil +-- prop> \x -> filter (const False) x == Nil filter :: (a -> Bool) -> List a -> List a -filter f = - foldRight (\a -> if f a then (a:.) else id) Nil +filter = + error "todo: Course.List#filter" -- | Append two lists to a new list. -- -- >>> (1 :. 2 :. 3 :. Nil) ++ (4 :. 5 :. 6 :. Nil) -- [1,2,3,4,5,6] -- --- prop> headOr x (Nil ++ infinity) == 0 +-- prop> \x -> headOr x (Nil ++ infinity) == 0 -- --- prop> headOr x (y ++ infinity) == headOr 0 y +-- prop> \x -> headOr x (y ++ infinity) == headOr 0 y -- --- prop> (x ++ y) ++ z == x ++ (y ++ z) +-- prop> \x -> (x ++ y) ++ z == x ++ (y ++ z) -- --- prop> x ++ Nil == x +-- prop> \x -> x ++ Nil == x (++) :: List a -> List a -> List a (++) = - flip (foldRight (:.)) + error "todo: Course.List#(++)" infixr 5 ++ @@ -179,47 +179,47 @@ infixr 5 ++ -- >>> flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) -- [1,2,3,4,5,6,7,8,9] -- --- prop> headOr x (flatten (infinity :. y :. Nil)) == 0 +-- prop> \x -> headOr x (flatten (infinity :. y :. Nil)) == 0 -- --- prop> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y +-- prop> \x -> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y -- --- prop> sum (map length x) == length (flatten x) +-- prop> \x -> sum (map length x) == length (flatten x) flatten :: List (List a) -> List a flatten = - foldRight (++) Nil + error "todo: Course.List#flatten" -- | Map a function then flatten to a list. -- -- >>> flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) -- [1,2,3,2,3,4,3,4,5] -- --- prop> headOr x (flatMap id (infinity :. y :. Nil)) == 0 +-- prop> \x -> headOr x (flatMap id (infinity :. y :. Nil)) == 0 -- --- prop> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y +-- prop> \x -> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y -- --- prop> flatMap id (x :: List (List Int)) == flatten x +-- prop> \x -> flatMap id (x :: List (List Int)) == flatten x flatMap :: (a -> List b) -> List a -> List b -flatMap f = - flatten . map f +flatMap = + error "todo: Course.List#flatMap" -- | Flatten a list of lists to a list (again). -- HOWEVER, this time use the /flatMap/ function that you just wrote. -- --- prop> let types = x :: List (List Int) in flatten x == flattenAgain x +-- prop> \x -> let types = x :: List (List Int) in flatten x == flattenAgain x flattenAgain :: List (List a) -> List a flattenAgain = - flatMap id + error "todo: Course.List#flattenAgain" -- | Convert a list of optional values to an optional list of values. -- --- * If the list contains all `Full` values, +-- * If the list contains all `Full` values, -- then return `Full` list of values. -- -- * If the list contains one or more `Empty` values, @@ -243,7 +243,7 @@ seqOptional :: List (Optional a) -> Optional (List a) seqOptional = - foldRight (twiceOptional (:.)) (Full Nil) + error "todo: Course.List#seqOptional" -- | Find the first element in the list matching the predicate. -- @@ -265,10 +265,8 @@ find :: (a -> Bool) -> List a -> Optional a -find p x = - case filter p x of - Nil -> Empty - h:._ -> Full h +find = + error "todo: Course.List#find" -- | Determine if the length of the given list is greater than 4. -- @@ -286,10 +284,8 @@ find p x = lengthGT4 :: List a -> Bool -lengthGT4 (_:._:._:._:._:._) = - True -lengthGT4 _ = - False +lengthGT4 = + error "todo: Course.List#lengthGT4" -- | Reverse a list. -- @@ -299,14 +295,14 @@ lengthGT4 _ = -- >>> take 1 (reverse (reverse largeList)) -- [1] -- --- prop> let types = x :: List Int in reverse x ++ reverse y == reverse (y ++ x) +-- prop> \x -> let types = x :: List Int in reverse x ++ reverse y == reverse (y ++ x) -- --- prop> let types = x :: Int in reverse (x :. Nil) == x :. Nil +-- prop> \x -> let types = x :: Int in reverse (x :. Nil) == x :. Nil reverse :: List a -> List a reverse = - foldLeft (flip (:.)) Nil + error "todo: Course.List#reverse" -- | Produce an infinite `List` that seeds with the given value at its head, -- then runs the given function for subsequent elements @@ -328,84 +324,14 @@ produce f x = x :. produce f (f x) -- >>> notReverse Nil -- [] -- --- prop> let types = x :: List Int in notReverse x ++ notReverse y == notReverse (y ++ x) +-- prop> \x -> let types = x :: List Int in notReverse x ++ notReverse y == notReverse (y ++ x) -- --- prop> let types = x :: Int in notReverse (x :. Nil) == x :. Nil +-- prop> \x -> let types = x :: Int in notReverse (x :. Nil) == x :. Nil notReverse :: List a -> List a notReverse = - reverse -- impossible --- For the sake of discussion, let's assume that, --- xs, ys :: List a --- x, y :: a --- We are given the following properties --- notReverse xs ++ notReverse ys = notReverse (ys ++ xs) -- Eq. 1 --- notReverse (x :. Nil) = x :. Nil -- Eq. 2 --- --- Now, to define --- notReverse Nil, --- we, first, observe that --- notReverse (x :. Nil) ++ notReverse Nil -- Eq. 3 --- = notReverse (Nil ++ (x :. Nil)) -- using Eq. 1 --- = notReverse (x :. Nil) -- defn of (++) --- = x :. Nil -- using Eq. 2 --- --- And --- notReverse (x :. Nil) ++ notReverse Nil -- Eq. 4 --- = (x :. Nil) ++ notReverse Nil -- using Eq. 2 --- --- Since, the LHS of Eq. 3 and the LHS of Eq. 4 are the same, --- the RHS of Eq. 4 must be equal to the RHS of Eq. 3, i.e., --- (x :. Nil) ++ notReverse Nil = x :. Nil --- = (x :. Nil) ++ Nil -- defn of (++) --- => notReverse Nil = Nil -- Eq. 5 --- --- Next, we see that --- notReverse (x :. Nil) ++ notReverse (y :. Nil) -- Eq. 6 --- = notReverse ((y :. Nil) ++ (x :. Nil)) -- using Eq. 1 --- = notReverse (y :. x :. Nil) -- defn of (++) --- And that --- notReverse (x :. Nil) ++ notReverse (y :. Nil) -- Eq. 7 --- = (x :. Nil) ++ (y :. Nil) -- using Eq. 2 --- = x :. y :. Nil -- defn of (++) --- --- Again, since the LHS of both Eq. 6 and Eq 7. are the same, --- the RHS of Eq. 6 and 7 must be the same, i.e., --- notReverse (y :. x :. Nil) = x :. y :. Nil -- Eq. 8 --- Or, simply (using variable renaming), we get --- notReverse (x :. y :. Nil) = y :. x :. Nil -- Eq. 8' --- --- Now, we want to prove that Eq. 1 and Eq. 2 imply 'reverse', using --- mathematical induction. --- --- We note that --- notReverse Nil = Nil = reverse Nil -- using Eq. 5, defn of reverse --- notReverse (x :. Nil) = (x :. Nil) = reverse (x :. Nil) -- using Eq. 2, defn of reverse --- notReverse (x :. y :. Nil) = (y :. x :. Nil) -- using Eq. 1 --- = reverse (x :. y :. Nil) -- defn of reverse --- i.e., notReverse is equal to reverse for cases when 'List a' has 0, --- 1, and 2 elements. --- --- Assume that it is true when 'List a' has n (n > 0) elements, --- notReverse (x1 :. x2 :. ... :. xn :. Nil) -- Eq. 9 --- = (xn :. x{n-1} :. ... :. x1 :. Nil) --- = reverse (x1 :. x2 :. ... :. xn :. Nil) -- defn of reverse --- --- Now, --- notReverse (x1 :. x2 :. ... :. xn :. x{n+1} :. Nil) --- = notReverse ((x1 :. x2 :. ... :. xn :. Nil) ++ (x{n+1} :. Nil)) -- defn of (++) --- = notReverse (x{n+1} :. Nil) ++ notReverse ((x1 :. x2 :. ... :. xn :. Nil) -- using Eq. 1 --- = (x{n+1} :. Nil) ++ (xn :. x{n-1} :. ... :. x1 :. Nil) -- using Eq. 2, Eq. 9 (assumption) --- = (x{n+1} :. xn :. ... :. x1 :. Nil) -- defn of (++) --- = reverse (x1 :. x2 :. ... :. xn :. x{n+1} :. Nil) -- defn of reverse --- --- Since, --- - notReverse is equal to reverse for cases when 'List a' has 0, 1, and 2 --- elements, and --- - if we assume that it is true when 'List a' has n (for some n > 0) --- elements, it is also true when 'List a' has n+1 elements, --- by mathematical induction notReverse is equal to reverse for all n in [0 ..]. + error "todo: Is it even possible?" ---- End of list exercises @@ -439,13 +365,13 @@ putStrLn = P.putStrLn . hlist readFile :: - Filename + FilePath -> IO Chars readFile = P.fmap listh . P.readFile . hlist writeFile :: - Filename + FilePath -> Chars -> IO () writeFile n s = @@ -740,8 +666,8 @@ instance IsString (List Char) where type Chars = List Char -type Filename = - Chars +type FilePath = + List Char strconcat :: [Chars] @@ -763,8 +689,8 @@ show' = listh . show instance P.Functor List where - fmap = - M.liftM + fmap f = + listh . P.fmap f . hlist instance A.Applicative List where (<*>) = diff --git a/src/Course/ListZipper.hs b/src/Course/ListZipper.hs index 72830ed59..a533aebc5 100644 --- a/src/Course/ListZipper.hs +++ b/src/Course/ListZipper.hs @@ -64,18 +64,41 @@ data MaybeListZipper a = -- >>> (+1) <$> (zipper [3,2,1] 4 [5,6,7]) -- [4,3,2] >5< [6,7,8] instance Functor ListZipper where - f <$> (ListZipper l x r) = - ListZipper (f <$> l) (f x) (f <$> r) + (<$>) = + error "todo: Course.ListZipper (<$>)#instance ListZipper" -- | Implement the `Functor` instance for `MaybeListZipper`. -- -- >>> (+1) <$> (IsZ (zipper [3,2,1] 4 [5,6,7])) -- [4,3,2] >5< [6,7,8] instance Functor MaybeListZipper where - f <$> (IsZ z) = - IsZ (f <$> z) - _ <$> IsNotZ = - IsNotZ + (<$>) = + error "todo: Course.ListZipper (<$>)#instance MaybeListZipper" + +-- | Convert the given zipper back to a list. +-- +-- >>> toList <$> toOptional (fromList Nil) +-- Empty +-- +-- >>> toList (ListZipper Nil 1 (2:.3:.4:.Nil)) +-- [1,2,3,4] +-- +-- >>> toList (ListZipper (3:.2:.1:.Nil) 4 (5:.6:.7:.Nil)) +-- [1,2,3,4,5,6,7] +toList :: + ListZipper a + -> List a +toList = + error "todo: Course.ListZipper#toList" + +-- | Convert the given (maybe) zipper back to a list. +toListZ :: + MaybeListZipper a + -> List a +toListZ IsNotZ = + Nil +toListZ (IsZ z) = + toList z -- | Create a `MaybeListZipper` positioning the focus at the head. -- @@ -85,27 +108,23 @@ instance Functor MaybeListZipper where -- >>> fromList Nil -- >< -- --- prop> xs == toListZ (fromList xs) +-- prop> \xs -> xs == toListZ (fromList xs) fromList :: List a -> MaybeListZipper a -fromList Nil = - IsNotZ -fromList (h:.t) = - IsZ (ListZipper Nil h t) +fromList = + error "todo: Course.ListZipper#fromList" -- | Retrieve the `ListZipper` from the `MaybeListZipper` if there is one. -- --- prop> isEmpty xs == (toOptional (fromList xs) == Empty) +-- prop> \xs -> isEmpty xs == (toOptional (fromList xs) == Empty) -- --- prop> toOptional (fromOptional z) == z +-- prop> \z -> toOptional (fromOptional z) == z toOptional :: MaybeListZipper a -> Optional (ListZipper a) -toOptional IsNotZ = - Empty -toOptional (IsZ z) = - Full z +toOptional = + error "todo: Course.ListZipper#toOptional" zipper :: [a] @@ -153,31 +172,6 @@ asMaybeZipper f (IsZ z) = (-<<) = asMaybeZipper --- | Convert the given zipper back to a list. --- --- >>> toList <$> toOptional (fromList Nil) --- Empty --- --- >>> toList (ListZipper Nil 1 (2:.3:.4:.Nil)) --- [1,2,3,4] --- --- >>> toList (ListZipper (3:.2:.1:.Nil) 4 (5:.6:.7:.Nil)) --- [1,2,3,4,5,6,7] -toList :: - ListZipper a - -> List a -toList (ListZipper l x r) = - reverse l ++ x:.r - --- | Convert the given (maybe) zipper back to a list. -toListZ :: - MaybeListZipper a - -> List a -toListZ IsNotZ = - Nil -toListZ (IsZ z) = - toList z - -- | Update the focus of the zipper with the given function on the current focus. -- -- >>> withFocus (+1) (zipper [] 0 [1]) @@ -189,8 +183,8 @@ withFocus :: (a -> a) -> ListZipper a -> ListZipper a -withFocus f (ListZipper l x r) = - ListZipper l (f x) r +withFocus = + error "todo: Course.ListZipper#withFocus" -- | Set the focus of the zipper to the given value. -- /Tip:/ Use `withFocus`. @@ -205,7 +199,7 @@ setFocus :: -> ListZipper a -> ListZipper a setFocus = - withFocus . const + error "todo: Course.ListZipper#setFocus" -- A flipped infix alias for `setFocus`. This allows: -- @@ -227,8 +221,8 @@ setFocus = hasLeft :: ListZipper a -> Bool -hasLeft (ListZipper l _ _) = - not (isEmpty l) +hasLeft = + error "todo: Course.ListZipper#hasLeft" -- | Returns whether there are values to the right of focus. -- @@ -240,15 +234,15 @@ hasLeft (ListZipper l _ _) = hasRight :: ListZipper a -> Bool -hasRight (ListZipper _ _ r) = - not (isEmpty r) +hasRight = + error "todo: Course.ListZipper#hasRight" --- | Seek to the left for a location matching a predicate, starting from the --- current one. +-- | Seek to the left for a location matching a predicate, excluding the +-- focus. -- -- /Tip:/ Use `break` -- --- prop> findLeft (const p) -<< fromList xs == IsNotZ +-- prop> \xs p -> findLeft (const p) -<< fromList xs == IsNotZ -- -- >>> findLeft (== 1) (zipper [2, 1] 3 [4, 5]) -- [] >1< [2,3,4,5] @@ -261,23 +255,22 @@ hasRight (ListZipper _ _ r) = -- -- >>> findLeft (== 1) (zipper [1, 2, 1] 3 [4, 5]) -- [2,1] >1< [3,4,5] +-- +-- >>> findLeft (== 1) (zipper [3, 4, 1, 5] 9 [2, 7]) +-- [5] >1< [4,3,9,2,7] findLeft :: (a -> Bool) -> ListZipper a -> MaybeListZipper a -findLeft p (ListZipper ls x rs) = - case break p ls of - (_, Nil) -> - IsNotZ - (rs', x':.ls') -> - IsZ (ListZipper ls' x' (reverse rs' ++ x :. rs)) - --- | Seek to the right for a location matching a predicate, starting from the --- current one. +findLeft = + error "todo: Course.ListZipper#findLeft" + +-- | Seek to the right for a location matching a predicate, excluding the +-- focus. -- -- /Tip:/ Use `break` -- --- prop> findRight (const False) -<< fromList xs == IsNotZ +-- prop> \xs -> findRight (const False) -<< fromList xs == IsNotZ -- -- >>> findRight (== 5) (zipper [2, 1] 3 [4, 5]) -- [4,3,2,1] >5< [] @@ -294,12 +287,8 @@ findRight :: (a -> Bool) -> ListZipper a -> MaybeListZipper a -findRight p (ListZipper ls x rs) = - case break p rs of - (_, Nil) -> - IsNotZ - (ls', x':.rs') -> - IsZ (ListZipper (reverse ls' ++ x :. ls) x' rs') +findRight = + error "todo: Course.ListZipper#findRight" -- | Move the zipper left, or if there are no elements to the left, go to the far right. -- @@ -311,11 +300,8 @@ findRight p (ListZipper ls x rs) = moveLeftLoop :: ListZipper a -> ListZipper a -moveLeftLoop (ListZipper Nil x r) = - let (x':.r') = reverse (x:.r) - in ListZipper r' x' Nil -moveLeftLoop (ListZipper (h:.t) x r) = - ListZipper t h (x:.r) +moveLeftLoop = + error "todo: Course.ListZipper#moveLeftLoop" -- | Move the zipper right, or if there are no elements to the right, go to the far left. -- @@ -327,11 +313,8 @@ moveLeftLoop (ListZipper (h:.t) x r) = moveRightLoop :: ListZipper a -> ListZipper a -moveRightLoop (ListZipper l x Nil) = - let (x':.l') = reverse (x:.l) - in ListZipper Nil x' l' -moveRightLoop (ListZipper l x (h:.t)) = - ListZipper (x:.l) h t +moveRightLoop = + error "todo: Course.ListZipper#moveRightLoop" -- | Move the zipper one position to the left. -- @@ -343,10 +326,8 @@ moveRightLoop (ListZipper l x (h:.t)) = moveLeft :: ListZipper a -> MaybeListZipper a -moveLeft (ListZipper Nil _ _) = - IsNotZ -moveLeft (ListZipper (h:.t) x r) = - IsZ (ListZipper t h (x:.r)) +moveLeft = + error "todo: Course.ListZipper#moveLeft" -- | Move the zipper one position to the right. -- @@ -358,10 +339,8 @@ moveLeft (ListZipper (h:.t) x r) = moveRight :: ListZipper a -> MaybeListZipper a -moveRight (ListZipper _ _ Nil) = - IsNotZ -moveRight (ListZipper l x (h:.t)) = - IsZ (ListZipper (x:.l) h t) +moveRight = + error "todo: Course.ListZipper#moveRight" -- | Swap the current focus with the value to the left of focus. -- @@ -373,10 +352,8 @@ moveRight (ListZipper l x (h:.t)) = swapLeft :: ListZipper a -> MaybeListZipper a -swapLeft (ListZipper Nil _ _) = - IsNotZ -swapLeft (ListZipper (h:.t) x r) = - IsZ (ListZipper (x:.t) h r) +swapLeft = + error "todo: Course.ListZipper#swapLeft" -- | Swap the current focus with the value to the right of focus. -- @@ -388,10 +365,8 @@ swapLeft (ListZipper (h:.t) x r) = swapRight :: ListZipper a -> MaybeListZipper a -swapRight (ListZipper _ _ Nil) = - IsNotZ -swapRight (ListZipper l x (h:.t)) = - IsZ (ListZipper l h (x:.t)) +swapRight = + error "todo: Course.ListZipper#swapRight" -- | Drop all values to the left of the focus. -- @@ -401,12 +376,12 @@ swapRight (ListZipper l x (h:.t)) = -- >>> dropLefts (zipper [] 1 [2,3,4]) -- [] >1< [2,3,4] -- --- prop> dropLefts (zipper l x r) == zipper [] x r +-- prop> \l x r -> dropLefts (zipper l x r) == zipper [] x r dropLefts :: ListZipper a -> ListZipper a -dropLefts (ListZipper _ x r) = - ListZipper Nil x r +dropLefts = + error "todo: Course.ListZipper#dropLefts" -- | Drop all values to the right of the focus. -- @@ -416,12 +391,12 @@ dropLefts (ListZipper _ x r) = -- >>> dropRights (zipper [3,2,1] 4 []) -- [3,2,1] >4< [] -- --- prop> dropRights (zipper l x r) == zipper l x [] +-- prop> \l x r -> dropRights (zipper l x r) == zipper l x [] dropRights :: ListZipper a -> ListZipper a -dropRights (ListZipper l x _) = - ListZipper l x Nil +dropRights = + error "todo: Course.ListZipper#dropRights" -- | Move the focus left the given number of positions. If the value is negative, move right instead. -- @@ -434,12 +409,8 @@ moveLeftN :: Int -> ListZipper a -> MaybeListZipper a -moveLeftN n z | n == 0 = - IsZ z -moveLeftN n z | n < 0 = - moveRightN (negate n) z -moveLeftN n z = - moveLeftN (pred n) -<< moveLeft z +moveLeftN = + error "todo: Course.ListZipper#moveLeftN" -- | Move the focus right the given number of positions. If the value is negative, move left instead. -- @@ -452,12 +423,8 @@ moveRightN :: Int -> ListZipper a -> MaybeListZipper a -moveRightN n z | n == 0 = - IsZ z -moveRightN n z | n < 0 = - moveLeftN (negate n) z -moveRightN n z = - moveRightN (pred n) -<< moveRight z +moveRightN = + error "todo: Course.ListZipper#moveRightN" -- | Move the focus left the given number of positions. If the value is negative, move right instead. -- If the focus cannot be moved, the given number of times, return the value by which it can be moved instead. @@ -486,15 +453,8 @@ moveLeftN' :: Int -> ListZipper a -> Either Int (ListZipper a) -moveLeftN' n z = - let moveLeftN'' n' z' q - | n' == 0 = Right z' - | n' < 0 = moveRightN' (negate n') z - | otherwise = - case moveLeft z' of - IsZ zz -> moveLeftN'' (n' - 1) zz (q + 1) - IsNotZ -> Left q - in moveLeftN'' n z 0 +moveLeftN' = + error "todo: Course.ListZipper#moveLeftN'" -- | Move the focus right the given number of positions. If the value is negative, move left instead. -- If the focus cannot be moved, the given number of times, return the value by which it can be moved instead. @@ -517,15 +477,8 @@ moveRightN' :: Int -> ListZipper a -> Either Int (ListZipper a) -moveRightN' n z = - let moveRightN'' n' z' q - | n' == 0 = Right z' - | n' < 0 = moveLeftN' (negate n') z - | otherwise = - case moveRight z' of - IsZ zz -> moveRightN'' (n' - 1) zz (q + 1) - IsNotZ -> Left q - in moveRightN'' n z 0 +moveRightN' = + error "todo: Course.ListZipper#moveRightN'" -- | Move the focus to the given absolute position in the zipper. Traverse the zipper only to the extent required. -- @@ -541,58 +494,48 @@ nth :: Int -> ListZipper a -> MaybeListZipper a -nth i z = - if i < 0 - then - IsNotZ - else - case moveLeftN' i z of - Left a -> moveRightN (i-a) z - Right (ListZipper l _ _) -> moveLeftN (length l) z +nth = + error "todo: Course.ListZipper#nth" -- | Return the absolute position of the current focus in the zipper. -- -- >>> index (zipper [3,2,1] 4 [5,6,7]) -- 3 -- --- prop> optional True (\z' -> index z' == i) (toOptional (nth i z)) +-- prop> \i z -> optional True (\z' -> index z' == i) (toOptional (nth i z)) index :: ListZipper a -> Int -index (ListZipper l _ _) = - length l +index = + error "todo: Course.ListZipper#index" -- | Move the focus to the end of the zipper. -- -- >>> end (zipper [3,2,1] 4 [5,6,7]) -- [6,5,4,3,2,1] >7< [] -- --- prop> toList lz == toList (end lz) +-- prop> \lz -> toList lz == toList (end lz) -- --- prop> rights (end lz) == Nil +-- prop> \lz -> rights (end lz) == Nil end :: ListZipper a -> ListZipper a -end z = - case moveRight z of - IsNotZ -> z - IsZ z' -> end z' +end = + error "todo: Course.ListZipper#end" -- | Move the focus to the start of the zipper. -- -- >>> start (zipper [3,2,1] 4 [5,6,7]) -- [] >1< [2,3,4,5,6,7] -- --- prop> toList lz == toList (start lz) +-- prop> \lz -> toList lz == toList (start lz) -- --- prop> lefts (start lz) == Nil +-- prop> \lz -> lefts (start lz) == Nil start :: ListZipper a -> ListZipper a -start z = - case moveLeft z of - IsNotZ -> z - IsZ z' -> start z' +start = + error "todo: Course.ListZipper#start" -- | Delete the current focus and pull the left values to take the empty position. -- @@ -604,10 +547,8 @@ start z = deletePullLeft :: ListZipper a -> MaybeListZipper a -deletePullLeft (ListZipper Nil _ _) = - IsNotZ -deletePullLeft (ListZipper (h:.t) _ r) = - IsZ (ListZipper t h r) +deletePullLeft = + error "todo: Course.ListZipper#deletePullLeft" -- | Delete the current focus and pull the right values to take the empty position. -- @@ -619,10 +560,8 @@ deletePullLeft (ListZipper (h:.t) _ r) = deletePullRight :: ListZipper a -> MaybeListZipper a -deletePullRight (ListZipper _ _ Nil) = - IsNotZ -deletePullRight (ListZipper l _ (h:.t)) = - IsZ (ListZipper l h t) +deletePullRight = + error "todo: Course.ListZipper#deletePullRight" -- | Insert at the current focus and push the left values to make way for the new position. -- @@ -632,13 +571,13 @@ deletePullRight (ListZipper l _ (h:.t)) = -- >>> insertPushLeft 15 (zipper [] 1 [2,3,4]) -- [1] >15< [2,3,4] -- --- prop> optional False (==z) (toOptional (deletePullLeft (insertPushLeft i z))) +-- prop> \i z -> optional False (==z) (toOptional (deletePullLeft (insertPushLeft i z))) insertPushLeft :: a -> ListZipper a -> ListZipper a -insertPushLeft a (ListZipper l x r) = - ListZipper (x:.l) a r +insertPushLeft = + error "todo: Course.ListZipper#insertPushLeft" -- | Insert at the current focus and push the right values to make way for the new position. -- @@ -648,40 +587,40 @@ insertPushLeft a (ListZipper l x r) = -- >>> insertPushRight 15 (zipper [3,2,1] 4 []) -- [3,2,1] >15< [4] -- --- prop> optional False (==z) (toOptional (deletePullRight (insertPushRight i z))) +-- prop> \i z -> optional False (==z) (toOptional (deletePullRight (insertPushRight i z))) insertPushRight :: a -> ListZipper a -> ListZipper a -insertPushRight a (ListZipper l x r) = - ListZipper l a (x:.r) +insertPushRight = + error "todo: Course.ListZipper#insertPushRight" -- | Implement the `Applicative` instance for `ListZipper`. -- `pure` produces an infinite list zipper (to both left and right). -- (<*>) zips functions with values by function application. -- --- prop> all . (==) <*> take n . lefts . pure +-- prop> \n -> all . (==) <*> take n . lefts . pure -- --- prop> all . (==) <*> take n . rights . pure +-- prop> \n -> all . (==) <*> take n . rights . pure -- -- >>> zipper [(+2), (+10)] (*2) [(*3), (4*), (5+)] <*> zipper [3,2,1] 4 [5,6,7] -- [5,12] >8< [15,24,12] instance Applicative ListZipper where -- /Tip:/ Use @List#repeat@. - pure a = - ListZipper (repeat a) a (repeat a) + pure = + error "todo: Course.ListZipper pure#instance ListZipper" -- /Tip:/ Use `zipWith` - ListZipper fl fx fr <*> ListZipper al ax ar = - ListZipper (zipWith ($) fl al) (fx ax) (zipWith ($) fr ar) + (<*>) = + error "todo: Course.ListZipper (<*>)#instance ListZipper" -- | Implement the `Applicative` instance for `MaybeListZipper`. -- -- /Tip:/ Use @pure@ for `ListZipper`. -- /Tip:/ Use `<*>` for `ListZipper`. -- --- prop> let is (IsZ z) = z in all . (==) <*> take n . lefts . is . pure +-- prop> \z n -> let is (IsZ z) = z in all . (==) <*> take n . lefts . is . pure -- --- prop> let is (IsZ z) = z in all . (==) <*> take n . rights . is . pure +-- prop> \z n -> let is (IsZ z) = z in all . (==) <*> take n . rights . is . pure -- -- >>> IsZ (zipper [(+2), (+10)] (*2) [(*3), (4*), (5+)]) <*> IsZ (zipper [3,2,1] 4 [5,6,7]) -- [5,12] >8< [15,24,12] @@ -696,10 +635,9 @@ instance Applicative ListZipper where -- >< instance Applicative MaybeListZipper where pure = - IsZ . pure - IsNotZ <*> _ = IsNotZ - _ <*> IsNotZ = IsNotZ - IsZ f <*> IsZ a = IsZ (f <*> a) + error "todo: Course.ListZipper pure#instance MaybeListZipper" + (<*>) = + error "todo: Course.ListZipper (<*>)#instance MaybeListZipper" -- | Implement the `Extend` instance for `ListZipper`. -- This implementation "visits" every possible zipper value derivable from a given zipper (i.e. all zippers to the left and right). @@ -709,8 +647,8 @@ instance Applicative MaybeListZipper where -- >>> id <<= (zipper [2,1] 3 [4,5]) -- [[1] >2< [3,4,5],[] >1< [2,3,4,5]] >[2,1] >3< [4,5]< [[3,2,1] >4< [5],[4,3,2,1] >5< []] instance Extend ListZipper where - f <<= z = - ListZipper (unfoldr ((<$>) (\z' -> (f z', z')) . toOptional . moveLeft) z) (f z) (unfoldr ((<$>) (\z' -> (f z', z')) . toOptional . moveRight) z) + (<<=) = + error "todo: Course.ListZipper (<<=)#instance ListZipper" -- | Implement the `Extend` instance for `MaybeListZipper`. -- This instance will use the `Extend` instance for `ListZipper`. @@ -722,10 +660,8 @@ instance Extend ListZipper where -- >>> id <<= (IsZ (zipper [2,1] 3 [4,5])) -- [[1] >2< [3,4,5],[] >1< [2,3,4,5]] >[2,1] >3< [4,5]< [[3,2,1] >4< [5],[4,3,2,1] >5< []] instance Extend MaybeListZipper where - _ <<= IsNotZ = - IsNotZ - f <<= IsZ z = - IsZ (f . IsZ <<= z) + (<<=) = + error "todo: Course.ListZipper (<<=)#instance MaybeListZipper" -- | Implement the `Comonad` instance for `ListZipper`. -- This implementation returns the current focus of the zipper. @@ -733,8 +669,8 @@ instance Extend MaybeListZipper where -- >>> copure (zipper [2,1] 3 [4,5]) -- 3 instance Comonad ListZipper where - copure (ListZipper _ x _) = - x + copure = + error "todo: Course.ListZipper copure#instance ListZipper" -- | Implement the `Traversable` instance for `ListZipper`. -- This implementation traverses a zipper while running some `Applicative` effect through the zipper. @@ -746,8 +682,8 @@ instance Comonad ListZipper where -- >>> traverse id (zipper [Full 1, Full 2, Full 3] (Full 4) [Empty, Full 6, Full 7]) -- Empty instance Traversable ListZipper where - traverse f (ListZipper l x r) = - (ListZipper . reverse) <$> traverse f (reverse l) <*> f x <*> traverse f r + traverse = + error "todo: Course.ListZipper traverse#instance ListZipper" -- | Implement the `Traversable` instance for `MaybeListZipper`. -- @@ -759,10 +695,8 @@ instance Traversable ListZipper where -- >>> traverse id (IsZ (zipper [Full 1, Full 2, Full 3] (Full 4) [Full 5, Full 6, Full 7])) -- Full [1,2,3] >4< [5,6,7] instance Traversable MaybeListZipper where - traverse _ IsNotZ = - pure IsNotZ - traverse f (IsZ z) = - IsZ <$> traverse f z + traverse = + error "todo: Course.ListZipper traverse#instance MaybeListZipper" ----------------------- -- SUPPORT LIBRARIES -- diff --git a/src/Course/Monad.hs b/src/Course/Monad.hs index 6ecb4ea51..e637d9a3c 100644 --- a/src/Course/Monad.hs +++ b/src/Course/Monad.hs @@ -3,14 +3,9 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RebindableSyntax #-} -module Course.Monad( - Monad(..) -, join -, (>>=) -, (<=<) -) where - -import Course.Applicative hiding ((<*>)) +module Course.Monad where + +import Course.Applicative import Course.Core import Course.ExactlyOne import Course.Functor @@ -32,47 +27,6 @@ class Applicative f => Monad f where infixr 1 =<< --- | Witness that all things with (=<<) and (<$>) also have (<*>). --- --- >>> ExactlyOne (+10) <*> ExactlyOne 8 --- ExactlyOne 18 --- --- >>> (+1) :. (*2) :. Nil <*> 1 :. 2 :. 3 :. Nil --- [2,3,4,2,4,6] --- --- >>> Full (+8) <*> Full 7 --- Full 15 --- --- >>> Empty <*> Full 7 --- Empty --- --- >>> Full (+8) <*> Empty --- Empty --- --- >>> ((+) <*> (+10)) 3 --- 16 --- --- >>> ((+) <*> (+5)) 3 --- 11 --- --- >>> ((+) <*> (+5)) 1 --- 7 --- --- >>> ((*) <*> (+10)) 3 --- 39 --- --- >>> ((*) <*> (+2)) 3 --- 15 -(<*>) :: - Monad f => - f (a -> b) - -> f a - -> f b -f <*> a = - (\f' -> return . f' =<< a) =<< f - -infixl 4 <*> - -- | Binds a function on the ExactlyOne monad. -- -- >>> (\x -> ExactlyOne(x+1)) =<< ExactlyOne 2 @@ -82,8 +36,8 @@ instance Monad ExactlyOne where (a -> ExactlyOne b) -> ExactlyOne a -> ExactlyOne b - f =<< ExactlyOne a = - f a + (=<<) = + error "todo: Course.Monad (=<<)#instance ExactlyOne" -- | Binds a function on a List. -- @@ -95,7 +49,7 @@ instance Monad List where -> List a -> List b (=<<) = - flatMap + error "todo: Course.Monad (=<<)#instance List" -- | Binds a function on an Optional. -- @@ -107,7 +61,7 @@ instance Monad Optional where -> Optional a -> Optional b (=<<) = - bindOptional + error "todo: Course.Monad (=<<)#instance Optional" -- | Binds a function on the reader ((->) t). -- @@ -118,8 +72,49 @@ instance Monad ((->) t) where (a -> ((->) t b)) -> ((->) t a) -> ((->) t b) - f =<< g = - \t -> f (g t) t + (=<<) = + error "todo: Course.Monad (=<<)#instance ((->) t)" + +-- | Witness that all things with (=<<) and (<$>) also have (<*>). +-- +-- >>> ExactlyOne (+10) <**> ExactlyOne 8 +-- ExactlyOne 18 +-- +-- >>> (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil +-- [2,3,4,2,4,6] +-- +-- >>> Full (+8) <**> Full 7 +-- Full 15 +-- +-- >>> Empty <**> Full 7 +-- Empty +-- +-- >>> Full (+8) <**> Empty +-- Empty +-- +-- >>> ((+) <**> (+10)) 3 +-- 16 +-- +-- >>> ((+) <**> (+5)) 3 +-- 11 +-- +-- >>> ((+) <**> (+5)) 1 +-- 7 +-- +-- >>> ((*) <**> (+10)) 3 +-- 39 +-- +-- >>> ((*) <**> (+2)) 3 +-- 15 +(<**>) :: + Monad f => + f (a -> b) + -> f a + -> f b +(<**>) = + error "todo: Course.Monad#(<**>)" + +infixl 4 <**> -- | Flattens a combined structure to a single structure. -- @@ -139,7 +134,7 @@ join :: f (f a) -> f a join = - (=<<) id + error "todo: Course.Monad#join" -- | Implement a flipped version of @(=<<)@, however, use only -- @join@ and @(<$>)@. @@ -152,8 +147,8 @@ join = f a -> (a -> f b) -> f b -a >>= f = - join (f <$> a) +(>>=) = + error "todo: Course.Monad#(>>=)" infixl 1 >>= @@ -168,8 +163,8 @@ infixl 1 >>= -> (a -> f b) -> a -> f c -f <=< g = - (=<<) f . g +(<=<) = + error "todo: Course.Monad#(<=<)" infixr 1 <=< diff --git a/src/Course/MonadTutorial.hs b/src/Course/MonadTutorial.hs index 86be70f9a..5712dfb7f 100644 --- a/src/Course/MonadTutorial.hs +++ b/src/Course/MonadTutorial.hs @@ -165,7 +165,7 @@ sequenceIntReader = data Reader r a = Reader (r -> a) - + bindReader :: (a -> Reader r b) -> Reader r a @@ -193,13 +193,13 @@ sequenceReader = data IntState a = IntState (Int -> (a, Int)) - + bindIntState :: (a -> IntState b) -> IntState a -> IntState b bindIntState f (IntState g) = - IntState (\i -> + IntState (\i -> let (a, j) = g i IntState h = f a in h j) @@ -230,7 +230,7 @@ bindState :: -> State s a -> State s b bindState f (State g) = - State (\s -> + State (\s -> let (a, t) = g s State h = f a in h t) @@ -448,4 +448,4 @@ class BindAndPure f where pure :: a -> f a - + diff --git a/src/Course/MoreParser.hs b/src/Course/MoreParser.hs index 6325728b8..99c9ed421 100644 --- a/src/Course/MoreParser.hs +++ b/src/Course/MoreParser.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE OverloadedStrings #-} module Course.MoreParser where @@ -12,6 +13,7 @@ import Course.Applicative import Course.Monad import Course.Functor import Course.Traversable +import Numeric hiding (readHex) -- $setup -- >>> :set -XOverloadedStrings @@ -39,7 +41,7 @@ P p <.> i = spaces :: Parser Chars spaces = - list space + error "todo: Course.MoreParser#spaces" -- | Write a function that applies the given parser, then parses 0 or more spaces, -- then produces the result of the original parser. @@ -54,10 +56,8 @@ spaces = tok :: Parser a -> Parser a -tok p = - do v <- p - spaces - pure v +tok = + error "todo: Course.MoreParser#tok" -- | Write a function that parses the given char followed by 0 or more spaces. -- @@ -66,13 +66,13 @@ tok p = -- -- >>> isErrorResult (parse (charTok 'a') "dabc") -- True --- +-- -- /Tip:/ Use `tok` and `is`. charTok :: Char -> Parser Char charTok = - tok . is + error "todo: Course.MoreParser#charTok" -- | Write a parser that parses a comma ',' followed by 0 or more spaces. -- @@ -81,12 +81,12 @@ charTok = -- -- >>> isErrorResult( parse commaTok "1,23") -- True --- +-- -- /Tip:/ Use `charTok`. commaTok :: Parser Char commaTok = - charTok ',' + error "todo: Course.MoreParser#commaTok" -- | Write a parser that parses either a double-quote or a single-quote. -- @@ -103,7 +103,7 @@ commaTok = quote :: Parser Char quote = - is '"' ||| is '\'' + error "todo: Course.MoreParser#quote" -- | Write a function that parses the given string (fails otherwise). -- @@ -118,9 +118,9 @@ string :: Chars -> Parser Chars string = - traverse is + error "todo: Course.MoreParser#string" --- | Write a function that parsers the given string, followed by 0 or more spaces. +-- | Write a function that parses the given string, followed by 0 or more spaces. -- -- /Tip:/ Use `tok` and `string`. -- @@ -133,7 +133,7 @@ stringTok :: Chars -> Parser Chars stringTok = - tok . string + error "todo: Course.MoreParser#stringTok" -- | Write a function that tries the given parser, otherwise succeeds by producing the given value. -- @@ -148,8 +148,8 @@ option :: a -> Parser a -> Parser a -option a p = - p ||| pure a +option = + error "todo: Course.MoreParser#option" -- | Write a parser that parses 1 or more digits. -- @@ -163,7 +163,7 @@ option a p = digits1 :: Parser Chars digits1 = - list1 digit + error "todo: Course.MoreParser#digits1" -- | Write a function that parses one of the characters in the given string. -- @@ -177,8 +177,8 @@ digits1 = oneof :: Chars -> Parser Char -oneof s = - satisfy (`elem` s) +oneof = + error "todo: Course.MoreParser#oneof" -- | Write a function that parses any character, but fails if it is in the given string. -- @@ -192,8 +192,8 @@ oneof s = noneof :: Chars -> Parser Char -noneof s = - satisfy (`notElem` s) +noneof = + error "todo: Course.MoreParser#noneof" -- | Write a function that applies the first parser, runs the third parser keeping the result, -- then runs the second parser and produces the obtained result. @@ -216,11 +216,8 @@ between :: -> Parser c -> Parser a -> Parser a -between o c a = - do o - v <- a - c - pure v +between = + error "todo: Course.MoreParser#between" -- | Write a function that applies the given parser in between the two given characters. -- @@ -242,12 +239,12 @@ betweenCharTok :: -> Char -> Parser a -> Parser a -betweenCharTok a b = - between (charTok a) (charTok b) +betweenCharTok = + error "todo: Course.MoreParser#betweenCharTok" -- | Write a function that parses 4 hex digits and return the character value. -- --- /Tip:/ Use `readHex`, `isHexDigit`, `replicateA`, `satisfy` and the monad instance. +-- /Tip:/ Use `readHex`, `isHexDigit`, `replicateA`, `satisfy`, `chr` and the monad instance. -- -- >>> parse hex "0010" -- Result >< '\DLE' @@ -263,10 +260,7 @@ betweenCharTok a b = hex :: Parser Char hex = - let hInt s = case readHex s of - Empty -> 0 - Full n -> n - in chr . hInt <$> replicateA 4 (satisfy isHexDigit) + error "todo: Course.MoreParser#hex" -- | Write a function that parses the character 'u' followed by 4 hex digits and return the character value. -- @@ -289,8 +283,7 @@ hex = hexu :: Parser Char hexu = - do is 'u' - hex + error "todo: Course.MoreParser#hexu" -- | Write a function that produces a non-empty list of values coming off the given parser (which must succeed at least once), -- separated by the second given parser. @@ -312,10 +305,8 @@ sepby1 :: Parser a -> Parser s -> Parser (List a) -sepby1 p s = - do v <- p - w <- list (s *> p) - pure (v:.w) +sepby1 = + error "todo: Course.MoreParser#sepby1" -- | Write a function that produces a list of values coming off the given parser, -- separated by the second given parser. @@ -337,8 +328,8 @@ sepby :: Parser a -> Parser s -> Parser (List a) -sepby p s = - sepby1 p s ||| pure Nil +sepby = + error "todo: Course.MoreParser#sepby" -- | Write a parser that asserts that there is no remaining input. -- @@ -350,9 +341,7 @@ sepby p s = eof :: Parser () eof = - P (\s -> case s of - Nil -> Result Nil () - x -> ErrorResult (ExpectedEof x)) + error "todo: Course.MoreParser#eof" -- | Write a parser that produces a character that satisfies all of the given predicates. -- @@ -375,8 +364,8 @@ eof = satisfyAll :: List (Char -> Bool) -> Parser Char -satisfyAll ps = - satisfy (and . sequence ps) +satisfyAll = + error "todo: Course.MoreParser#satisfyAll" -- | Write a parser that produces a character that satisfies any of the given predicates. -- @@ -396,8 +385,8 @@ satisfyAll ps = satisfyAny :: List (Char -> Bool) -> Parser Char -satisfyAny ps = - satisfy (or . sequence ps) +satisfyAny = + error "todo: Course.MoreParser#satisfyAny" -- | Write a parser that parses between the two given characters, separated by a comma character ','. -- @@ -409,6 +398,15 @@ satisfyAny ps = -- >>> parse (betweenSepbyComma '[' ']' lower) "[]" -- Result >< "" -- +-- >>> parse (betweenSepbyComma '[' ']' lower) "[a,b,c]" +-- Result >< "abc" +-- +-- >>> parse (betweenSepbyComma '[' ']' lower) "[a, b, c]" +-- Result >< "abc" +-- +-- >>> parse (betweenSepbyComma '[' ']' digits1) "[123,456]" +-- Result >< ["123","456"] +-- -- >>> isErrorResult (parse (betweenSepbyComma '[' ']' lower) "[A]") -- True -- @@ -425,5 +423,5 @@ betweenSepbyComma :: -> Char -> Parser a -> Parser (List a) -betweenSepbyComma a b g = - betweenCharTok a b $ g `sepby` charTok ',' +betweenSepbyComma = + error "todo: Course.MoreParser#betweenSepbyComma" diff --git a/src/Course/Optional.hs b/src/Course/Optional.hs index 658c32533..4a38e90c2 100644 --- a/src/Course/Optional.hs +++ b/src/Course/Optional.hs @@ -27,10 +27,8 @@ mapOptional :: (a -> b) -> Optional a -> Optional b -mapOptional _ Empty = - Empty -mapOptional f (Full a) = - Full (f a) +mapOptional = + error "todo: Course.Optional#mapOptional" -- | Bind the given function on the possible value. -- @@ -46,10 +44,8 @@ bindOptional :: (a -> Optional b) -> Optional a -> Optional b -bindOptional _ Empty = - Empty -bindOptional f (Full a) = - f a +bindOptional = + error "todo: Course.Optional#bindOptional" -- | Return the possible value if it exists; otherwise, the second argument. -- @@ -62,10 +58,9 @@ bindOptional f (Full a) = Optional a -> a -> a -Empty ?? a = - a -Full a ?? _ = - a +(??) = + error "todo: Course.Optional#(??)" + -- | Try the first optional for a value. If it has a value, use it; otherwise, -- use the second value. -- @@ -84,13 +79,26 @@ Full a ?? _ = Optional a -> Optional a -> Optional a -Empty <+> x = - x -Full a <+> _ = - Full a +(<+>) = + error "todo: Course.Optional#(<+>)" + +-- | Replaces the Full and Empty constructors in an optional. +-- +-- >>> optional (+1) 0 (Full 8) +-- 9 +-- +-- >>> optional (+1) 0 Empty +-- 0 +optional :: + (a -> b) + -> b + -> Optional a + -> b +optional = + error "todo: Course.Optional#optional" applyOptional :: Optional (a -> b) -> Optional a -> Optional b -applyOptional f a = bindOptional (\f' -> mapOptional (\a' -> f' a') a) f +applyOptional f a = bindOptional (\f' -> mapOptional f' a) f twiceOptional :: (a -> b -> c) -> Optional a -> Optional b -> Optional c twiceOptional f = applyOptional . mapOptional f diff --git a/src/Course/Parser.hs b/src/Course/Parser.hs index da150a5ff..9aea9d38f 100644 --- a/src/Course/Parser.hs +++ b/src/Course/Parser.hs @@ -21,38 +21,35 @@ import Data.Char type Input = Chars -data ParseError = - UnexpectedEof +data ParseResult a = + UnexpectedEof | ExpectedEof Input | UnexpectedChar Char - | Failed + | UnexpectedString Chars + | Result Input a deriving Eq - -instance Show ParseError where +instance Show a => Show (ParseResult a) where show UnexpectedEof = "Unexpected end of stream" show (ExpectedEof i) = stringconcat ["Expected end of stream, but got >", show i, "<"] show (UnexpectedChar c) = stringconcat ["Unexpected character: ", show [c]] - show Failed = - "Parse failed" - -data ParseResult a = - ErrorResult ParseError - | Result Input a - deriving Eq - -instance Show a => Show (ParseResult a) where - show (ErrorResult e) = - show e + show (UnexpectedString s) = + stringconcat ["Unexpected string: ", show s] show (Result i a) = stringconcat ["Result >", hlist i, "< ", show a] instance Functor ParseResult where - _ <$> ErrorResult e = - ErrorResult e + _ <$> UnexpectedEof = + UnexpectedEof + _ <$> ExpectedEof i = + ExpectedEof i + _ <$> UnexpectedChar c = + UnexpectedChar c + _ <$> UnexpectedString s = + UnexpectedString s f <$> Result i a = Result i (f a) @@ -60,41 +57,58 @@ instance Functor ParseResult where isErrorResult :: ParseResult a -> Bool -isErrorResult (ErrorResult _) = - True isErrorResult (Result _ _) = False +isErrorResult UnexpectedEof = + True +isErrorResult (ExpectedEof _) = + True +isErrorResult (UnexpectedChar _) = + True +isErrorResult (UnexpectedString _) = + True -data Parser a = P { - parse :: Input -> ParseResult a -} +-- | Runs the given function on a successful parse result. Otherwise return the same failing parse result. +onResult :: + ParseResult a + -> (Input -> a -> ParseResult b) + -> ParseResult b +onResult UnexpectedEof _ = + UnexpectedEof +onResult (ExpectedEof i) _ = + ExpectedEof i +onResult (UnexpectedChar c) _ = + UnexpectedChar c +onResult (UnexpectedString s) _ = + UnexpectedString s +onResult (Result i a) k = + k i a + +data Parser a = P (Input -> ParseResult a) + +parse :: + Parser a + -> Input + -> ParseResult a +parse (P p) = + p -- | Produces a parser that always fails with @UnexpectedChar@ using the given character. unexpectedCharParser :: Char -> Parser a unexpectedCharParser c = - P (\_ -> ErrorResult (UnexpectedChar c)) - --- | Return a parser that always succeeds with the given value and consumes no input. --- --- >>> parse (valueParser 3) "abc" --- Result >abc< 3 -valueParser :: - a - -> Parser a -valueParser a = - P (`Result` a) + P (\_ -> UnexpectedChar c) --- | Return a parser that always fails with the given error. --- --- >>> isErrorResult (parse (failed Failed) "abc") --- True -failed :: - ParseError +--- | Return a parser that always returns the given parse result. +--- +--- >>> isErrorResult (parse (constantParser UnexpectedEof) "abc") +--- True +constantParser :: + ParseResult a -> Parser a -failed = - P . const . ErrorResult +constantParser = + P . const -- | Return a parser that succeeds with a character off the input or fails with an error if the input is empty. -- @@ -106,93 +120,30 @@ failed = character :: Parser Char character = - P (\s -> case s of Nil -> ErrorResult UnexpectedEof - (c:.r) -> Result r c) + error "todo: Course.Parser#character" --- | Return a parser that maps any succeeding result with the given function. --- --- >>> parse (mapParser succ character) "amz" --- Result >mz< 'b' +-- | Parsers can map. +-- Write a Functor instance for a @Parser@. -- --- >>> parse (mapParser (+10) (valueParser 7)) "" --- Result >< 17 -mapParser :: - (a -> b) - -> Parser a - -> Parser b -mapParser f (P p) = - P (\input -> case p input of - ErrorResult e -> ErrorResult e - Result r a -> Result r (f a)) - --- | This is @mapParser@ with the arguments flipped. --- It might be more helpful to use this function if you prefer this argument order. -flmapParser :: - Parser a - -> (a -> b) - -> Parser b -flmapParser = - flip mapParser +-- >>> parse (toUpper <$> character) "amz" +-- Result >mz< 'A' +instance Functor Parser where + (<$>) :: + (a -> b) + -> Parser a + -> Parser b + (<$>) = + error "todo: Course.Parser (<$>)#instance Parser" --- | Return a parser that puts its input into the given parser and --- --- * if that parser succeeds with a value (a), put that value into the given function --- then put in the remaining input in the resulting parser. --- --- * if that parser fails with an error the returned parser fails with that error. --- --- >>> parse (bindParser (\c -> if c == 'x' then character else valueParser 'v') character) "abc" --- Result >bc< 'v' --- --- >>> parse (bindParser (\c -> if c == 'x' then character else valueParser 'v') character) "a" --- Result >< 'v' --- --- >>> parse (bindParser (\c -> if c == 'x' then character else valueParser 'v') character) "xabc" --- Result >bc< 'a' --- --- >>> isErrorResult (parse (bindParser (\c -> if c == 'x' then character else valueParser 'v') character) "") --- True +-- | Return a parser that always succeeds with the given value and consumes no input. -- --- >>> isErrorResult (parse (bindParser (\c -> if c == 'x' then character else valueParser 'v') character) "x") --- True -bindParser :: - (a -> Parser b) +-- >>> parse (valueParser 3) "abc" +-- Result >abc< 3 +valueParser :: + a -> Parser a - -> Parser b -bindParser f (P p) = - P (\i -> case p i of - Result r a -> parse (f a) r - ErrorResult e -> ErrorResult e) - --- | This is @bindParser@ with the arguments flipped. --- It might be more helpful to use this function if you prefer this argument order. -flbindParser :: - Parser a - -> (a -> Parser b) - -> Parser b -flbindParser = - flip bindParser - --- | Return a parser that puts its input into the given parser and --- --- * if that parser succeeds with a value (a), ignore that value --- but put the remaining input into the second given parser. --- --- * if that parser fails with an error the returned parser fails with that error. --- --- /Tip:/ Use @bindParser@ or @flbindParser@. --- --- >>> parse (character >>> valueParser 'v') "abc" --- Result >bc< 'v' --- --- >>> isErrorResult (parse (character >>> valueParser 'v') "") --- True -(>>>) :: - Parser a - -> Parser b - -> Parser b -p >>> q = - bindParser (const q) p +valueParser = + error "todo: Course.Parser#valueParser" -- | Return a parser that tries the first parser for a successful value. -- @@ -203,75 +154,67 @@ p >>> q = -- >>> parse (character ||| valueParser 'v') "" -- Result >< 'v' -- --- >>> parse (failed Failed ||| valueParser 'v') "" +-- >>> parse (constantParser UnexpectedEof ||| valueParser 'v') "" -- Result >< 'v' -- -- >>> parse (character ||| valueParser 'v') "abc" -- Result >bc< 'a' -- --- >>> parse (failed Failed ||| valueParser 'v') "abc" +-- >>> parse (constantParser UnexpectedEof ||| valueParser 'v') "abc" -- Result >abc< 'v' (|||) :: Parser a -> Parser a -> Parser a -P p1 ||| P p2 = - P (\s -> let v = p1 s - in if isErrorResult v - then - p2 s - else - v) +(|||) = + error "todo: Course.Parser#(|||)" infixl 3 ||| --- | Return a parser that continues producing a list of values from the given parser. --- --- /Tip:/ Use @list1@, @valueParser@ and @(|||)@. --- --- >>> parse (list character) "" --- Result >< "" --- --- >>> parse (list digit) "123abc" --- Result >abc< "123" +-- | Parsers can bind. +-- Return a parser that puts its input into the given parser and -- --- >>> parse (list digit) "abc" --- Result >abc< "" --- --- >>> parse (list character) "abc" --- Result >< "abc" +-- * if that parser succeeds with a value (a), put that value into the given function +-- then put in the remaining input in the resulting parser. -- --- >>> parse (list (character *> valueParser 'v')) "abc" --- Result >< "vvv" +-- * if that parser fails with an error the returned parser fails with that error. -- --- >>> parse (list (character *> valueParser 'v')) "" --- Result >< "" -list :: - Parser a - -> Parser (List a) -list k = - list1 k ||| valueParser Nil - --- | Return a parser that produces at least one value from the given parser then --- continues producing a list of values from the given parser (to ultimately produce a non-empty list). +-- >>> parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "abc" +-- Result >bc< 'v' -- --- /Tip:/ Use @bindParser@, @list@ and @valueParser@. +-- >>> parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "a" +-- Result >< 'v' -- --- >>> parse (list1 (character)) "abc" --- Result >< "abc" +-- >>> parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "xabc" +-- Result >bc< 'a' -- --- >>> parse (list1 (character *> valueParser 'v')) "abc" --- Result >< "vvv" +-- >>> isErrorResult (parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "") +-- True -- --- >>> isErrorResult (parse (list1 (character *> valueParser 'v')) "") +-- >>> isErrorResult (parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "x") -- True -list1 :: - Parser a - -> Parser (List a) -list1 k = - flbindParser k (\k' -> - flbindParser (list k) (\kk' -> - valueParser (k' :. kk'))) +instance Monad Parser where + (=<<) :: + (a -> Parser b) + -> Parser a + -> Parser b + (=<<) = + error "todo: Course.Parser (=<<)#instance Parser" + +-- | Write an Applicative functor instance for a @Parser@. +-- /Tip:/ Use @(=<<)@. +instance Applicative Parser where + pure :: + a + -> Parser a + pure = + valueParser + (<*>) :: + Parser (a -> b) + -> Parser a + -> Parser b + (<*>) = + error "todo: Course.Parser (<*>)#instance Parser" -- | Return a parser that produces a character but fails if -- @@ -279,7 +222,7 @@ list1 k = -- -- * The character does not satisfy the given predicate. -- --- /Tip:/ The @bindParser@, @unexpectedCharParser@ and @character@ functions will be helpful here. +-- /Tip:/ The @(=<<)@, @unexpectedCharParser@ and @character@ functions will be helpful here. -- -- >>> parse (satisfy isUpper) "Abc" -- Result >bc< 'A' @@ -289,9 +232,8 @@ list1 k = satisfy :: (Char -> Bool) -> Parser Char -satisfy p = - bindParser (\c -> - if p c then valueParser c else unexpectedCharParser c) character +satisfy = + error "todo: Course.Parser#satisfy" -- | Return a parser that produces the given character but fails if -- @@ -302,8 +244,8 @@ satisfy p = -- /Tip:/ Use the @satisfy@ function. is :: Char -> Parser Char -is c = - satisfy (== c) +is = + error "todo: Course.Parser#is" -- | Return a parser that produces a character between '0' and '9' but fails if -- @@ -315,45 +257,66 @@ is c = digit :: Parser Char digit = - satisfy isDigit + error "todo: Course.Parser#digit" --- | Return a parser that produces zero or a positive integer but fails if +-- +-- | Return a parser that produces a space character but fails if -- -- * The input is empty. -- --- * The input does not produce a valid series of digits +-- * The produced character is not a space. +-- +-- /Tip:/ Use the @satisfy@ and @Data.Char#isSpace@ functions. +space :: + Parser Char +space = + error "todo: Course.Parser#space" + +-- | Return a parser that continues producing a list of values from the given parser. -- --- /Tip:/ Use the @bindParser@, @valueParser@, @list1@, @read@ and @digit@ --- functions. --- >>> parse natural "123" --- Result >< 123 +-- /Tip:/ Use @list1@, @pure@ and @(|||)@. -- --- >>> parse natural "123ab" --- Result >ab< 123 +-- >>> parse (list character) "" +-- Result >< "" -- --- >>> isErrorResult (parse natural "abc") --- True +-- >>> parse (list digit) "123abc" +-- Result >abc< "123" -- --- >>> isErrorResult (parse natural "") --- True -natural :: - Parser Int -natural = - bindParser (\k -> case read k of Empty -> failed Failed - Full h -> valueParser h) (list digit) +-- >>> parse (list digit) "abc" +-- Result >abc< "" +-- +-- >>> parse (list character) "abc" +-- Result >< "abc" +-- +-- >>> parse (list (character *> valueParser 'v')) "abc" +-- Result >< "vvv" +-- +-- >>> parse (list (character *> valueParser 'v')) "" +-- Result >< "" +list :: + Parser a + -> Parser (List a) +list = + error "todo: Course.Parser#list" +-- | Return a parser that produces at least one value from the given parser then +-- continues producing a list of values from the given parser (to ultimately produce a non-empty list). -- --- | Return a parser that produces a space character but fails if +-- /Tip:/ Use @(=<<)@, @list@ and @pure@. -- --- * The input is empty. +-- >>> parse (list1 (character)) "abc" +-- Result >< "abc" -- --- * The produced character is not a space. +-- >>> parse (list1 (character *> valueParser 'v')) "abc" +-- Result >< "vvv" -- --- /Tip:/ Use the @satisfy@ and @Data.Char#isSpace@ functions. -space :: - Parser Char -space = - satisfy isSpace +-- >>> isErrorResult (parse (list1 (character *> valueParser 'v')) "") +-- True +list1 :: + Parser a + -> Parser (List a) +list1 = + error "todo: Course.Parser#list1" -- | Return a parser that produces one or more space characters -- (consuming until the first non-space) but fails if @@ -366,7 +329,7 @@ space = spaces1 :: Parser Chars spaces1 = - list1 space + error "todo: Course.Parser#spaces1" -- | Return a parser that produces a lower-case character but fails if -- @@ -378,7 +341,7 @@ spaces1 = lower :: Parser Char lower = - satisfy isLower + error "todo: Course.Parser#lower" -- | Return a parser that produces an upper-case character but fails if -- @@ -390,7 +353,7 @@ lower = upper :: Parser Char upper = - satisfy isUpper + error "todo: Course.Parser#upper" -- | Return a parser that produces an alpha character but fails if -- @@ -402,12 +365,12 @@ upper = alpha :: Parser Char alpha = - satisfy isAlpha + error "todo: Course.Parser#alpha" -- | Return a parser that sequences the given list of parsers by producing all their results -- but fails on the first failing parser of the list. -- --- /Tip:/ Use @bindParser@ and @valueParser@. +-- /Tip:/ Use @(=<<)@ and @pure@. -- /Tip:/ Optionally use @List#foldRight@. If not, an explicit recursive call. -- -- >>> parse (sequenceParser (character :. is 'x' :. upper :. Nil)) "axCdef" @@ -418,12 +381,8 @@ alpha = sequenceParser :: List (Parser a) -> Parser (List a) -sequenceParser Nil = - valueParser Nil -sequenceParser (h:.t) = - flbindParser h (\a -> - flbindParser (sequenceParser t) (\as -> - valueParser (a :. as))) +sequenceParser = + error "todo: Course.Parser#sequenceParser" -- | Return a parser that produces the given number of values off the given parser. -- This parser fails if the given parser fails in the attempt to produce the given number of values. @@ -439,15 +398,13 @@ thisMany :: Int -> Parser a -> Parser (List a) -thisMany n p = - sequenceParser (replicate n p) +thisMany = + error "todo: Course.Parser#thisMany" --- | Write a parser for Person.age. +-- | This one is done for you. -- -- /Age: positive integer/ -- --- /Tip:/ Equivalent to @natural@. --- -- >>> parse ageParser "120" -- Result >< 120 -- @@ -459,12 +416,13 @@ thisMany n p = ageParser :: Parser Int ageParser = - natural + (\k -> case read k of Empty -> constantParser (UnexpectedString k) + Full h -> pure h) =<< (list1 digit) -- | Write a parser for Person.firstName. -- /First Name: non-empty string that starts with a capital letter and is followed by zero or more lower-case letters/ -- --- /Tip:/ Use @bindParser@, @valueParser@, @upper@, @list@ and @lower@. +-- /Tip:/ Use @(=<<)@, @pure@, @upper@, @list@ and @lower@. -- -- >>> parse firstNameParser "Abc" -- Result >< "Abc" @@ -474,19 +432,20 @@ ageParser = firstNameParser :: Parser Chars firstNameParser = - flbindParser upper (\c -> - flbindParser (list lower) (\cs -> - valueParser (c :. cs))) + error "todo: Course.Parser#firstNameParser" -- | Write a parser for Person.surname. -- -- /Surname: string that starts with a capital letter and is followed by 5 or more lower-case letters./ -- --- /Tip:/ Use @bindParser@, @valueParser@, @upper@, @thisMany@, @lower@ and @list@. +-- /Tip:/ Use @(=<<)@, @pure@, @upper@, @thisMany@, @lower@ and @list@. -- -- >>> parse surnameParser "Abcdef" -- Result >< "Abcdef" -- +-- >>> parse surnameParser "Abcdefghijklmnopqrstuvwxyz" +-- Result >< "Abcdefghijklmnopqrstuvwxyz" +-- -- >>> isErrorResult (parse surnameParser "Abc") -- True -- @@ -495,10 +454,7 @@ firstNameParser = surnameParser :: Parser Chars surnameParser = - flbindParser upper (\c -> - flbindParser (thisMany 5 lower) (\cs -> - flbindParser (list lower) (\t -> - valueParser (c :. cs ++ t)))) + error "todo: Course.Parser#surnameParser" -- | Write a parser for Person.smoker. -- @@ -507,17 +463,17 @@ surnameParser = -- /Tip:/ Use @is@ and @(|||)@./ -- -- >>> parse smokerParser "yabc" --- Result >abc< 'y' +-- Result >abc< True -- -- >>> parse smokerParser "nabc" --- Result >abc< 'n' +-- Result >abc< False -- -- >>> isErrorResult (parse smokerParser "abc") -- True smokerParser :: - Parser Char + Parser Bool smokerParser = - is 'y' ||| is 'n' + error "todo: Course.Parser#smokerParser" -- | Write part of a parser for Person#phoneBody. -- This parser will only produce a string of digits, dots or hyphens. @@ -539,13 +495,13 @@ smokerParser = phoneBodyParser :: Parser Chars phoneBodyParser = - list (digit ||| is '.' ||| is '-') + error "todo: Course.Parser#phoneBodyParser" -- | Write a parser for Person.phone. -- -- /Phone: ... but must start with a digit and end with a hash (#)./ -- --- /Tip:/ Use @bindParser@, @valueParser@, @digit@, @phoneBodyParser@ and @is@. +-- /Tip:/ Use @(=<<)@, @pure@, @digit@, @phoneBodyParser@ and @is@. -- -- >>> parse phoneParser "123-456#" -- Result >< "123-456" @@ -561,15 +517,12 @@ phoneBodyParser = phoneParser :: Parser Chars phoneParser = - flbindParser digit (\d -> - flbindParser phoneBodyParser (\z -> - flbindParser (is '#') (\_ -> - valueParser (d :. z)))) + error "todo: Course.Parser#phoneParser" -- | Write a parser for Person. -- --- /Tip:/ Use @bindParser@, --- @valueParser@, +-- /Tip:/ Use @(=<<)@, +-- @pure@, -- @(>>>)@, -- @spaces1@, -- @ageParser@, @@ -606,57 +559,42 @@ phoneParser = -- True -- -- >>> parse personParser "123 Fred Clarkson y 123-456.789#" --- Result >< Person {age = 123, firstName = "Fred", surname = "Clarkson", smoker = 'y', phone = "123-456.789"} +-- Result >< Person 123 "Fred" "Clarkson" True "123-456.789" + -- -- >>> parse personParser "123 Fred Clarkson y 123-456.789# rest" --- Result > rest< Person {age = 123, firstName = "Fred", surname = "Clarkson", smoker = 'y', phone = "123-456.789"} +-- Result > rest< Person 123 "Fred" "Clarkson" True "123-456.789" + +-- +-- >>> parse personParser "123 Fred Clarkson y 123-456.789#" +-- Result >< Person 123 "Fred" "Clarkson" True "123-456.789" personParser :: Parser Person personParser = - flbindParser ageParser (\a -> - spaces1 >>> - flbindParser firstNameParser (\f -> - spaces1 >>> - flbindParser surnameParser (\s -> - spaces1 >>> - flbindParser smokerParser (\g -> - spaces1 >>> - flbindParser phoneParser ( - valueParser . Person a f s g))))) + error "todo: Course.Parser#personParser" -- Make sure all the tests pass! +---- --- | Write a Functor instance for a @Parser@. --- /Tip:/ Use @bindParser@ and @valueParser@. -instance Functor Parser where - (<$>) :: - (a -> b) - -> Parser a - -> Parser b - (<$>) f = - bindParser (valueParser . f) +-- Did you repeat yourself in `personParser` ? This might help: --- | Write an Applicative functor instance for a @Parser@. --- /Tip:/ Use @bindParser@ and @valueParser@. -instance Applicative Parser where - pure :: - a - -> Parser a - pure = - valueParser - (<*>) :: - Parser (a -> b) - -> Parser a - -> Parser b - p <*> q = - bindParser (\f -> bindParser (valueParser . f) q) p +(>>=~) :: + Parser a + -> (a -> Parser b) + -> Parser b +(>>=~) p f = + (p <* spaces1) >>= f --- | Write a Monad instance for a @Parser@. -instance Monad Parser where - (=<<) :: - (a -> Parser b) - -> Parser a - -> Parser b - (=<<) = - bindParser +infixl 1 >>=~ + +-- or maybe this + +(<*>~) :: + Parser (a -> b) + -> Parser a + -> Parser b +(<*>~) f a = + f <*> spaces1 *> a + +infixl 4 <*>~ diff --git a/src/Course/Person.hs b/src/Course/Person.hs index 52d49f687..77a557c82 100644 --- a/src/Course/Person.hs +++ b/src/Course/Person.hs @@ -10,13 +10,13 @@ import Course.List -- * Age: positive integer -- * First Name: non-empty string that starts with a capital letter and is followed by zero or more lower-case letters -- * Surname: string that starts with a capital letter and is followed by 5 or more lower-case letters --- * Smoker: character that must be 'y' or 'n' +-- * Smoker: character that must be 'y' or 'n' that maps to a boolean -- * Phone: string of digits, dots or hyphens but must start with a digit and end with a hash (#) -data Person = Person { - age :: Int, - firstName :: Chars, - surname :: Chars, - smoker :: Char, - phone :: Chars -} deriving (Eq, Show) - +data Person = + Person + Int -- age + Chars -- first name + Chars -- surname + Bool -- smoker + Chars -- phone number + deriving (Eq, Show) diff --git a/src/Course/State.hs b/src/Course/State.hs index 0ef25d248..239a13032 100644 --- a/src/Course/State.hs +++ b/src/Course/State.hs @@ -31,6 +31,45 @@ newtype State s a = -> (a, s) } +-- | Run the `State` seeded with `s` and retrieve the resulting state. +-- +-- prop> \(Fun _ f) s -> exec (State f) s == snd (runState (State f) s) +exec :: + State s a + -> s + -> s +exec = + error "todo: Course.State#exec" + +-- | Run the `State` seeded with `s` and retrieve the resulting value. +-- +-- prop> \(Fun _ f) s -> eval (State f) s == fst (runState (State f) s) +eval :: + State s a + -> s + -> a +eval = + error "todo: Course.State#eval" + +-- | A `State` where the state also distributes into the produced value. +-- +-- >>> runState get 0 +-- (0,0) +get :: + State s s +get = + error "todo: Course.State#get" + +-- | A `State` where the resulting state is seeded with the given value. +-- +-- >>> runState (put 1) 0 +-- ((),1) +put :: + s + -> State s () +put = + error "todo: Course.State#put" + -- | Implement the `Functor` instance for `State s`. -- -- >>> runState ((+1) <$> State (\s -> (9, s * 2))) 3 @@ -40,8 +79,8 @@ instance Functor (State s) where (a -> b) -> State s a -> State s b - f <$> State k = - State (\s -> let (a, t) = k s in (f a, t)) + (<$>) = + error "todo: Course.State#(<$>)" -- | Implement the `Applicative` instance for `State s`. -- @@ -58,18 +97,16 @@ instance Applicative (State s) where pure :: a -> State s a - pure a = - State (\s -> (a, s)) + pure = + error "todo: Course.State pure#instance (State s)" (<*>) :: State s (a -> b) -> State s a - -> State s b - State f <*> State a = - State (\s -> let (g, t) = f s - (z, u) = a t - in (g z, u)) + -> State s b + (<*>) = + error "todo: Course.State (<*>)#instance (State s)" --- | Implement the `Bind` instance for `State s`. +-- | Implement the `Monad` instance for `State s`. -- -- >>> runState ((const $ put 2) =<< put 1) 0 -- ((),2) @@ -81,47 +118,8 @@ instance Monad (State s) where (a -> State s b) -> State s a -> State s b - f =<< State k = - State (\s -> let (a, t) = k s in runState (f a) t) - --- | Run the `State` seeded with `s` and retrieve the resulting state. --- --- prop> \(Fun _ f) -> exec (State f) s == snd (runState (State f) s) -exec :: - State s a - -> s - -> s -exec (State k) = - snd . k - --- | Run the `State` seeded with `s` and retrieve the resulting value. --- --- prop> \(Fun _ f) -> eval (State f) s == fst (runState (State f) s) -eval :: - State s a - -> s - -> a -eval (State k) = - fst . k - --- | A `State` where the state also distributes into the produced value. --- --- >>> runState get 0 --- (0,0) -get :: - State s s -get = - State (\s -> (s, s)) - --- | A `State` where the resulting state is seeded with the given value. --- --- >>> runState (put 1) 0 --- ((),1) -put :: - s - -> State s () -put = - State . const . (,) () + (=<<) = + error "todo: Course.State (=<<)#instance (State s)" -- | Find the first element in a `List` that satisfies a given predicate. -- It is possible that no element is found, hence an `Optional` result. @@ -142,48 +140,35 @@ findM :: (a -> f Bool) -> List a -> f (Optional a) -findM _ Nil = - pure Empty -findM p (h :. t) = - (\q -> if q then pure (Full h) else findM p t) =<< p h +findM = + error "todo: Course.State#findM" -- | Find the first element in a `List` that repeats. -- It is possible that no element repeats, hence an `Optional` result. -- -- /Tip:/ Use `findM` and `State` with a @Data.Set#Set@. -- --- prop> case firstRepeat xs of Empty -> let xs' = hlist xs in nub xs' == xs'; Full x -> length (filter (== x) xs) > 1 --- prop> case firstRepeat xs of Empty -> True; Full x -> let (l, (rx :. rs)) = span (/= x) xs in let (l2, r2) = span (/= x) rs in let l3 = hlist (l ++ (rx :. Nil) ++ l2) in nub l3 == l3 +-- prop> \xs -> case firstRepeat xs of Empty -> let xs' = hlist xs in nub xs' == xs'; Full x -> length (filter (== x) xs) > 1 +-- prop> \xs -> case firstRepeat xs of Empty -> True; Full x -> let (l, (rx :. rs)) = span (/= x) xs in let (l2, r2) = span (/= x) rs in let l3 = hlist (l ++ (rx :. Nil) ++ l2) in nub l3 == l3 firstRepeat :: Ord a => List a -> Optional a firstRepeat = - listWithState findM S.member + error "todo: Course.State#firstRepeat" -- | Remove all duplicate elements in a `List`. -- /Tip:/ Use `filtering` and `State` with a @Data.Set#Set@. -- --- prop> firstRepeat (distinct xs) == Empty +-- prop> \xs -> firstRepeat (distinct xs) == Empty -- --- prop> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs) +-- prop> \xs -> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs) distinct :: Ord a => List a -> List a distinct = - listWithState filtering S.notMember - -listWithState :: - Ord a1 => - ((a1 -> State (S.Set a1) a2) - -> t - -> State (S.Set a3) a) - -> (a1 -> S.Set a1 -> a2) - -> t - -> a -listWithState f m x = - eval (f (State . lift2 (lift2 (,)) m S.insert) x) S.empty + error "todo: Course.State#distinct" -- | A happy number is a positive integer, where the sum of the square of its digits eventually reaches 1 after repetition. -- In contrast, a sad number (not a happy number) is where the sum of the square of its digits never reaches 1 @@ -210,10 +195,4 @@ isHappy :: Integer -> Bool isHappy = - contains 1 . - firstRepeat . - produce (toInteger . - sum . - map (join (*) . - digitToInt) . - show') + error "todo: Course.State#isHappy" diff --git a/src/Course/StateT.hs b/src/Course/StateT.hs index cb2986460..22bb827f8 100644 --- a/src/Course/StateT.hs +++ b/src/Course/StateT.hs @@ -39,8 +39,8 @@ instance Functor f => Functor (StateT s f) where (a -> b) -> StateT s f a -> StateT s f b - f <$> StateT k = - StateT ((<$>) (first f) . k) + (<$>) = + error "todo: Course.StateT (<$>)#instance (StateT s f)" -- | Implement the `Applicative` instance for @StateT s f@ given a @Monad f@. -- @@ -49,19 +49,28 @@ instance Functor f => Functor (StateT s f) where -- -- >>> runStateT ((pure 2) :: StateT Int List Int) 0 -- [(2,0)] +-- +-- >>> runStateT (pure (+2) <*> ((pure 2) :: StateT Int List Int)) 0 +-- [(4,0)] +-- +-- >>> import qualified Prelude as P +-- >>> runStateT (StateT (\s -> Full ((+2), s P.++ [1])) <*> (StateT (\s -> Full (2, s P.++ [2])))) [0] +-- Full (4,[0,1,2]) +-- +-- >>> runStateT (StateT (\s -> ((+2), s P.++ [1]) :. ((+3), s P.++ [1]) :. Nil) <*> (StateT (\s -> (2, s P.++ [2]) :. Nil))) [0] +-- [(4,[0,1,2]),(5,[0,1,2])] instance Monad f => Applicative (StateT s f) where pure :: a -> StateT s f a - pure a = - StateT (\s -> pure (a, s)) + pure = + error "todo: Course.StateT pure#instance (StateT s f)" (<*>) :: StateT s f (a -> b) -> StateT s f a -> StateT s f b - StateT f <*> StateT a = - -- StateT (\s -> (\(g, t) -> (\(z, u) -> (g z, u)) <$> a t) =<< f s) - StateT ((\(g, t) -> first g <$> a t) <=< f) + (<*>) = + error "todo: Course.StateT (<*>)#instance (StateT s f)" -- | Implement the `Monad` instance for @StateT s f@ given a @Monad f@. -- Make sure the state value is passed through in `bind`. @@ -76,8 +85,8 @@ instance Monad f => Monad (StateT s f) where (a -> StateT s f b) -> StateT s f a -> StateT s f b - f =<< StateT k = - StateT ((=<<) (\(a, t) -> runStateT (f a) t) . k) + (=<<) = + error "todo: Course.StateT (=<<)#instance (StateT s f)" -- | A `State'` is `StateT` specialised to the `ExactlyOne` functor. type State' s a = @@ -90,8 +99,8 @@ type State' s a = state' :: (s -> (a, s)) -> State' s a -state' k = - StateT (ExactlyOne . k) +state' = + error "todo: Course.StateT#state'" -- | Provide an unwrapper for `State'` values. -- @@ -101,52 +110,64 @@ runState' :: State' s a -> s -> (a, s) -runState' (StateT k) = - runExactlyOne . k +runState' = + error "todo: Course.StateT#runState'" -- | Run the `StateT` seeded with `s` and retrieve the resulting state. +-- +-- >>> execT (StateT $ \s -> Full ((), s + 1)) 2 +-- Full 3 execT :: Functor f => StateT s f a -> s -> f s -execT (StateT k) = - (<$>) snd . k +execT = + error "todo: Course.StateT#execT" --- | Run the `State` seeded with `s` and retrieve the resulting state. +-- | Run the `State'` seeded with `s` and retrieve the resulting state. +-- +-- >>> exec' (state' $ \s -> ((), s + 1)) 2 +-- 3 exec' :: State' s a -> s -> s -exec' t = - runExactlyOne . execT t +exec' = + error "todo: Course.StateT#exec'" -- | Run the `StateT` seeded with `s` and retrieve the resulting value. +-- +-- >>> evalT (StateT $ \s -> Full (even s, s + 1)) 2 +-- Full True evalT :: Functor f => StateT s f a -> s -> f a -evalT (StateT k) = - (<$>) fst . k +evalT = + error "todo: Course.StateT#evalT" --- | Run the `State` seeded with `s` and retrieve the resulting value. +-- | Run the `State'` seeded with `s` and retrieve the resulting value. +-- +-- >>> eval' (state' $ \s -> (even s, s + 1)) 5 +-- False eval' :: State' s a -> s -> a -eval' t = - runExactlyOne . evalT t +eval' = + error "todo: Course.StateT#eval'" -- | A `StateT` where the state also distributes into the produced value. -- -- >>> (runStateT (getT :: StateT Int List Int) 3) -- [(3,3)] getT :: - Monad f => + Applicative f => StateT s f s getT = - StateT (\s -> pure (s, s)) + error "todo: Course.StateT#getT" -- | A `StateT` where the resulting state is seeded with the given value. -- @@ -156,23 +177,23 @@ getT = -- >>> runStateT (putT 2 :: StateT Int List ()) 0 -- [((),2)] putT :: - Monad f => + Applicative f => s -> StateT s f () putT = - StateT . const . pure . (,) () + error "todo: Course.StateT#putT" -- | Remove all duplicate elements in a `List`. -- -- /Tip:/ Use `filtering` and `State'` with a @Data.Set#Set@. ---w --- prop> distinct' xs == distinct' (flatMap (\x -> x :. x :. Nil) xs) +-- +-- prop> \xs -> distinct' xs == distinct' (flatMap (\x -> x :. x :. Nil) xs) distinct' :: Ord a => List a -> List a -distinct' x = - eval' (filtering (\a -> state' (S.notMember a &&& S.insert a)) x) S.empty +distinct' = + error "todo: Course.StateT#distinct'" -- | Remove all duplicate elements in a `List`. -- However, if you see a value greater than `100` in the list, @@ -189,9 +210,8 @@ distinctF :: (Ord a, Num a) => List a -> Optional (List a) -distinctF x = - evalT (filtering (\a -> StateT (\s -> - if a > 100 then Empty else Full (a `S.notMember` s, a `S.insert` s))) x) S.empty +distinctF = + error "todo: Course.StateT#distinctF" -- | An `OptionalT` is a functor of an `Optional` value. data OptionalT f a = @@ -205,30 +225,62 @@ data OptionalT f a = -- >>> runOptionalT $ (+1) <$> OptionalT (Full 1 :. Empty :. Nil) -- [Full 2,Empty] instance Functor f => Functor (OptionalT f) where - f <$> OptionalT x = - OptionalT ((<$>) f <$> x) + (<$>) :: + (a -> b) + -> OptionalT f a + -> OptionalT f b + (<$>) = + error "todo: Course.StateT (<$>)#instance (OptionalT f)" --- | Implement the `Applicative` instance for `OptionalT f` given a Applicative f. +-- | Implement the `Applicative` instance for `OptionalT f` given a Monad f. +-- +-- /Tip:/ Use `onFull` to help implement (<*>). +-- +-- >>> runOptionalT $ OptionalT Nil <*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT Nil +-- [] +-- +-- >>> runOptionalT $ OptionalT (Empty :. Nil) <*> OptionalT (Empty :. Nil) +-- [Empty] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Empty :. Nil) +-- [Empty,Empty] +-- +-- >>> runOptionalT $ OptionalT (Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [Empty] +-- +-- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) +-- [Full 2,Full 3,Empty] -- -- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT (Full 1 :. Empty :. Nil) -- [Full 2,Empty,Full 3,Empty] - --- | Implement the `Applicative` instance for `OptionalT f` given a Applicative f. -instance Applicative f => Applicative (OptionalT f) where +instance Monad f => Applicative (OptionalT f) where + pure :: + a + -> OptionalT f a pure = - OptionalT . pure . pure - OptionalT f <*> OptionalT a = - OptionalT (lift2 (<*>) f a) + error "todo: Course.StateT pure#instance (OptionalT f)" + + (<*>) :: + OptionalT f (a -> b) + -> OptionalT f a + -> OptionalT f b + (<*>) = + error "todo: Course.StateT (<*>)#instance (OptionalT f)" -- | Implement the `Monad` instance for `OptionalT f` given a Monad f. -- -- >>> runOptionalT $ (\a -> OptionalT (Full (a+1) :. Full (a+2) :. Nil)) =<< OptionalT (Full 1 :. Empty :. Nil) -- [Full 2,Full 3,Empty] instance Monad f => Monad (OptionalT f) where - f =<< OptionalT x = - OptionalT ((\o -> case o of - Empty -> pure Empty - Full a -> runOptionalT (f a)) =<< x) + (=<<) :: + (a -> OptionalT f b) + -> OptionalT f a + -> OptionalT f b + (=<<) = + error "todo: Course.StateT (=<<)#instance (OptionalT f)" -- | A `Logger` is a pair of a list of log values (`[l]`) and an arbitrary value (`a`). data Logger l a = @@ -240,8 +292,12 @@ data Logger l a = -- >>> (+3) <$> Logger (listh [1,2]) 3 -- Logger [1,2] 6 instance Functor (Logger l) where - f <$> Logger l a = - Logger l (f a) + (<$>) :: + (a -> b) + -> Logger l a + -> Logger l b + (<$>) = + error "todo: Course.StateT (<$>)#instance (Logger l)" -- | Implement the `Applicative` instance for `Logger`. -- @@ -251,10 +307,18 @@ instance Functor (Logger l) where -- >>> Logger (listh [1,2]) (+7) <*> Logger (listh [3,4]) 3 -- Logger [1,2,3,4] 10 instance Applicative (Logger l) where + pure :: + a + -> Logger l a pure = - Logger Nil - Logger l f <*> Logger m a = - Logger (l ++ m) (f a) + error "todo: Course.StateT pure#instance (Logger l)" + + (<*>) :: + Logger l (a -> b) + -> Logger l a + -> Logger l b + (<*>) = + error "todo: Course.StateT (<*>)#instance (Logger l)" -- | Implement the `Monad` instance for `Logger`. -- The `bind` implementation must append log values to maintain associativity. @@ -262,9 +326,12 @@ instance Applicative (Logger l) where -- >>> (\a -> Logger (listh [4,5]) (a+3)) =<< Logger (listh [1,2]) 3 -- Logger [1,2,4,5] 6 instance Monad (Logger l) where - f =<< Logger l a = - let Logger l' b = f a - in Logger (l ++ l') b + (=<<) :: + (a -> Logger l b) + -> Logger l a + -> Logger l b + (=<<) = + error "todo: Course.StateT (=<<)#instance (Logger l)" -- | A utility function for producing a `Logger` with one log value. -- @@ -274,8 +341,8 @@ log1 :: l -> a -> Logger l a -log1 l = - Logger (l :. Nil) +log1 = + error "todo: Course.StateT#log1" -- | Remove all duplicate integers from a list. Produce a log as you go. -- If there is an element above 100, then abort the entire computation and produce no result. @@ -295,11 +362,17 @@ distinctG :: (Integral a, Show a) => List a -> Logger Chars (Optional (List a)) -distinctG x = - runOptionalT (evalT (filtering (\a -> StateT (\s -> - OptionalT (if a > 100 - then - log1 (fromString ("aborting > 100: " P.++ show a)) Empty - else (if even a - then log1 (fromString ("even number: " P.++ show a)) - else pure) (Full (a `S.notMember` s, a `S.insert` s))))) x) S.empty) +distinctG = + error "todo: Course.StateT#distinctG" + +onFull :: + Applicative f => + (t -> f (Optional a)) + -> Optional t + -> f (Optional a) +onFull g o = + case o of + Empty -> + pure Empty + Full a -> + g a diff --git a/src/Course/Traversable.hs b/src/Course/Traversable.hs index 905e11971..987105604 100644 --- a/src/Course/Traversable.hs +++ b/src/Course/Traversable.hs @@ -4,11 +4,15 @@ module Course.Traversable where +import Course.Core import Course.Functor import Course.Applicative import Course.List +import Course.ExactlyOne +import Course.Optional +import Course.Compose --- | All instances of the `Traversable` type-class must satisfy two laws. These +-- | All instances of the `Traversable` type-class must satisfy three laws. These -- laws are not checked by the compiler. These laws are given as: -- -- * The law of naturality @@ -34,3 +38,77 @@ instance Traversable List where -> f (List b) traverse f = foldRight (\a b -> (:.) <$> f a <*> b) (pure Nil) + +instance Traversable ExactlyOne where + traverse :: + Applicative f => + (a -> f b) + -> ExactlyOne a + -> f (ExactlyOne b) + traverse = + error "todo: Course.Traversable traverse#instance ExactlyOne" + +instance Traversable Optional where + traverse :: + Applicative f => + (a -> f b) + -> Optional a + -> f (Optional b) + traverse = + error "todo: Course.Traversable traverse#instance Optional" + +-- | Sequences a traversable value of structures to a structure of a traversable value. +-- +-- >>> sequenceA (ExactlyOne 7 :. ExactlyOne 8 :. ExactlyOne 9 :. Nil) +-- ExactlyOne [7,8,9] +-- +-- >>> sequenceA (Full (ExactlyOne 7)) +-- ExactlyOne (Full 7) +-- +-- >>> sequenceA (Full (*10)) 6 +-- Full 60 +sequenceA :: + (Applicative f, Traversable t) => + t (f a) + -> f (t a) +sequenceA = + error "todo: Course.Traversable#sequenceA" + +instance (Traversable f, Traversable g) => + Traversable (Compose f g) where +-- Implement the traverse function for a Traversable instance for Compose + traverse = + error "todo: Course.Traversable traverse#instance (Compose f g)" + +-- | The `Product` data type contains one value from each of the two type constructors. +data Product f g a = + Product (f a) (g a) deriving (Show, Eq) + +instance (Functor f, Functor g) => + Functor (Product f g) where +-- Implement the (<$>) function for a Functor instance for Product + (<$>) = + error "todo: Course.Traversable (<$>)#instance (Product f g)" + +instance (Traversable f, Traversable g) => + Traversable (Product f g) where +-- Implement the traverse function for a Traversable instance for Product + traverse = + error "todo: Course.Traversable traverse#instance (Product f g)" + +-- | The `Coproduct` data type contains one value from either of the two type constructors. +data Coproduct f g a = + InL (f a) + | InR (g a) deriving (Show, Eq) + +instance (Functor f, Functor g) => + Functor (Coproduct f g) where +-- Implement the (<$>) function for a Functor instance for Coproduct + (<$>) = + error "todo: Course.Traversable (<$>)#instance (Coproduct f g)" + +instance (Traversable f, Traversable g) => + Traversable (Coproduct f g) where +-- Implement the traverse function for a Traversable instance for Coproduct + traverse = + error "todo: Course.Traversable traverse#instance (Coproduct f g)" diff --git a/src/Course/Validation.hs b/src/Course/Validation.hs index e7d011cde..932664bd3 100644 --- a/src/Course/Validation.hs +++ b/src/Course/Validation.hs @@ -28,7 +28,7 @@ type Err = P.String -- >>> isError (Value 7) -- False -- --- prop> isError x /= isValue x +-- prop> \x -> isError x /= isValue x isError :: Validation a -> Bool isError (Error _) = True isError (Value _) = False @@ -41,7 +41,7 @@ isError (Value _) = False -- >>> isValue (Value 7) -- True -- --- prop> isValue x /= isError x +-- prop> \x -> isValue x /= isError x isValue :: Validation a -> Bool isValue = not . isError @@ -53,7 +53,7 @@ isValue = not . isError -- >>> mapValidation (+10) (Value 7) -- Value 17 -- --- prop> mapValidation id x == x +-- prop> \x -> mapValidation id x == x mapValidation :: (a -> b) -> Validation a -> Validation b mapValidation _ (Error s) = Error s mapValidation f (Value a) = Value (f a) @@ -69,7 +69,7 @@ mapValidation f (Value a) = Value (f a) -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Value 8) -- Value 18 -- --- prop> bindValidation Value x == x +-- prop> \x -> bindValidation Value x == x bindValidation :: (a -> Validation b) -> Validation a -> Validation b bindValidation _ (Error s) = Error s bindValidation f (Value a) = f a @@ -82,7 +82,7 @@ bindValidation f (Value a) = f a -- >>> valueOr (Value 7) 3 -- 7 -- --- prop> isValue x || valueOr x n == n +-- prop> \x -> isValue x || valueOr x n == n valueOr :: Validation a -> a -> a valueOr (Error _) a = a valueOr (Value a) _ = a @@ -95,7 +95,7 @@ valueOr (Value a) _ = a -- >>> errorOr (Value 7) "q" -- "q" -- --- prop> isError x || errorOr x e == e +-- prop> \x -> isError x || errorOr x e == e errorOr :: Validation a -> Err -> Err errorOr (Error e) _ = e errorOr (Value _) a = a diff --git a/test/Course/ApplicativeTest.hs b/test/Course/ApplicativeTest.hs new file mode 100644 index 000000000..e1c1195fe --- /dev/null +++ b/test/Course/ApplicativeTest.hs @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Course.ApplicativeTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Applicative (filtering, lift2, lift3, lift4, pure, + replicateA, sequence, (*>), lift1, + (<*), (<*>)) +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) +import Course.Functor ((<$>)) +import Course.List (List (..), filter, length, listh, + product, sum) +import Course.Optional (Optional (..)) + +test_Applicative :: TestTree +test_Applicative = + testGroup "Applicative" [ + exactlyOneTest + , listTest + , haveFmapTest + , optionalTest + , functionTest + , lift2Test + , lift3Test + , lift4Test + , rightApplyTest + , leftApplyTest + , sequenceTest + , replicateATest + , filteringTest + ] + +exactlyOneTest :: TestTree +exactlyOneTest = + testGroup "ExactlyOne instance" [ + testProperty "pure == ExactlyOne" $ + \(x :: Integer) -> pure x == ExactlyOne x + , testCase "Applying within ExactlyOne" $ + ExactlyOne (+ 10) <*> ExactlyOne 8 @?= ExactlyOne 18 + ] + +listTest :: TestTree +listTest = + testGroup "List instance" [ + testProperty "pure" $ + \x -> pure x == (x :. Nil :: List Integer) + , testCase "<*>" $ + (+1) :. (*2) :. Nil <*> listh [1,2,3] @?= listh [2,3,4,2,4,6] + ] + +haveFmapTest :: TestTree +haveFmapTest = + testGroup "lift1" [ + testCase "ExactlyOne" $ + (lift1 (+ 1) (ExactlyOne 2)) @?= ExactlyOne (3 :: Integer) + , testCase "empty List" $ + (lift1 (+ 1) Nil) @?= Nil + , testCase "List" $ + (lift1 (+ 1) (listh [1,2,3])) @?= listh [2,3,4] + ] + +optionalTest :: TestTree +optionalTest = + testGroup "Optional instance" [ + testProperty "pure" $ + \(x :: Integer) -> pure x == Full x + , testCase "Full <*> Full" $ + Full (+8) <*> Full 7 @?= Full 15 + , testCase "Empty <*> Full" $ + Empty <*> Full "tilt" @?= (Empty :: Optional Integer) + , testCase "Full <*> Empty" $ + Full (+8) <*> Empty @?= Empty + ] + +functionTest :: TestTree +functionTest = + testGroup "Function instance" [ + testCase "addition" $ + ((+) <*> (+10)) 3 @?= 16 + , testCase "more addition" $ + ((+) <*> (+5)) 3 @?= 11 + , testCase "even more addition" $ + ((+) <*> (+5)) 1 @?= 7 + , testCase "addition and multiplication" $ + ((*) <*> (+10)) 3 @?= 39 + , testCase "more addition and multiplcation" $ + ((*) <*> (+2)) 3 @?= 15 + , testProperty "pure" $ + \(x :: Integer) (y :: Integer) -> pure x y == x + ] + +lift2Test :: TestTree +lift2Test = + testGroup "lift2" [ + testCase "+ over ExactlyOne" $ + lift2 (+) (ExactlyOne 7) (ExactlyOne 8) @?= ExactlyOne 15 + , testCase "+ over List" $ + lift2 (+) (listh [1,2,3]) (listh [4,5]) @?= listh [5,6,6,7,7,8] + , testCase "+ over Optional - all full" $ + lift2 (+) (Full 7) (Full 8) @?= Full 15 + , testCase "+ over Optional - first Empty" $ + lift2 (+) Empty (Full 8) @?= Empty + , testCase "+ over Optional - second Empty" $ + lift2 (+) (Full 7) Empty @?= Empty + , testCase "+ over functions" $ + lift2 (+) length sum (listh [4,5,6]) @?= 18 + ] + +lift3Test :: TestTree +lift3Test = + testGroup "lift3" [ + testCase "+ over ExactlyOne" $ + lift3 (\a b c -> a + b + c) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) @?= ExactlyOne 24 + , testCase "+ over List" $ + lift3 (\a b c -> a + b + c) (listh [1,2,3]) (listh [4,5]) (listh [6,7,8]) @?= + listh [11,12,13,12,13,14,12,13,14,13,14,15,13,14,15,14,15,16] + , testCase "+ over Optional" $ + lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) @?= Full 24 + , testCase "+ over Optional - third Empty" $ + lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty @?= Empty + , testCase "+ over Optional - first Empty" $ + lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) @?= Empty + , testCase "+ over Optional - first and second Empty" $ + lift3 (\a b c -> a + b + c) Empty Empty (Full 9) @?= Empty + , testCase "+ over functions" $ + lift3 (\a b c -> a + b + c) length sum product (listh [4,5,6]) @?= 138 + ] + +lift4Test :: TestTree +lift4Test = + testGroup "lift4" [ + testCase "+ over ExactlyOne" $ + lift4 (\a b c d -> a + b + c + d) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) (ExactlyOne 10) @?= ExactlyOne 34 + , testCase "+ over List" $ + lift4 (\a b c d -> a + b + c + d) (listh [1, 2, 3]) (listh [4, 5]) (listh [6, 7, 8]) (listh [9, 10]) @?= + (listh [20,21,21,22,22,23,21,22,22,23,23,24,21,22,22,23,23,24,22,23,23,24,24,25,22,23,23,24,24,25,23,24,24,25,25,26]) + , testCase "+ over Optional" $ + lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) @?= Full 34 + , testCase "+ over Optional - third Empty" $ + lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) @?= Empty + , testCase "+ over Optional - first Empty" $ + lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) @?= Empty + , testCase "+ over Optional - first and second Empty" $ + lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) @?= Empty + , testCase "+ over functions" $ + lift4 (\a b c d -> a + b + c + d) length sum product (sum . filter even) (listh [4,5,6]) @?= 148 + ] + +rightApplyTest :: TestTree +rightApplyTest = + testGroup "rightApply" [ + testCase "*> over List" $ + listh [1, 2, 3] *> listh [4, 5, 6] @?= listh [4,5,6,4,5,6,4,5,6] + , testCase "*> over List" $ + listh [1, 2] *> listh [4, 5, 6] @?= listh [4,5,6,4,5,6] + , testCase "another *> over List" $ + listh [1, 2, 3] *> listh [4, 5] @?= listh [4,5,4,5,4,5] + , testCase "*> over Optional" $ + Full 7 *> Full 8 @?= Full 8 + , testProperty "*> over List property" $ + \a b c x y z -> + let l1 = (listh [a, b, c] :: List Integer) + l2 = (listh [x, y, z] :: List Integer) + in l1 *> l2 == listh [x, y, z, x, y, z, x, y, z] + , testProperty "*> over Optional property" $ + \x y -> (Full x :: Optional Integer) *> (Full y :: Optional Integer) == Full y + ] + +leftApplyTest :: TestTree +leftApplyTest = + testGroup "leftApply" [ + testCase "<* over List" $ + (1 :. 2 :. 3 :. Nil) <* (4 :. 5 :. 6 :. Nil) @?= listh [1,1,1,2,2,2,3,3,3] + , testCase "another <* over List" $ + (1 :. 2 :. Nil) <* (4 :. 5 :. 6 :. Nil) @?= listh [1,1,1,2,2,2] + , testCase "Yet another <* over List" $ + (1 :. 2 :. 3 :. Nil) <* (4 :. 5 :. Nil) @?= listh [1,1,2,2,3,3] + , testCase "<* over Optional" $ + Full 7 <* Full 8 @?= Full 7 + , testProperty "<* over List property" $ + \x y z a b c -> + let l1 = (x :. y :. z :. Nil) :: List Integer + l2 = (a :. b :. c :. Nil) :: List Integer + in l1 <* l2 == listh [x, x, x, y, y, y, z, z, z] + , testProperty "<* over Optional property" $ + \x y -> Full (x :: Integer) <* Full (y :: Integer) == Full x + ] + +sequenceTest :: TestTree +sequenceTest = + testGroup "sequence" [ + testCase "ExactlyOne" $ + sequence (listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) @?= ExactlyOne (listh [7,8,9]) + , testCase "List" $ + sequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) @?= (listh <$> (listh [[1,1],[1,2],[2,1],[2,2],[3,1],[3,2]])) + , testCase "Optional with an empty" $ + sequence (Full 7 :. Empty :. Nil) @?= Empty + , testCase "Optional" $ + sequence (Full 7 :. Full 8 :. Nil) @?= Full (listh [7,8]) + , testCase "(->)" $ + sequence ((*10) :. (+2) :. Nil) 6 @?= (listh [60,8]) + ] + +replicateATest :: TestTree +replicateATest = + testGroup "replicateA" [ + testCase "ExactlyOne" $ + replicateA 4 (ExactlyOne "hi") @?= ExactlyOne (listh ["hi","hi","hi","hi"]) + , testCase "Optional - Full" $ + replicateA 4 (Full "hi") @?= Full (listh ["hi","hi","hi","hi"]) + , testCase "Optional - Empty" $ + replicateA 4 Empty @?= (Empty :: Optional (List Integer)) + , testCase "(->)" $ + replicateA 4 (*2) 5 @?= (listh [10,10,10,10]) + , testCase "List" $ + let expected = listh <$> (listh ["aaa","aab","aac","aba","abb","abc","aca","acb","acc", + "baa","bab","bac","bba","bbb","bbc","bca","bcb","bcc", + "caa","cab","cac","cba","cbb","cbc","cca","ccb","ccc"]) + in replicateA 3 ('a' :. 'b' :. 'c' :. Nil) @?= expected + ] + +filteringTest :: TestTree +filteringTest = + testGroup "filtering" [ + testCase "ExactlyOne" $ + filtering (ExactlyOne . even) (4 :. 5 :. 6 :. Nil) @?= ExactlyOne (listh [4,6]) + , testCase "Optional - all true" $ + filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) @?= Full (listh [4,5,6]) + , testCase "Optional - some false" $ + filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) @?= Full (listh [4,5,6,7]) + , testCase "Optional - some empty" $ + filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) @?= Empty + , testCase "(->)" $ + filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 @?= listh [9,10,11,12] + , testCase "List" $ + let expected = listh <$> listh [[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3]] + in filtering (const $ True :. True :. Nil) (1 :. 2 :. 3 :. Nil) @?= expected + ] diff --git a/test/Course/ChequeTest.hs b/test/Course/ChequeTest.hs new file mode 100644 index 000000000..a30122952 --- /dev/null +++ b/test/Course/ChequeTest.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Course.ChequeTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Core +import Course.Cheque (dollars) +import Course.List (List (..)) + +test_Cheque :: TestTree +test_Cheque = + testGroup "Cheque" [ + chequeDollarsTest + ] + +chequeDollarsTest :: TestTree +chequeDollarsTest = + testGroup "jsonObject" [ + testCase "empty" $ + dollars "0" @?= "zero dollars and zero cents" + , testCase "dollars '1'" $ + dollars "1" @?= "one dollar and zero cents" + , testCase "dollars '0.1'" $ + dollars "0.1" @?= "zero dollars and ten cents" + , testCase "dollars '1.'" $ + dollars "1." @?= "one dollar and zero cents" + , testCase "dollars '0.'" $ + dollars "0." @?= "zero dollars and zero cents" + , testCase "dollars '0.0'" $ + dollars "0.0" @?= "zero dollars and zero cents" + , testCase "dollars '.34'" $ + dollars ".34" @?= "zero dollars and thirty-four cents" + , testCase "dollars '0.3456789'" $ + dollars "0.3456789" @?= "zero dollars and thirty-four cents" + , testCase "dollars '1.0'" $ + dollars "1.0" @?= "one dollar and zero cents" + , testCase "dollars '1.01'" $ + dollars "1.01" @?= "one dollar and one cent" + , testCase "dollars 'a1a'" $ + dollars "a1a" @?= "one dollar and zero cents" + , testCase "dollars 'a1a.a0.7b'" $ + dollars "a1a.a0.7b" @?= "one dollar and seven cents" + , testCase "dollars '100'" $ + dollars "100" @?= "one hundred dollars and zero cents" + , testCase "dollars '100.0'" $ + dollars "100.0" @?= "one hundred dollars and zero cents" + , testCase "dollars '100.00'" $ + dollars "100.00" @?= "one hundred dollars and zero cents" + , testCase "dollars '100.00000'" $ + dollars "100.00000" @?= "one hundred dollars and zero cents" + , testCase "dollars '1000456.13'" $ + dollars "1000456.13" @?= "one million four hundred and fifty-six dollars and thirteen cents" + , testCase "dollars '1001456.13'" $ + dollars "1001456.13" @?= "one million one thousand four hundred and fifty-six dollars and thirteen cents" + , testCase "dollars '16000000456.13'" $ + dollars "16000000456.13" @?= "sixteen billion four hundred and fifty-six dollars and thirteen cents" + , testCase "dollars '100.45'" $ + dollars "100.45" @?= "one hundred dollars and forty-five cents" + , testCase "dollars '100.07'" $ + dollars "100.07" @?= "one hundred dollars and seven cents" + , testCase "dollars '9abc9def9ghi.jkl9mno'" $ + dollars "9abc9def9ghi.jkl9mno" @?= "nine hundred and ninety-nine dollars and ninety cents" + , testCase "dollars '12345.67'" $ + dollars "12345.67" @?= "twelve thousand three hundred and forty-five dollars and sixty-seven cents" + , testCase "dollars '456789123456789012345678901234567890123456789012345678901234567890.12'" $ + dollars "456789123456789012345678901234567890123456789012345678901234567890.12" @?= "four hundred and fifty-six vigintillion seven hundred and eighty-nine novemdecillion one hundred and twenty-three octodecillion four hundred and fifty-six septendecillion seven hundred and eighty-nine sexdecillion twelve quindecillion three hundred and forty-five quattuordecillion six hundred and seventy-eight tredecillion nine hundred and one duodecillion two hundred and thirty-four undecillion five hundred and sixty-seven decillion eight hundred and ninety nonillion one hundred and twenty-three octillion four hundred and fifty-six septillion seven hundred and eighty-nine sextillion twelve quintillion three hundred and forty-five quadrillion six hundred and seventy-eight trillion nine hundred and one billion two hundred and thirty-four million five hundred and sixty-seven thousand eight hundred and ninety dollars and twelve cents" + ] diff --git a/test/Course/ComonadTest.hs b/test/Course/ComonadTest.hs new file mode 100644 index 000000000..1af7ef192 --- /dev/null +++ b/test/Course/ComonadTest.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.ComonadTest where + + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Comonad (copure, (<$$>)) +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) + +test_Comonad :: TestTree +test_Comonad = + testGroup "Comonad" [ + exactlyOneTest + , fmapTest + ] + +exactlyOneTest :: TestTree +exactlyOneTest = + testCase "ExactlyOne" $ copure (ExactlyOne 7) @?= 7 + +fmapTest :: TestTree +fmapTest = + testCase "<$$>" $ + ((+10) <$$> ExactlyOne 7) @?= ExactlyOne 17 diff --git a/test/Course/ExtendTest.hs b/test/Course/ExtendTest.hs new file mode 100644 index 000000000..1a9a3fb56 --- /dev/null +++ b/test/Course/ExtendTest.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.ExtendTest where + + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Core +import Course.ExactlyOne (ExactlyOne (ExactlyOne)) +import Course.Functor ((<$>)) +import Course.List (List (..), length, listh, reverse) +import Course.Optional (Optional (..)) + +import Course.Extend (cojoin, (<<=)) + +test_Extend :: TestTree +test_Extend = + testGroup "Extend" [ + exactlyOneTest + , listTest + , optionalTest + , cojoinTest + ] + +exactlyOneTest :: TestTree +exactlyOneTest = + testCase "ExactlyOne instance" $ + (id <<= ExactlyOne 7) @?= ExactlyOne (ExactlyOne 7) + +listTest :: TestTree +listTest = + testGroup "List" [ + testCase "length" $ + (length <<= ('a' :. 'b' :. 'c' :. Nil)) @?= (3 :. 2 :. 1 :. Nil) + , testCase "id" $ + (id <<= (1 :. 2 :. 3 :. 4 :. Nil)) @?= nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] + , testCase "reverse" $ + (reverse <<= ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil)) @?= + nestedListh3 [[[4,5,6],[1,2,3]],[[4,5,6]]] + ] + +optionalTest :: TestTree +optionalTest = + testGroup "Optional" [ + testCase "id Full" $ + (id <<= (Full 7)) @?= Full (Full 7) + , testCase "id Empty" $ + (id <<= Empty) @?= (Empty :: Optional (Optional Integer)) + ] + +cojoinTest :: TestTree +cojoinTest = + testGroup "cojoin" [ + testCase "ExactlyOne" $ + cojoin (ExactlyOne 7) @?= ExactlyOne (ExactlyOne 7) + , testCase "List" $ + cojoin (1 :. 2 :. 3 :. 4 :. Nil) @?= nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] + , testCase "Full" $ + cojoin (Full 7) @?= Full (Full 7) + , testCase "Empty" $ + cojoin Empty @?= (Empty :: Optional (Optional Integer)) + ] + +nestedListh2 :: [[a]] -> List (List a) +nestedListh2 = (listh <$>) . listh + +nestedListh3 :: [[[a]]] -> List (List (List a)) +nestedListh3 = ((listh <$>) <$>) . nestedListh2 diff --git a/test/Course/FunctorTest.hs b/test/Course/FunctorTest.hs new file mode 100644 index 000000000..e9492dd2e --- /dev/null +++ b/test/Course/FunctorTest.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Course.FunctorTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) +import Course.Functor (void, (<$), (<$>)) +import Course.List (List (..)) +import Course.Optional (Optional (..)) + +test_Functor :: TestTree +test_Functor = + testGroup "Functor" [ + idTest + , listTest + , optionalTest + , functionTest + , anonMapTest + , voidTest + ] + +idTest :: TestTree +idTest = + testCase "ExactlyOne" $ (+1) <$> ExactlyOne 2 @?= ExactlyOne 3 + +listTest :: TestTree +listTest = + testGroup "List" [ + testCase "empty list" $ + (+1) <$> Nil @?= Nil + , testCase "increment" $ + (+1) <$> (1 :. 2 :. 3 :. Nil) @?= (2 :. 3 :. 4 :. Nil) + ] + +optionalTest :: TestTree +optionalTest = + testGroup "Optional" [ + testCase "Empty" $ (+1) <$> Empty @?= Empty + , testCase "Full" $ (+1) <$> Full 2 @?= Full 3 + ] + +functionTest :: TestTree +functionTest = + testCase "(->)" $ ((+1) <$> (*2)) 8 @?= 17 + + +anonMapTest :: TestTree +anonMapTest = + testGroup "(<$)" [ + testCase "Map 7" $ 7 <$ (1 :. 2 :. 3 :. Nil) @?= (7 :. 7 :. 7 :. Nil) + , testProperty "Always maps a constant value over List" $ + \x a b c -> (x :: Integer) <$ ((a :. b :. c :. Nil) :: List Integer) == (x :. x :. x :. Nil) + , testProperty "Always maps a constant value over Full (Optional)" $ + \(x :: Integer) (q :: Integer) -> x <$ Full q == Full x + ] + +voidTest :: TestTree +voidTest = + testGroup "void" [ + testCase "List" $ void (1 :. 2 :. 3 :. Nil) @?= () :. () :. () :. Nil + , testCase "Full" $ void (Full 7) @?= Full () + , testCase "Empty" $ void Empty @?= Empty + , testCase "(->)" $ void (+10) 5 @?= () + ] diff --git a/test/Course/Gens.hs b/test/Course/Gens.hs new file mode 100644 index 000000000..125621562 --- /dev/null +++ b/test/Course/Gens.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Gens where + +import qualified Prelude as P (fmap, foldr, (<$>), (<*>)) +import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable, + forAllShrink) + +import Course.Core +import Course.List (List (..), hlist, listh) +import Course.ListZipper (ListZipper (..), zipper) + +genList :: Arbitrary a => Gen (List a) +genList = P.fmap ((P.foldr (:.) Nil) :: [a] -> List a) arbitrary + +shrinkList :: Arbitrary a => List a -> [List a] +shrinkList = + P.fmap listh . shrink . hlist + +genIntegerList :: Gen (List Integer) +genIntegerList = genList + +genIntegerAndList :: Gen (Integer, List Integer) +genIntegerAndList = P.fmap (P.fmap listh) arbitrary + +shrinkIntegerAndList :: (Integer, List Integer) -> [(Integer, List Integer)] +shrinkIntegerAndList = P.fmap (P.fmap listh) . shrink . P.fmap hlist + +genTwoLists :: Gen (List Integer, List Integer) +genTwoLists = (,) P.<$> genIntegerList P.<*> genIntegerList + +shrinkTwoLists :: (List Integer, List Integer) -> [(List Integer, List Integer)] +shrinkTwoLists (a,b) = P.fmap (\(as,bs) -> (listh as, listh bs)) $ shrink (hlist a, hlist b) + +genThreeLists :: Gen (List Integer, List Integer, List Integer) +genThreeLists = (,,) P.<$> genIntegerList P.<*> genIntegerList P.<*> genIntegerList + +shrinkThreeLists :: (List Integer, List Integer, List Integer) -> [(List Integer, List Integer, List Integer)] +shrinkThreeLists (a,b,c) = P.fmap (\(as,bs,cs) -> (listh as, listh bs, listh cs)) $ shrink (hlist a, hlist b, hlist c) + +genListOfLists :: Gen (List (List Integer)) +genListOfLists = P.fmap (P.fmap listh) (genList :: (Gen (List [Integer]))) + +shrinkListOfLists :: Arbitrary a => List (List a) -> [List (List a)] +shrinkListOfLists = P.fmap (P.fmap listh). shrinkList . P.fmap hlist + +forAllLists :: Testable prop => (List Integer -> prop) -> Property +forAllLists = forAllShrink genIntegerList shrinkList + +-- (List Integer) and a Bool +genListAndBool :: Gen (List Integer, Bool) +genListAndBool = (,) P.<$> genIntegerList P.<*> arbitrary + +shrinkListAndBool :: (List Integer, Bool) -> [(List Integer, Bool)] +shrinkListAndBool (xs,b) = (,) P.<$> (shrinkList xs) P.<*> (shrink b) + +forAllListsAndBool :: Testable prop + => ((List Integer, Bool) -> prop) + -> Property +forAllListsAndBool = + forAllShrink genListAndBool shrinkListAndBool + +-- ListZipper Integer +genListZipper :: Gen (ListZipper Integer) +genListZipper = + zipper P.<$> arbitrary P.<*> arbitrary P.<*> arbitrary + +shrinkListZipper :: ListZipper Integer -> [ListZipper Integer] +shrinkListZipper (ListZipper l x r) = + ListZipper P.<$> (shrinkList l) P.<*> (shrink x) P.<*> (shrinkList r) + +forAllListZipper :: Testable prop + => (ListZipper Integer -> prop) + -> Property +forAllListZipper = + forAllShrink genListZipper shrinkListZipper + +genListZipperWithInt :: Gen (ListZipper Integer, Int) +genListZipperWithInt = + (,) P.<$> genListZipper P.<*> arbitrary + +shrinkListZipperWithInt :: (ListZipper Integer, Int) -> [(ListZipper Integer, Int)] +shrinkListZipperWithInt (z, i) = + (,) P.<$> (shrinkListZipper z) P.<*> (shrink i) + +forAllListZipperWithInt :: Testable prop + => ((ListZipper Integer, Int) -> prop) + -> Property +forAllListZipperWithInt = + forAllShrink genListZipperWithInt shrinkListZipperWithInt diff --git a/test/Course/JsonParserTest.hs b/test/Course/JsonParserTest.hs new file mode 100644 index 000000000..c463717d8 --- /dev/null +++ b/test/Course/JsonParserTest.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Course.JsonParserTest where + +import Data.Ratio ((%)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Core +import Course.JsonParser (jsonArray, jsonFalse, jsonNull, jsonNumber, + jsonObject, jsonString, jsonTrue, jsonValue) +import Course.JsonValue (JsonValue (..)) +import Course.List (List (..)) +import Course.Parser (ParseResult (..), isErrorResult, parse) + +test_JsonParser :: TestTree +test_JsonParser = + testGroup "JsonParser" [ + jsonStringTest + , jsonNumberTest + , jsonTrueTest + , jsonFalseTest + , jsonNullTest + , jsonArrayTest + , jsonObjectTest + ] + +jsonStringTest :: TestTree +jsonStringTest = + testGroup "jsonString" [ + testCase "parse whole ASCII input" $ + parse jsonString "\" abc\"" @?= Result "" " abc" + , testCase "parse only the first string of input" $ + parse jsonString "\"abc\"def" @?= Result "def" "abc" + , testCase "parse back slash (\\)" $ + parse jsonString "\"\\babc\"def" @?= Result "def" "\babc" + , testCase "parse unicode (\\u00abc)" $ + parse jsonString "\"\\u00abc\"def" @?= Result "def" "«c" + , testCase "parse unicode (\\u00ff)" $ + parse jsonString "\"\\u00ffabc\"def" @?= Result "def" "ÿabc" + , testCase "parse unicode (\\u00fa)" $ + parse jsonString "\"\\u00faabc\"def" @?= Result "def" "úabc" + , testCase "parsing string without quotes is an error" $ + isErrorResult (parse jsonString "abc") @?= True + , testCase "parsing string containing \\a is an error - \\a isn't a special character" $ + isErrorResult (parse jsonString "\"\\abc\"def") @?= True + ] + +jsonNumberTest :: TestTree +jsonNumberTest = + testGroup "jsonNumber" [ + testCase "positive whole" $ parse jsonNumber "234" @?= Result "" (234 % 1) + , testCase "negative whole" $ parse jsonNumber "-234" @?= Result "" ((-234) % 1) + , testCase "positive decimal" $ parse jsonNumber "123.45" @?= Result "" (2469 % 20) + , testCase "negative whole (2)" $ parse jsonNumber "-123" @?= Result "" ((-123) % 1) + , testCase "negative decimal" $ parse jsonNumber "-123.45" @?= Result "" ((-2469) % 20) + , testCase "negative sign on its own is error" $ isErrorResult (parse jsonNumber "-") @?= True + , testCase "alphabetic characters is error" $ isErrorResult (parse jsonNumber "abc") @?= True + ] + +jsonTrueTest :: TestTree +jsonTrueTest = + testGroup "jsonTrue" [ + testCase "parses true" $ parse jsonTrue "true" @?= Result "" "true" + , testCase "TRUE (caps) is an error" $ isErrorResult (parse jsonTrue "TRUE") @?= True + ] + +jsonFalseTest :: TestTree +jsonFalseTest = + testGroup "jsonFalse" [ + testCase "parses false" $ parse jsonFalse "false" @?= Result "" "false" + , testCase "FALSE (caps) is an error" $ isErrorResult (parse jsonFalse "FALSE") @?= True + ] + +jsonNullTest :: TestTree +jsonNullTest = + testGroup "jsonNull" [ + testCase "parses null" $ parse jsonNull "null" @?= Result "" "null" + , testCase "NULL (caps) is an error" $ isErrorResult (parse jsonNull "NULL") @?= True + ] + +jsonArrayTest :: TestTree +jsonArrayTest = + testGroup "jsonArray" [ + testCase "[]" $ + parse jsonArray "[]" @?= Result "" Nil + , testCase "[true]" $ + parse jsonArray "[true]" @?= Result "" (JsonTrue :. Nil) + , testCase "[true, \"abc\"]" $ + parse jsonArray "[true, \"abc\"]" @?= Result "" (JsonTrue :. JsonString "abc" :. Nil) + , testCase "[true, \"abc\", []]" $ + parse jsonArray "[true, \"abc\", []]" @?= Result "" (JsonTrue :. JsonString "abc" :. JsonArray Nil :. Nil) + , testCase "[true, \"abc\", [false]]" $ + let result = Result "" (JsonTrue :. JsonString "abc" :. JsonArray (JsonFalse :. Nil) :. Nil) + in parse jsonArray "[true, \"abc\", [false]]" @?= result + ] + +jsonObjectTest :: TestTree +jsonObjectTest = + testGroup "jsonObject" [ + testCase "empty" $ + parse jsonObject "{}" @?= Result "" Nil + , testCase "one key" $ + parse jsonObject "{ \"key1\" : true }" @?= Result "" (("key1",JsonTrue) :. Nil) + , testCase "two keys" $ + parse jsonObject "{ \"key1\" : true , \"key2\" : false }" @?= Result "" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) + , testCase "two keys and left over input" $ + let result = Result "xyz" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) + in parse jsonObject "{ \"key1\" : true , \"key2\" : false } xyz" @?= result + ] + +jsonValueTest :: TestTree +jsonValueTest = + testGroup "jsonValue" [ + testCase "true" $ + parse jsonValue "true" @?= Result "" JsonTrue + , testCase "object" $ + let result = Result "" ( ("key1",JsonTrue) + :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse:.Nil)) + :. Nil + ) + in parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] }" @?= result + , testCase "nested object" $ + let result = Result "" ( ("key1",JsonTrue) + :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse :. Nil)) + :. ("key3",JsonObject (("key4",JsonNull) :. Nil)) + :. Nil + ) + in parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] , \"key3\" : { \"key4\" : null } }" @?= result + ] diff --git a/test/Course/ListTest.hs b/test/Course/ListTest.hs new file mode 100644 index 000000000..070f7a33e --- /dev/null +++ b/test/Course/ListTest.hs @@ -0,0 +1,218 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.ListTest where + +import qualified Prelude as P (length) + +import Test.QuickCheck (forAllShrink) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Core +import Course.Gens (forAllLists, genIntegerAndList, genList, + genListOfLists, genThreeLists, + genTwoLists, shrinkIntegerAndList, + shrinkList, shrinkListOfLists, + shrinkThreeLists, shrinkTwoLists) +import Course.List (List (..), filter, find, flatMap, + flatten, flattenAgain, foldLeft, headOr, + hlist, infinity, largeList, length, + lengthGT4, listh, map, produce, product, + reverse, seqOptional, sum, take, (++)) +import Course.Optional (Optional (..)) + +test_List :: TestTree +test_List = + testGroup "List" [ + headOrTest + , productTest + , sumTest + , lengthTest + , mapTest + , filterTest + , appendTest + , flattenTest + , flatMapTest + , flattenAgainTest + , seqOptionalTest + , findTest + , lengthGT4Test + , reverseTest + , produceTest + ] + +headOrTest :: TestTree +headOrTest = + testGroup "headOr" [ + testCase "headOr on non-empty list" $ headOr 3 (1 :. 2 :. Nil) @?= 1 + , testCase "headOr on empty list" $ headOr 3 Nil @?= 3 + , testProperty "headOr on infinity always 0" $ \x -> x `headOr` infinity == 0 + , testProperty "headOr on empty list always the default" $ \x -> x `headOr` Nil == (x :: Integer) + ] + +productTest :: TestTree +productTest = + testGroup "productTest" [ + testCase "product of empty list" $ product Nil @?= 1 + , testCase "product of 1..3" $ product (1 :. 2 :. 3 :. Nil) @?= 6 + , testCase "product of 1..4" $ product (1 :. 2 :. 3 :. 4 :. Nil) @?= 24 + ] + +sumTest :: TestTree +sumTest = + testGroup "sum" [ + testCase "sum 1..3" $ sum (1 :. 2 :. 3 :. Nil) @?= 6 + , testCase "sum 1..4" $ sum (1 :. 2 :. 3 :. 4 :. Nil) @?= 10 + , testProperty "subtracting each element in a list from its sum is always 0" $ + forAllShrink genList shrinkList (\x -> foldLeft (-) (sum x) x == 0) + ] + +lengthTest :: TestTree +lengthTest = + testGroup "length" [ + testCase "length 1..3" $ length (1 :. 2 :. 3 :. Nil) @?= 3 + , testProperty "summing a list of 1s is equal to its length" $ + forAllLists (\x -> P.length (hlist x) == length x) + ] + +mapTest :: TestTree +mapTest = + testGroup "map" [ + testCase "add 10 on list" $ + map (+10) (1 :. 2 :. 3 :. Nil) @?= (11 :. 12 :. 13 :. Nil) + , testProperty "headOr after map" $ + \x -> headOr (x :: Integer) (map (+1) infinity) == 1 + , testProperty "map id is id" $ + forAllLists (\x -> map id x == x) + ] + +filterTest :: TestTree +filterTest = + testGroup "filter" [ + testCase "filter even" $ + filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) @?= (2 :. 4 :. Nil) + , testProperty "filter (const True) is identity (headOr)" $ + \x -> headOr x (filter (const True) infinity) == 0 + , testProperty "filter (const True) is identity" $ + forAllLists (\x -> filter (const True) x == x) + , testProperty "filter (const False) is the empty list" $ + forAllLists (\x -> filter (const False) x == Nil) + ] + +appendTest :: TestTree +appendTest = + testGroup "(++)" [ + testCase "(1..6)" $ + (1 :. 2 :. 3 :. Nil) ++ (4 :. 5 :. 6 :. Nil) @?= listh [1,2,3,4,5,6] + , testProperty "append empty to infinite" $ + \x -> headOr x (Nil ++ infinity) == 0 + , testProperty "append anything to infinity" $ + forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (y ++ infinity) == headOr 0 y) + , testProperty "associativity" $ + forAllShrink genThreeLists shrinkThreeLists (\(x,y,z) -> (x ++ y) ++ z == x ++ (y ++ z)) + , testProperty "append to empty list" $ + forAllLists (\x -> x ++ Nil == x) + ] + +flattenTest :: TestTree +flattenTest = + testGroup "flatten" [ + testCase "(1..9)" $ + flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) @?= listh [1,2,3,4,5,6,7,8,9] + , testProperty "flatten (infinity :. y)" $ + forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatten (infinity :. y :. Nil)) == 0) + , testProperty "flatten (y :. infinity)" $ + forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y) + , testProperty "sum of lengths == length of flattened" $ + forAllShrink genListOfLists shrinkListOfLists (\x -> sum (map length x) == length (flatten x)) + ] + +flatMapTest :: TestTree +flatMapTest = + testGroup "flatMap" [ + testCase "lists of Integer" $ + flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) @?= listh [1,2,3,2,3,4,3,4,5] + , testProperty "flatMap id flattens a list of lists" $ + forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatMap id (infinity :. y :. Nil)) == 0) + , testProperty "flatMap id on a list of lists take 2" $ + forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y) + , testProperty "flatMap id == flatten" $ + forAllShrink genListOfLists shrinkListOfLists (\x -> flatMap id x == flatten x) + ] + +flattenAgainTest :: TestTree +flattenAgainTest = + testGroup "flattenAgain" [ + testProperty "lists of Integer" $ + forAllShrink genListOfLists shrinkListOfLists (\x -> flatten x == flattenAgain x) + ] + + +seqOptionalTest :: TestTree +seqOptionalTest = + testGroup "seqOptional" [ + testCase "all Full" $ + seqOptional (Full 1 :. Full 10 :. Nil) @?= Full (1 :. 10 :. Nil) + , testCase "empty list" $ + let empty = Nil :: List (Optional Integer) + in seqOptional empty @?= Full Nil + , testCase "contains Empty" $ + seqOptional (Full 1 :. Full 10 :. Empty :. Nil) @?= Empty + , testCase "Empty at head of infinity" $ + seqOptional (Empty :. map Full infinity) @?= Empty + ] + +findTest :: TestTree +findTest = + testGroup "find" [ + testCase "find no matches" $ + find even (1 :. 3 :. 5 :. Nil) @?= Empty + , testCase "empty list" $ find even Nil @?= Empty + , testCase "find only even" $ + find even (1 :. 2 :. 3 :. 5 :. Nil) @?= Full 2 + , testCase "find first, not second even" $ + find even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) @?= Full 2 + , testCase "find on infinite list" $ + find (const True) infinity @?= Full 0 + ] + +lengthGT4Test :: TestTree +lengthGT4Test = + testGroup "lengthGT4" [ + testCase "list of length 3" $ + lengthGT4 (1 :. 3 :. 5 :. Nil) @?= False + , testCase "list of length 4" $ + lengthGT4 (1 :. 2 :. 3 :. 4 :. Nil) @?= False + , testCase "empty list" $ + lengthGT4 Nil @?= False + , testCase "list of length 5" $ + lengthGT4 (1 :. 2 :. 3 :. 4 :. 5 :. Nil) @?= True + , testCase "infinite list" $ + lengthGT4 infinity @?= True + ] + +reverseTest :: TestTree +reverseTest = + testGroup "reverse" [ + testCase "empty list" $ + reverse Nil @?= (Nil :: List Integer) + , testCase "reverse . reverse on largeList" $ + take 1 (reverse (reverse largeList)) @?= (1 :. Nil) + , testProperty "reverse then append is same as append then reverse" $ + forAllShrink genTwoLists shrinkTwoLists (\(x, y) -> reverse x ++ reverse y == reverse (y ++ x)) + , testProperty "" $ + forAllLists (\x -> reverse (x :. Nil) == x :. Nil) + ] + +produceTest :: TestTree +produceTest = + testGroup "produce" [ + testCase "increment" $ + let (x:.y:.z:.w:._) = produce (+1) 0 + in (x:.y:.z:.w:.Nil) @?= (0:.1:.2:.3:.Nil) + , testCase "double" $ + let (x:.y:.z:.w:._) = produce (*2) 1 + in (x:.y:.z:.w:.Nil) @?= (1:.2:.4:.8:.Nil) + ] diff --git a/test/Course/ListZipperTest.hs b/test/Course/ListZipperTest.hs new file mode 100644 index 000000000..0273b1e3e --- /dev/null +++ b/test/Course/ListZipperTest.hs @@ -0,0 +1,463 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.ListZipperTest where + + +import qualified Prelude as P (fromIntegral, (<$>)) +import Test.QuickCheck.Function (Fun (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Applicative (pure, (<*>)) +import Course.Comonad (copure) +import Course.Core +import Course.Extend ((<<=)) +import Course.Functor ((<$>)) +import Course.List (List (..), all, isEmpty, take) +import Course.ListZipper (ListZipper, MaybeListZipper (..), + deletePullLeft, deletePullRight, + dropLefts, dropRights, end, findLeft, + findRight, fromList, hasLeft, + hasRight, index, insertPushLeft, + insertPushRight, lefts, moveLeft, + moveLeftLoop, moveLeftN, moveLeftN', + moveRight, moveRightLoop, moveRightN, + moveRightN', nth, rights, setFocus, + start, swapLeft, swapRight, toList, + toListZ, toOptional, withFocus, + zipper, (-<<)) +import Course.Optional (Optional (Empty, Full)) +import Course.Traversable (traverse) + +import Course.Gens (forAllListZipper, + forAllListZipperWithInt, forAllLists, + forAllListsAndBool) + +test_ListZipper :: TestTree +test_ListZipper = + testGroup "ListZipper" [ + functorTest + , functorMaybeTest + , toListTest + , fromListTest + , toOptionalTest + , withFocusTest + , setFocusTest + , hasLeftTest + , hasRightTest + , findLeftTest + , findRightTest + , moveLeftLoopTest + , moveRightLoopTest + , moveLeftTest + , moveRightTest + , swapLeftTest + , swapRightTest + , dropLeftsTest + , dropRightsTest + , moveLeftNTest + , moveRightNTest + , moveLeftN'Test + , moveRightN'Test + , nthTest + , indexTest + , endTest + , startTest + , deletePullLeftTest + , deletePullRightTest + , insertPushLeftTest + , insertPushRightTest + , applicativeTest + , applicativeMaybeTest + , extendTest + , extendMaybeTest + , comonadTest + , traversableTest + , traversableMaybeTest + ] + +functorTest :: TestTree +functorTest = + testCase "ListZipper (<$>)" $ + (+1) <$> zipper [3,2,1] 4 [5,6,7] @?= zipper [4,3,2] 5 [6,7,8] + +functorMaybeTest :: TestTree +functorMaybeTest = + testCase "MaybeListZipper (<$>)" $ + (+1) <$> IsZ (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [4,3,2] 5 [6,7,8]) + +toListTest :: TestTree +toListTest = + testGroup "toList" [ + testCase "Optional empty list" $ + toList <$> Empty @?= (Empty :: Optional (List Int)) + , testCase "empty left" $ + toList (zipper [] 1 [2,3,4]) @?= (1:.2:.3:.4:.Nil) + , testCase "lefts and rights" $ + toList (zipper [3,2,1] 4 [5,6,7]) @?= (1:.2:.3:.4:.5:.6:.7:.Nil) + ] + +fromListTest :: TestTree +fromListTest = + testGroup "fromList" [ + testCase "non-empty" $ fromList (1 :. 2 :. 3 :. Nil) @?= IsZ (zipper [] 1 [2,3]) + , testCase "empty" $ fromList Nil @?= (IsNotZ :: MaybeListZipper Integer) + , testProperty "round trip" $ + forAllLists (\xs -> toListZ (fromList xs) == xs) + ] + +toOptionalTest :: TestTree +toOptionalTest = + testGroup "toOptional" [ + testProperty "empty" $ + forAllLists (\xs -> isEmpty xs == (toOptional (fromList xs) == Empty)) + ] + +withFocusTest :: TestTree +withFocusTest = + testGroup "withFocus" [ + testCase "empty left" $ + withFocus (+1) (zipper [] 0 [1]) @?= zipper [] 1 [1] + , testCase "left and right" $ + withFocus (+1) (zipper [1,0] 2 [3,4]) @?= zipper [1,0] 3 [3,4] + ] + +setFocusTest :: TestTree +setFocusTest = + testGroup "setFocus" [ + testCase "empty left" $ + setFocus 1 (zipper [] 0 [1]) @?= zipper [] 1 [1] + , testCase "left and right" $ + setFocus 1 (zipper [1,0] 2 [3,4]) @?= zipper [1,0] 1 [3,4] + ] + +hasLeftTest :: TestTree +hasLeftTest = + testGroup "hasLeft" [ + testCase "left and right" $ hasLeft (zipper [1,0] 2 [3,4]) @?= True + , testCase "empty left" $ hasLeft (zipper [] 0 [1,2]) @?= False + ] + +hasRightTest :: TestTree +hasRightTest = + testGroup "hasRight" [ + testCase "left and right" $ hasRight (zipper [1,0] 2 [3,4]) @?= True + , testCase "empty right" $ hasRight (zipper [1,0] 2 []) @?= False + ] + +findLeftTest :: TestTree +findLeftTest = + testGroup "findLeft" [ + testProperty "missing element returns IsNotZ" $ + forAllListsAndBool (\(xs, p) -> findLeft (const p) -<< fromList xs == IsNotZ) + , testCase "found in left" $ + findLeft (== 1) (zipper [2,1] 3 [4,5]) @?= IsZ (zipper [] 1 [2,3,4,5]) + , testCase "not found" $ + findLeft (== 6) (zipper [2,1] 3 [4,5]) @?= IsNotZ + , testCase "one match in left" $ + findLeft (== 1) (zipper [2,1] 1 [4,5]) @?= IsZ (zipper [] 1 [2,1,4,5]) + , testCase "multiple matches in left" $ + findLeft (== 1) (zipper [1,2,1] 3 [4,5]) @?= IsZ (zipper [2,1] 1 [3,4,5]) + , testCase "elements shifted to right correctly" $ + findLeft (== 1) (zipper [3,4,1,5] 9 [2,7]) @?= IsZ (zipper [5] 1 [4,3,9,2,7]) + ] + +findRightTest :: TestTree +findRightTest = + testGroup "findRight" [ + testProperty "missing element returns IsNotZ" $ + forAllLists (\xs -> findRight (const False) -<< fromList xs == IsNotZ) + , testCase "found in right" $ + findRight (== 5) (zipper [2,1] 3 [4,5]) @?= IsZ (zipper [4,3,2,1] 5 []) + , testCase "not found" $ + findRight (== 6) (zipper [2,1] 3 [4,5]) @?= IsNotZ + , testCase "one match in right" $ + findRight (== 1) (zipper [2,3] 1 [4,5,1]) @?= IsZ (zipper [5,4,1,2,3] 1 []) + , testCase "multiple matches in right" $ + findRight (== 1) (zipper [2,3] 1 [1,4,5,1]) @?= IsZ (zipper [1,2,3] 1 [4,5,1]) + ] + +moveLeftLoopTest :: TestTree +moveLeftLoopTest = + testGroup "moveLeftLoop" [ + testCase "with left" $ + moveLeftLoop (zipper [3,2,1] 4 [5,6,7]) @?= zipper [2,1] 3 [4,5,6,7] + , testCase "empty left" $ + moveLeftLoop (zipper [] 1 [2,3,4]) @?= zipper [3,2,1] 4 [] + ] + +moveRightLoopTest :: TestTree +moveRightLoopTest = + testGroup "moveRightLoop" [ + testCase "with right" $ + moveRightLoop (zipper [3,2,1] 4 [5,6,7]) @?= zipper [4,3,2,1] 5 [6,7] + , testCase "empty right" $ + moveRightLoop (zipper [3,2,1] 4 []) @?= zipper [] 1 [2,3,4] + ] + +moveLeftTest :: TestTree +moveLeftTest = + testGroup "moveLeft" [ + testCase "with left" $ + moveLeft (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [2,1] 3 [4,5,6,7]) + , testCase "empty left" $ + moveLeft (zipper [] 1 [2,3,4]) @?= IsNotZ + ] + +moveRightTest :: TestTree +moveRightTest = + testGroup "moveRight" [ + testCase "with right" $ + moveRight (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [4,3,2,1] 5 [6,7]) + , testCase "empty right" $ + moveRight (zipper [3,2,1] 4 []) @?= IsNotZ + ] + +swapLeftTest :: TestTree +swapLeftTest = + testGroup "swapLeft" [ + testCase "with left" $ + swapLeft (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [4,2,1] 3 [5,6,7]) + , testCase "empty left" $ + swapLeft (zipper [] 1 [2,3,4]) @?= IsNotZ + ] + +swapRightTest :: TestTree +swapRightTest = + testGroup "swapRight" [ + testCase "with right" $ + swapRight (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [3,2,1] 5 [4,6,7]) + , testCase "empty right" $ + swapRight (zipper [3,2,1] 4 []) @?= IsNotZ + ] + +dropLeftsTest :: TestTree +dropLeftsTest = + testGroup "dropLeft" [ + testCase "with left" $ + dropLefts (zipper [3,2,1] 4 [5,6,7]) @?= zipper [] 4 [5,6,7] + , testCase "empty left" $ + dropLefts (zipper [] 1 [2,3,4]) @?= zipper [] 1 [2,3,4] + , testProperty "dropLefts empties left of zipper" + (\l x r -> dropLefts (zipper l x r) == (zipper [] x r :: ListZipper Integer)) + ] + +dropRightsTest :: TestTree +dropRightsTest = + testGroup "dropRights" [ + testCase "with right" $ + dropRights (zipper [3,2,1] 4 [5,6,7]) @?= zipper [3,2,1] 4 [] + , testCase "empty right" $ + dropRights (zipper [3,2,1] 4 []) @?= zipper [3,2,1] 4 [] + , testProperty "dropRights empties right of zipper" + (\l x r -> dropRights (zipper l x r) == (zipper l x [] :: ListZipper Integer)) + ] + +moveLeftNTest :: TestTree +moveLeftNTest = + testGroup "moveLeftN" [ + testCase "positive moves" $ + moveLeftN 2 (zipper [2,1,0] 3 [4,5,6]) @?= IsZ (zipper [0] 1 [2,3,4,5,6]) + , testCase "negative moves" $ + moveLeftN (-1) (zipper [2,1,0] 3 [4,5,6]) @?= IsZ (zipper [3,2,1,0] 4 [5,6]) + ] + +moveRightNTest :: TestTree +moveRightNTest = + testGroup "moveRightN" [ + testCase "positive moves" $ + moveRightN 1 (zipper [2,1,0] 3 [4,5,6]) @?= IsZ (zipper [3,2,1,0] 4 [5,6]) + , testCase "negative moves" $ + moveRightN (-1) (zipper [2,1,0] 3 [4,5,6]) @?= IsZ (zipper [1,0] 2 [3,4,5,6]) + ] + +moveLeftN'Test :: TestTree +moveLeftN'Test = + testGroup "moveLeftN'" [ + testCase "positive - out of bounds both sides" $ + moveLeftN' 4 (zipper [3,2,1] 4 [5,6,7]) @?= Left 3 + , testCase "positive in range" $ + moveLeftN' 1 (zipper [3,2,1] 4 [5,6,7]) @?= Right (zipper [2,1] 3 [4,5,6,7]) + , testProperty "moving zero is `Right . id`" + (\l x r -> let lz = zipper l x r :: ListZipper Integer + in moveLeftN' 0 lz == (Right . id $ lz)) + , testCase "negative in range" $ + moveLeftN' (-2) (zipper [3,2,1] 4 [5,6,7]) @?= Right (zipper [5,4,3,2,1] 6 [7]) + , testCase "negative out of bounds" $ + moveLeftN' (-4 ) (zipper [3,2,1] 4 [5,6,7]) @?= Left 3 + , testCase "positive - out of bounds on left only" $ + moveLeftN' 4 (zipper [3,2,1] 4 [5,6,7,8,9]) @?= Left 3 + , testCase "negative - out of bounds on right only" $ + moveLeftN' (-4) (zipper [5,4,3,2,1] 6 [7,8,9]) @?= Left 3 + ] + +moveRightN'Test :: TestTree +moveRightN'Test = + testGroup "moveRightN'" [ + testCase "positive - out of bounds both sides" $ + moveRightN' 4 (zipper [3,2,1] 4 [5,6,7]) @?= Left 3 + , testCase "positive in range" $ + moveRightN' 1 (zipper [3,2,1] 4 [5,6,7]) @?= Right (zipper [4,3,2,1] 5 [6,7]) + , testProperty "moving zero is `Right . id`" + (\l x r -> let lz = (zipper l x r :: ListZipper Integer) in moveRightN' 0 lz == (Right . id $ lz)) + , testCase "negative in range" $ + moveRightN' (-2) (zipper [3,2,1] 4 [5,6,7]) @?= Right (zipper [1] 2 [3,4,5,6,7]) + , testCase "negative - out of bounds both sides" $ + moveRightN' (-4) (zipper [3,2,1] 4 [5,6,7]) @?= Left 3 + ] + +nthTest :: TestTree +nthTest = + testGroup "nth" [ + testCase "have 1" $ nth 1 (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [1] 2 [3,4,5,6,7]) + , testCase "have 5" $ nth 5 (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [5,4,3,2,1] 6 [7]) + , testCase "missing 8" $ nth 8 (zipper [3,2,1] 4 [5,6,7]) @?= IsNotZ + ] + +indexTest :: TestTree +indexTest = + testGroup "index" [ + testCase "index works" $ index (zipper [3,2,1] 4 [5,6,7]) @?= 3 + , testProperty "Always returns the index on a valid zipper" $ + forAllListZipperWithInt (\(z,i) -> optional True (\z' -> index z' == i) (toOptional (nth i z))) + ] + +endTest :: TestTree +endTest = + testGroup "end" [ + testCase "end" $ end (zipper [3,2,1] 4 [5,6,7]) @?= zipper [6,5,4,3,2,1] 7 [] + , testProperty "end never changes the zipper's contents" $ + forAllListZipper (\z -> toList z == toList (end z)) + , testProperty "never have rights after calling end" $ + forAllListZipper (\z -> rights (end z) == Nil) + ] + +startTest :: TestTree +startTest = + testGroup "start" [ + testCase "start" $ start (zipper [3,2,1] 4 [5,6,7]) @?= zipper [] 1 [2,3,4,5,6,7] + , testProperty "start never changes the zipper's contents" $ + forAllListZipper (\z -> toList z == toList (start z)) + , testProperty "never have lefts after calling start" $ + forAllListZipper (\z -> lefts (start z) == Nil) + ] + +deletePullLeftTest :: TestTree +deletePullLeftTest = + testGroup "deletePullLeft" [ + testCase "non-empty lefts" $ deletePullLeft (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [2,1] 3 [5,6,7]) + , testCase "empty lefts" $ deletePullLeft (zipper [] 1 [2,3,4]) @?= IsNotZ + ] + +deletePullRightTest :: TestTree +deletePullRightTest = + testGroup "deletePullRight" [ + testCase "non-empty rights" $ deletePullRight (zipper [3,2,1] 4 [5,6,7]) @?= IsZ (zipper [3,2,1] 5 [6,7]) + , testCase "empty rights" $ deletePullRight (zipper [3,2,1] 4 []) @?= IsNotZ + ] + +insertPushLeftTest :: TestTree +insertPushLeftTest = + testGroup "insertPushLeft" [ + testCase "non-empty lefts" $ + insertPushLeft 15 (zipper [3,2,1] 4 [5,6,7]) @?= zipper [4,3,2,1] 15 [5,6,7] + , testCase "empty lefts" $ + insertPushLeft 15 (zipper [] 1 [2,3,4]) @?= zipper [1] 15 [2,3,4] + , testProperty "deletePullLeft . insertPushLeft == id" $ + forAllListZipperWithInt (\(z,i) -> optional False (==z) (toOptional (deletePullLeft (insertPushLeft (P.fromIntegral i) z)))) + ] + +insertPushRightTest :: TestTree +insertPushRightTest = + testGroup "insertPushRight" [ + testCase "non-empty rights" $ + insertPushRight 15 (zipper [3,2,1] 4 [5,6,7]) @?= zipper [3,2,1] 15 [4,5,6,7] + , testCase "empty rights" $ + insertPushRight 15 (zipper [3,2,1] 4 []) @?= zipper [3,2,1] 15 [4] + , testProperty "deletePullRight . insertPushRight == id" $ + forAllListZipperWithInt (\(z,i) -> optional False (==z) (toOptional (deletePullRight (insertPushRight (P.fromIntegral i) z)))) + ] + +applicativeTest :: TestTree +applicativeTest = + testGroup "Applicative" [ + testProperty "pure produces infinite lefts" + (\a n -> (all . (==) <*> take (n :: Int) . lefts . pure) (a :: Integer)) + , testProperty "pure produces infinite rights" + (\a n -> (all . (==) <*> take (n :: Int) . rights . pure) (a :: Integer)) + , testCase "<*> applies functions to corresponding elements in zipper" $ + zipper [(+2), (+10)] (*2) [(*3), (4*), (5+)] <*> zipper [3,2,1] 4 [5,6,7] @?= zipper [5,12] 8 [15,24,12] + ] + +applicativeMaybeTest :: TestTree +applicativeMaybeTest = + let is (IsZ z) = z + is _ = error "MaybeListZipper's Applicative instances is busted" + notZ = IsNotZ :: MaybeListZipper Integer + in + testGroup "Applicative (MaybeListZipper)" [ + testProperty "pure produces infinite lefts" + (\a n -> (all . (==) <*> take (n :: Int) . lefts . is . pure) (a :: Integer)) + , testProperty "pure produces infinite rights" + (\a n -> (all . (==) <*> take (n :: Int) . rights . is . pure) (a :: Integer)) + , testCase "IsZ <*> IsZ" $ + let z = IsZ (zipper [(+2), (+10)] (*2) [(*3), (4*), (5+)]) <*> IsZ (zipper [3,2,1] 4 [5,6,7]) + in z @?= IsZ (zipper [5,12] 8 [15,24,12]) + , testProperty "IsNotZ <*> IsZ" $ + let fs = (IsNotZ :: MaybeListZipper (Integer -> Integer)) + in forAllListZipper (\z -> (fs <*> IsZ z) == IsNotZ) + , testProperty "IsZ <*> IsNotZ" + (\(Fun _ f) -> (IsZ (pure f) <*> notZ) == notZ) + , testCase "IsNotZ <*> IsNotZ" $ + IsNotZ <*> notZ @?= notZ + ] + +extendTest :: TestTree +extendTest = + testGroup "Extend" [ + testCase "zipper o' zippers" $ + let z = zipper [2,1] 3 [4,5] + l = [zipper [1] 2 [3,4,5], zipper [] 1 [2,3,4,5]] + r = [zipper [3,2,1] 4 [5], zipper [4,3,2,1] 5 []] + in (id <<= z) @?= zipper l z r + ] + +extendMaybeTest :: TestTree +extendMaybeTest = + testGroup "Extend (MaybeListZipper)" [ + testCase "IsNotZ" $ (id <<= IsNotZ) @?= (IsNotZ :: MaybeListZipper (MaybeListZipper Integer)) + , testCase "IsZ" $ + let z = IsZ (zipper [2,1] 3 [4,5]) + l = IsZ P.<$> [zipper [1] 2 [3,4,5], zipper [] 1 [2,3,4,5]] + r = IsZ P.<$> [zipper [3,2,1] 4 [5], zipper [4,3,2,1] 5 []] + in (id <<= z) @?= IsZ (zipper l z r) + ] + +comonadTest :: TestTree +comonadTest = + testGroup "Comonad" [ + testCase "copure" $ copure (zipper [2,1] 3 [4,5]) @?= 3 + ] + +traversableTest :: TestTree +traversableTest = + testGroup "Traversable" [ + testProperty "All Full" $ + forAllListZipper (\z -> traverse id (Full <$> z) == Full z) + , testCase "One Empty" $ + traverse id (zipper [Full 1, Full 2, Full 3] (Full 4) [Empty, Full 6, Full 7]) @?= Empty + ] + +traversableMaybeTest :: TestTree +traversableMaybeTest = + testGroup "Traversable (MaybeListZipper)" [ + testCase "IsNotZ" $ traverse id IsNotZ @?= (Full IsNotZ :: Optional (MaybeListZipper Integer)) + , testProperty "IsZ Full" $ + forAllListZipper (\z -> traverse id (Full <$> IsZ z) == Full (IsZ z)) + ] + +optional :: b -> (a -> b) -> Optional a -> b +optional e _ Empty = e +optional _ f (Full a) = f a diff --git a/test/Course/MonadTest.hs b/test/Course/MonadTest.hs new file mode 100644 index 000000000..4f8fe35bc --- /dev/null +++ b/test/Course/MonadTest.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.MonadTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) +import Course.List (List (..)) +import Course.Monad (join, (<**>), (=<<), (>>=), (<=<)) +import Course.Optional (Optional (..)) + +test_Monad :: TestTree +test_Monad = + testGroup "Monad" [ + bindExactlyOneTest + , bindListTest + , bindOptionalTest + , bindReaderTest + , appTest + , joinTest + , bindFlippedTest + , kleisliCompositionTest + ] + +bindExactlyOneTest :: TestTree +bindExactlyOneTest = + testCase "(=<<) for ExactlyOne" $ + ((\x -> ExactlyOne(x+1)) =<< ExactlyOne 2) @?= ExactlyOne 3 + +bindListTest :: TestTree +bindListTest = + testCase "(=<<) for List" $ + ((\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil)) @?= (1:.1:.2:.2:.3:.3:.Nil) + +bindOptionalTest :: TestTree +bindOptionalTest = + testCase "(=<<) for Optional" $ + ((\n -> Full (n + n)) =<< Full 7) @?= Full 14 + +bindReaderTest :: TestTree +bindReaderTest = + testCase "(=<<) for (->)" $ + ((*) =<< (+10)) 7 @?= 119 + +appTest :: TestTree +appTest = + testGroup "<**>" [ + testCase "ExactlyOne" $ + ExactlyOne (+10) <**> ExactlyOne 8 @?= ExactlyOne 18 + , testCase "List" $ + (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil @?= (2:.3:.4:.2:.4:.6:.Nil) + , testCase "Optional" $ + Full (+8) <**> Full 7 @?= Full 15 + , testCase "Optional - empty function" $ + Empty <**> Full 7 @?= (Empty :: Optional Integer) + , testCase "Optional - empty value" $ + Full (+8) <**> Empty @?= Empty + , testCase "(->) 1" $ + ((+) <**> (+10)) 3 @?= 16 + , testCase "(->) 2" $ + ((+) <**> (+5)) 3 @?= 11 + , testCase "(->) 3" $ + ((+) <**> (+5)) 1 @?= 7 + , testCase "(->) 4" $ + ((*) <**> (+10)) 3 @?= 39 + , testCase "(->) 5" $ + ((*) <**> (+2)) 3 @?= 15 + ] + +joinTest :: TestTree +joinTest = + testGroup "join" [ + testCase "List" $ + join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) @?= (1:.2:.3:.1:.2:.Nil) + , testCase "Optional with Empty" $ + join (Full Empty) @?= (Empty :: Optional Integer) + , testCase "Optional all Full" $ + join (Full (Full 7)) @?= Full 7 + , testCase "(->)" $ + join (+) 7 @?= 14 + ] + +bindFlippedTest :: TestTree +bindFlippedTest = + testCase "(>>=)" $ + ((+10) >>= (*)) 7 @?= 119 + +kleisliCompositionTest :: TestTree +kleisliCompositionTest = + testCase "kleislyComposition" $ + ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1 @?= (2:.2:.3:.3:.Nil) diff --git a/test/Course/MoreParserTest.hs b/test/Course/MoreParserTest.hs new file mode 100644 index 000000000..4399b4001 --- /dev/null +++ b/test/Course/MoreParserTest.hs @@ -0,0 +1,304 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Course.MoreParserTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), assertBool) + +import Course.Core +import Course.List (List (..)) +import Course.Parser +import Course.MoreParser + +test_MoreParser :: TestTree +test_MoreParser = + testGroup "MoreParser" [ + spacesTest + , tokTest + , charTokTest + , commaTokTest + , quoteTest + , stringTest + , stringTokTest + , optionTest + , digits1Test + , oneofTest + , noneofTest + , betweenTest + , betweenCharTokTest + , hexTest + , hexuTest + , sepby1Test + , sepbyTest + , eofTest + , satisfyAllTest + , satisfyAnyTest + , betweenSepbyCommaTest + ] + +spacesTest :: TestTree +spacesTest = + testGroup "spacesTest" [ + testCase "can parse zero spaces" $ + parse spaces "abc" @?= Result "abc" "" + , testCase "can parse single space" $ + parse spaces " abc" @?= Result "abc" " " + , testCase "can parse multiple spaces" $ + parse spaces " abc" @?= Result "abc" " " + ] + +tokTest :: TestTree +tokTest = + testGroup "tokTest" [ + testCase "can parse input without spaces" $ + parse (tok (is 'a')) "abc" @?= Result "bc" 'a' + , testCase "can parse single space" $ + parse (tok (is 'a')) "a bc" @?= Result "bc" 'a' + , testCase "can parse multiple spaces" $ + parse (tok (is 'a')) "a bc" @?= Result "bc" 'a' + ] + +charTokTest :: TestTree +charTokTest = + testGroup "charTokTest" [ + testCase "fails when character does not match" $ + assertBool "fails when character does not match" $ + isErrorResult (parse (charTok 'a') "dabc") + , testCase "parses successfully when character matches" $ do + parse (charTok 'a') "abc" @?= Result "bc" 'a' + parse (charTok 'a') "a bc" @?= Result "bc" 'a' + parse (charTok 'a') "a bc" @?= Result "bc" 'a' + ] + +commaTokTest :: TestTree +commaTokTest = + testGroup "commaTokTest" [ + testCase "fails when character is not a comma" $ + assertBool "fails when character is not a comma" $ + isErrorResult (parse commaTok "1,23") + , testCase "parses successfully when character is a comma" $ do + parse commaTok ",123" @?= Result "123" ',' + parse commaTok ", 123" @?= Result "123" ',' + parse commaTok ", 123" @?= Result "123" ',' + ] + +quoteTest :: TestTree +quoteTest = + testGroup "quoteTest" [ + testCase "fails when character is not a single or double quote" $ + assertBool "fails when character is not a single or double quote" $ + isErrorResult (parse quote "abc") + , testCase "parses single quotes" $ do + parse quote "'abc" @?= Result "abc" '\'' + parse quote "\"abc" @?= Result "abc" '"' + ] + +stringTest :: TestTree +stringTest = + testGroup "stringTest" [ + testCase "fails when string is not matched" $ + assertBool "fails when string is not matched" $ + isErrorResult (parse (string "abc") "bcdef") + , testCase "parses string that matches" $ do + parse (string "abc") "abcdef" @?= Result "def" "abc" + parse (string "abc") "abc" @?= Result "" "abc" + ] + +stringTokTest :: TestTree +stringTokTest = + testGroup "stringTokTest" [ + testCase "fails when string is not matched" $ + assertBool "fails when string is not matched" $ + isErrorResult (parse (stringTok "abc") "bc ") + , testCase "parses matching string followed by zero or more spaces" $ do + parse (stringTok "abc") "abc" @?= Result "" "abc" + parse (stringTok "abc") "abc " @?= Result "" "abc" + parse (stringTok "abc") "abc " @?= Result "" "abc" + ] + +optionTest :: TestTree +optionTest = + testGroup "optionTest" [ + testCase "produces parsed value when parser fails" $ + parse (option 'x' character) "abc" @?= Result "bc" 'a' + , testCase "produces given value when parser fails" $ + parse (option 'x' character) "" @?= Result "" 'x' + ] + +digits1Test :: TestTree +digits1Test = + testGroup "digits1Test" [ + testCase "fails when no digits at start of input" $ + assertBool "fails when no digits at start of input" $ + isErrorResult (parse digits1 "abc123") + , testCase "succeeds when there are digits at start of input" $ do + parse digits1 "123" @?= Result "" "123" + parse digits1 "123abc" @?= Result "abc" "123" + ] + +oneofTest :: TestTree +oneofTest = + testGroup "oneofTest" [ + testCase "fails when given character not in string" $ + assertBool "fails when given character not in string" $ + isErrorResult (parse (oneof "abc") "def") + , testCase "succeeds when there are digits at start of input" $ + parse (oneof "abc") "bcdef" @?= Result "cdef" 'b' + ] + +noneofTest :: TestTree +noneofTest = + testGroup "noneofTest" [ + testCase "fails when any character at start of input" $ + assertBool "fails when any character at start of input" $ + isErrorResult (parse (noneof "abcd") "abc") + , testCase "succeeds when there are digits at start of input" $ do + parse (noneof "xyz") "abc" @?= Result "bc" 'a' + parse (noneof "bcd") "abc" @?= Result "bc" 'a' + ] + +betweenTest :: TestTree +betweenTest = + testGroup "betweenTest" [ + testCase "fails when sequence can't be parsed" $ do + assertBool "should fail when first parser fails" $ + isErrorResult (parse (between (is '[') (is ']') character) "abc]") + assertBool "should fail when second parser fails" $ + isErrorResult (parse (between (is '[') (is ']') character) "[abc]") + assertBool "should fail when third parser fails" $ + isErrorResult (parse (between (is '[') (is ']') character) "[abc") + , testCase "succeeds when all three parsers succeed" $ do + parse (between (is '[') (is ']') character) "[a]" @?= Result "" 'a' + parse (between (is '[') (is ']') digits1) "[123]" @?= Result "" "123" + ] + +betweenCharTokTest :: TestTree +betweenCharTokTest = + testGroup "betweenCharTokTest" [ + testCase "fails when sequence can't be parsed" $ do + assertBool "should fail when opening char not parsed" $ + isErrorResult (parse (betweenCharTok '[' ']' character) "abc]") + assertBool "should fail when closing char not parsed" $ + isErrorResult (parse (betweenCharTok '[' ']' character) "[abc") + assertBool "should fail when given parser fails" $ + isErrorResult (parse (betweenCharTok '[' ']' character) "[abc]") + , testCase "succeeds when sequence can be parsed" $ do + parse (betweenCharTok '[' ']' character) "[a]" @?= Result "" 'a' + parse (betweenCharTok '[' ']' digits1) "[123]" @?= Result "" "123" + ] + +hexTest :: TestTree +hexTest = + testGroup "hexTest" [ + testCase "fails on invalid hex string" $ do + assertBool "fails on invalid hex string" $ + isErrorResult (parse hex "001") + assertBool "fails on invalid hex string" $ + isErrorResult (parse hex "0axf") + , testCase "succeeds on valid hex value" $ do + parse hex "0010" @?= Result "" '\DLE' + ] + +hexuTest :: TestTree +hexuTest = + testGroup "hexuTest" [ + testCase "fails on invalid string" $ do + assertBool "fails when no u at start" $ + isErrorResult (parse hexu "0010") + assertBool "fails when not 4 hex digits after u" $ + isErrorResult (parse hexu "u010") + assertBool "fails on invalid hex" $ + isErrorResult (parse hexu "u0axf") + , testCase "succeeds on valid string" $ do + parse hexu "u0010" @?= Result "" '\DLE' + parse hexu "u0a1f" @?= Result "" '\2591' + ] + +sepby1Test :: TestTree +sepby1Test = + testGroup "sepby1Test" [ + testCase "fails when first parser fails" $ do + assertBool "fails when first parser fails" $ + isErrorResult (parse (sepby1 character (is ',')) "") + , testCase "parses single character not followed by seperator" $ + parse (sepby1 character (is ',')) "a" @?= Result "" "a" + , testCase "parses multiple characters with seperator inbetween" $ do + parse (sepby1 character (is ',')) "a,b,c" @?= Result "" "abc" + parse (sepby1 character (is ',')) "a,b,c,,def" @?= Result "def" "abc," + ] + +sepbyTest :: TestTree +sepbyTest = + testGroup "sepbyTest" [ + testCase "succeeds on empty string" $ + parse (sepby character (is ',')) "" @?= Result "" "" + , testCase "succeeds on single match without seperator" $ + parse (sepby character (is ',')) "a" @?= Result "" "a" + , testCase "succeeds on multiple matches with seperator inbetween" $ + parse (sepby character (is ',')) "a,b,c" @?= Result "" "abc" + , testCase "succeeds up until first character fails" $ + parse (sepby character (is ',')) "a,b,c,,def" @?= Result "def" "abc," + ] + +eofTest :: TestTree +eofTest = + testGroup "eofTest" [ + testCase "fails when still input left" $ do + assertBool "fails when still input left" $ + isErrorResult (parse eof "abc") + , testCase "succeeds when no input left" $ + parse eof "" @?= Result "" () + ] + +satisfyAllTest :: TestTree +satisfyAllTest = + testGroup "satisfyAllTest" [ + testCase "fails when not all of the predicates pass" $ do + assertBool "fails not all of the predicates pass" $ + isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "XBc") + , testCase "fails when none of the predicates pass" $ do + assertBool "fails when none of the predicates pass" $ + isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "") + assertBool "fails when none of the predicates pass" $ + isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "abc") + , testCase "succeeds when all predicats pass" $ do + parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "ABC" @?= Result "BC" 'A' + parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "ABc" @?= Result "Bc" 'A' + ] + +satisfyAnyTest :: TestTree +satisfyAnyTest = + testGroup "satisfyAnyTest" [ + testCase "fails when none of the predicates pass" $ do + assertBool "fails when none of the predicates pass" $ + isErrorResult (parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "XBc") + assertBool "fails when none of the predicates pass" $ + isErrorResult (parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "") + , testCase "succeeds when all predicates pass" $ + parse (satisfyAny (isUpper :. (/= 'X') :. Nil)) "ABc" @?= Result "Bc" 'A' + , testCase "succeeds whan any predicate passes" $ + parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "ABc" @?= Result "Bc" 'A' + ] + +betweenSepbyCommaTest :: TestTree +betweenSepbyCommaTest = + testGroup "betweenSepbyCommaTest" [ + testCase "fails on invalid inputs" $ do + assertBool "fails when opening char missing" $ + isErrorResult (parse (betweenSepbyComma '[' ']' lower) "a]") + assertBool "fails when closing char missing" $ + isErrorResult (parse (betweenSepbyComma '[' ']' lower) "[a") + assertBool "fails when input between seperators doesn't match" $ + isErrorResult (parse (betweenSepbyComma '[' ']' lower) "[abc]") + assertBool "fails when input between seperators doesn't match" $ + isErrorResult (parse (betweenSepbyComma '[' ']' lower) "[A]") + , testCase "succeeds on valid input" $ do + parse (betweenSepbyComma '[' ']' lower) "[a]" @?= Result "" "a" + parse (betweenSepbyComma '[' ']' lower) "[]" @?= Result "" "" + parse (betweenSepbyComma '[' ']' lower) "[a,b,c]" @?= Result "" "abc" + parse (betweenSepbyComma '[' ']' lower) "[a, b, c]" @?= Result "" "abc" + parse (betweenSepbyComma '[' ']' digits1) "[123,456]" @?= Result "" ("123":."456":.Nil) + ] + diff --git a/test/Course/OptionalTest.hs b/test/Course/OptionalTest.hs new file mode 100644 index 000000000..b026190e2 --- /dev/null +++ b/test/Course/OptionalTest.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.OptionalTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Core +import Course.Optional (Optional (..), bindOptional, mapOptional, + (<+>), (??), optional) + +test_Optional :: TestTree +test_Optional = + testGroup "Optional" [ + mapOptionalTest + , bindOptionalTest + , valueOrTest + , firstFullTest + , optionalTest + ] + +mapOptionalTest :: TestTree +mapOptionalTest = + testGroup "mapOptional" [ + testCase "Empty" $ + mapOptional (+1) Empty @?= Empty + , testCase "Full" $ + mapOptional (+1) (Full 8) @?= Full 9 + ] + +bindOptionalTest :: TestTree +bindOptionalTest = + let evenDecOddInc n = if even n then Full (n - 1) else Full (n + 1) + in testGroup "bindOptional" [ + testCase "Empty" $ + bindOptional Full Empty @?= (Empty :: Optional Integer) + , testCase "even dec, odd inc, even input" $ + bindOptional evenDecOddInc (Full 8) @?= Full 7 + , testCase "even dec, odd inc, odd input" $ + bindOptional evenDecOddInc (Full 9) @?= Full 10 + ] + +valueOrTest :: TestTree +valueOrTest = + testGroup "??" [ + testCase "Full" $ + Full 8 ?? 99 @?= 8 + , testCase "Empty" $ + Empty ?? 99 @?= 99 + ] + +firstFullTest :: TestTree +firstFullTest = + testGroup "<+>" [ + testCase "first Full" $ + Full 8 <+> Empty @?= Full 8 + , testCase "both Full" $ + Full 8 <+> Full 9 @?= Full 8 + , testCase "first Empty" $ + Empty <+> Full 9 @?= Full 9 + , testCase "both empty" $ + Empty <+> Empty @?= (Empty :: Optional Integer) + ] + +optionalTest :: TestTree +optionalTest = + testGroup "optional" [ + testCase "replaces full data constructor" $ + optional (+1) 0 (Full 8) @?= 9 + , testCase "replaces empty data constructor" $ + optional (+1) 0 Empty @?= 0 + ] diff --git a/test/Course/ParserTest.hs b/test/Course/ParserTest.hs new file mode 100644 index 000000000..c6730d7bb --- /dev/null +++ b/test/Course/ParserTest.hs @@ -0,0 +1,323 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Course.ParserTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=), assertBool) + +import Course.Applicative (pure, (<*>), (*>)) +import Course.Core +import Course.List (List (..)) +import Course.Monad ((=<<)) +import Course.Optional (Optional (..)) +import Course.Parser +import Course.Person (Person(..)) + +test_Parser :: TestTree +test_Parser = + testGroup "Parser" [ + constantParserTest + , characterTest + , valueParserTest + , alternativeParserTest + , parserMonadInstanceTest + , parserApplicativeInstanceTest + , satisfyTest + , digitTest + , spaceTest + , listTest + , list1Test + , spaces1Test + , lowerTest + , upperTest + , alphaTest + , sequenceParserTest + , thisManyTest + , ageParserTest + , firstNameParserTest + , surnameParserTest + , smokerParserTest + , phoneBodyParserTest + , phoneParserTest + , personParserTest + ] + +constantParserTest :: TestTree +constantParserTest = + testGroup "constantParserTest" [ + testCase "can return error result" $ + parse (constantParser (UnexpectedEof :: ParseResult Int)) "abc" @?= (UnexpectedEof :: ParseResult Int) + , testCase "can return ParseResult" $ + parse (constantParser (Result "xyz" 4)) "abc" @?= Result "xyz" 4 + ] + +characterTest :: TestTree +characterTest = + testGroup "characterTest" [ + testCase "parses single character from non-empty string" $ + parse character "abc" @?= Result "bc" 'a' + , testCase "errors on empty string" $ + assertBool "parsing empty string is an error" (isErrorResult (parse character "")) + ] + +valueParserTest :: TestTree +valueParserTest = + testGroup "valueParserTest" [ + testCase "succeeds with given value" $ + parse (valueParser 3) "abc" @?= Result "abc" 3 + ] + +alternativeParserTest :: TestTree +alternativeParserTest = + testGroup "alternativeParserTest" [ + testCase "takes the second result when the first fails" $ do + parse (character ||| valueParser 'v') "" @?= Result "" 'v' + parse (constantParser UnexpectedEof ||| valueParser 'v') "" @?= Result "" 'v' + parse (constantParser UnexpectedEof ||| valueParser 'v') "abc" @?= Result "abc" 'v' + , testCase "takes first parse result when it succeeds" $ + parse (character ||| valueParser 'v') "abc" @?= Result "bc" 'a' + ] + +parserMonadInstanceTest :: TestTree +parserMonadInstanceTest = + testGroup "parserMonadInstanceTest" [ + testCase "if parser fails with error, the returned parser fails with error" $ do + assertBool + "bind propgates error" + (isErrorResult (parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "")) + assertBool + "bind propogates error" + (isErrorResult (parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "x")) + , testCase "if parser succeeds, value passed to bind function and input propogated" $ do + parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "abc" @?= Result "bc" 'v' + parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "a" @?= Result "" 'v' + parse ((\c -> if c == 'x' then character else valueParser 'v') =<< character) "xabc" @?= Result "bc" 'a' + ] + +parserApplicativeInstanceTest :: TestTree +parserApplicativeInstanceTest = + testGroup "parserApplicativeInstanceTest" [ + testCase "pure" $ do + parse (pure 'a' :: Parser Char) "xyz" @?= Result "xyz" 'a' + parse (pure (Full 5) :: Parser (Optional Int)) "xyz" @?= Result "xyz" (Full 5) + , testCase "<*>" $ do + parse (valueParser toUpper <*> valueParser 'a') "xyz" @?= Result "xyz" 'A' + parse (valueParser show <*> valueParser 599) "xyz" @?= Result "xyz" "599" + ] + +satisfyTest :: TestTree +satisfyTest = + testGroup "satisfyTest" [ + testCase "when character satisfies predicate" $ + parse (satisfy isUpper) "Abc" @?= Result "bc" 'A' + , testCase "when character does not satisfy predicate" $ + assertBool "is error when preidcate not satisfied" (isErrorResult (parse (satisfy isUpper) "abc")) + ] + +digitTest :: TestTree +digitTest = + testGroup "digitTest" [ + testCase "fails when input empty" $ + assertBool "is error when input empty" (isErrorResult $ parse digit "") + , testCase "fails when character not digit" $ + assertBool "is error when character not digit" (isErrorResult $ parse digit "ABC") + , testCase "succeeds when character is a digit " $ + parse digit "1BC" @?= Result "BC" '1' + ] + +spaceTest :: TestTree +spaceTest = + testGroup "spaceTest" [ + testCase "fails when input empty" $ + assertBool "is error when input empty" (isErrorResult $ parse space "") + , testCase "fails when character not space" $ + assertBool "is error when character not space" (isErrorResult $ parse space "ABC") + , testCase "succeeds when character is a space" $ + parse space " abc" @?= Result "abc" ' ' + ] + +listTest :: TestTree +listTest = + testGroup "listTest" [ + testCase "succeeds on empty input" $ + parse (list character) "" @?= Result "" "" + , testCase "parses for as long as characters match" $ do + parse (list digit) "123abc" @?= Result "abc" "123" + parse (list digit) "abc" @?= Result "abc" "" + parse (list character) "abc" @?= Result "" "abc" + parse (list (character *> valueParser 'v')) "abc" @?= Result "" "vvv" + parse (list (character *> valueParser 'v')) "" @?= Result "" "" + ] + +list1Test :: TestTree +list1Test = + testGroup "list1Test" [ + testCase "succeeds when at least one character matches" $ do + parse (list1 (character)) "abc" @?= Result "" "abc" + parse (list1 (character *> valueParser 'v')) "abc" @?= Result "" "vvv" + , testCase "fails when no characters match" $ + assertBool "no matching chars fails" (isErrorResult (parse (list1 (character *> valueParser 'v')) "")) + ] + +spaces1Test :: TestTree +spaces1Test = + testGroup "spaces1Test" [ + testCase "fails on empty string" $ + assertBool "fails on empty string" (isErrorResult (parse spaces1 "")) + , testCase "consumes single space" $ + parse spaces1 " " @?= Result "" " " + , testCase "consumes multiple spaces" $ + parse spaces1 " abc" @?= Result "abc" " " + ] + +lowerTest :: TestTree +lowerTest = + testGroup "lowerTest" [ + testCase "fails on empty string" $ + assertBool "fails on empty string" (isErrorResult (parse lower "")) + , testCase "fails if character is not lowercase" $ + assertBool "fails if character is not lowercase" (isErrorResult (parse lower "Abc")) + , testCase "produces lowercase character" $ + parse lower "aBC" @?= Result "BC" 'a' + ] + +upperTest :: TestTree +upperTest = + testGroup "upperTest" [ + testCase "fails on empty string" $ + assertBool "fails on empty string" (isErrorResult (parse upper "")) + , testCase "fails if character is not uppercase" $ + assertBool "fails if character is not uppercase" (isErrorResult (parse upper "aBC")) + , testCase "produces uppercase character" $ + parse upper "Abc" @?= Result "bc" 'A' + ] + +alphaTest :: TestTree +alphaTest = + testGroup "alphaTest" [ + testCase "fails on empty string" $ + assertBool "fails on empty string" (isErrorResult (parse alpha "")) + , testCase "fails if character is not alpha" $ + assertBool "fails if character is not alpha" (isErrorResult (parse alpha "5BC")) + , testCase "produces alpha character" $ + parse upper "A45" @?= Result "45" 'A' + ] + +sequenceParserTest :: TestTree +sequenceParserTest = + testGroup "sequenceParserTest" [ + testCase "fails on first failing parser" $ + assertBool "fails on first failing parser" $ + isErrorResult (parse (sequenceParser (character :. is 'x' :. upper :. Nil)) "abCdef") + , testCase "sequences list of successful parsers" $ + parse (sequenceParser (character :. is 'x' :. upper :. Nil)) "axCdef" @?= Result "def" "axC" + ] + +thisManyTest :: TestTree +thisManyTest = + testGroup "thisManyTest" [ + testCase "fails when not enough matches" $ + assertBool "fails when not enough matches" $ + isErrorResult (parse (thisMany 4 upper) "ABcDef") + , testCase "produces n values when matched" $ + parse (thisMany 4 upper) "ABCDef" @?= Result "ef" "ABCD" + ] + +ageParserTest :: TestTree +ageParserTest = + testGroup "ageParserTest (done for you)" [ + testCase "fails on invalid age" $ do + assertBool "fails on invalid age" $ + isErrorResult (parse ageParser "abc") + assertBool "fails on invalid age" $ + isErrorResult (parse ageParser "-120") + , testCase "parses valid age" $ + parse ageParser "120" @?= Result "" 120 + ] + +firstNameParserTest :: TestTree +firstNameParserTest = + testGroup "firstNameParserTest" [ + testCase "fails on invalid first name" $ + assertBool "fails on invalid first name" $ + isErrorResult (parse firstNameParser "abc") + , testCase "parses valid first name" $ + parse firstNameParser "Abc" @?= Result "" "Abc" + ] + +surnameParserTest :: TestTree +surnameParserTest = + testGroup "surnameParserTest" [ + testCase "fails on invalid surname" $ do + assertBool "fails on invalid surname" $ + isErrorResult (parse surnameParser "Abc") + assertBool "fails on invalid surname" $ + isErrorResult (parse surnameParser "abc") + , testCase "parses valid surname" $ do + parse surnameParser "Abcdef" @?= Result "" "Abcdef" + parse surnameParser "Abcdefghijklmnopqrstuvwxyz" @?= Result "" "Abcdefghijklmnopqrstuvwxyz" + ] + +smokerParserTest :: TestTree +smokerParserTest = + testGroup "smokerParserTest" [ + testCase "fails on non y/n value" $ + assertBool "fails on non y/n value" $ + isErrorResult (parse smokerParser "abc") + , testCase "parses valid smoker value" $ do + parse smokerParser "yabc" @?= Result "abc" True + parse smokerParser "nabc" @?= Result "abc" False + ] + +phoneBodyParserTest :: TestTree +phoneBodyParserTest = + testGroup "phoneBodyParserTest" [ + testCase "produces empty list when no characters match" $ + parse phoneBodyParser "a123-456" @?= Result "a123-456" "" + , testCase "parses valid phone body value" $ do + parse phoneBodyParser "123-456" @?= Result "" "123-456" + parse phoneBodyParser "123-a456" @?= Result "a456" "123-" + ] + +phoneParserTest :: TestTree +phoneParserTest = + testGroup "phoneParserTest" [ + testCase "fails on invalid phone values" $ do + assertBool "fails on invalid phone values" $ + isErrorResult (parse phoneParser "123-456") + assertBool "fails on invalid phone values" $ + isErrorResult (parse phoneParser "a123-456") + , testCase "produces valid phone numbers" $ do + parse phoneParser "123-456#" @?= Result "" "123-456" + parse phoneParser "123-456#abc" @?= Result "abc" "123-456" + ] + +personParserTest :: TestTree +personParserTest = + testGroup "personParserTest" [ + testCase "fails in invalid inputs" $ do + assertBool "fails on empty string" $ + isErrorResult (parse personParser "") + assertBool "fails on invalid age" $ + isErrorResult (parse personParser "12x Fred Clarkson y 123-456.789#") + assertBool "fails on first name that doesn't start with capital" $ + isErrorResult (parse personParser "123 fred Clarkson y 123-456.789#") + assertBool "fails on surname that is too short" $ + isErrorResult (parse personParser "123 Fred Cla y 123-456.789#") + assertBool "fails on surname that doesn't start with a capital letter" $ + isErrorResult (parse personParser "123 Fred clarkson y 123-456.789#") + assertBool "fails on invalid smoker value" $ + isErrorResult (parse personParser "123 Fred Clarkson x 123-456.789#") + assertBool "fails on invalid phone number" $ + isErrorResult (parse personParser "123 Fred Clarkson y 1x3-456.789#") + assertBool "fails on invalid phone number" $ + isErrorResult (parse personParser "123 Fred Clarkson y -123-456.789#") + assertBool "fails on invalid phone number" $ + isErrorResult (parse personParser "123 Fred Clarkson y 123-456.789") + , testCase "produces person for valid input" $ + parse personParser "123 Fred Clarkson y 123-456.789#" @?= + Result "" (Person 123 "Fred" "Clarkson" True "123-456.789") + + ] diff --git a/test/Course/StateTTest.hs b/test/Course/StateTTest.hs new file mode 100644 index 000000000..710b29955 --- /dev/null +++ b/test/Course/StateTTest.hs @@ -0,0 +1,207 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.StateTTest where + +import qualified Prelude as P (String, (++)) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Applicative (pure, (<*>)) +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) +import Course.Functor ((<$>)) +import Course.Gens (forAllLists) +import Course.List (List (..), flatMap, listh) +import Course.Monad ((=<<), (>>=)) +import Course.Optional (Optional (..)) +import Course.State (put, runState) +import Course.StateT (Logger (..), OptionalT (..), + StateT (..), distinct', distinctF, + distinctG, getT, log1, putT, + runOptionalT, runState', state', + execT, exec', evalT, eval') + +test_StateT :: TestTree +test_StateT = + testGroup "StateT" [ + functorTest + , applicativeTest + , monadTest + , state'Test + , runState'Test + , execTTest + , exec'Test + , evalTTest + , eval'Test + , getTTest + , putTTest + , distinct'Test + , distinctFTest + , optionalTFunctorTest + , optionalTApplicativeTest + , optionalTMonadTest + , loggerFunctorTest + , loggerApplicativeTest + , loggerMonadTest + , log1Test + , distinctGTest + ] + +functorTest :: TestTree +functorTest = + testCase "<$>" $ + let st = StateT (\s -> ((2, s) :. Nil)) + in runStateT ((+1) <$> st) 0 @?= ((3,0) :. Nil) + +applicativeTest :: TestTree +applicativeTest = + testGroup "Applicative" [ + testCase "List (pure)" $ runStateT ((pure 2) :: StateT Int List Int) 0 @?= ((2,0) :. Nil) + , testCase "List (<*>)" $ runStateT (pure (+2) <*> ((pure 2) :: StateT Int List Int)) 0 @?= ((4,0) :. Nil) + , testCase "Optional" $ + let st = StateT (\s -> Full ((+2), s P.++ [1])) <*> (StateT (\s -> Full (2, s P.++ [2]))) + in runStateT st [0] @?= Full (4,[0,1,2]) + , testCase "List" $ + let st = StateT (\s -> ((+2), s P.++ [1]) :. ((+3), s P.++ [1]) :. Nil) + <*> (StateT (\s -> (2, s P.++ [2]) :. Nil)) + in runStateT st [0] @?= ((4,[0,1,2]) :. (5,[0,1,2]) :. Nil) + ] + +monadTest :: TestTree +monadTest = + testGroup "Monad" [ + testCase "bind const" $ + let s n = StateT $ const (((), n) :. Nil) + in runStateT (const (s 2) =<< s 1) 0 @?= (((), 2) :. Nil) + , testCase "modify" $ + let modify f = StateT (\s -> pure ((), f s)) + in runStateT (modify (+1) >>= \() -> modify (*2)) 7 @?= (((), 16) :. Nil) + ] + +state'Test :: TestTree +state'Test = + testCase "state'" $ + runStateT (state' $ runState $ put 1) 0 @?= ExactlyOne ((), 1) + +runState'Test :: TestTree +runState'Test = + testCase "runState'" $ + runState' (state' $ runState $ put 1) 0 @?= ((),1) + +execTTest :: TestTree +execTTest = + testCase "execTTest" $ + execT (StateT $ \s -> Full ((), s + 1)) 2 @?= Full 3 + +exec'Test :: TestTree +exec'Test = + testCase "exec'Test" $ + exec' (state' $ \s -> ((), s + 1)) 2 @?= 3 + +evalTTest :: TestTree +evalTTest = + testCase "evalTTest" $ + evalT (StateT $ \s -> Full (even s, s + 1)) 2 @?= Full True + +eval'Test :: TestTree +eval'Test = + testCase "eval'Test" $ + eval' (state' $ \s -> (even s, s + 1)) 5 @?= False + +getTTest :: TestTree +getTTest = + testCase "getTTest" $ + runStateT (getT :: StateT Int List Int) 3 @?= ((3,3) :. Nil) + +putTTest :: TestTree +putTTest = + testCase "putTTest" $ + runStateT (putT 2 :: StateT Int List ()) 0 @?= (((),2) :. Nil) + +distinct'Test :: TestTree +distinct'Test = + testProperty "distinct'" $ + forAllLists (\xs -> distinct' xs == distinct' (flatMap (\x -> x :. x :. Nil) xs)) + +distinctFTest :: TestTree +distinctFTest = + testGroup "distinctF" [ + testCase "Full case" $ distinctF (listh [1,2,3,2,1]) @?= Full (listh [1,2,3]) + , testCase "Empty case" $ distinctF (listh [1,2,3,2,1,101]) @?= Empty + ] + +optionalTFunctorTest :: TestTree +optionalTFunctorTest = + testCase "(<$>) for OptionalT" $ + runOptionalT ((+1) <$> OptionalT (Full 1 :. Empty :. Nil)) @?= (Full 2 :. Empty :. Nil) + +optionalTApplicativeTest :: TestTree +optionalTApplicativeTest = + testGroup "(<*>) for OptionalT" [ + testCase "one" $ + let ot = (OptionalT Nil <*> OptionalT (Full 1 :. Full 2 :. Nil)) + in runOptionalT ot @?= (Nil :: List (Optional Int)) + , testCase "two" $ + let ot = OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT Nil + in runOptionalT ot @?= (Nil :: List (Optional Int)) + , testCase "three" $ + let ot = OptionalT (Empty :. Nil) <*> OptionalT (Empty :. Nil) + in runOptionalT ot @?= (Empty :. Nil :: List (Optional Int)) + , testCase "four" $ + let ot = OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Empty :. Nil) + in runOptionalT ot @?= (Empty :. Empty :. Nil :: List (Optional Int)) + , testCase "five" $ + let ot = OptionalT (Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) + in runOptionalT ot @?= (Empty :. Nil :: List (Optional Int)) + , testCase "six" $ + let ot = OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) + in runOptionalT ot @?= (Full 2 :. Full 3 :. Empty :. Nil) + , testCase "seven" $ + let ot = OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT (Full 1 :. Empty :. Nil) + in runOptionalT ot @?= (Full 2 :. Empty :. Full 3 :. Empty :. Nil) + ] + +optionalTMonadTest :: TestTree +optionalTMonadTest = + testCase "(=<<) for OptionalT" $ + let ot = (\a -> OptionalT (Full (a+1) :. Full (a+2) :. Nil)) =<< OptionalT (Full 1 :. Empty :. Nil) + in runOptionalT ot @?= (Full 2:.Full 3:.Empty:.Nil) + +loggerFunctorTest :: TestTree +loggerFunctorTest = + testCase "(<$>) for Logger" $ + (+3) <$> Logger (1 :. 2 :. Nil) 3 @?= Logger (1 :. 2 :. Nil) 6 + +loggerApplicativeTest :: TestTree +loggerApplicativeTest = + testGroup "Logger Applicative" [ + testCase "pure" $ + (pure "table" :: Logger Int P.String) @?= Logger Nil "table" + , testCase "<*>" $ + Logger (1:.2:.Nil) (+7) <*> Logger (3:.4:.Nil) 3 @?= Logger (1:.2:.3:.4:.Nil) 10 + ] + +loggerMonadTest :: TestTree +loggerMonadTest = + testCase "(=<<) for Logger" $ + ((\a -> Logger (4:.5:.Nil) (a+3)) =<< Logger (1:.2:.Nil) 3) @?= Logger (1:.2:.4:.5:.Nil) 6 + +log1Test :: TestTree +log1Test = + testCase "log1" $ + log1 1 2 @?= Logger (1:.Nil) 2 + +distinctGTest :: TestTree +distinctGTest = + testGroup "distinctG" [ + testCase "Full case" $ + let expected = Logger (listh <$> ("even number: 2":."even number: 2":."even number: 6":.Nil)) + (Full (1:.2:.3:.6:.Nil)) + in distinctG (1:.2:.3:.2:.6:.Nil) @?= expected + , testCase "Empty case" $ + let expected = Logger (listh <$> ("even number: 2":."even number: 2":."even number: 6":."aborting > 100: 106":.Nil)) Empty + in distinctG (listh [1,2,3,2,6,106]) @?= expected + ] diff --git a/test/Course/StateTest.hs b/test/Course/StateTest.hs new file mode 100644 index 000000000..73c316ad0 --- /dev/null +++ b/test/Course/StateTest.hs @@ -0,0 +1,134 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Course.StateTest where + +import Data.List (nub) +import qualified Prelude as P ((++)) + +import Test.QuickCheck.Function (Fun (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty) + +import Course.Applicative (pure, (<*>)) +import Course.Core +import Course.Functor ((<$>)) +import Course.List (List (..), filter, flatMap, hlist, + length, listh, span, (++)) +import Course.Gens (forAllLists) +import Course.Monad +import Course.Optional (Optional (..)) +import Course.State (State (..), distinct, eval, exec, + findM, firstRepeat, get, isHappy, + put, put, runState) + +test_State :: TestTree +test_State = + testGroup "State" [ + execTest + , evalTest + , getTest + , putTest + , functorTest + , applicativeTest + , monadTest + , findMTest + , firstRepeatTest + , distinctTest + , isHappyTest + ] + +execTest :: TestTree +execTest = + testProperty "exec" $ + \(Fun _ f :: Fun Integer (Integer, Integer)) s -> exec (State f) s == snd (runState (State f) s) + +evalTest :: TestTree +evalTest = + testProperty "eval" $ + \(Fun _ f :: Fun Integer (Integer, Integer)) s -> eval (State f) s == fst (runState (State f) s) + +getTest :: TestTree +getTest = + testCase "get" $ runState get 0 @?= (0,0) + +putTest :: TestTree +putTest = + testCase "put" $ runState (put 1) 0 @?= ((),1) + +functorTest :: TestTree +functorTest = + testCase "(<$>)" $ + runState ((+1) <$> State (\s -> (9, s * 2))) 3 @?= (10,6) + +applicativeTest :: TestTree +applicativeTest = + testGroup "Applicative" [ + testCase "pure" $ runState (pure 2) 0 @?= (2,0) + , testCase "<*>" $ runState (pure (+1) <*> pure 0) 0 @?= (1,0) + , testCase "complicated <*>" $ + let state = State (\s -> ((+3), s P.++ ["apple"])) <*> State (\s -> (7, s P.++ ["banana"])) + in runState state [] @?= (10,["apple","banana"]) + ] + +monadTest :: TestTree +monadTest = + testGroup "Monad" [ + testCase "(=<<)" $ + runState ((const $ put 2) =<< put 1) 0 @?= ((),2) + , testCase "(>>=)" $ + let modify f = State (\s -> ((), f s)) + in runState (modify (+1) >>= \() -> modify (*2)) 7 @?= ((),16) + ] + +findMTest :: TestTree +findMTest = + testGroup "findM" [ + testCase "find 'c' in 'a'..'h'" $ + let p x = (\s -> (const $ pure (x == 'c')) =<< put (1+s)) =<< get + in runState (findM p $ listh ['a'..'h']) 0 @?= (Full 'c',3) + , testCase "find 'i' in 'a'..'h'" $ + let p x = (\s -> (const $ pure (x == 'i')) =<< put (1+s)) =<< get + in runState (findM p $ listh ['a'..'h']) 0 @?= (Empty,8) + ] + +firstRepeatTest :: TestTree +firstRepeatTest = + testGroup "firstRepeat" [ + testProperty "finds repeats" $ forAllLists (\xs -> + case firstRepeat xs of + Empty -> + let xs' = hlist xs + in nub xs' == xs' + Full x -> length (filter (== x) xs) > 1 + ) + , testProperty "" $ forAllLists (\xs -> + case firstRepeat xs of + Empty -> True + Full x -> + let (l, (rx :. rs)) = span (/= x) xs + in let (l2, _) = span (/= x) rs + in let l3 = hlist (l ++ (rx :. Nil) ++ l2) + in nub l3 == l3 + ) + ] + +distinctTest :: TestTree +distinctTest = + testGroup "distinct" [ + testProperty "No repeats after distinct" $ + forAllLists (\xs -> firstRepeat (distinct xs) == Empty) + , testProperty "" $ + forAllLists (\xs -> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs)) + ] + +isHappyTest :: TestTree +isHappyTest = + testGroup "isHappy" [ + testCase "4" $ isHappy 4 @?= False + , testCase "7" $ isHappy 7 @?= True + , testCase "42" $ isHappy 42 @?= False + , testCase "44" $ isHappy 44 @?= True + ] diff --git a/test/Course/TraversableTest.hs b/test/Course/TraversableTest.hs new file mode 100644 index 000000000..ba3c13dc8 --- /dev/null +++ b/test/Course/TraversableTest.hs @@ -0,0 +1,139 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.TraversableTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Course.Compose (Compose (..)) +import Course.Core +import Course.ExactlyOne (ExactlyOne (..)) +import Course.Functor +import Course.List (List (..), listh) +import Course.Optional (Optional (..)) +import Course.Traversable + +test_Traversable :: TestTree +test_Traversable = + testGroup "Traversable" [ + listTest + , exactlyOneTest + , optionalTest + , sequenceATest + , composeTest + , productFunctorTest + , productTraversableTest + , coProductFunctorTest + , coProductTraversableTest + ] + +listTest :: TestTree +listTest = + testGroup "listTest" [ + testCase "traverse on empty list" $ + traverse (\a -> Full (a * 2)) (Nil :: List Int) @?= Full Nil + , testCase "traverse on non-empty list" $ + traverse (\a -> Full (a * 2)) (listh [1, 2, 3]) @?= Full (listh [2, 4, 6]) + ] + +exactlyOneTest :: TestTree +exactlyOneTest = + testGroup "exactlyOneTest" [ + testCase "traverse on ExactlyOne" $ + traverse (\a -> Full (a * 2)) (ExactlyOne 3) @?= Full (ExactlyOne 6) + ] + +optionalTest :: TestTree +optionalTest = + testGroup "optionalTest" [ + testCase "traverse on Empty" $ + traverse (\a -> ExactlyOne (a * 2)) Empty @?= ExactlyOne Empty + , testCase "traverse on Full" $ + traverse (\a -> ExactlyOne (a * 2)) (Full 5) @?= ExactlyOne (Full 10) + ] + +sequenceATest :: TestTree +sequenceATest = + testGroup "sequenceATest" [ + testCase "on List over ExactlyOne" $ + sequenceA (listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) @?= ExactlyOne (listh [7,8,9]) + , testCase "on Optional over ExactlyOne" $ + sequenceA (Full (ExactlyOne 7)) @?= ExactlyOne (Full 7) + , testCase "on Optional over function" $ + sequenceA (Full (*10)) 6 @?= Full 60 + ] + +composeTest :: TestTree +composeTest = + testGroup "composeTest" [ + testCase "traverse on Compose Optional List Int" $ + traverse (\a -> ExactlyOne (a * 2)) cfli @?= ExactlyOne traversedCfli + , testCase "traverse on Compose List ExactlyOne Int" $ + traverse (\a -> Full (a * 2)) clei @?= Full traversedClei + ] + where + cfli = Compose fullListOfInts + traversedCfli = Compose $ (*2) `fmap2` fullListOfInts + clei = Compose listOfExactlyOnes + traversedClei = Compose $ (*2) `fmap2` listOfExactlyOnes + fullListOfInts = Full (listh [1, 2, 3]) + listOfExactlyOnes = listh [ExactlyOne 1, ExactlyOne 2, ExactlyOne 3] + fmap2 f = ((f <$>) <$>) + +productFunctorTest :: TestTree +productFunctorTest = + testGroup "productFunctorTest" [ + testCase "fmap on Product Optional List Int" $ + (*2) <$> Product (Full 4) listOfInts @?= Product (Full 8) ((*2) <$> listOfInts) + , testCase "fmap on Product ExactlyOne Optional Int" $ + (*2) <$> Product (ExactlyOne 4) Empty @?= Product (ExactlyOne 8) Empty + ] + where + listOfInts = listh [1, 2, 3] + +productTraversableTest :: TestTree +productTraversableTest = + testGroup "productTraversableTest" [ + testCase "traverse on Product Optional List Int" $ + traverse (\a -> ExactlyOne (a*2)) product @?= ExactlyOne productTimesTwo + ] + where + listOfInts = listh [1, 2, 3] + product = Product (Full 4) listOfInts + productTimesTwo = Product (Full 8) ((*2) <$> listOfInts) + +coProductFunctorTest :: TestTree +coProductFunctorTest = + testGroup "coProductFunctorTest" [ + testCase "fmap on InL Optional Int" $ + (*2) <$> inL @?= inLTimesTwo + , testCase "fmap on InR ExactlyOne Int" $ + (*2) <$> inR @?= inRTimesTwo + ] + where + inL, inLTimesTwo :: Coproduct Optional List Int + inL = InL (Full 4) + inLTimesTwo = InL (Full 8) + inR, inRTimesTwo :: Coproduct Optional List Int + inR = InR listOfInts + inRTimesTwo = InR ((*2) <$> listOfInts) + listOfInts = listh [1, 2, 3] + +coProductTraversableTest :: TestTree +coProductTraversableTest = + testGroup "coProductTraversableTest" [ + testCase "traverse on InL Optional Int" $ + traverse (\a -> ExactlyOne (a*2)) inL @?= ExactlyOne inLTimesTwo + , testCase "traverse on InR List Int" $ + traverse (\a -> Full (a*2)) inR @?= Full inRTimesTwo + ] + where + inL, inLTimesTwo :: Coproduct Optional List Int + inL = InL (Full 4) + inLTimesTwo = InL (Full 8) + inR, inRTimesTwo :: Coproduct Optional List Int + inR = InR listOfInts + inRTimesTwo = InR ((*2) <$> listOfInts) + listOfInts = listh [1, 2, 3] + diff --git a/test/Course/ValidationTest.hs b/test/Course/ValidationTest.hs new file mode 100644 index 000000000..6d561c894 --- /dev/null +++ b/test/Course/ValidationTest.hs @@ -0,0 +1,99 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Course.ValidationTest where + +import qualified Prelude as P (either, fmap) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Course.Core +import Course.Validation + +instance Arbitrary a => Arbitrary (Validation a) where + arbitrary = P.fmap (P.either Error Value) arbitrary + +test_Validation :: TestTree +test_Validation = + testGroup "Validation" [ + isErrorTest + , isValueTest + , mapValidationTest + , bindValidationTest + , valueOrTest + , errorOrTest + ] + +isErrorTest :: TestTree +isErrorTest = + testGroup "isError" [ + testCase "true for errors" $ + isError (Error "Message") @?= True + , testCase "false for values" $ + isError (Value "7") @?= False + , testProperty "not the same as isValue" $ + \(x :: Validation Int) -> isError x /= isValue x + ] + +isValueTest :: TestTree +isValueTest = + testGroup "isValue" [ + testCase "false for errors" $ + isValue (Error "Message") @?= False + , testCase "false for values" $ + isValue (Value "7") @?= True + , testProperty "not the same as isValue" $ + \(x :: Validation Int) -> isValue x /= isError x + ] + +mapValidationTest :: TestTree +mapValidationTest = + testGroup "mapValidation" [ + testCase "errors unchanged" $ + mapValidation (+ 10) (Error "message") @?= Error "message" + , testCase "values changed" $ + mapValidation (+ 10) (Value 7) @?= Value 17 + , testProperty "map with id causes no change" $ + \(x :: Validation Int) -> mapValidation id x == x + ] + +bindValidationTest :: TestTree +bindValidationTest = + let + f n = if even n then Value (n + 10) else Error "odd" + in + testGroup "bindValidation" [ + testCase "error unchanged" $ + bindValidation f (Error "message") @?= Error "message" + , testCase "odd value" $ + bindValidation f (Value 7) @?= Error "odd" + , testCase "even value" $ + bindValidation f (Value 8) @?= Value 18 + , testProperty "bind with Value causes no change" $ + \(x :: Validation Int) -> bindValidation Value x == x + ] + +valueOrTest :: TestTree +valueOrTest = + testGroup "valueOr" [ + testCase "falls through for errors" $ + valueOr (Error "message") "foo" @?= "foo" + , testCase "unwraps values" $ + valueOr (Value "foo") "bar" @?= "foo" + , testProperty "isValue or valueOr falls through" $ + \(x :: Validation Int) n -> isValue x || valueOr x n == n + ] + +errorOrTest :: TestTree +errorOrTest = + testGroup "errorOr" [ + testCase "unwraps errors" $ + errorOr (Error "message") "q" @?= "message" + , testCase "falls through for values" $ + errorOr (Value (7 :: Integer)) "q" @?= "q" + , testProperty "isError or errorOr falls through" $ + \(x :: Validation Int) n -> isError x || errorOr x n == n + ] diff --git a/test/TastyLoader.hs b/test/TastyLoader.hs new file mode 100644 index 000000000..f42cfe3f4 --- /dev/null +++ b/test/TastyLoader.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ImplicitPrelude #-} + +import Data.String (fromString) +import Test.Tasty +import Course.ApplicativeTest (test_Applicative) +import Course.ComonadTest (test_Comonad) +import Course.ExtendTest (test_Extend) +import Course.FunctorTest (test_Functor) +import Course.JsonParserTest (test_JsonParser) +import Course.ChequeTest (test_Cheque) +import Course.ListTest (test_List) +import Course.ListZipperTest (test_ListZipper) +import Course.MonadTest (test_Monad) +import Course.MoreParserTest (test_MoreParser) +import Course.OptionalTest (test_Optional) +import Course.ParserTest (test_Parser) +import Course.StateTest (test_State) +import Course.StateTTest (test_StateT) +import Course.TraversableTest (test_Traversable) +import Course.ValidationTest (test_Validation) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "Tests" [ + test_Optional + , test_List + , test_Functor + , test_Applicative + , test_Monad + , test_MoreParser + , test_Parser + , test_State + , test_StateT + , test_Validation + , test_Extend + , test_Comonad + , test_Traversable + , test_ListZipper + , test_JsonParser + , test_Cheque + ] + diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 index 9d90a92be..000000000 --- a/test/doctests.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Main where - -import Control.Applicative -import Prelude -import Build_doctests (deps) -import Control.Monad -import Data.List -import Data.Monoid -import System.Directory -import System.FilePath -import System.IO -import Test.DocTest - -main :: - IO () -main = - getSources >>= \sources -> - forM_ (preferredOrderFirst sources) $ \source -> do - hPutStrLn stderr $ "Testing " <> source - doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ [source] - -sourceDirectories :: - [FilePath] -sourceDirectories = - [ - "src" - ] - -preferredOrderFirst :: [FilePath] -> [FilePath] -preferredOrderFirst sources = - filter (`elem` sources ) preferredOrder - <> filter (`notElem` preferredOrder) sources - --- If you find the tests are running slowly. --- Comment out the Modules you have completed --- in the list below. -preferredOrder :: [String] -preferredOrder = map (\f -> "src/Course" f <.> "hs") [ - "List" - , "Functor" - , "Applicative" - , "Monad" - , "FileIO" - , "State" - , "StateT" - , "Extend" - , "Comonad" - , "Compose" - , "Traversable" - , "ListZipper" - , "Parser" - , "MoreParser" - , "JsonParser" - , "Interactive" - , "Anagrams" - , "FastAnagrams" - , "Cheque" - ] - -isSourceFile :: - FilePath - -> Bool -isSourceFile p = - and [takeFileName p /= "Setup.hs", isSuffixOf ".hs" p] - -getSources :: IO [FilePath] -getSources = - liftM (filter isSourceFile . concat) (mapM go sourceDirectories) - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c