├── src ├── .ghci ├── Course │ ├── .ghci │ ├── JsonValue.hs │ ├── FastAnagrams.hs │ ├── Person.hs │ ├── ExactlyOne.hs │ ├── Anagrams.hs │ ├── Comonad.hs │ ├── Compose.hs │ ├── Core.hs │ ├── Extend.hs │ ├── Optional.hs │ ├── Validation.hs │ ├── Functor.hs │ ├── FileIO.hs │ ├── Traversable.hs │ ├── Monad.hs │ ├── Interactive.hs │ ├── State.hs │ ├── JsonParser.hs │ ├── MonadTutorial.hs │ ├── Cheque.hs │ ├── StateT.hs │ └── Applicative.hs └── Course.hs ├── share ├── a.txt ├── b.txt ├── c.txt └── files.txt ├── stack-snapshot.yaml ├── test ├── Spec.hs ├── .gitignore └── Course │ ├── ComonadSpec.hs │ ├── OptionalSpec.hs │ ├── FunctorSpec.hs │ ├── ExtendSpec.hs │ ├── MonadSpec.hs │ ├── ValidationSpec.hs │ ├── StateSpec.hs │ ├── Gens.hs │ ├── JsonParserSpec.hs │ ├── StateTSpec.hs │ └── ListSpec.hs ├── Setup.lhs ├── stack.yaml ├── projects ├── NetworkServer │ ├── haskell │ │ ├── stack.yaml │ │ ├── test │ │ │ ├── .gitignore │ │ │ └── doctests.hs │ │ ├── app │ │ │ ├── Chat │ │ │ │ └── Main.hs │ │ │ └── TicTacToe │ │ │ │ └── Main.hs │ │ ├── src │ │ │ ├── Network │ │ │ │ ├── Server.hs │ │ │ │ └── Server │ │ │ │ │ ├── Chat.hs │ │ │ │ │ ├── TicTacToe.hs │ │ │ │ │ ├── Common │ │ │ │ │ ├── Ref.hs │ │ │ │ │ ├── HandleLens.hs │ │ │ │ │ ├── Accept.hs │ │ │ │ │ ├── Env.hs │ │ │ │ │ ├── Line.hs │ │ │ │ │ └── Lens.hs │ │ │ │ │ ├── Common.hs │ │ │ │ │ ├── Chat │ │ │ │ │ ├── Chat.hs │ │ │ │ │ └── Loop.hs │ │ │ │ │ └── TicTacToe │ │ │ │ │ ├── Game.hs │ │ │ │ │ └── Loop.hs │ │ │ └── Data │ │ │ │ └── TicTacToe.hs │ │ ├── .gitignore │ │ ├── Makefile │ │ ├── etc │ │ │ └── LICENCE │ │ ├── package.yaml │ │ └── Setup.lhs │ └── NetworkServer.markdown └── TicTacToe │ └── TicTacToe.markdown ├── Vagrantfile ├── .editorconfig ├── CHANGELOG.md ├── .gitignore ├── ci ├── jobsets.json ├── ci.nix └── jobsets.nix ├── ops ├── sublime.yaml ├── vs-code.yaml ├── haskell.yaml ├── emacs.d │ └── init.el ├── README.md └── ansible.yaml ├── Makefile ├── etc ├── LICENCE └── CONTRIBUTORS ├── package.yaml ├── .travis.yml └── CHEATSHEET.md /src/.ghci: -------------------------------------------------------------------------------- 1 | Course/.ghci -------------------------------------------------------------------------------- /share/a.txt: -------------------------------------------------------------------------------- 1 | the contents of a 2 | -------------------------------------------------------------------------------- /share/b.txt: -------------------------------------------------------------------------------- 1 | the contents of b 2 | -------------------------------------------------------------------------------- /share/c.txt: -------------------------------------------------------------------------------- 1 | the contents of c 2 | -------------------------------------------------------------------------------- /share/files.txt: -------------------------------------------------------------------------------- 1 | share/a.txt 2 | share/b.txt 3 | share/c.txt 4 | -------------------------------------------------------------------------------- /stack-snapshot.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.21 2 | name: fp-course 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | import Distribution.Simple 3 | main = defaultMain 4 | \end{code} 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | require-stack-version: ">= 1.6.1" 2 | resolver: stack-snapshot.yaml 3 | 4 | packages: 5 | - . 6 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/stack.yaml: -------------------------------------------------------------------------------- 1 | require-stack-version: ">= 1.6.1" 2 | resolver: ../../../stack-snapshot.yaml 3 | 4 | packages: 5 | - . 6 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/app/Chat/Main.hs: -------------------------------------------------------------------------------- 1 | module Main ( 2 | main 3 | ) where 4 | 5 | import Network.Server.Chat.Chat 6 | 7 | main :: IO a 8 | main = chat 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server.hs: -------------------------------------------------------------------------------- 1 | module Network.Server 2 | ( 3 | module Network.Server.Common 4 | ) where 5 | 6 | import Network.Server.Common 7 | 8 | -------------------------------------------------------------------------------- /src/Course/.ghci: -------------------------------------------------------------------------------- 1 | :! echo -e "\033[0;31m\033[47mYOU ARE IN THE WRONG DIRECTORY\033[0m" 2 | :set prompt "\ESC[1;40m\STX%s\n\ESC[0;41m\STXYOU ARE IN THE WRONG DIRECTORY> \ESC[m\STX" 3 | kill -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/app/TicTacToe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( 3 | main 4 | ) where 5 | 6 | import Network.Server.TicTacToe.Game 7 | 8 | main :: 9 | IO () 10 | main = 11 | play 12 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import System.FilePath.Glob (glob) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = do 8 | glob "src/**/*.hs" >>= doctest 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat 2 | ( 3 | module Network.Server.Chat.Chat 4 | , module Network.Server.Chat.Loop 5 | ) where 6 | 7 | import Network.Server.Chat.Chat 8 | import Network.Server.Chat.Loop 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe 2 | ( 3 | module Network.Server.TicTacToe.Game 4 | , module Network.Server.TicTacToe.Loop 5 | ) where 6 | 7 | import Network.Server.TicTacToe.Game 8 | import Network.Server.TicTacToe.Loop 9 | -------------------------------------------------------------------------------- /Vagrantfile: -------------------------------------------------------------------------------- 1 | Vagrant.configure("2") do |config| 2 | config.vm.box = "ubuntu/xenial64" 3 | 4 | config.vm.provider 'virtualbox' do |vbox| 5 | vbox.memory = 4096 6 | vbox.cpus = 2 7 | vbox.gui = true 8 | end 9 | 10 | config.vm.provision 'ansible' do |ansible| 11 | ansible.playbook = 'ops/ansible.yaml' 12 | end 13 | end 14 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | dist 6 | 7 | # cabal-dev 8 | /cabal-dev 9 | 10 | # Haskell Program Coverage 11 | .hpc 12 | 13 | # Leksah 14 | *.lkshs 15 | 16 | # Intellij IDEA 17 | .idea/workspace.xml 18 | .idea/ant.xml 19 | 20 | # darcs 21 | _darcs 22 | 23 | # ctags 24 | TAGS 25 | 26 | # sbt 27 | /project 28 | /target 29 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [Makefile] 5 | indent_style = tabs 6 | indent_size = 8 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | 12 | [*.{hs,md,yml,yaml}] 13 | indent_style = space 14 | indent_size = 2 15 | end_of_line = lf 16 | charset = utf-8 17 | trim_trailing_whitespace = true 18 | insert_final_newline = true 19 | max_line_length = 80 20 | -------------------------------------------------------------------------------- /src/Course/JsonValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.JsonValue where 5 | 6 | import Course.Core 7 | import Course.List 8 | 9 | type Assoc = List (Chars, JsonValue) 10 | 11 | data JsonValue = 12 | JsonString Chars 13 | | JsonRational Rational 14 | | JsonObject Assoc 15 | | JsonArray (List JsonValue) 16 | | JsonTrue 17 | | JsonFalse 18 | | JsonNull 19 | deriving (Show, Eq) 20 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.1.5 2 | 3 | - Change the test suite from `tasty` to `hspec` 4 | 5 | # 0.1.2 6 | 7 | Switch around the the hex parser exercise. There are now two exercises: 8 | 9 | 1. Implement `hex`, which is a sub-exercise of the previous `hex`. 10 | 2. Implement `hexu`, which is the complete exercise of what was formerly `hex`. 11 | 12 | This switching is required to implement `jsonString` parser properly (without a try-parser). 13 | 14 | # 0.1.1 15 | 16 | This change log started. 17 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Ref.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Ref where 2 | 3 | import Network.Server.Common.HandleLens(HandleLens(..)) 4 | import Network.Server.Common.Lens(iso) 5 | import System.IO(Handle) 6 | import Data.Function(on) 7 | 8 | newtype Ref = 9 | Ref Handle 10 | deriving (Eq, Show) 11 | 12 | instance Ord Ref where 13 | compare = 14 | compare `on` show 15 | 16 | instance HandleLens Ref where 17 | handleL = 18 | iso (\(Ref h) -> h) Ref 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | /dist 6 | /dist-newstyle 7 | /cabal-dev 8 | /.cabal-sandbox 9 | /cabal.sandbox.config 10 | /cabal.project.local 11 | 12 | # Haskell Program Coverage 13 | /.hpc 14 | 15 | # Leksah 16 | *.lkshs 17 | 18 | # Intellij IDEA 19 | /.idea 20 | 21 | # darcs 22 | /_darcs 23 | 24 | # ctags 25 | TAGS 26 | 27 | # sbt 28 | /project 29 | /target 30 | 31 | *.swp 32 | 33 | # Stack 34 | .stack-work/ 35 | 36 | # Hpack 37 | *.cabal 38 | 39 | # Vagrant 40 | .vagrant 41 | ops/*.retry 42 | 43 | # HSpec 44 | .hspec-failures 45 | -------------------------------------------------------------------------------- /test/Course/ComonadSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.ComonadSpec where 5 | 6 | 7 | import Test.Hspec (Spec, it, shouldBe) 8 | 9 | import Course.Comonad (copure, (<$$>)) 10 | import Course.Core 11 | import Course.ExactlyOne (ExactlyOne (..)) 12 | 13 | spec :: Spec 14 | spec = do 15 | it "ExactlyOne" $ copure (ExactlyOne 7) `shouldBe` 7 16 | 17 | it "<$$>" $ 18 | ((+10) <$$> ExactlyOne 7) `shouldBe` ExactlyOne 17 19 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common 2 | ( 3 | module Network.Server.Common.Accept 4 | , module Network.Server.Common.Env 5 | , module Network.Server.Common.HandleLens 6 | , module Network.Server.Common.Lens 7 | , module Network.Server.Common.Line 8 | , module Network.Server.Common.Ref 9 | ) where 10 | 11 | import Network.Server.Common.Accept 12 | import Network.Server.Common.Env 13 | import Network.Server.Common.HandleLens 14 | import Network.Server.Common.Lens 15 | import Network.Server.Common.Line 16 | import Network.Server.Common.Ref 17 | -------------------------------------------------------------------------------- /ci/jobsets.json: -------------------------------------------------------------------------------- 1 | { 2 | "enabled": 1, 3 | "hidden": false, 4 | "description": "jobsets", 5 | "nixexprinput": "fp-course", 6 | "nixexprpath": "ci/jobsets.nix", 7 | "checkinterval": 300, 8 | "schedulingshares": 1, 9 | "enableemail": false, 10 | "emailoverride": "", 11 | "keepnr": 5, 12 | "inputs": { 13 | "fp-course": { "type": "git", "value": "https://github.com/data61/fp-course.git master", "emailresponsible": false }, 14 | "nixpkgs": { "type": "git", "value": "https://github.com/NixOS/nixpkgs.git release-17.09", "emailresponsible": false } 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /ops/sublime.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Check if Sublime installed" 3 | command: which subl 4 | ignore_errors: true 5 | register: haz_sublime 6 | 7 | - name: "Add apt key for sublime" 8 | apt_key: 9 | url: https://download.sublimetext.com/sublimehq-pub.gpg 10 | state: present 11 | become: yes 12 | when: haz_sublime|failed 13 | 14 | - name: "Add source for sublime" 15 | apt_repository: 16 | repo: deb https://download.sublimetext.com/ apt/stable/ 17 | state: present 18 | become: yes 19 | when: haz_sublime|failed 20 | 21 | - name: "Install sublime" 22 | apt: 23 | name: sublime-text 24 | update_cache: yes 25 | state: present 26 | become: yes 27 | when: haz_sublime|failed 28 | -------------------------------------------------------------------------------- /src/Course/FastAnagrams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.FastAnagrams where 5 | 6 | import Course.Core 7 | import Course.List 8 | import Course.Functor 9 | import qualified Data.Set as S 10 | 11 | -- Return all anagrams of the given string 12 | -- that appear in the given dictionary file. 13 | fastAnagrams :: 14 | Chars 15 | -> FilePath 16 | -> IO (List Chars) 17 | fastAnagrams = 18 | error "todo: Course.FastAnagrams#fastAnagrams" 19 | 20 | newtype NoCaseString = 21 | NoCaseString { 22 | ncString :: Chars 23 | } 24 | 25 | instance Eq NoCaseString where 26 | (==) = (==) `on` map toLower . ncString 27 | 28 | instance Show NoCaseString where 29 | show = show . ncString 30 | -------------------------------------------------------------------------------- /ops/vs-code.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Check if VS Code is installed" 3 | command: which code 4 | ignore_errors: true 5 | register: haz_code 6 | 7 | - name: "Download VS code" 8 | get_url: 9 | url: https://go.microsoft.com/fwlink/?LinkID=760868 10 | dest: /tmp/vs-code.deb 11 | when: haz_code|failed 12 | 13 | # So the recommended install method is to install a thing with broken/missing 14 | # dependencies, and then fix it. 15 | - name: "Install VS Code deb" 16 | command: dpkg -i /tmp/vs-code.deb 17 | become: yes 18 | ignore_errors: true 19 | when: haz_code|failed 20 | 21 | - name: "Fix VS code installation" 22 | command: apt-get install -fy 23 | become: yes 24 | when: haz_code|failed 25 | 26 | - name: "Install haskell syntax highlighting for VS Code" 27 | command: code --install-extension justusadam.language-haskell 28 | -------------------------------------------------------------------------------- /ops/haskell.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | - name: Add ghc PPA 4 | apt_repository: 5 | repo: ppa:hvr/ghc 6 | become: yes 7 | 8 | - name: Install ghc-8.0.2 9 | apt: 10 | name: "{{ item }}" 11 | update_cache: yes 12 | state: present 13 | with_items: 14 | - ghc-8.0.2 15 | - cabal-install-1.24 16 | become: yes 17 | 18 | - name: Add cabal bin directory to PATH 19 | lineinfile: 20 | line: export PATH="{{ ansible_env.HOME }}/.cabal/bin:$PATH" 21 | dest: ~/.profile 22 | 23 | - name: Add /opt/ghc/bin to the path 24 | lineinfile: 25 | line: export PATH=/opt/ghc/bin:$PATH 26 | dest: ~/.profile 27 | 28 | - name: Update cabal 29 | command: cabal update 30 | environment: 31 | PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" 32 | 33 | - name: Insall cabal packages 34 | command: cabal install doctest 35 | environment: 36 | PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" 37 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | package = course 2 | 3 | stack_yaml = STACK_YAML="stack.yaml" 4 | stack = $(stack_yaml) stack 5 | 6 | build: 7 | $(stack) build $(package) 8 | 9 | build-dirty: 10 | $(stack) build --ghc-options=-fforce-recomp $(package) 11 | 12 | build-profile: 13 | $(stack) --work-dir .stack-work-profiling --profile build 14 | 15 | run: 16 | $(stack) build --fast && $(stack) exec -- $(package) 17 | 18 | install: 19 | $(stack) install 20 | 21 | ghci: 22 | $(stack) ghci $(package):lib 23 | 24 | test: 25 | $(stack) test $(package) 26 | 27 | test-ghci: 28 | $(stack) ghci $(package):test:$(package)-tests 29 | 30 | bench: 31 | $(stack) bench $(package) 32 | 33 | ghcid: 34 | $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind'" 35 | 36 | dev-deps: 37 | stack install ghcid 38 | 39 | .PHONY : build build-dirty build-profile run install ghci test test-ghci ghcid dev-deps 40 | -------------------------------------------------------------------------------- /src/Course/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Person where 5 | 6 | import Course.Core 7 | import Course.List 8 | 9 | -- Suppose we have a data structure to represent a person. The person data structure has these attributes: 10 | -- * Age: positive integer 11 | -- * First Name: non-empty string that starts with a capital letter and is followed by zero or more lower-case letters 12 | -- * Surname: string that starts with a capital letter and is followed by 5 or more lower-case letters 13 | -- * Smoker: character that must be 'y' or 'n' that maps to a boolean 14 | -- * Phone: string of digits, dots or hyphens but must start with a digit and end with a hash (#) 15 | data Person = 16 | Person 17 | Int -- age 18 | Chars -- first name 19 | Chars -- surname 20 | Bool -- smoker 21 | Chars -- phone number 22 | deriving (Eq, Show) 23 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/HandleLens.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.HandleLens where 2 | 3 | import Network.Server.Common.Lens(Lens, identityL, getL) 4 | import System.IO(Handle, BufferMode, hGetLine, hPutStrLn, hClose, hSetBuffering) 5 | 6 | class HandleLens a where 7 | handleL :: 8 | Lens a Handle 9 | 10 | instance HandleLens Handle where 11 | handleL = 12 | identityL 13 | 14 | lGetLine :: 15 | HandleLens h => 16 | h 17 | -> IO String 18 | lGetLine h = 19 | hGetLine (handleL `getL` h) 20 | 21 | lPutStrLn :: 22 | HandleLens h => 23 | h 24 | -> String 25 | -> IO () 26 | lPutStrLn h = 27 | hPutStrLn (handleL `getL` h) 28 | 29 | lClose :: 30 | HandleLens h => 31 | h 32 | -> IO () 33 | lClose h = 34 | hClose (handleL `getL` h) 35 | 36 | lSetBuffering :: 37 | HandleLens h => 38 | h 39 | -> BufferMode 40 | -> IO () 41 | lSetBuffering h = 42 | hSetBuffering (handleL `getL` h) 43 | -------------------------------------------------------------------------------- /src/Course.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course (module X) where 5 | 6 | import Course.Anagrams as X 7 | import Course.Applicative as X 8 | import Course.Cheque as X 9 | import Course.Comonad as X (Comonad (..)) 10 | import Course.Compose as X 11 | import Course.Core as X 12 | import Course.ExactlyOne as X 13 | import Course.Extend as X 14 | import Course.FastAnagrams as X 15 | import Course.FileIO as X 16 | import Course.Functor as X 17 | import Course.Interactive as X 18 | import Course.JsonParser as X 19 | import Course.JsonValue as X 20 | import Course.List as X 21 | import Course.ListZipper as X 22 | import Course.Monad as X 23 | import Course.MoreParser as X 24 | import Course.Optional as X 25 | import Course.Parser as X 26 | import Course.Person as X 27 | import Course.State as X 28 | import Course.StateT as X 29 | import Course.Traversable as X 30 | import Course.Validation as X 31 | -------------------------------------------------------------------------------- /ci/ci.nix: -------------------------------------------------------------------------------- 1 | { supportedSystems ? ["x86_64-linux"] 2 | , supportedCompilers ? ["ghc7103" "ghc802" "ghc821"] 3 | }: 4 | 5 | with (import { inherit supportedSystems; }); 6 | 7 | let 8 | pkgs = import {}; 9 | 10 | configurations = 11 | pkgs.lib.listToAttrs ( 12 | pkgs.lib.concatMap (compiler: 13 | pkgs.lib.concatMap (system: 14 | [{name = "fp-course_" + compiler + "_" + system; value = {inherit compiler system;};}] 15 | ) supportedSystems 16 | ) supportedCompilers 17 | ); 18 | 19 | jobs = 20 | pkgs.lib.mapAttrs (name: configuration: 21 | let 22 | compiler = configuration.compiler; 23 | system = configuration.system; 24 | nixpkgs = { pkgs = pkgsFor system; }; 25 | course = import ../default.nix { inherit nixpkgs compiler; }; 26 | in 27 | course 28 | ) configurations; 29 | in 30 | jobs 31 | -------------------------------------------------------------------------------- /src/Course/ExactlyOne.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.ExactlyOne where 5 | 6 | import qualified Control.Applicative as A 7 | import qualified Control.Monad as M 8 | import Course.Core 9 | import qualified Prelude as P 10 | 11 | data ExactlyOne a = ExactlyOne a deriving (Eq, Show) 12 | 13 | runExactlyOne :: ExactlyOne a -> a 14 | runExactlyOne (ExactlyOne a) = a 15 | 16 | mapExactlyOne :: (a -> b) -> ExactlyOne a -> ExactlyOne b 17 | mapExactlyOne f (ExactlyOne a) = ExactlyOne (f a) 18 | 19 | bindExactlyOne :: (a -> ExactlyOne b) -> ExactlyOne a -> ExactlyOne b 20 | bindExactlyOne f (ExactlyOne a) = f a 21 | 22 | instance P.Functor ExactlyOne where 23 | fmap = 24 | M.liftM 25 | 26 | instance A.Applicative ExactlyOne where 27 | (<*>) = 28 | M.ap 29 | pure = 30 | ExactlyOne 31 | 32 | instance P.Monad ExactlyOne where 33 | (>>=) = 34 | flip bindExactlyOne 35 | return = 36 | ExactlyOne 37 | 38 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/Makefile: -------------------------------------------------------------------------------- 1 | package = network-server 2 | 3 | stack_yaml = STACK_YAML="stack.yaml" 4 | stack = $(stack_yaml) stack 5 | 6 | build: 7 | $(stack) build $(package) 8 | 9 | build-dirty: 10 | $(stack) build --ghc-options=-fforce-recomp $(package) 11 | 12 | build-profile: 13 | $(stack) --work-dir .stack-work-profiling --profile build 14 | 15 | run: 16 | $(stack) build --fast && $(stack) exec -- $(package) 17 | 18 | install: 19 | $(stack) install 20 | 21 | ghci: 22 | $(stack) ghci $(package):lib 23 | 24 | test: 25 | $(stack) test $(package) 26 | 27 | test-ghci: 28 | $(stack) ghci $(package):test:$(package)-tests 29 | 30 | bench: 31 | $(stack) bench $(package) 32 | 33 | ghcid: 34 | $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is $(package):$(package)" 35 | 36 | dev-deps: 37 | stack install ghcid 38 | 39 | .PHONY : build build-dirty run install ghci test test-ghci ghcid dev-deps 40 | 41 | -------------------------------------------------------------------------------- /ci/jobsets.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs, declInput }: let pkgs = import nixpkgs {}; in { 2 | jobsets = pkgs.runCommand "spec.json" {} '' 3 | cat < $out < b) -> IO a -> IO b 16 | * readFile :: FilePath -> IO Str 17 | * lines :: Str -> [Str] 18 | * permutations :: [a] -> [[a]] 19 | * intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] 20 | * toLower :: Char -> Char 21 | 22 | Functions that might help 23 | - 24 | * on :: (b -> b -> c) -> (a -> b) -> a -> a -> c 25 | 26 | -} 27 | 28 | 29 | -- Return all anagrams of the given string 30 | -- that appear in the given dictionary file. 31 | anagrams :: 32 | Chars 33 | -> FilePath 34 | -> IO (List Chars) 35 | anagrams = 36 | error "todo: Course.Anagrams#anagrams" 37 | 38 | -- Compare two strings for equality, ignoring case 39 | equalIgnoringCase :: 40 | Chars 41 | -> Chars 42 | -> Bool 43 | equalIgnoringCase = 44 | error "todo: Course.Anagrams#equalIgnoringCase" 45 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Accept.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Accept where 2 | 3 | import Network.Server.Common.Lens 4 | import Network.Server.Common.HandleLens(HandleLens(..)) 5 | import Network.Server.Common.Ref(Ref(..)) 6 | import Network(HostName, Socket, PortNumber, accept) 7 | 8 | data Accept = 9 | Accept 10 | Ref 11 | HostName 12 | PortNumber 13 | deriving (Eq, Ord, Show) 14 | 15 | refL :: 16 | Lens Accept Ref 17 | refL = 18 | Lens 19 | (\(Accept _ nam num) hd -> Accept hd nam num) 20 | (\(Accept hd _ _) -> hd) 21 | 22 | hostNameL :: 23 | Lens Accept HostName 24 | hostNameL = 25 | Lens 26 | (\(Accept hd _ num) nam -> Accept hd nam num) 27 | (\(Accept _ nam _) -> nam) 28 | 29 | portNumberL :: 30 | Lens Accept PortNumber 31 | portNumberL = 32 | Lens 33 | (\(Accept hd nam _) num -> Accept hd nam num) 34 | (\(Accept _ _ num) -> num) 35 | 36 | instance HandleLens Accept where 37 | handleL = 38 | refL .@ handleL 39 | 40 | accept' :: 41 | Socket 42 | -> IO Accept 43 | accept' = 44 | fmap (\(hd, nam, num) -> Accept (Ref hd) nam num) . accept 45 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Env.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Env where 2 | 3 | import Network.Server.Common.Accept 4 | import Network.Server.Common.Ref 5 | import Network.Server.Common.HandleLens 6 | import Network.Server.Common.Lens 7 | import Data.IORef(IORef, atomicModifyIORef) 8 | import Data.Set(Set) 9 | 10 | data Env a = 11 | Env 12 | Accept 13 | (IORef (Set Ref)) 14 | a 15 | deriving Eq 16 | 17 | acceptL :: 18 | Lens (Env a) Accept 19 | acceptL = 20 | Lens 21 | (\(Env _ s a) x -> Env x s a) 22 | (\(Env x _ _) -> x) 23 | 24 | clientsL :: 25 | Lens (Env a) (IORef (Set Ref)) 26 | clientsL = 27 | Lens 28 | (\(Env x _ a) s -> Env x s a) 29 | (\(Env _ s _) -> s) 30 | 31 | envvalL :: 32 | Lens (Env a) a 33 | envvalL = 34 | Lens 35 | (\(Env x s _) a -> Env x s a) 36 | (\(Env _ _ a) -> a) 37 | 38 | instance HandleLens (Env a) where 39 | handleL = 40 | acceptL .@ handleL 41 | 42 | instance Functor Env where 43 | fmap f (Env x s a) = 44 | Env x s (f a) 45 | 46 | atomicModifyIORef_ :: 47 | IORef a 48 | -> (a -> a) 49 | -> IO a 50 | atomicModifyIORef_ r f = 51 | atomicModifyIORef r (\a -> (f a, a)) 52 | -------------------------------------------------------------------------------- /src/Course/Comonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Comonad where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.Extend 10 | 11 | -- | All instances of the `Comonad` type-class must satisfy two laws. These 12 | -- laws are not checked by the compiler. These laws are given as: 13 | -- 14 | -- * The law of left identity 15 | -- `∀x. copure <<= x ≅ x` 16 | -- 17 | -- * The law of right identity 18 | -- `∀f. copure . (f <<=) == f 19 | class Extend f => Comonad f where 20 | copure :: 21 | f a 22 | -> a 23 | 24 | -- | Implement the @Comonad@ instance for @ExactlyOne@. 25 | -- 26 | -- >>> copure (ExactlyOne 7) 27 | -- 7 28 | instance Comonad ExactlyOne where 29 | copure :: 30 | ExactlyOne a 31 | -> a 32 | copure = 33 | error "todo: Course.Comonad copure#instance ExactlyOne" 34 | 35 | -- | Witness that all things with (<<=) and copure also have (<$>). 36 | -- 37 | -- >>> (+10) <$$> ExactlyOne 7 38 | -- ExactlyOne 17 39 | (<$$>) :: 40 | Comonad f => 41 | (a -> b) 42 | -> f a 43 | -> f b 44 | (<$$>) = 45 | error "todo: Course.Comonad#(<$>)" 46 | -------------------------------------------------------------------------------- /src/Course/Compose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Compose where 5 | 6 | import Course.Core 7 | import Course.Functor 8 | import Course.Applicative 9 | import Course.Monad 10 | 11 | -- Exactly one of these exercises will not be possible to achieve. Determine which. 12 | 13 | newtype Compose f g a = 14 | Compose (f (g a)) 15 | 16 | -- Implement a Functor instance for Compose 17 | instance (Functor f, Functor g) => 18 | Functor (Compose f g) where 19 | (<$>) = 20 | error "todo: Course.Compose (<$>)#instance (Compose f g)" 21 | 22 | instance (Applicative f, Applicative g) => 23 | Applicative (Compose f g) where 24 | -- Implement the pure function for an Applicative instance for Compose 25 | pure = 26 | error "todo: Course.Compose pure#instance (Compose f g)" 27 | -- Implement the (<*>) function for an Applicative instance for Compose 28 | (<*>) = 29 | error "todo: Course.Compose (<*>)#instance (Compose f g)" 30 | 31 | instance (Monad f, Monad g) => 32 | Monad (Compose f g) where 33 | -- Implement the (=<<) function for a Monad instance for Compose 34 | (=<<) = 35 | error "todo: Course.Compose (<<=)#instance (Compose f g)" 36 | -------------------------------------------------------------------------------- /ops/emacs.d/init.el: -------------------------------------------------------------------------------- 1 | ;; Pull in Marmalade packages 2 | (require 'package) 3 | (add-to-list 'package-archives 4 | '("marmalade" . "http://marmalade-repo.org/packages/")) 5 | (add-to-list 'package-archives 6 | '("melpa" . "http://melpa.milkbox.net/packages/")) 7 | (package-initialize) 8 | 9 | ;; Ensure our preferred packages are all loaded in this install - taken from 10 | ;; http://batsov.com/articles/2012/02/19/package-management-in-emacs-the-good-the-bad-and-the-ugly/ 11 | (defvar my-packages 12 | '(markdown-mode 13 | auto-complete 14 | haskell-mode) 15 | "A list of packages to ensure are installed at launch.") 16 | 17 | (require 'cl) 18 | (defun my-packages-installed-p () 19 | (loop for p in my-packages 20 | when (not (package-installed-p p)) do (return nil) 21 | finally (return t))) 22 | 23 | (unless (my-packages-installed-p) 24 | ;; check for new packages (package versions) 25 | (message "%s" "Emacs is now refreshing its package database...") 26 | (package-refresh-contents) 27 | (message "%s" " done.") 28 | ;; install the missing packages 29 | (dolist (p my-packages) 30 | (when (not (package-installed-p p)) 31 | (package-install p)))) 32 | 33 | ;; Show column numbers in mode line 34 | (column-number-mode t) 35 | -------------------------------------------------------------------------------- /ops/README.md: -------------------------------------------------------------------------------- 1 | # Vagrant Box 2 | 3 | If you'd rather use a pre-configured haskell development environment, then these instructions will 4 | get you up and running in a VirtualBox virtual machine. The machine includes: 5 | 6 | - A Xubuntu desktop environment 7 | - GHC 8.0.2 installed 8 | - doctest 9 | - emacs with haskell-mode 10 | - vim 11 | - sublime 12 | - VS Code 13 | 14 | **NOTE**: The VM's default user is `ubuntu` and their password is `ubuntu` 15 | 16 | **WARNING**: Building the environment might take a while and download gigabytes of pacakges over the internet. 17 | 18 | ## Prerequisites 19 | 20 | - Install [VirtualBox](https://www.virtualbox.org/) 21 | - Install [Vagrant](https://www.vagrantup.com/) 22 | - Install [ansible](https://www.ansible.com/) 23 | 24 | ## Make it so 25 | 26 | The following will download a VM image of Ubuntu and then provision it to build a desktop 27 | environment for Haskell development. Once it's provisioned, reload the machine, which will log you 28 | straight into a graphical environment. 29 | 30 | ``` 31 | cd fp-course 32 | vagrant up 33 | # go have lunch - this could take a while 34 | vagrant reload 35 | ``` 36 | 37 | You should now see a virtual machine running Xubuntu. The course materials are checked out to 38 | `~/fp-course` and you should have all required binaries on your PATH. 39 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat/Chat.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat.Chat where 2 | 3 | import Network.Server.Common.Line 4 | import Network.Server.Chat.Loop 5 | import Data.Maybe(fromMaybe) 6 | import Data.Foldable(msum) 7 | import Data.IORef(atomicModifyIORef) 8 | import Control.Applicative((<$), (<$>)) 9 | import Control.Monad.Trans(MonadIO(..)) 10 | 11 | type Chat a = 12 | IORefLoop Integer a 13 | 14 | data ChatCommand = 15 | Chat String 16 | | Incr 17 | | Unknown String 18 | deriving (Eq, Show) 19 | 20 | incr :: 21 | Chat Integer 22 | incr = 23 | do e <- readEnvval 24 | liftIO $ atomicModifyIORef e (\n -> (n + 1, n + 1)) 25 | 26 | chat :: 27 | IO a 28 | chat = 29 | iorefLoop 0 (readIOEnvval >>= pPutStrLn . show) (process . chatCommand) 30 | 31 | -- | 32 | -- 33 | -- >>> chatCommand "CHAT hi" 34 | -- Chat "hi" 35 | -- 36 | -- >>> chatCommand "Chat bye" 37 | -- Chat "bye" 38 | -- 39 | -- >>> chatCommand "INCR" 40 | -- Incr 41 | -- 42 | -- >>> chatCommand "Nothing" 43 | -- UNKNOWN "Nothing" 44 | chatCommand :: 45 | String 46 | -> ChatCommand 47 | chatCommand z = 48 | Unknown z `fromMaybe` msum [ 49 | Chat <$> trimPrefixThen "CHAT" z 50 | , Incr <$ trimPrefixThen "INCR" z 51 | ] 52 | 53 | process :: 54 | ChatCommand 55 | -> Chat () 56 | process = 57 | error "todo" 58 | -------------------------------------------------------------------------------- /ops/ansible.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Install ansible deps (Python 2.7 stuff)" 3 | hosts: all 4 | user: ubuntu 5 | gather_facts: false 6 | tasks: 7 | - name: "Install ansible requirements" 8 | raw: apt-get update && apt-get install -y python2.7 python-simplejson 9 | become: yes 10 | 11 | - name: "Setup Ubuntu 16.04" 12 | hosts: all 13 | user: ubuntu 14 | 15 | tasks: 16 | - name: "Set ubuntu user's password to 'ubuntu'" 17 | user: 18 | name: ubuntu 19 | password: $6$hVCglTDqXKLR45$b4M1N30zbQmieXbHpqm3z1yYCZKNq1jF554WU7AwiBI/z8DkbV1zyE.aYeZvOkCgxsWIJv63IBEwB9riNmdyY/ 20 | become: yes 21 | 22 | - name: "Install packages" 23 | apt: 24 | name: "{{ item }}" 25 | update_cache: yes 26 | state: present 27 | become: yes 28 | with_items: 29 | - emacs 30 | - git 31 | - vim 32 | - xubuntu-desktop 33 | - virtualbox-guest-x11 34 | 35 | - name: "Automatically login as ubuntu user" 36 | lineinfile: 37 | line: autologin-user=ubuntu 38 | dest: /usr/share/lightdm/lightdm.conf.d/60-xubuntu.conf 39 | become: yes 40 | 41 | - name: "Checkout course repo" 42 | git: 43 | repo: https://github.com/data61/fp-course 44 | dest: ~/fp-course 45 | 46 | - include: haskell.yaml 47 | - include: vs-code.yaml 48 | - include: sublime.yaml 49 | 50 | - name: "Copy emacs.d" 51 | copy: 52 | src: emacs.d/ 53 | dest: ~/.emacs.d/ 54 | mode: 0755 55 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Line.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Line where 2 | 3 | import Data.Char(isSpace, toLower) 4 | import Data.Function(on) 5 | import Control.Monad.Trans(MonadIO(..)) 6 | import Control.Exception(IOException) 7 | 8 | -- | 9 | -- 10 | -- >>> trimPrefixThen "ABC" "AB" 11 | -- Nothing 12 | -- 13 | -- >>> trimPrefixThen "ABC" "ABC" 14 | -- Just "" 15 | -- 16 | -- >>> trimPrefixThen "ABC" "ABCDEF" 17 | -- Just "DEF" 18 | -- 19 | -- >>> trimPrefixThen "ABC" "Ab" 20 | -- Nothing 21 | -- 22 | -- >>> trimPrefixThen "ABC" "Abc" 23 | -- Just "" 24 | -- 25 | -- >>> trimPrefixThen "ABC" "Abcdef" 26 | -- Just "def" 27 | -- 28 | -- >>> trimPrefixThen "ABC" "Abcdef ghi " 29 | -- Just "def ghi" 30 | trimPrefixThen :: 31 | String 32 | -> String 33 | -> Maybe String 34 | trimPrefixThen l z = 35 | fmap (reverse . dropWhile isSpace . reverse . dropWhile isSpace) (prefixThen ((==) `on` toLower) l z) 36 | 37 | -- | 38 | -- 39 | -- >>> prefixThen (==) "ABC" "AB" 40 | -- Nothing 41 | -- 42 | -- >>> prefixThen (==) "ABC" "ABC" 43 | -- Just "" 44 | -- 45 | -- >>> prefixThen (==) "ABC" "ABCDEF" 46 | -- Just "DEF" 47 | prefixThen :: 48 | (a -> a -> Bool) 49 | -> [a] 50 | -> [a] 51 | -> Maybe [a] 52 | prefixThen _ [] r = 53 | Just r 54 | prefixThen _ _ [] = 55 | Nothing 56 | prefixThen e (a:b) (c:d) = 57 | if e a c 58 | then 59 | prefixThen e b d 60 | else 61 | Nothing 62 | 63 | xprint :: 64 | MonadIO m => 65 | IOException 66 | -> m () 67 | xprint = 68 | liftIO . print 69 | -------------------------------------------------------------------------------- /test/Course/OptionalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.OptionalSpec where 5 | 6 | import Test.Hspec (Spec, describe, it, shouldBe) 7 | 8 | import Course.Core 9 | import Course.Optional (Optional (..), bindOptional, mapOptional, 10 | (<+>), (??)) 11 | spec :: Spec 12 | spec = do 13 | describe "mapOptional" $ do 14 | it "Empty" $ 15 | mapOptional (+1) Empty `shouldBe` Empty 16 | it "Full" $ 17 | mapOptional (+1) (Full 8) `shouldBe` Full 9 18 | 19 | let 20 | evenDecOddInc n = 21 | if even n 22 | then Full (n - 1) 23 | else Full (n + 1) 24 | 25 | describe "bindOptional" $ do 26 | it "Empty" $ 27 | bindOptional Full Empty `shouldBe` (Empty :: Optional Integer) 28 | it "even dec, odd inc, even input" $ 29 | bindOptional evenDecOddInc (Full 8) `shouldBe` Full 7 30 | it "even dec, odd inc, odd input" $ 31 | bindOptional evenDecOddInc (Full 9) `shouldBe` Full 10 32 | 33 | describe "??" $ do 34 | it "Full" $ 35 | Full 8 ?? 99 `shouldBe` 8 36 | it "Empty" $ 37 | Empty ?? 99 `shouldBe` 99 38 | 39 | describe "<+>" $ do 40 | it "first Full" $ 41 | Full 8 <+> Empty `shouldBe` Full 8 42 | it "both Full" $ 43 | Full 8 <+> Full 9 `shouldBe` Full 8 44 | it "first Empty" $ 45 | Empty <+> Full 9 `shouldBe` Full 9 46 | it "both empty" $ 47 | Empty <+> Empty `shouldBe` (Empty :: Optional Integer) 48 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/etc/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2013 National ICT Australia Limited 2012, 2013 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /etc/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2010-2013 Tony Morris 2 | Copyright 2012-2016 National ICT Australia Limited 3 | Copyright 2017 Commonwealth Scientific and Industrial Research Organisation 4 | (CSIRO) ABN 41 687 119 230 5 | Copyright 2012 James Earl Douglas 6 | Copyright 2012 Ben Sinclair 7 | 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions 12 | are met: 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in the 17 | documentation and/or other materials provided with the distribution. 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 23 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 24 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 25 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 26 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 31 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 32 | SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /test/Course/FunctorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Course.FunctorSpec where 6 | 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | import Test.Hspec.QuickCheck (prop) 9 | import Test.QuickCheck.Function (Fun (..)) 10 | 11 | import Course.Core 12 | import Course.ExactlyOne (ExactlyOne (..)) 13 | import Course.Functor (void, (<$), (<$>)) 14 | import Course.List (List (..)) 15 | import Course.Optional (Optional (..)) 16 | 17 | spec :: Spec 18 | spec = do 19 | it "ExactlyOne" $ (+1) <$> ExactlyOne 2 `shouldBe` ExactlyOne 3 20 | 21 | describe "List" $ do 22 | it "empty list" $ 23 | (+1) <$> Nil `shouldBe` Nil 24 | it "increment" $ 25 | (+1) <$> (1 :. 2 :. 3 :. Nil) `shouldBe` (2 :. 3 :. 4 :. Nil) 26 | 27 | describe "Optional" $ do 28 | it "Empty" $ (+1) <$> Empty `shouldBe` Empty 29 | it "Full" $ (+1) <$> Full 2 `shouldBe` Full 3 30 | 31 | describe "Function" $ do 32 | it "(->)" $ ((+1) <$> (*2)) 8 `shouldBe` 17 33 | 34 | describe "(<$)" $ do 35 | it "Map 7" $ 7 <$ (1 :. 2 :. 3 :. Nil) `shouldBe` (7 :. 7 :. 7 :. Nil) 36 | prop "Always maps a constant value over List" $ 37 | \x a b c -> (x :: Integer) <$ ((a :. b :. c :. Nil) :: List Integer) == (x :. x :. x :. Nil) 38 | prop "Always maps a constant value over Full (Optional)" $ 39 | \(x :: Integer) (q :: Integer) -> x <$ Full q == Full x 40 | 41 | describe "void" $ do 42 | it "List" $ void (1 :. 2 :. 3 :. Nil) `shouldBe` () :. () :. () :. Nil 43 | it "Full" $ void (Full 7) `shouldBe` Full () 44 | it "Empty" $ void Empty `shouldBe` Empty 45 | it "(->)" $ void (+10) 5 `shouldBe` () 46 | -------------------------------------------------------------------------------- /src/Course/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RebindableSyntax #-} 4 | 5 | module Course.Core( 6 | Eq(..) 7 | , Ord(..) 8 | , Show(..) 9 | , Integral(..) 10 | , RealFrac(..) 11 | , Num(..) 12 | , Fractional(..) 13 | , Bool(..) 14 | , Either(..) 15 | , Int 16 | , Integer 17 | , IO 18 | , Rational 19 | , seq 20 | , error 21 | , undefined 22 | , const 23 | , flip 24 | , curry 25 | , uncurry 26 | , id 27 | , otherwise 28 | , (.) 29 | , ($) 30 | , (&&) 31 | , (||) 32 | , not 33 | , even 34 | , odd 35 | , fst 36 | , snd 37 | , getChar 38 | , on 39 | , first 40 | , second 41 | , (&&&) 42 | , (***) 43 | , IsString(..) 44 | , module Data.Char 45 | , ifThenElse 46 | , bool 47 | ) where 48 | 49 | 50 | import Prelude( 51 | Eq(..) 52 | , Ord(..) 53 | , Show(..) 54 | , Integral(..) 55 | , RealFrac(..) 56 | , Num(..) 57 | , Fractional(..) 58 | , Bool(..) 59 | , Either(..) 60 | , Char 61 | , Int 62 | , Integer 63 | , IO 64 | , Rational 65 | , seq 66 | , error 67 | , undefined 68 | , const 69 | , flip 70 | , curry 71 | , uncurry 72 | , id 73 | , otherwise 74 | , (.) 75 | , ($) 76 | , (&&) 77 | , (||) 78 | , not 79 | , even 80 | , odd 81 | , fst 82 | , snd 83 | ) 84 | import Data.String( 85 | IsString(..) 86 | ) 87 | 88 | import System.IO( 89 | getChar 90 | ) 91 | import Data.Function( 92 | on 93 | ) 94 | import Control.Arrow( 95 | first 96 | , second 97 | , (&&&) 98 | , (***) 99 | ) 100 | import Data.Char 101 | 102 | ifThenElse :: 103 | Bool 104 | -> a 105 | -> a 106 | -> a 107 | ifThenElse True t _ = 108 | t 109 | ifThenElse False _ f = 110 | f 111 | 112 | bool :: 113 | a 114 | -> a 115 | -> Bool 116 | -> a 117 | bool f _ False = 118 | f 119 | bool _ t True = 120 | t 121 | 122 | -------------------------------------------------------------------------------- /test/Course/ExtendSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.ExtendSpec where 5 | 6 | 7 | import Test.Hspec (Spec, describe, it, shouldBe) 8 | 9 | import Course.Core 10 | import Course.ExactlyOne (ExactlyOne (ExactlyOne)) 11 | import Course.Functor ((<$>)) 12 | import Course.List (List (..), length, listh, reverse) 13 | import Course.Optional (Optional (..)) 14 | 15 | import Course.Extend (cojoin, (<<=)) 16 | 17 | spec :: Spec 18 | spec = do 19 | it "ExactlyOne instance" $ 20 | (id <<= ExactlyOne 7) `shouldBe` ExactlyOne (ExactlyOne 7) 21 | 22 | describe "List" $ do 23 | it "length" $ 24 | (length <<= ('a' :. 'b' :. 'c' :. Nil)) `shouldBe` (3 :. 2 :. 1 :. Nil) 25 | it "id" $ 26 | (id <<= (1 :. 2 :. 3 :. 4 :. Nil)) `shouldBe` nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] 27 | it "reverse" $ 28 | (reverse <<= ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil)) `shouldBe` 29 | nestedListh3 [[[4,5,6],[1,2,3]],[[4,5,6]]] 30 | 31 | describe "Optional" $ do 32 | it "id Full" $ 33 | (id <<= (Full 7)) `shouldBe` Full (Full 7) 34 | it "id Empty" $ 35 | (id <<= Empty) `shouldBe` (Empty :: Optional (Optional Integer)) 36 | 37 | describe "cojoin" $ do 38 | it "ExactlyOne" $ 39 | cojoin (ExactlyOne 7) `shouldBe` ExactlyOne (ExactlyOne 7) 40 | it "List" $ 41 | cojoin (1 :. 2 :. 3 :. 4 :. Nil) `shouldBe` nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] 42 | it "Full" $ 43 | cojoin (Full 7) `shouldBe` Full (Full 7) 44 | it "Empty" $ 45 | cojoin Empty `shouldBe` (Empty :: Optional (Optional Integer)) 46 | 47 | 48 | nestedListh2 :: [[a]] -> List (List a) 49 | nestedListh2 = (listh <$>) . listh 50 | 51 | nestedListh3 :: [[[a]]] -> List (List (List a)) 52 | nestedListh3 = ((listh <$>) <$>) . nestedListh2 53 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/package.yaml: -------------------------------------------------------------------------------- 1 | name: network-server 2 | version: '0.0.1' 3 | synopsis: A network server 4 | description: A network server 5 | category: Education 6 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 7 | maintainer: Chris Allen 8 | copyright: Copyright (C) 2013 National ICT Australia Limited 2013 9 | license: BSD3 10 | license-file: etc/LICENCE 11 | homepage: https://github.com/data61/fp-course 12 | git: git@github.com:data61/fp-course.git 13 | bug-reports: https://github.com/data61/fp-course/issues 14 | 15 | library: 16 | source-dirs: src 17 | ghc-options: -Wall 18 | exposed-modules: 19 | - Network.Server.Chat.Chat 20 | - Network.Server.Chat.Loop 21 | - Network.Server.Chat 22 | - Network.Server.Common.Accept 23 | - Network.Server.Common.Env 24 | - Network.Server.Common.HandleLens 25 | - Network.Server.Common.Lens 26 | - Network.Server.Common.Line 27 | - Network.Server.Common.Ref 28 | - Network.Server.Common 29 | - Network.Server.TicTacToe.Game 30 | - Network.Server.TicTacToe.Loop 31 | - Network.Server.TicTacToe 32 | - Network.Server 33 | dependencies: 34 | - base <5 && >=4 35 | - mtl 36 | - containers 37 | - network 38 | - QuickCheck 39 | 40 | executables: 41 | network-chat: 42 | main: Chat/Main.hs 43 | source-dirs: app 44 | ghc-options: -Wall 45 | dependencies: 46 | - base <5 && >=4 47 | - network-server 48 | - mtl 49 | - containers 50 | - network 51 | - QuickCheck 52 | 53 | network-tictactoe: 54 | main: TicTacToe/Main.hs 55 | source-dirs: app 56 | ghc-options: -Wall 57 | dependencies: 58 | - base <5 && >=4 59 | - network-server 60 | - mtl 61 | - containers 62 | - network 63 | - QuickCheck 64 | 65 | tests: 66 | doctests: 67 | main: doctests.hs 68 | 69 | source-dirs: test 70 | 71 | ghc-options: 72 | - -Wall 73 | - -threaded 74 | 75 | dependencies: 76 | - base <5 && >=3 77 | - doctest >=0.9.7 78 | - filepath >=1.3 79 | - directory >=1.1 80 | - QuickCheck >=2.0 81 | -------------------------------------------------------------------------------- /etc/CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Tony Morris 2 | tmorris@tmorris.net 3 | http://tmorris.net/ 4 | -----BEGIN PGP PUBLIC KEY BLOCK----- 5 | Version: GnuPG v1.4.6 (GNU/Linux) 6 | 7 | mQGiBETNyC0RBAC3MYSZSbDZhBLKra2YUphB9OO6+qMFl/v2Lq8590ZfeE2WjIOu 8 | c/KGKyOigXztMrA4+iekUjM4FA8E6AlBRQiAqZK8HF0ftX5hDpuSyEKkZe3jcxxI 9 | BbhwX/SWHtDEVzwNmvO1wEnwhRE1oY/BCmy+bQ9wmAjlNav4UbOIcXcJUwCgz6FF 10 | UwDvPxzybgd9FNS14BE37n8D/AzGmGjunBW/x+g/ndwu6WEpTEn1ZNdja6VrNXSG 11 | xQ8XM+NBulroAIYX+YWdHsKnuGvSKCgVoc1ifVHdztA9sksID5GBGzhmVbIP2E16 12 | w/LEzqqwruv9dX0Y1b7n8hcnvbl4DgEgLgeQ+VgJfLUkY2jFZ2m3dEBRH9USSgB/ 13 | V2pBBACP4Us2ZBYEXtMG29g6GqyeeJLEP34PLYVHWJZbet/wPQsHFhYahhzjwZGG 14 | Srp0JUpegJOdaqX/Y0nio2whgCpqJcrbGuUBqNgQI3k4gvBwnPyx7jM0kfHfFORG 15 | lq9SDbfLpV0EJx6fWXGStW33zsQQvenDcV2F5czzKQcy66BFwbQhVG9ueSBNb3Jy 16 | aXMgPHRtb3JyaXNAdG1vcnJpcy5uZXQ+iGMEExECACMFAkTNyC0FCQlmAYAGCwkI 17 | BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRCaemCth7qvrf0pAKCFii2pI2W1BKVFuQcw 18 | yoNxP0CAUACgyhuI9isCvtrOkeyjDmCVueRCdaC5Ag0ERM3IThAIAJ6A1z+d40ve 19 | WvPIhpFiGfoS8UX4YdgYpo2mC/orY0xszBitogtaTHQHU5YDemGg81plNg9I3DbM 20 | Er8uyONV4DqF6RbLj4w+iA6zn93+PTEZ73ydhxF6vDuojpVZPXVzXzpgyXHkEVLC 21 | 3hKL9oVlEsh+DWCvCiSAIy780JZ3FNVuMC3VH4qKxTw0CwPuuZvVfnMoIRfpODRR 22 | fVEk2VDor+lr8kqJkBaHgN5o/AvOXC7QCYadwbEkpr0ecxIZ1VcASYytIIM3YNL7 23 | ZcHWwU5PCNLOdMXPqOdthhDhsHkKJNEXXr0YsjX/bQqYOUqYKPDyqh/yrrRO9Ro6 24 | 7eTSbfIguycAAwcH/2waLIQR8qYKxPknNuSdsOOqF2jf2gglL/7uMsIzjfkFzgHo 25 | +GNHw9tmlZqD3yzaZ/N7Yv08ujRHhmWPBYAWRICBM3qo0zMJ9kI5XWRobeRQpLtf 26 | YxxIOenq8R9t6YU9ryHdqf+P+Fi38eN5ERTDhNLrJOnO5/TA+of97BWCmdtJMlWM 27 | RaHtqXxwo02Yi65IqKx6L7oOvT7Gh4NV2eglz8ZafPEoP8+V8ER7rwBYPiLk4Mse 28 | oVImjveq2dmLUip9OPwznoaeyC8zB0mJ13m/KNC+CffkBgoXpMPiKzbu5YTjVw++ 29 | MlEmfgL42yDK0hnokmW2i9y1RBh/T1VQQeQbUaeITAQYEQIADAUCRM3ITgUJCWYB 30 | gAAKCRCaemCth7qvrcbtAJ9j3C6lKNRB3uKcrfze66jAVQh0qACaAysOK82TcQ/2 31 | 73ryR0xWMFnpGqg= 32 | =bMTb 33 | -----END PGP PUBLIC KEY BLOCK----- 34 | 35 | Mark Hibberd 36 | mthibberd@gmail.com 37 | 38 | Ben Sinclair 39 | ben.d.sinclair@gmail.com 40 | 41 | James Earl Douglas 42 | james@earldouglas.com 43 | 44 | Eric Torreborre 45 | etorreborre@yahoo.com 46 | 47 | Matt Parsons 48 | parsonsmatt@gmail.com 49 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | \begin{code} 3 | {-# OPTIONS_GHC -Wall #-} 4 | module Main (main) where 5 | 6 | import Data.List ( nub ) 7 | import Data.Version ( showVersion ) 8 | import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) 9 | import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) 10 | import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) 11 | import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) 12 | import Distribution.Simple.BuildPaths ( autogenModulesDir ) 13 | import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) 14 | import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) 15 | import Distribution.Verbosity ( Verbosity ) 16 | import System.FilePath ( () ) 17 | 18 | main :: IO () 19 | main = defaultMainWithHooks simpleUserHooks 20 | { buildHook = \pkg lbi hooks flags -> do 21 | generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi 22 | buildHook simpleUserHooks pkg lbi hooks flags 23 | } 24 | 25 | generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () 26 | generateBuildModule verbosity pkg lbi = do 27 | let dir = autogenModulesDir lbi 28 | createDirectoryIfMissingVerbose verbosity True dir 29 | withLibLBI pkg lbi $ \_ libcfg -> do 30 | withTestLBI pkg lbi $ \suite suitecfg -> do 31 | rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines 32 | [ "module Build_" ++ testName suite ++ " where" 33 | , "deps :: [String]" 34 | , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) 35 | ] 36 | where 37 | formatdeps = map (formatone . snd) 38 | formatone p = case packageName p of 39 | PackageName n -> n ++ "-" ++ showVersion (packageVersion p) 40 | 41 | testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] 42 | testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys 43 | 44 | \end{code} 45 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Lens.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Lens where 2 | 3 | -- | A lens is a pair of set and get. 4 | -- 5 | -- The type parameter 'a' denotes the target object. 6 | -- The type parameter 'b' denotes the field object. 7 | data Lens a b = 8 | Lens (a -> b -> a) (a -> b) 9 | 10 | -- | Given a lens and a target object, return its field object. 11 | getL :: 12 | Lens a b 13 | -> a 14 | -> b 15 | getL (Lens _ g) = 16 | g 17 | 18 | -- | Given a lens, a target object and a field object, return a new target object with the field set. 19 | setL :: 20 | Lens a b 21 | -> a 22 | -> b 23 | -> a 24 | setL (Lens s _) = 25 | s 26 | 27 | -- | Produce the lens for the first element of a pair. 28 | -- 29 | -- >>> getL fstL ("hi", 3) 30 | -- "hi" 31 | -- 32 | -- >>> setL fstL ("hi", 3) "bye" 33 | -- ("bye",3) 34 | fstL :: 35 | Lens (a, b) a 36 | fstL = 37 | Lens (\(_, b) a -> (a, b)) fst 38 | 39 | -- | Produce the lens for the second element of a pair. 40 | -- 41 | -- >>> getL sndL ("hi", 3) 42 | -- 3 43 | -- 44 | -- >>> setL sndL ("hi", 3) 4 45 | -- ("hi",4) 46 | sndL :: 47 | Lens (a, b) b 48 | sndL = 49 | Lens (\(a, _) b -> (a, b)) snd 50 | 51 | -- | Lens composition. 52 | -- Given lens (a to b) and lens (b to c), produce lens (a to c). 53 | -- 54 | -- >>> getL (fstL .@ sndL) (("hi", 3), [7,8,9]) 55 | -- 3 56 | -- 57 | -- >>> setL (fstL .@ sndL) (("hi", 3), [7,8,9]) 4 58 | -- (("hi",4),[7,8,9]) 59 | (.@) :: 60 | Lens a b 61 | -> Lens b c 62 | -> Lens a c 63 | Lens s1 g1 .@ Lens s2 g2 = 64 | Lens (\a -> s1 a . s2 (g1 a)) (g2 . g1) 65 | 66 | -- | Lens identity. 67 | -- Produce lens that /does nothing/. 68 | -- 69 | -- prop> getL identityL (x :: Int) == x 70 | -- 71 | -- prop> setL identityL x (y :: Int) == y 72 | identityL :: 73 | Lens a a 74 | identityL = 75 | Lens (const id) id 76 | 77 | -- | Lens modification. 78 | -- Given a lens and a modification function on the field object 79 | -- and a target object, return a target with the function applied at that field. 80 | -- 81 | -- >>> modify fstL (+10) (4, "hi") 82 | -- (14,"hi") 83 | modify :: 84 | Lens a b 85 | -> (b -> b) 86 | -> a 87 | -> a 88 | modify (Lens s g) f a = 89 | s a (f (g a)) 90 | 91 | iso :: 92 | (a -> b) 93 | -> (b -> a) 94 | -> Lens a b 95 | iso f g = 96 | Lens (const g) f 97 | -------------------------------------------------------------------------------- /src/Course/Extend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Extend where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.List 10 | import Course.Optional 11 | import Course.Functor 12 | 13 | -- | All instances of the `Extend` type-class must satisfy one law. This law 14 | -- is not checked by the compiler. This law is given as: 15 | -- 16 | -- * The law of associativity 17 | -- `∀f g. (f <<=) . (g <<=) ≅ (<<=) (f . (g <<=))` 18 | class Functor f => Extend f where 19 | -- Pronounced, extend. 20 | (<<=) :: 21 | (f a -> b) 22 | -> f a 23 | -> f b 24 | 25 | infixr 1 <<= 26 | 27 | -- | Implement the @Extend@ instance for @ExactlyOne@. 28 | -- 29 | -- >>> id <<= ExactlyOne 7 30 | -- ExactlyOne (ExactlyOne 7) 31 | instance Extend ExactlyOne where 32 | (<<=) :: 33 | (ExactlyOne a -> b) 34 | -> ExactlyOne a 35 | -> ExactlyOne b 36 | (<<=) = 37 | error "todo: Course.Extend (<<=)#instance ExactlyOne" 38 | 39 | -- | Implement the @Extend@ instance for @List@. 40 | -- 41 | -- >>> length <<= ('a' :. 'b' :. 'c' :. Nil) 42 | -- [3,2,1] 43 | -- 44 | -- >>> id <<= (1 :. 2 :. 3 :. 4 :. Nil) 45 | -- [[1,2,3,4],[2,3,4],[3,4],[4]] 46 | -- 47 | -- >>> reverse <<= ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil) 48 | -- [[[4,5,6],[1,2,3]],[[4,5,6]]] 49 | instance Extend List where 50 | (<<=) :: 51 | (List a -> b) 52 | -> List a 53 | -> List b 54 | (<<=) = 55 | error "todo: Course.Extend (<<=)#instance List" 56 | 57 | -- | Implement the @Extend@ instance for @Optional@. 58 | -- 59 | -- >>> id <<= (Full 7) 60 | -- Full (Full 7) 61 | -- 62 | -- >>> id <<= Empty 63 | -- Empty 64 | instance Extend Optional where 65 | (<<=) :: 66 | (Optional a -> b) 67 | -> Optional a 68 | -> Optional b 69 | (<<=) = 70 | error "todo: Course.Extend (<<=)#instance Optional" 71 | 72 | -- | Duplicate the functor using extension. 73 | -- 74 | -- >>> cojoin (ExactlyOne 7) 75 | -- ExactlyOne (ExactlyOne 7) 76 | -- 77 | -- >>> cojoin (1 :. 2 :. 3 :. 4 :. Nil) 78 | -- [[1,2,3,4],[2,3,4],[3,4],[4]] 79 | -- 80 | -- >>> cojoin (Full 7) 81 | -- Full (Full 7) 82 | -- 83 | -- >>> cojoin Empty 84 | -- Empty 85 | cojoin :: 86 | Extend f => 87 | f a 88 | -> f (f a) 89 | cojoin = 90 | error "todo: Course.Extend#cojoin" 91 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: course 2 | version: 0.1.5 3 | synopsis: Source code for a functional programming course 4 | description: Source code for a course in functional programming using Haskell 5 | category: Education 6 | author: ! 'Tony Morris 7 | Mark Hibberd 8 | Ben Sinclair 9 | James Earl Douglas 10 | Eric Torreborre ' 11 | maintainer: Chris Allen 12 | copyright: ! 'Copyright (C) 2010-2013 Tony Morris 13 | Copyright (C) 2012-2015 National ICT Australia Limited 14 | Copyright (C) 2012 James Earl Douglas 15 | Copyright (C) 2012 Ben Sinclair 16 | Copyright (C) 2016-2017 Data61' 17 | license: BSD3 18 | license-file: etc/LICENCE 19 | homepage: https://github.com/bitemyapp/fp-course 20 | git: git@github.com:bitemyapp/fp-course.git 21 | bug-reports: https://github.com/bitemyapp/fp-course/issues 22 | 23 | tested-with: GHC==8.0.2 24 | 25 | extra-source-files: 26 | - etc/CONTRIBUTORS 27 | - CHANGELOG.md 28 | 29 | ghc-options: -Wall 30 | 31 | library: 32 | source-dirs: src 33 | 34 | default-extensions: 35 | - NoImplicitPrelude 36 | - ScopedTypeVariables 37 | - InstanceSigs 38 | 39 | ghc-options: 40 | - -fwarn-incomplete-uni-patterns 41 | - -fno-warn-unused-binds 42 | - -fno-warn-unused-do-bind 43 | - -fno-warn-unused-imports 44 | - -fno-warn-type-defaults 45 | - -ferror-spans 46 | 47 | exposed-modules: 48 | - Course 49 | - Course.Anagrams 50 | - Course.Applicative 51 | - Course.Cheque 52 | - Course.Comonad 53 | - Course.Compose 54 | - Course.Core 55 | - Course.ExactlyOne 56 | - Course.Extend 57 | - Course.FastAnagrams 58 | - Course.FileIO 59 | - Course.Functor 60 | - Course.Interactive 61 | - Course.JsonParser 62 | - Course.JsonValue 63 | - Course.List 64 | - Course.ListZipper 65 | - Course.Monad 66 | - Course.MonadTutorial 67 | - Course.MoreParser 68 | - Course.Optional 69 | - Course.Parser 70 | - Course.Person 71 | - Course.State 72 | - Course.StateT 73 | - Course.Traversable 74 | - Course.Validation 75 | 76 | dependencies: 77 | - base <5 && >=4 78 | - containers >=0.4.0.0 79 | - array >=0.4 80 | 81 | tests: 82 | course-tests: 83 | main: Spec.hs 84 | source-dirs: test 85 | ghc-options: 86 | - -threaded 87 | dependencies: 88 | - base <5 && >=3 89 | - course 90 | - hspec 91 | - hspec-discover 92 | - QuickCheck >=2.9 93 | -------------------------------------------------------------------------------- /test/Course/MonadSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.MonadSpec where 5 | 6 | import Test.Hspec (Spec, describe, it, shouldBe) 7 | 8 | import Course.Core 9 | import Course.ExactlyOne (ExactlyOne (..)) 10 | import Course.List (List (..)) 11 | import Course.Monad (join, (<**>), (=<<), (>>=), (<=<)) 12 | import Course.Optional (Optional (..)) 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "Bind tests" $ do 17 | it "(=<<) for ExactlyOne" $ 18 | ((\x -> ExactlyOne(x+1)) =<< ExactlyOne 2) `shouldBe` ExactlyOne 3 19 | 20 | it "(=<<) for List" $ 21 | ((\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil)) `shouldBe` (1:.1:.2:.2:.3:.3:.Nil) 22 | 23 | it "(=<<) for Optional" $ 24 | ((\n -> Full (n + n)) =<< Full 7) `shouldBe` Full 14 25 | 26 | it "(=<<) for (->)" $ 27 | ((*) =<< (+10)) 7 `shouldBe` 119 28 | 29 | describe "<**>" $ do 30 | it "ExactlyOne" $ 31 | ExactlyOne (+10) <**> ExactlyOne 8 `shouldBe` ExactlyOne 18 32 | it "List" $ 33 | (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil `shouldBe` (2:.3:.4:.2:.4:.6:.Nil) 34 | it "Optional" $ 35 | Full (+8) <**> Full 7 `shouldBe` Full 15 36 | it "Optional - empty function" $ 37 | Empty <**> Full 7 `shouldBe` (Empty :: Optional Integer) 38 | it "Optional - empty value" $ 39 | Full (+8) <**> Empty `shouldBe` Empty 40 | it "(->) 1" $ 41 | ((+) <**> (+10)) 3 `shouldBe` 16 42 | it "(->) 2" $ 43 | ((+) <**> (+5)) 3 `shouldBe` 11 44 | it "(->) 3" $ 45 | ((+) <**> (+5)) 1 `shouldBe` 7 46 | it "(->) 4" $ 47 | ((*) <**> (+10)) 3 `shouldBe` 39 48 | it "(->) 5" $ 49 | ((*) <**> (+2)) 3 `shouldBe` 15 50 | 51 | describe "join" $ do 52 | it "List" $ 53 | join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` (1:.2:.3:.1:.2:.Nil) 54 | it "Optional with Empty" $ 55 | join (Full Empty) `shouldBe` (Empty :: Optional Integer) 56 | it "Optional all Full" $ 57 | join (Full (Full 7)) `shouldBe` Full 7 58 | it "(->)" $ 59 | join (+) 7 `shouldBe` 14 60 | 61 | describe "bindFlipped" $ do 62 | it "(>>=)" $ 63 | ((+10) >>= (*)) 7 `shouldBe` 119 64 | 65 | describe "Kleisli Composition" $ do 66 | it "kleisliComposition" $ 67 | ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1 68 | `shouldBe` 69 | (2:.2:.3:.3:.Nil) 70 | -------------------------------------------------------------------------------- /src/Course/Optional.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Optional where 5 | 6 | import qualified Control.Applicative as A 7 | import qualified Control.Monad as M 8 | import Course.Core 9 | import qualified Prelude as P 10 | 11 | -- | The `Optional` data type contains 0 or 1 value. 12 | -- 13 | -- It might be thought of as a list, with a maximum length of one. 14 | data Optional a = 15 | Full a 16 | | Empty 17 | deriving (Eq, Show) 18 | 19 | -- | Map the given function on the possible value. 20 | -- 21 | -- >>> mapOptional (+1) Empty 22 | -- Empty 23 | -- 24 | -- >>> mapOptional (+1) (Full 8) 25 | -- Full 9 26 | mapOptional :: 27 | (a -> b) 28 | -> Optional a 29 | -> Optional b 30 | mapOptional = 31 | error "todo: Course.Optional#mapOptional" 32 | 33 | -- | Bind the given function on the possible value. 34 | -- 35 | -- >>> bindOptional Full Empty 36 | -- Empty 37 | -- 38 | -- >>> bindOptional (\n -> if even n then Full (n - 1) else Full (n + 1)) (Full 8) 39 | -- Full 7 40 | -- 41 | -- >>> bindOptional (\n -> if even n then Full (n - 1) else Full (n + 1)) (Full 9) 42 | -- Full 10 43 | bindOptional :: 44 | (a -> Optional b) 45 | -> Optional a 46 | -> Optional b 47 | bindOptional = 48 | error "todo: Course.Optional#bindOptional" 49 | 50 | -- | Return the possible value if it exists; otherwise, the second argument. 51 | -- 52 | -- >>> Full 8 ?? 99 53 | -- 8 54 | -- 55 | -- >>> Empty ?? 99 56 | -- 99 57 | (??) :: 58 | Optional a 59 | -> a 60 | -> a 61 | (??) = 62 | error "todo: Course.Optional#(??)" 63 | 64 | -- | Try the first optional for a value. If it has a value, use it; otherwise, 65 | -- use the second value. 66 | -- 67 | -- >>> Full 8 <+> Empty 68 | -- Full 8 69 | -- 70 | -- >>> Full 8 <+> Full 9 71 | -- Full 8 72 | -- 73 | -- >>> Empty <+> Full 9 74 | -- Full 9 75 | -- 76 | -- >>> Empty <+> Empty 77 | -- Empty 78 | (<+>) :: 79 | Optional a 80 | -> Optional a 81 | -> Optional a 82 | (<+>) = 83 | error "todo: Course.Optional#(<+>)" 84 | 85 | applyOptional :: Optional (a -> b) -> Optional a -> Optional b 86 | applyOptional f a = bindOptional (\f' -> mapOptional f' a) f 87 | 88 | twiceOptional :: (a -> b -> c) -> Optional a -> Optional b -> Optional c 89 | twiceOptional f = applyOptional . mapOptional f 90 | 91 | contains :: Eq a => a -> Optional a -> Bool 92 | contains _ Empty = False 93 | contains a (Full z) = a == z 94 | 95 | instance P.Functor Optional where 96 | fmap = 97 | M.liftM 98 | 99 | instance A.Applicative Optional where 100 | (<*>) = 101 | M.ap 102 | pure = 103 | Full 104 | 105 | instance P.Monad Optional where 106 | (>>=) = 107 | flip bindOptional 108 | return = 109 | Full 110 | -------------------------------------------------------------------------------- /test/Course/ValidationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Course.ValidationSpec where 7 | 8 | import qualified Prelude as P (either, fmap) 9 | import Test.Hspec (Spec, describe, it, shouldBe) 10 | import Test.Hspec.QuickCheck (prop) 11 | import Test.QuickCheck (Arbitrary(..), (===), (.||.)) 12 | 13 | import Course.Core 14 | import Course.Validation 15 | 16 | instance Arbitrary a => Arbitrary (Validation a) where 17 | arbitrary = P.fmap (P.either Error Value) arbitrary 18 | 19 | spec :: Spec 20 | spec = do 21 | describe "isError" $ do 22 | it "true for errors" $ 23 | isError (Error "Message") `shouldBe` True 24 | it "false for values" $ 25 | isError (Value "7") `shouldBe` False 26 | prop "not the same as isValue" $ 27 | \(x :: Validation Int) -> isError x /= isValue x 28 | 29 | describe "isValue" $ do 30 | it "false for errors" $ 31 | isValue (Error "Message") `shouldBe` False 32 | it "false for values" $ 33 | isValue (Value "7") `shouldBe` True 34 | prop "not the same as isValue" $ 35 | \(x :: Validation Int) -> isValue x /= isError x 36 | 37 | describe "mapValidation" $ do 38 | it "errors unchanged" $ 39 | mapValidation (+ 10) (Error "message") `shouldBe` Error "message" 40 | it "values changed" $ 41 | mapValidation (+ 10) (Value 7) `shouldBe` Value 17 42 | prop "map with id causes no change" $ 43 | \(x :: Validation Int) -> mapValidation id x === x 44 | 45 | let 46 | f n = 47 | if even n 48 | then Value (n + 10) 49 | else Error "odd" 50 | describe "bindValidation" $ do 51 | it "error unchanged" $ 52 | bindValidation f (Error "message") `shouldBe` Error "message" 53 | it "odd value" $ 54 | bindValidation f (Value 7) `shouldBe` Error "odd" 55 | it "even value" $ 56 | bindValidation f (Value 8) `shouldBe` Value 18 57 | prop "bind with Value causes no change" $ 58 | \(x :: Validation Int) -> bindValidation Value x === x 59 | 60 | describe "valueOr" $ do 61 | it "falls through for errors" $ 62 | valueOr (Error "message") "foo" `shouldBe` "foo" 63 | it "unwraps values" $ 64 | valueOr (Value "foo") "bar" `shouldBe` "foo" 65 | prop "isValue or valueOr falls through" $ 66 | \(x :: Validation Int) n -> isValue x .||. valueOr x n === n 67 | 68 | describe "errorOr" $ do 69 | it "unwraps errors" $ 70 | errorOr (Error "message") "q" `shouldBe` "message" 71 | it "falls through for values" $ 72 | errorOr (Value (7 :: Integer)) "q" `shouldBe` "q" 73 | prop "isError or errorOr falls through" $ 74 | \(x :: Validation Int) n -> isError x .||. errorOr x n === n 75 | -------------------------------------------------------------------------------- /src/Course/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Validation where 5 | 6 | import qualified Prelude as P(String) 7 | import Course.Core 8 | 9 | -- class Validation { 10 | -- Validation(String error) {} // Error 11 | -- Validation(A value) {} // Value 12 | -- } 13 | 14 | -- $setup 15 | -- >>> import Test.QuickCheck 16 | -- >>> import qualified Prelude as P(fmap, either) 17 | -- >>> instance Arbitrary a => Arbitrary (Validation a) where arbitrary = P.fmap (P.either Error Value) arbitrary 18 | data Validation a = Error Err | Value a 19 | deriving (Eq, Show) 20 | 21 | type Err = P.String 22 | 23 | -- | Returns whether or not the given validation is an error. 24 | -- 25 | -- >>> isError (Error "message") 26 | -- True 27 | -- 28 | -- >>> isError (Value 7) 29 | -- False 30 | -- 31 | -- prop> \x -> isError x /= isValue x 32 | isError :: Validation a -> Bool 33 | isError (Error _) = True 34 | isError (Value _) = False 35 | 36 | -- | Returns whether or not the given validation is a value. 37 | -- 38 | -- >>> isValue (Error "message") 39 | -- False 40 | -- 41 | -- >>> isValue (Value 7) 42 | -- True 43 | -- 44 | -- prop> \x -> isValue x /= isError x 45 | isValue :: Validation a -> Bool 46 | isValue = not . isError 47 | 48 | -- | Maps a function on a validation's value side. 49 | -- 50 | -- >>> mapValidation (+10) (Error "message") 51 | -- Error "message" 52 | -- 53 | -- >>> mapValidation (+10) (Value 7) 54 | -- Value 17 55 | -- 56 | -- prop> \x -> mapValidation id x == x 57 | mapValidation :: (a -> b) -> Validation a -> Validation b 58 | mapValidation _ (Error s) = Error s 59 | mapValidation f (Value a) = Value (f a) 60 | 61 | -- | Binds a function on a validation's value side to a new validation. 62 | -- 63 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Error "message") 64 | -- Error "message" 65 | -- 66 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Value 7) 67 | -- Error "odd" 68 | -- 69 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Value 8) 70 | -- Value 18 71 | -- 72 | -- prop> \x -> bindValidation Value x == x 73 | bindValidation :: (a -> Validation b) -> Validation a -> Validation b 74 | bindValidation _ (Error s) = Error s 75 | bindValidation f (Value a) = f a 76 | 77 | -- | Returns a validation's value side or the given default if it is an error. 78 | -- 79 | -- >>> valueOr (Error "message") 3 80 | -- 3 81 | -- 82 | -- >>> valueOr (Value 7) 3 83 | -- 7 84 | -- 85 | -- prop> \x -> isValue x || valueOr x n == n 86 | valueOr :: Validation a -> a -> a 87 | valueOr (Error _) a = a 88 | valueOr (Value a) _ = a 89 | 90 | -- | Returns a validation's error side or the given default if it is a value. 91 | -- 92 | -- >>> errorOr (Error "message") "q" 93 | -- "message" 94 | -- 95 | -- >>> errorOr (Value 7) "q" 96 | -- "q" 97 | -- 98 | -- prop> \x -> isError x || errorOr x e == e 99 | errorOr :: Validation a -> Err -> Err 100 | errorOr (Error e) _ = e 101 | errorOr (Value _) a = a 102 | 103 | valueValidation :: a -> Validation a 104 | valueValidation = Value 105 | -------------------------------------------------------------------------------- /src/Course/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Functor where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.Optional 10 | import Course.List 11 | import qualified Prelude as P(fmap) 12 | 13 | -- | All instances of the `Functor` type-class must satisfy two laws. These laws 14 | -- are not checked by the compiler. These laws are given as: 15 | -- 16 | -- * The law of identity 17 | -- `∀x. (id <$> x) ≅ x` 18 | -- 19 | -- * The law of composition 20 | -- `∀f g x.(f . g <$> x) ≅ (f <$> (g <$> x))` 21 | class Functor f where 22 | -- Pronounced, eff-map. 23 | (<$>) :: 24 | (a -> b) 25 | -> f a 26 | -> f b 27 | 28 | infixl 4 <$> 29 | 30 | -- $setup 31 | -- >>> :set -XOverloadedStrings 32 | -- >>> import Course.Core 33 | -- >>> import qualified Prelude as P(return, (>>)) 34 | 35 | -- | Maps a function on the ExactlyOne functor. 36 | -- 37 | -- >>> (+1) <$> ExactlyOne 2 38 | -- ExactlyOne 3 39 | instance Functor ExactlyOne where 40 | (<$>) :: 41 | (a -> b) 42 | -> ExactlyOne a 43 | -> ExactlyOne b 44 | (<$>) = 45 | error "todo: Course.Functor (<$>)#instance ExactlyOne" 46 | 47 | -- | Maps a function on the List functor. 48 | -- 49 | -- >>> (+1) <$> Nil 50 | -- [] 51 | -- 52 | -- >>> (+1) <$> (1 :. 2 :. 3 :. Nil) 53 | -- [2,3,4] 54 | instance Functor List where 55 | (<$>) :: 56 | (a -> b) 57 | -> List a 58 | -> List b 59 | (<$>) = 60 | error "todo: Course.Functor (<$>)#instance List" 61 | 62 | -- | Maps a function on the Optional functor. 63 | -- 64 | -- >>> (+1) <$> Empty 65 | -- Empty 66 | -- 67 | -- >>> (+1) <$> Full 2 68 | -- Full 3 69 | instance Functor Optional where 70 | (<$>) :: 71 | (a -> b) 72 | -> Optional a 73 | -> Optional b 74 | (<$>) = 75 | error "todo: Course.Functor (<$>)#instance Optional" 76 | 77 | -- | Maps a function on the reader ((->) t) functor. 78 | -- 79 | -- >>> ((+1) <$> (*2)) 8 80 | -- 17 81 | instance Functor ((->) t) where 82 | (<$>) :: 83 | (a -> b) 84 | -> ((->) t a) 85 | -> ((->) t b) 86 | (<$>) = 87 | error "todo: Course.Functor (<$>)#((->) t)" 88 | 89 | -- | Anonymous map. Maps a constant value on a functor. 90 | -- 91 | -- >>> 7 <$ (1 :. 2 :. 3 :. Nil) 92 | -- [7,7,7] 93 | -- 94 | -- prop> \x a b c -> x <$ (a :. b :. c :. Nil) == (x :. x :. x :. Nil) 95 | -- 96 | -- prop> \x q -> x <$ Full q == Full x 97 | (<$) :: 98 | Functor f => 99 | a 100 | -> f b 101 | -> f a 102 | (<$) = 103 | error "todo: Course.Functor#(<$)" 104 | 105 | -- | Anonymous map producing unit value. 106 | -- 107 | -- >>> void (1 :. 2 :. 3 :. Nil) 108 | -- [(),(),()] 109 | -- 110 | -- >>> void (Full 7) 111 | -- Full () 112 | -- 113 | -- >>> void Empty 114 | -- Empty 115 | -- 116 | -- >>> void (+10) 5 117 | -- () 118 | void :: 119 | Functor f => 120 | f a 121 | -> f () 122 | void = 123 | error "todo: Course.Functor#void" 124 | 125 | ----------------------- 126 | -- SUPPORT LIBRARIES -- 127 | ----------------------- 128 | 129 | -- | Maps a function on an IO program. 130 | -- 131 | -- >>> reverse <$> (putStr "hi" P.>> P.return ("abc" :: List Char)) 132 | -- hi"cba" 133 | instance Functor IO where 134 | (<$>) = 135 | P.fmap 136 | -------------------------------------------------------------------------------- /src/Course/FileIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.FileIO where 7 | 8 | import Course.Core 9 | import Course.Applicative 10 | import Course.Monad 11 | import Course.Functor 12 | import Course.List 13 | 14 | {- 15 | 16 | Useful Functions -- 17 | 18 | getArgs :: IO (List Chars) 19 | putStrLn :: Chars -> IO () 20 | readFile :: FilePath -> IO Chars 21 | lines :: Chars -> List Chars 22 | void :: IO a -> IO () 23 | 24 | Abstractions -- 25 | Applicative, Monad: 26 | 27 | <$>, <*>, >>=, =<<, pure 28 | 29 | Tuple Functions that could help -- 30 | 31 | fst :: (a, b) -> a 32 | snd :: (a, b) -> b 33 | (,) :: a -> b -> (a, b) 34 | 35 | Problem -- 36 | Given a single argument of a file name, read that file, 37 | each line of that file contains the name of another file, 38 | read the referenced file and print out its name and contents. 39 | 40 | Consideration -- 41 | Try to avoid repetition. Factor out any common expressions. 42 | 43 | Example -- 44 | Given file files.txt, containing: 45 | a.txt 46 | b.txt 47 | c.txt 48 | 49 | And a.txt, containing: 50 | the contents of a 51 | 52 | And b.txt, containing: 53 | the contents of b 54 | 55 | And c.txt, containing: 56 | the contents of c 57 | 58 | To test this module, load ghci in the root of the project directory, and do 59 | >> :main "share/files.txt" 60 | 61 | Example output: 62 | 63 | $ ghci 64 | GHCi, version ... 65 | Loading package... 66 | Loading ... 67 | [ 1 of 28] Compiling (etc... 68 | ... 69 | Ok, modules loaded: Course, etc... 70 | >> :main "share/files.txt" 71 | ============ share/a.txt 72 | the contents of a 73 | 74 | ============ share/b.txt 75 | the contents of b 76 | 77 | ============ share/c.txt 78 | the contents of c 79 | 80 | -} 81 | 82 | -- Given the file name, and file contents, print them. 83 | -- Use @putStrLn@. 84 | printFile :: 85 | FilePath 86 | -> Chars 87 | -> IO () 88 | printFile = 89 | error "todo: Course.FileIO#printFile" 90 | 91 | -- Given a list of (file name and file contents), print each. 92 | -- Use @printFile@. 93 | printFiles :: 94 | List (FilePath, Chars) 95 | -> IO () 96 | printFiles = 97 | error "todo: Course.FileIO#printFiles" 98 | 99 | -- Given a file name, return (file name and file contents). 100 | -- Use @readFile@. 101 | getFile :: 102 | FilePath 103 | -> IO (FilePath, Chars) 104 | getFile = 105 | error "todo: Course.FileIO#getFile" 106 | 107 | -- Given a list of file names, return list of (file name and file contents). 108 | -- Use @getFile@. 109 | getFiles :: 110 | List FilePath 111 | -> IO (List (FilePath, Chars)) 112 | getFiles = 113 | error "todo: Course.FileIO#getFiles" 114 | 115 | -- Given a file name, read it and for each line in that file, read and print contents of each. 116 | -- Use @getFiles@ and @printFiles@. 117 | run :: 118 | FilePath 119 | -> IO () 120 | run = 121 | error "todo: Course.FileIO#run" 122 | 123 | -- /Tip:/ use @getArgs@ and @run@ 124 | main :: 125 | IO () 126 | main = 127 | error "todo: Course.FileIO#main" 128 | 129 | ---- 130 | 131 | -- Was there was some repetition in our solution? 132 | -- ? `sequence . (<$>)` 133 | -- ? `void . sequence . (<$>)` 134 | -- Factor it out. 135 | -------------------------------------------------------------------------------- /test/Course/StateSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Course.StateSpec where 6 | 7 | import Data.List (nub) 8 | import qualified Prelude as P ((++)) 9 | 10 | import Test.Hspec (Spec, describe, it, shouldBe) 11 | import Test.Hspec.QuickCheck (prop) 12 | import Test.QuickCheck.Function (Fun (..)) 13 | 14 | import Course.Applicative (pure, (<*>)) 15 | import Course.Core 16 | import Course.Functor ((<$>)) 17 | import Course.Gens (forAllLists) 18 | import Course.List (List (..), filter, flatMap, hlist, 19 | length, listh, span, (++)) 20 | import Course.Monad 21 | import Course.Optional (Optional (..)) 22 | import Course.State (State (..), distinct, eval, exec, 23 | findM, firstRepeat, get, isHappy, 24 | put, runState) 25 | 26 | spec :: Spec 27 | spec = do 28 | describe "State methods" $ do 29 | prop "exec" $ 30 | \(Fun _ f :: Fun Integer (Integer, Integer)) s -> exec (State f) s == snd (runState (State f) s) 31 | 32 | prop "eval" $ 33 | \(Fun _ f :: Fun Integer (Integer, Integer)) s -> eval (State f) s == fst (runState (State f) s) 34 | 35 | it "get" $ runState get 0 `shouldBe` (0,0) 36 | 37 | it "put" $ runState (put 1) 0 `shouldBe` ((),1) 38 | 39 | it "(<$>)" $ 40 | runState ((+1) <$> State (\s -> (9, s * 2))) 3 `shouldBe` (10,6) 41 | 42 | describe "Applicative" $ do 43 | it "pure" $ runState (pure 2) 0 `shouldBe` (2,0) 44 | it "<*>" $ runState (pure (+1) <*> pure 0) 0 `shouldBe` (1,0) 45 | it "complicated <*>" $ 46 | let state = State (\s -> ((+3), s P.++ ["apple"])) <*> State (\s -> (7, s P.++ ["banana"])) 47 | in runState state [] `shouldBe` (10,["apple","banana"]) 48 | 49 | describe "Monad" $ do 50 | it "(=<<)" $ 51 | runState ((const $ put 2) =<< put 1) 0 `shouldBe` ((),2) 52 | it "(>>=)" $ 53 | let modify f = State (\s -> ((), f s)) 54 | in runState (modify (+1) >>= \() -> modify (*2)) 7 `shouldBe` ((),16) 55 | 56 | describe "findM" $ do 57 | it "find 'c' in 'a'..'h'" $ 58 | let p x = (\s -> (const $ pure (x == 'c')) =<< put (1+s)) =<< get 59 | in runState (findM p $ listh ['a'..'h']) 0 `shouldBe` (Full 'c',3) 60 | it "find 'i' in 'a'..'h'" $ 61 | let p x = (\s -> (const $ pure (x == 'i')) =<< put (1+s)) =<< get 62 | in runState (findM p $ listh ['a'..'h']) 0 `shouldBe` (Empty,8) 63 | 64 | describe "firstRepeat" $ do 65 | prop "finds repeats" $ forAllLists $ \xs -> 66 | case firstRepeat xs of 67 | Empty -> 68 | let xs' = hlist xs 69 | in nub xs' == xs' 70 | Full x -> length (filter (== x) xs) > 1 71 | prop "" $ forAllLists $ \xs -> 72 | case firstRepeat xs of 73 | Empty -> True 74 | Full x -> 75 | let 76 | (l, (rx :. rs)) = span (/= x) xs 77 | (l2, _) = span (/= x) rs 78 | l3 = hlist (l ++ (rx :. Nil) ++ l2) 79 | in 80 | nub l3 == l3 81 | 82 | describe "distinct" $ do 83 | prop "No repeats after distinct" $ 84 | forAllLists (\xs -> firstRepeat (distinct xs) == Empty) 85 | prop "" $ 86 | forAllLists (\xs -> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs)) 87 | 88 | describe "isHappy" $ do 89 | it "4" $ isHappy 4 `shouldBe` False 90 | it "7" $ isHappy 7 `shouldBe` True 91 | it "42" $ isHappy 42 `shouldBe` False 92 | it "44" $ isHappy 44 `shouldBe` True 93 | -------------------------------------------------------------------------------- /src/Course/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Traversable where 6 | 7 | import Course.Core 8 | import Course.Functor 9 | import Course.Applicative 10 | import Course.List 11 | import Course.ExactlyOne 12 | import Course.Optional 13 | import Course.Compose 14 | 15 | -- | All instances of the `Traversable` type-class must satisfy two laws. These 16 | -- laws are not checked by the compiler. These laws are given as: 17 | -- 18 | -- * The law of naturality 19 | -- `∀f g. f . traverse g ≅ traverse (f . g)` 20 | -- 21 | -- * The law of identity 22 | -- `∀x. traverse ExactlyOne x ≅ ExactlyOne x` 23 | -- 24 | -- * The law of composition 25 | -- `∀f g. traverse ((g <$>) . f) ≅ (traverse g <$>) . traverse f` 26 | class Functor t => Traversable t where 27 | traverse :: 28 | Applicative f => 29 | (a -> f b) 30 | -> t a 31 | -> f (t b) 32 | 33 | instance Traversable List where 34 | traverse :: 35 | Applicative f => 36 | (a -> f b) 37 | -> List a 38 | -> f (List b) 39 | traverse f = 40 | foldRight (\a b -> (:.) <$> f a <*> b) (pure Nil) 41 | 42 | instance Traversable ExactlyOne where 43 | traverse :: 44 | Applicative f => 45 | (a -> f b) 46 | -> ExactlyOne a 47 | -> f (ExactlyOne b) 48 | traverse = 49 | error "todo: Course.Traversable traverse#instance ExactlyOne" 50 | 51 | instance Traversable Optional where 52 | traverse :: 53 | Applicative f => 54 | (a -> f b) 55 | -> Optional a 56 | -> f (Optional b) 57 | traverse = 58 | error "todo: Course.Traversable traverse#instance Optional" 59 | 60 | -- | Sequences a traversable value of structures to a structure of a traversable value. 61 | -- 62 | -- >>> sequenceA (ExactlyOne 7 :. ExactlyOne 8 :. ExactlyOne 9 :. Nil) 63 | -- ExactlyOne [7,8,9] 64 | -- 65 | -- >>> sequenceA (Full (ExactlyOne 7)) 66 | -- ExactlyOne (Full 7) 67 | -- 68 | -- >>> sequenceA (Full (*10)) 6 69 | -- Full 60 70 | sequenceA :: 71 | (Applicative f, Traversable t) => 72 | t (f a) 73 | -> f (t a) 74 | sequenceA = 75 | error "todo: Course.Traversable#sequenceA" 76 | 77 | instance (Traversable f, Traversable g) => 78 | Traversable (Compose f g) where 79 | -- Implement the traverse function for a Traversable instance for Compose 80 | traverse = 81 | error "todo: Course.Traversable traverse#instance (Compose f g)" 82 | 83 | -- | The `Product` data type contains one value from each of the two type constructors. 84 | data Product f g a = 85 | Product (f a) (g a) 86 | 87 | instance (Functor f, Functor g) => 88 | Functor (Product f g) where 89 | -- Implement the (<$>) function for a Functor instance for Product 90 | (<$>) = 91 | error "todo: Course.Traversable (<$>)#instance (Product f g)" 92 | 93 | instance (Traversable f, Traversable g) => 94 | Traversable (Product f g) where 95 | -- Implement the traverse function for a Traversable instance for Product 96 | traverse = 97 | error "todo: Course.Traversable traverse#instance (Product f g)" 98 | 99 | -- | The `Coproduct` data type contains one value from either of the two type constructors. 100 | data Coproduct f g a = 101 | InL (f a) 102 | | InR (g a) 103 | 104 | instance (Functor f, Functor g) => 105 | Functor (Coproduct f g) where 106 | -- Implement the (<$>) function for a Functor instance for Coproduct 107 | (<$>) = 108 | error "todo: Course.Traversable (<$>)#instance (Coproduct f g)" 109 | 110 | instance (Traversable f, Traversable g) => 111 | Traversable (Coproduct f g) where 112 | -- Implement the traverse function for a Traversable instance for Coproduct 113 | traverse = 114 | error "todo: Course.Traversable traverse#instance (Coproduct f g)" 115 | -------------------------------------------------------------------------------- /test/Course/Gens.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.Gens where 5 | 6 | import qualified Prelude as P (fmap, foldr, (<$>), (<*>)) 7 | import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable, 8 | forAllShrink) 9 | 10 | import Course.Core 11 | import Course.List (List (..), hlist, listh) 12 | import Course.ListZipper (ListZipper (..), zipper) 13 | 14 | genList :: Arbitrary a => Gen (List a) 15 | genList = P.fmap ((P.foldr (:.) Nil) :: [a] -> List a) arbitrary 16 | 17 | shrinkList :: Arbitrary a => List a -> [List a] 18 | shrinkList = 19 | P.fmap listh . shrink . hlist 20 | 21 | genIntegerList :: Gen (List Integer) 22 | genIntegerList = genList 23 | 24 | genIntegerAndList :: Gen (Integer, List Integer) 25 | genIntegerAndList = P.fmap (P.fmap listh) arbitrary 26 | 27 | shrinkIntegerAndList :: (Integer, List Integer) -> [(Integer, List Integer)] 28 | shrinkIntegerAndList = P.fmap (P.fmap listh) . shrink . P.fmap hlist 29 | 30 | genTwoLists :: Gen (List Integer, List Integer) 31 | genTwoLists = (,) P.<$> genIntegerList P.<*> genIntegerList 32 | 33 | shrinkTwoLists :: (List Integer, List Integer) -> [(List Integer, List Integer)] 34 | shrinkTwoLists (a,b) = P.fmap (\(as,bs) -> (listh as, listh bs)) $ shrink (hlist a, hlist b) 35 | 36 | genThreeLists :: Gen (List Integer, List Integer, List Integer) 37 | genThreeLists = (,,) P.<$> genIntegerList P.<*> genIntegerList P.<*> genIntegerList 38 | 39 | shrinkThreeLists :: (List Integer, List Integer, List Integer) -> [(List Integer, List Integer, List Integer)] 40 | shrinkThreeLists (a,b,c) = P.fmap (\(as,bs,cs) -> (listh as, listh bs, listh cs)) $ shrink (hlist a, hlist b, hlist c) 41 | 42 | genListOfLists :: Gen (List (List Integer)) 43 | genListOfLists = P.fmap (P.fmap listh) (genList :: (Gen (List [Integer]))) 44 | 45 | shrinkListOfLists :: Arbitrary a => List (List a) -> [List (List a)] 46 | shrinkListOfLists = P.fmap (P.fmap listh). shrinkList . P.fmap hlist 47 | 48 | forAllLists :: Testable prop => (List Integer -> prop) -> Property 49 | forAllLists = forAllShrink genIntegerList shrinkList 50 | 51 | -- (List Integer) and a Bool 52 | genListAndBool :: Gen (List Integer, Bool) 53 | genListAndBool = (,) P.<$> genIntegerList P.<*> arbitrary 54 | 55 | shrinkListAndBool :: (List Integer, Bool) -> [(List Integer, Bool)] 56 | shrinkListAndBool (xs,b) = (,) P.<$> (shrinkList xs) P.<*> (shrink b) 57 | 58 | forAllListsAndBool :: Testable prop 59 | => ((List Integer, Bool) -> prop) 60 | -> Property 61 | forAllListsAndBool = 62 | forAllShrink genListAndBool shrinkListAndBool 63 | 64 | -- ListZipper Integer 65 | genListZipper :: Gen (ListZipper Integer) 66 | genListZipper = 67 | zipper P.<$> arbitrary P.<*> arbitrary P.<*> arbitrary 68 | 69 | shrinkListZipper :: ListZipper Integer -> [ListZipper Integer] 70 | shrinkListZipper (ListZipper l x r) = 71 | ListZipper P.<$> (shrinkList l) P.<*> (shrink x) P.<*> (shrinkList r) 72 | 73 | forAllListZipper :: Testable prop 74 | => (ListZipper Integer -> prop) 75 | -> Property 76 | forAllListZipper = 77 | forAllShrink genListZipper shrinkListZipper 78 | 79 | genListZipperWithInt :: Gen (ListZipper Integer, Int) 80 | genListZipperWithInt = 81 | (,) P.<$> genListZipper P.<*> arbitrary 82 | 83 | shrinkListZipperWithInt :: (ListZipper Integer, Int) -> [(ListZipper Integer, Int)] 84 | shrinkListZipperWithInt (z, i) = 85 | (,) P.<$> (shrinkListZipper z) P.<*> (shrink i) 86 | 87 | forAllListZipperWithInt :: Testable prop 88 | => ((ListZipper Integer, Int) -> prop) 89 | -> Property 90 | forAllListZipperWithInt = 91 | forAllShrink genListZipperWithInt shrinkListZipperWithInt 92 | -------------------------------------------------------------------------------- /src/Course/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.Monad where 7 | 8 | import Course.Applicative 9 | import Course.Core 10 | import Course.ExactlyOne 11 | import Course.Functor 12 | import Course.List 13 | import Course.Optional 14 | import qualified Prelude as P((=<<)) 15 | 16 | -- | All instances of the `Monad` type-class must satisfy one law. This law 17 | -- is not checked by the compiler. This law is given as: 18 | -- 19 | -- * The law of associativity 20 | -- `∀f g x. g =<< (f =<< x) ≅ ((g =<<) . f) =<< x` 21 | class Applicative f => Monad f where 22 | -- Pronounced, bind. 23 | (=<<) :: 24 | (a -> f b) 25 | -> f a 26 | -> f b 27 | 28 | infixr 1 =<< 29 | 30 | -- | Binds a function on the ExactlyOne monad. 31 | -- 32 | -- >>> (\x -> ExactlyOne(x+1)) =<< ExactlyOne 2 33 | -- ExactlyOne 3 34 | instance Monad ExactlyOne where 35 | (=<<) :: 36 | (a -> ExactlyOne b) 37 | -> ExactlyOne a 38 | -> ExactlyOne b 39 | (=<<) = 40 | error "todo: Course.Monad (=<<)#instance ExactlyOne" 41 | 42 | -- | Binds a function on a List. 43 | -- 44 | -- >>> (\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil) 45 | -- [1,1,2,2,3,3] 46 | instance Monad List where 47 | (=<<) :: 48 | (a -> List b) 49 | -> List a 50 | -> List b 51 | (=<<) = 52 | error "todo: Course.Monad (=<<)#instance List" 53 | 54 | -- | Binds a function on an Optional. 55 | -- 56 | -- >>> (\n -> Full (n + n)) =<< Full 7 57 | -- Full 14 58 | instance Monad Optional where 59 | (=<<) :: 60 | (a -> Optional b) 61 | -> Optional a 62 | -> Optional b 63 | (=<<) = 64 | error "todo: Course.Monad (=<<)#instance Optional" 65 | 66 | -- | Binds a function on the reader ((->) t). 67 | -- 68 | -- >>> ((*) =<< (+10)) 7 69 | -- 119 70 | instance Monad ((->) t) where 71 | (=<<) :: 72 | (a -> ((->) t b)) 73 | -> ((->) t a) 74 | -> ((->) t b) 75 | (=<<) = 76 | error "todo: Course.Monad (=<<)#instance ((->) t)" 77 | 78 | -- | Witness that all things with (=<<) and (<$>) also have (<*>). 79 | -- 80 | -- >>> ExactlyOne (+10) <**> ExactlyOne 8 81 | -- ExactlyOne 18 82 | -- 83 | -- >>> (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil 84 | -- [2,3,4,2,4,6] 85 | -- 86 | -- >>> Full (+8) <**> Full 7 87 | -- Full 15 88 | -- 89 | -- >>> Empty <**> Full 7 90 | -- Empty 91 | -- 92 | -- >>> Full (+8) <**> Empty 93 | -- Empty 94 | -- 95 | -- >>> ((+) <**> (+10)) 3 96 | -- 16 97 | -- 98 | -- >>> ((+) <**> (+5)) 3 99 | -- 11 100 | -- 101 | -- >>> ((+) <**> (+5)) 1 102 | -- 7 103 | -- 104 | -- >>> ((*) <**> (+10)) 3 105 | -- 39 106 | -- 107 | -- >>> ((*) <**> (+2)) 3 108 | -- 15 109 | (<**>) :: 110 | Monad f => 111 | f (a -> b) 112 | -> f a 113 | -> f b 114 | (<**>) = 115 | error "todo: Course.Monad#(<**>)" 116 | 117 | infixl 4 <**> 118 | 119 | -- | Flattens a combined structure to a single structure. 120 | -- 121 | -- >>> join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) 122 | -- [1,2,3,1,2] 123 | -- 124 | -- >>> join (Full Empty) 125 | -- Empty 126 | -- 127 | -- >>> join (Full (Full 7)) 128 | -- Full 7 129 | -- 130 | -- >>> join (+) 7 131 | -- 14 132 | join :: 133 | Monad f => 134 | f (f a) 135 | -> f a 136 | join = 137 | error "todo: Course.Monad#join" 138 | 139 | -- | Implement a flipped version of @(=<<)@, however, use only 140 | -- @join@ and @(<$>)@. 141 | -- Pronounced, bind flipped. 142 | -- 143 | -- >>> ((+10) >>= (*)) 7 144 | -- 119 145 | (>>=) :: 146 | Monad f => 147 | f a 148 | -> (a -> f b) 149 | -> f b 150 | (>>=) = 151 | error "todo: Course.Monad#(>>=)" 152 | 153 | infixl 1 >>= 154 | 155 | -- | Implement composition within the @Monad@ environment. 156 | -- Pronounced, kleisli composition. 157 | -- 158 | -- >>> ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1 159 | -- [2,2,3,3] 160 | (<=<) :: 161 | Monad f => 162 | (b -> f c) 163 | -> (a -> f b) 164 | -> a 165 | -> f c 166 | (<=<) = 167 | error "todo: Course.Monad#(<=<)" 168 | 169 | infixr 1 <=< 170 | 171 | ----------------------- 172 | -- SUPPORT LIBRARIES -- 173 | ----------------------- 174 | 175 | instance Monad IO where 176 | (=<<) = 177 | (P.=<<) 178 | -------------------------------------------------------------------------------- /projects/TicTacToe/TicTacToe.markdown: -------------------------------------------------------------------------------- 1 | TicTacToe 2 | ========= 3 | 4 | The goal is to write an API for the tic-tac-toe game. An API user, should be able to play a game of tic-tac-toe using this API, but importantly, it should be impossible for the API user to break the rules of the game. Specifically, if an attempt is made to break a rule, the API should reject the program. This is often done by way of a *compile-time type error*. 5 | 6 | It is strongly advised that functional programming techniques are used to achieve the goal. This is because ensuring that the API adheres to the rules of tic-tac-toe, while rejecting a program otherwise, is difficult otherwise. No specific programming language is prescribed. 7 | 8 | The following API functions should exist. By removing the need for some of these functions, the challenge becomes significantly easier. Removing some or all optional API functions is an advised path for someone who is looking to make the challenge easier. 9 | 10 | * `move`: takes a tic-tac-toe board and position and moves to that position (if not occupied) returning a new board. This function can only be called on a board that is empty or in-play. Calling `move` on a game board that is finished is a *compile-time type error*. 11 | 12 | *(optional)* If fewer than 5 moves have been played, then this guarantees that the game is still in play, and so calling `move` will never produce a type-error in this case. 13 | 14 | * `whoWon`: takes a tic-tac-toe board and returns the player that won the game (or a draw if neither). This function can only be called on a board that is finished. Calling `whoWon` on a game board that is empty or in-play is a *compile-time type error*. As an optional consideration, `whoWon` should never be a draw if fewer than nine moves have been played. In the case that the game is completed, but fewer than nine moves have been played, return a value that can only be one of two possibilities (the winner) and never a draw. 15 | 16 | * `playerAt`: takes a tic-tac-toe board and position and returns the (possible) player at a given position. This function works on any type of board. 17 | 18 | * `takeBack` *(optional)*: takes either a finished board or a board in-play that has had at least one move and returns a board in-play. It is a compile-time type error to call this function on an empty board. 19 | 20 | * `isDraw` *(optional)* if called on a game with fewer than 9 moves, a compile-time type-error results. 21 | 22 | * Other API functions that might be considered useful for general API use. Ensure that it is not possible to violate the game rules of tic-tac-toe. These functions can often be determined by also writing an interactive console application that uses the API -- other useful functions are likely to arise. 23 | 24 | You should write automated tests for your API. For example, the following universally quantified property holds true: 25 | 26 | `forall Board b. forall Position p. such that (not (positionIsOccupied 27 | p b)). takeBack(move(p, b)) == b` 28 | 29 | You should encode this property in an automated specification test. For Scala, use ScalaCheck. For Haskell, QuickCheck. For Java, consider [Functional Java](http://functionaljava.org/). For .NET, use [FsCheck](https://github.com/fsharp/FsCheck). For other languages, you may need to search around. 30 | 31 | Haskell-specific 32 | ---------------- 33 | 34 | If you choose to use Haskell, also take advantage of its tooling: 35 | 36 | * Build with CABAL 37 | * Include a `.ghci` file for convenience when developing 38 | * https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci-dot-files.html 39 | * API documented using Haddock 40 | * [http://www.haskell.org/haddock/doc/html/index.html](http://www.haskell.org/haddock/doc/html/index.html) 41 | * Code style examined using hlint 42 | * `cabal install hlint` 43 | * Produce a report (`--report`) 44 | * [http://community.haskell.org/~ndm/darcs/hlint/hlint.htm](http://community.haskell.org/~ndm/darcs/hlint/hlint.htm) 45 | * Use hoogle and hayoo to find library functions 46 | * [http://haskell.org/hoogle/](http://haskell.org/hoogle/) 47 | * [http://holumbus.fh-wedel.de/hayoo/hayoo.html](http://holumbus.fh-wedel.de/hayoo/hayoo.html) 48 | 49 | 50 | Extra-curricular 51 | ---------------- 52 | * Write an opponent that never loses 53 | * Write an opponent with easy, medium, hard difficulty levels 54 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs 'course.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-7.10.3" 32 | env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.0.2" 35 | env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} 40 | 41 | before_install: 42 | - HC=${CC} 43 | - HCPKG=${HC/ghc/ghc-pkg} 44 | - unset CC 45 | - ROOTDIR=$(pwd) 46 | - mkdir -p $HOME/.local/bin 47 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 48 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 49 | - echo $HCNUMVER 50 | 51 | install: 52 | - cabal --version 53 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 54 | - BENCH=${BENCH---enable-benchmarks} 55 | - TEST=${TEST---enable-tests} 56 | - HADDOCK=${HADDOCK-true} 57 | - INSTALLED=${INSTALLED-true} 58 | - GHCHEAD=${GHCHEAD-false} 59 | - travis_retry cabal update -v 60 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 61 | - rm -fv cabal.project cabal.project.local 62 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 63 | - "printf 'packages: \".\"\\n' > cabal.project" 64 | - cat cabal.project 65 | - if [ -f "./configure.ac" ]; then 66 | (cd "." && autoreconf -i); 67 | fi 68 | - rm -f cabal.project.freeze 69 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 70 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 71 | - rm -rf .ghc.environment.* "."/dist 72 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 73 | 74 | # Here starts the actual work to be performed for the package under test; 75 | # any command which exits with a non-zero exit code causes the build to fail. 76 | script: 77 | # test that source-distributions can be generated 78 | - (cd "." && cabal sdist) 79 | - mv "."/dist/course-*.tar.gz ${DISTDIR}/ 80 | - cd ${DISTDIR} || false 81 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 82 | - "printf 'packages: course-*/*.cabal\\n' > cabal.project" 83 | - cat cabal.project 84 | # this builds all libraries and executables (without tests/benchmarks) 85 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 86 | 87 | # Build with installed constraints for packages in global-db 88 | - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi 89 | 90 | # build & run tests, build benchmarks 91 | # MODOFIED - always build the tests 92 | - cabal new-build -w ${HC} --enable-tests ${BENCH} all 93 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 94 | 95 | # cabal check 96 | - (cd course-* && cabal check) 97 | 98 | # haddock 99 | - rm -rf ./dist-newstyle 100 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 101 | 102 | # REGENDATA ["course.cabal"] 103 | # EOF 104 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat/Loop.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat.Loop where 2 | 3 | import Prelude hiding (mapM_) 4 | import Network(PortID(..), sClose, withSocketsDo, listenOn) 5 | import System.IO(BufferMode(..)) 6 | import Data.IORef(IORef, newIORef, readIORef) 7 | import Data.Foldable(Foldable, mapM_) 8 | import Control.Applicative(Applicative, pure) 9 | import Control.Concurrent(forkIO) 10 | import Control.Exception(finally, try, catch, Exception) 11 | import Control.Monad(forever) 12 | import Control.Monad.Trans(MonadTrans(..), MonadIO(..)) 13 | 14 | import Network.Server.Common.Accept 15 | import Network.Server.Common.HandleLens 16 | import Network.Server.Common.Lens 17 | import Network.Server.Common.Line 18 | import Network.Server.Common.Env 19 | import Network.Server.Common.Ref 20 | import Data.Set(Set) 21 | import qualified Data.Set as S 22 | 23 | data Loop v f a = 24 | Loop (Env v -> f a) 25 | 26 | type IOLoop v a = 27 | Loop v IO a 28 | 29 | type IORefLoop v a = 30 | IOLoop (IORef v) a 31 | 32 | instance Functor f => Functor (Loop v f) where 33 | fmap f (Loop k) = 34 | Loop (fmap f . k) 35 | 36 | instance Applicative f => Applicative (Loop v f) where 37 | pure = 38 | Loop . pure . pure 39 | Loop f <*> Loop x = 40 | Loop (\a -> f a <*> x a) 41 | 42 | instance Monad f => Monad (Loop v f) where 43 | return = 44 | Loop . return . return 45 | Loop k >>= f = 46 | Loop (\v -> k v >>= \a -> 47 | let Loop l = f a 48 | in l v) 49 | 50 | instance MonadTrans (Loop v) where 51 | lift = 52 | Loop . const 53 | 54 | instance MonadIO f => MonadIO (Loop v f) where 55 | liftIO = 56 | lift . liftIO 57 | 58 | etry :: 59 | Exception e => 60 | (Env v -> IO a) 61 | -> IOLoop v (Either e a) 62 | etry k = 63 | Loop $ try . k 64 | 65 | server :: 66 | IO w -- server initialise 67 | -> (w -> IO v) -- client accepted (pre) 68 | -> IOLoop v () -- per-client 69 | -> IO a 70 | server i r (Loop f) = 71 | let hand s w c = forever $ 72 | do q <- accept' s 73 | lSetBuffering q NoBuffering 74 | _ <- atomicModifyIORef_ c (S.insert (refL `getL` q)) 75 | x <- r w 76 | forkIO (f (Env q c x)) 77 | in withSocketsDo $ do 78 | s <- listenOn (PortNumber 6060) 79 | w <- i 80 | c <- newIORef S.empty 81 | hand s w c `finally` sClose s 82 | 83 | allClients :: IOLoop v (Set Ref) 84 | allClients = Loop $ \env -> readIORef (clientsL `getL` env) 85 | 86 | perClient :: 87 | IOLoop v x -- client accepted (post) 88 | -> (String -> IOLoop v a) -- read line from client 89 | -> IOLoop v () 90 | perClient = 91 | error "todo" 92 | 93 | loop :: 94 | IO w -- server initialise 95 | -> (w -> IO v) -- client accepted (pre) 96 | -> IOLoop v x -- client accepted (post) 97 | -> (String -> IOLoop v w) -- read line from client 98 | -> IO a 99 | loop i r q f = 100 | server i r (perClient q f) 101 | 102 | iorefServer :: 103 | v -- server initialise 104 | -> IORefLoop v () -- per-client 105 | -> IO a 106 | iorefServer x = 107 | server (newIORef x) return 108 | 109 | iorefLoop :: 110 | v -- server initialise 111 | -> IORefLoop v x -- client accepted (post) 112 | -> (String -> IORefLoop v w) -- read line from client 113 | -> IO a 114 | iorefLoop x q f = 115 | iorefServer x (perClient q f) 116 | 117 | pPutStrLn :: 118 | String 119 | -> IOLoop v () 120 | pPutStrLn s = 121 | Loop (`lPutStrLn` s) 122 | 123 | (!) :: 124 | Foldable t => 125 | IOLoop v (t Ref) 126 | -> String 127 | -> IOLoop v () 128 | clients ! msg = 129 | clients >>= purgeClients (\y -> liftIO (lPutStrLn y msg)) 130 | 131 | infixl 2 ! 132 | 133 | purgeClients :: 134 | Foldable t => 135 | (Ref -> IOLoop v ()) 136 | -> t Ref 137 | -> IOLoop v () 138 | purgeClients a = 139 | mapM_ (\y -> 140 | ecatch (a y) 141 | (\x -> do _ <- modifyClients (S.delete y) 142 | xprint x) 143 | ) 144 | 145 | readEnv :: 146 | Applicative f => 147 | Loop v f (Env v) 148 | readEnv = 149 | Loop $ pure 150 | 151 | readEnvval :: 152 | Applicative f => 153 | Loop v f v 154 | readEnvval = 155 | fmap (envvalL `getL`) readEnv 156 | 157 | readIOEnvval :: 158 | IORefLoop a a 159 | readIOEnvval = 160 | Loop $ \env -> 161 | readIORef (envvalL `getL` env) 162 | 163 | allClientsButThis :: 164 | IOLoop v (Set Ref) 165 | allClientsButThis = 166 | Loop $ \env -> 167 | fmap (S.delete ((acceptL .@ refL) `getL` env)) (readIORef (clientsL `getL` env)) 168 | 169 | -- Control.Monad.CatchIO 170 | ecatch :: 171 | Exception e => 172 | IOLoop v a 173 | -> (e -> IOLoop v a) 174 | -> IOLoop v a 175 | ecatch (Loop k) f = 176 | Loop $ \env -> k env `catch` (\e -> let Loop l = f e in l env) 177 | 178 | modifyClients :: 179 | (Set Ref -> Set Ref) 180 | -> IOLoop v (Set Ref) 181 | modifyClients f = 182 | Loop $ \env -> 183 | atomicModifyIORef_ (clientsL `getL` env) f 184 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Data/TicTacToe.hs: -------------------------------------------------------------------------------- 1 | module Data.TicTacToe where 2 | 3 | import Prelude hiding (any, all, mapM, concat) 4 | import qualified GHC.OldList as L 5 | import Test.QuickCheck 6 | import Data.Map (Map, singleton) 7 | import qualified Data.Map as M 8 | import Data.Traversable 9 | import Data.Foldable hiding (foldr) 10 | import Data.List(intercalate) 11 | 12 | 13 | data Player = 14 | Naught 15 | | Cross 16 | deriving (Ord, Eq) 17 | 18 | instance Show Player where 19 | show Naught = 20 | "O" 21 | show Cross = 22 | "X" 23 | 24 | data EmptyBoard = 25 | EmptyBoard 26 | deriving (Eq, Show) 27 | 28 | data Board = 29 | Board (Map Position Player) [(Position, Player)] 30 | deriving Eq 31 | 32 | data FinishedBoard = 33 | FinishedBoard (Maybe Player) Board 34 | deriving Eq 35 | 36 | instance Show FinishedBoard where 37 | show (FinishedBoard Nothing b) = 38 | show b ++ "\nDraw" 39 | show (FinishedBoard (Just p) b) = 40 | show b ++ "\n" ++ show p ++ " wins" 41 | 42 | data Position = 43 | N | E | S | W | NE | NW | SE | SW | C 44 | deriving (Ord, Eq, Show) 45 | 46 | data Outcome = 47 | InvalidMove 48 | | Inplay Board 49 | | Done FinishedBoard 50 | deriving Eq 51 | 52 | instance Show Outcome where 53 | show InvalidMove = 54 | "?" 55 | show (Inplay b) = 56 | show b 57 | show (Done b) = 58 | show b 59 | 60 | 61 | instance Show Board where 62 | show (Board m _) = 63 | let p x = case M.lookup x m of 64 | Nothing -> ' ' 65 | Just Naught -> 'O' 66 | Just Cross -> 'X' 67 | line a b c = 68 | concat 69 | [ 70 | "| " 71 | , [p a] 72 | , " | " 73 | , [p b] 74 | , " | " 75 | , [p c] 76 | , " |" 77 | ] 78 | blank = ".===.===.===." 79 | in intercalate "\n" 80 | [ 81 | blank 82 | , line NW N NE 83 | , blank 84 | , line W C E 85 | , blank 86 | , line SW S SE 87 | , blank 88 | ] 89 | 90 | start :: 91 | Position 92 | -> Board 93 | start p = 94 | Board (singleton p Naught) [(p, Naught)] 95 | 96 | move'' :: 97 | Outcome 98 | -> Position 99 | -> Outcome 100 | move'' InvalidMove _ = 101 | InvalidMove 102 | move'' (Inplay b) p = 103 | move b p 104 | move'' (Done b) _ = 105 | Done b 106 | 107 | data TakenBack = 108 | BoardBack Board 109 | | EmptyBack 110 | deriving (Eq, Show) 111 | 112 | takeBack' :: 113 | FinishedBoard 114 | -> Board 115 | takeBack' = 116 | undefined 117 | 118 | takeBack :: 119 | Board 120 | -> TakenBack 121 | takeBack = 122 | undefined 123 | 124 | move :: 125 | Board 126 | -> Position 127 | -> Outcome 128 | move board@(Board m h) p = 129 | if p `M.member` m 130 | then 131 | InvalidMove 132 | else 133 | let m' = M.insert p player m 134 | wins = 135 | [ 136 | (NW, N, NE) 137 | , (N, C, S) 138 | , (NE, E, SE) 139 | , (NW, N, NE) 140 | , (W, C, E) 141 | , (SW, S, SE) 142 | , (NW, C, SE) 143 | , (SW, C, NE) 144 | ] 145 | allEqual (a:b:t) = a == b && allEqual (b:t) 146 | allEqual _ = True 147 | isDraw = M.size m' >= 9 148 | isWin = any (\(a, b, c) -> any allEqual $ mapM (`M.lookup` m') [a, b, c]) wins 149 | player = whoseTurn board 150 | b' = Board m' ((p, player):h) 151 | in 152 | if isWin 153 | then Done (FinishedBoard (Just player) b') 154 | else 155 | if isDraw 156 | then Done (FinishedBoard Nothing b') 157 | else Inplay b' 158 | 159 | switch :: Player -> Player 160 | switch Cross = Naught 161 | switch Naught = Cross 162 | 163 | whoseTurn :: Board -> Player 164 | whoseTurn (Board _ ((_, p):_)) = 165 | switch p 166 | whoseTurn (Board _ []) = 167 | error "broke it" 168 | 169 | -- cabal install QuickCheck 170 | instance Arbitrary Position where 171 | arbitrary = elements [N, NE, NW, S, SE, SW, E, W, C] 172 | 173 | instance Arbitrary Player where 174 | arbitrary = elements [Naught, Cross] 175 | 176 | instance Arbitrary Board where 177 | arbitrary = do 178 | p <- arbitrary 179 | ps <- arbitrary 180 | return $ L.foldr propell (start p) ps 181 | 182 | propell :: Position -> Board -> Board 183 | propell p b = 184 | case move b p of 185 | InvalidMove -> b 186 | Done _ -> b 187 | Inplay b' -> b' 188 | 189 | data Blah = Blah Player Position Int 190 | 191 | instance Arbitrary Blah where 192 | arbitrary = do 193 | player <- arbitrary 194 | position <- arbitrary 195 | n <- choose (1, 9) 196 | return $ Blah player position n 197 | 198 | prop_eqp :: Position -> Bool 199 | prop_eqp n = n == n 200 | 201 | prop_eq :: Int -> Bool 202 | prop_eq n = n == n 203 | 204 | prop_switch :: Player -> Bool 205 | prop_switch p = switch p /= p 206 | 207 | main :: IO () 208 | main = do 209 | quickCheck prop_eqp 210 | quickCheck prop_eq 211 | quickCheck prop_switch 212 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe/Game.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe.Game where 2 | 3 | import Data.TicTacToe 4 | import Network.Server.Common.Env 5 | import Network.Server.Common.HandleLens 6 | import Network.Server.Common.Lens 7 | import Network.Server.Common.Line 8 | import Network.Server.Common.Ref 9 | import Network.Server.TicTacToe.Loop 10 | import Data.Char(isSpace, toLower, toUpper) 11 | import Data.Function(on) 12 | import Data.IORef(readIORef, atomicModifyIORef) 13 | import Data.Maybe(fromMaybe) 14 | import Data.Foldable(msum, find) 15 | import Data.Set(Set) 16 | import Control.Applicative((<$), (<$>)) 17 | import System.IO(hGetLine, hPutStrLn) 18 | 19 | type FinishedGames = 20 | [FinishedBoard] 21 | 22 | type Game a = 23 | IORefLoop Board (Board, FinishedGames) a 24 | 25 | data Command = 26 | Move Position 27 | | Current 28 | | Finished 29 | | Chat String 30 | | Turn 31 | | At Position 32 | | Unknown String 33 | deriving (Eq, Show) 34 | 35 | -- | 36 | -- 37 | -- >>> command "MOVE ne" 38 | -- Move NE 39 | -- 40 | -- >>> command "MOVE 2" 41 | -- Move N 42 | -- 43 | -- >>> command "GAME" 44 | -- Current 45 | -- 46 | -- >>> command "FiniSHED" 47 | -- Finished 48 | -- 49 | -- >>> command "CHAT hi" 50 | -- Chat "hi" 51 | -- 52 | -- >>> command "Turn" 53 | -- Turn 54 | -- 55 | -- >>> command "At 4" 56 | -- At W 57 | -- 58 | -- >>> command "At C" 59 | -- At C 60 | -- 61 | -- >>> command "At X" 62 | -- Unknown "At X" 63 | -- 64 | -- >>> command "Move i" 65 | -- Unknown "Move i" 66 | command :: 67 | String 68 | -> Command 69 | command z = 70 | let p l = reverse . dropWhile isSpace . reverse . dropWhile isSpace <$> prefixThen ((==) `on` toLower) l z 71 | in Unknown z `fromMaybe` msum [ 72 | do m <- p "MOVE " 73 | q <- sPosition m 74 | return (Move q) 75 | , Current <$ p "GAME" 76 | , Finished <$ p "FINISHED" 77 | , Chat <$> p "CHAT" 78 | , Turn <$ p "TURN" 79 | , do a <- p "AT" 80 | q <- sPosition a 81 | return (At q) 82 | ] 83 | 84 | -- | 85 | -- 86 | -- >>> sPosition "1" 87 | -- Just NW 88 | -- 89 | -- > sPosition "E" 90 | -- Just E 91 | -- 92 | -- > sPosition "sw" 93 | -- Just SW 94 | -- 95 | -- > sPosition "x" 96 | -- Nothing 97 | sPosition :: 98 | String 99 | -> Maybe Position 100 | sPosition s = 101 | let table = [ 102 | ( 103 | ["1", "NW"] 104 | , NW 105 | ) 106 | , ( 107 | ["2", "N"] 108 | , N 109 | ) 110 | , ( 111 | ["3", "NE"] 112 | , NE 113 | ) 114 | , ( 115 | ["4", "W"] 116 | , W 117 | ) 118 | , ( 119 | ["5", "C"] 120 | , C 121 | ) 122 | , ( 123 | ["6", "E"] 124 | , E 125 | ) 126 | , ( 127 | ["7", "SW"] 128 | , SW 129 | ) 130 | , ( 131 | ["8", "S"] 132 | , S 133 | ) 134 | , ( 135 | ["9", "SE"] 136 | , SE 137 | ) 138 | ] 139 | toUppers = map toUpper 140 | in fmap snd . find (\(t, _) -> elem (toUppers s) (toUppers <$> t)) $ table 141 | 142 | currentBoard :: 143 | Game Board 144 | currentBoard = 145 | initLoop $ \env -> 146 | readIORef (envvalL `getL` env) 147 | 148 | withCurrentBoard :: 149 | (Board -> (Board, a)) 150 | -> Game a 151 | withCurrentBoard f = 152 | initLoop $ \env -> 153 | atomicModifyIORef (envvalL `getL` env) f 154 | 155 | lastBoard :: 156 | Game Board 157 | lastBoard = 158 | Loop $ \_ (s, t) -> 159 | return (s, (s, t)) 160 | 161 | putBoard :: 162 | Board 163 | -> Game () 164 | putBoard s = 165 | Loop $ \_ (_, t) -> 166 | return ((), (s, t)) 167 | 168 | modifyFinishedGames :: 169 | (FinishedGames -> FinishedGames) 170 | -> Game () 171 | modifyFinishedGames f = 172 | Loop $ \_ (s, t) -> return ((), (s, f t)) 173 | 174 | finishedGames :: 175 | Game FinishedGames 176 | finishedGames = 177 | Loop $ \_ (s, t) -> return (t, (s, t)) 178 | 179 | eGetLine :: 180 | Game String 181 | eGetLine = 182 | initLoop (hGetLine . getL handleL) 183 | 184 | ePutStrLn :: 185 | String 186 | -> Game () 187 | ePutStrLn s = 188 | initLoop (\env -> (hPutStrLn (handleL `getL` env) s)) 189 | 190 | allClients :: 191 | Game (Set Ref) 192 | allClients = 193 | initLoop $ \env -> (readIORef (clientsL `getL` env)) 194 | 195 | process :: 196 | Command 197 | -> Game () 198 | process = 199 | error "todo" 200 | 201 | game :: 202 | Game x -- client accepted (post) 203 | -> (String -> Game w) -- read line from client 204 | -> IO a 205 | game = 206 | error "todo" 207 | 208 | play :: 209 | IO a 210 | play = 211 | game (currentBoard >>= pPutStrLn . show) (process . command) 212 | -------------------------------------------------------------------------------- /src/Course/Interactive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.Interactive where 6 | 7 | import Course.Core 8 | import Course.Functor 9 | import Course.Applicative 10 | import Course.Monad 11 | import Course.Traversable 12 | import Course.List 13 | import Course.Optional 14 | 15 | -- | Eliminates any value over which a functor is defined. 16 | vooid :: 17 | Functor m => 18 | m a 19 | -> m () 20 | vooid = 21 | (<$>) (const ()) 22 | 23 | -- | A version of @bind@ that ignores the result of the effect. 24 | (>-) :: 25 | Monad m => 26 | m a 27 | -> m b 28 | -> m b 29 | (>-) a = 30 | (>>=) a . const 31 | 32 | -- | Runs an action until a result of that action satisfies a given predicate. 33 | untilM :: 34 | Monad m => 35 | (a -> m Bool) -- ^ The predicate to satisfy to stop running the action. 36 | -> m a -- ^ The action to run until the predicate satisfies. 37 | -> m a 38 | untilM p a = 39 | a >>= \r -> 40 | p r >>= \q -> 41 | if q 42 | then 43 | pure r 44 | else 45 | untilM p a 46 | 47 | -- | Example program that uses IO to echo back characters that are entered by the user. 48 | echo :: 49 | IO () 50 | echo = 51 | vooid (untilM 52 | (\c -> 53 | if c == 'q' 54 | then 55 | putStrLn "Bye!" >- 56 | pure True 57 | else 58 | pure False) 59 | (putStr "Enter a character: " >- 60 | getChar >>= \c -> 61 | putStrLn "" >- 62 | putStrLn (c :. Nil) >- 63 | pure c)) 64 | 65 | data Op = 66 | Op Char Chars (IO ()) -- keyboard entry, description, program 67 | 68 | -- | 69 | -- 70 | -- * Ask the user to enter a string to convert to upper-case. 71 | -- 72 | -- * Convert the string to upper-case. 73 | -- 74 | -- * Print the upper-cased string to standard output. 75 | -- 76 | -- /Tip:/ @getLine :: IO String@ -- an IO action that reads a string from standard input. 77 | -- 78 | -- /Tip:/ @toUpper :: Char -> Char@ -- (Data.Char) converts a character to upper-case. 79 | -- 80 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 81 | -- 82 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 83 | convertInteractive :: 84 | IO () 85 | convertInteractive = 86 | error "todo: Course.Interactive#convertInteractive" 87 | 88 | -- | 89 | -- 90 | -- * Ask the user to enter a file name to reverse. 91 | -- 92 | -- * Ask the user to enter a file name to write the reversed file to. 93 | -- 94 | -- * Read the contents of the input file. 95 | -- 96 | -- * Reverse the contents of the input file. 97 | -- 98 | -- * Write the reversed contents to the output file. 99 | -- 100 | -- /Tip:/ @getLine :: IO String@ -- an IO action that reads a string from standard input. 101 | -- 102 | -- /Tip:/ @readFile :: FilePath -> IO String@ -- an IO action that reads contents of a file. 103 | -- 104 | -- /Tip:/ @writeFile :: FilePath -> String -> IO ()@ -- writes a string to a file. 105 | -- 106 | -- /Tip:/ @reverse :: [a] -> [a]@ -- reverses a list. 107 | -- 108 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 109 | -- 110 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 111 | reverseInteractive :: 112 | IO () 113 | reverseInteractive = 114 | error "todo: Course.Interactive#reverseInteractive" 115 | 116 | -- | 117 | -- 118 | -- * Ask the user to enter a string to url-encode. 119 | -- 120 | -- * Convert the string with a URL encoder. 121 | -- 122 | -- * For simplicity, encoding is defined as: 123 | -- 124 | -- * @' ' -> \"%20\"@ 125 | -- 126 | -- * @'\t' -> \"%09\"@ 127 | -- 128 | -- * @'\"' -> \"%22\"@ 129 | -- 130 | -- * @/anything else is unchanged/@ 131 | -- 132 | -- * Print the encoded URL to standard output. 133 | -- 134 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 135 | -- 136 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 137 | encodeInteractive :: 138 | IO () 139 | encodeInteractive = 140 | error "todo: Course.Interactive#encodeInteractive" 141 | 142 | interactive :: 143 | IO () 144 | interactive = 145 | let ops = ( 146 | Op 'c' "Convert a string to upper-case" convertInteractive 147 | :. Op 'r' "Reverse a file" reverseInteractive 148 | :. Op 'e' "Encode a URL" encodeInteractive 149 | :. Op 'q' "Quit" (pure ()) 150 | :. Nil 151 | ) 152 | in vooid (untilM 153 | (\c -> 154 | if c == 'q' 155 | then 156 | putStrLn "Bye!" >- 157 | pure True 158 | else 159 | pure False) 160 | (putStrLn "Select: " >- 161 | traverse (\(Op c s _) -> 162 | putStr (c :. Nil) >- 163 | putStr ". " >- 164 | putStrLn s) ops >- 165 | getChar >>= \c -> 166 | putStrLn "" >- 167 | let o = find (\(Op c' _ _) -> c' == c) ops 168 | r = case o of 169 | Empty -> (putStrLn "Not a valid selection. Try again." >-) 170 | Full (Op _ _ k) -> (k >-) 171 | in r (pure c))) 172 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe/Loop.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe.Loop where 2 | 3 | import Control.Applicative (Applicative, pure) 4 | import Control.Concurrent (forkIO) 5 | import Control.Exception (Exception, catch, finally, try) 6 | import Control.Monad (liftM) 7 | import Control.Monad (forever) 8 | import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) 9 | import Data.Foldable (Foldable, mapM_) 10 | import Data.IORef (IORef, newIORef, readIORef) 11 | import Data.Set (Set) 12 | import qualified Data.Set as S 13 | import Prelude hiding (mapM_) 14 | import System.IO (BufferMode(..)) 15 | 16 | import Network (PortID(..), listenOn, sClose, withSocketsDo) 17 | import Network.Server.Common.Accept 18 | import Network.Server.Common.Env 19 | import Network.Server.Common.HandleLens 20 | import Network.Server.Common.Lens 21 | import Network.Server.Common.Line 22 | import Network.Server.Common.Ref 23 | 24 | data Loop v s f a = 25 | Loop (Env v -> s -> f (a, s)) 26 | 27 | type IOLoop v s a = Loop v s IO a 28 | 29 | type IORefLoop v s a = IOLoop (IORef v) s a 30 | 31 | execLoop :: Functor f => Loop v s f a -> Env v -> s -> f a 32 | execLoop (Loop l) e = fmap fst . l e 33 | 34 | initLoop :: Functor f => (Env v -> f a) -> Loop v s f a 35 | initLoop f = Loop $ \env s -> fmap (\a -> (a, s)) . f $ env 36 | 37 | instance Functor f => Functor (Loop v s f) where 38 | fmap f (Loop k) = Loop (\env -> fmap (\(a, t) -> (f a, t)) . k env) 39 | 40 | instance Applicative f => Applicative (Loop v s f) where 41 | pure = undefined 42 | (<*>) = undefined 43 | 44 | instance Monad f => Monad (Loop v s f) where 45 | return a = Loop $ \_ s -> return (a, s) 46 | Loop k >>= f = 47 | Loop 48 | (\env s -> 49 | k env s >>= \(a, t) -> 50 | let Loop l = f a 51 | in l env t) 52 | 53 | instance MonadTrans (Loop v s) where 54 | lift x = Loop (\_ s -> liftM (\a -> (a, s)) x) 55 | 56 | instance MonadIO f => MonadIO (Loop v s f) where 57 | liftIO = lift . liftIO 58 | 59 | etry :: Exception e => (Env v -> IO a) -> IOLoop v s (Either e a) 60 | etry k = initLoop $ try . k 61 | 62 | server :: 63 | IO w -- server initialise 64 | -> (w -> IO v) -- client accepted (pre) 65 | -> s -- initial state 66 | -> IOLoop v s () -- per-client 67 | -> IO a 68 | server i r t l = 69 | let hand s w c = 70 | forever $ do 71 | q <- accept' s 72 | lSetBuffering q NoBuffering 73 | _ <- atomicModifyIORef_ c (S.insert (refL `getL` q)) 74 | x <- r w 75 | forkIO (execLoop l (Env q c x) t) 76 | in withSocketsDo $ do 77 | s <- listenOn (PortNumber 6060) 78 | w <- i 79 | c <- newIORef S.empty 80 | hand s w c `finally` sClose s 81 | 82 | perClient :: 83 | IOLoop v s x -- client accepted (post) 84 | -> (String -> IOLoop v s a) -- read line from client 85 | -> IOLoop v s () 86 | perClient q f = 87 | let lp = do 88 | k <- etry lGetLine 89 | case k of 90 | Left e -> xprint e 91 | Right [] -> lp 92 | Right l -> f l >> lp 93 | in do _ <- q 94 | lp 95 | 96 | loop :: 97 | IO w -- server initialise 98 | -> (w -> IO v) -- client accepted (pre) 99 | -> s -- initial state 100 | -> IOLoop v s x -- client accepted (post) 101 | -> (String -> IOLoop v s w) -- read line from client 102 | -> IO a 103 | loop i r s q f = server i r s (perClient q f) 104 | 105 | iorefServer :: 106 | v -- server initialise 107 | -> s -- initial state 108 | -> IORefLoop v s () -- per-client 109 | -> IO a 110 | iorefServer x s = server (newIORef x) return s 111 | 112 | iorefLoop :: 113 | v -- server initialise 114 | -> s -- initial state 115 | -> IORefLoop v s x -- client accepted (post) 116 | -> (String -> IORefLoop v s w) -- read line from client 117 | -> IO a 118 | iorefLoop x s q f = iorefServer x s (perClient q f) 119 | 120 | pPutStrLn :: String -> IOLoop v s () 121 | pPutStrLn s = initLoop (`lPutStrLn` s) 122 | 123 | (!) :: Foldable t => IOLoop v s (t Ref) -> String -> IOLoop v s () 124 | clients !msg = clients >>= purgeClients (\y -> liftIO (lPutStrLn y msg)) 125 | 126 | infixl 2 ! 127 | 128 | purgeClients :: Foldable t => (Ref -> IOLoop s v ()) -> t Ref -> IOLoop s v () 129 | purgeClients a = 130 | mapM_ 131 | (\y -> 132 | ecatch 133 | (a y) 134 | (\x -> do 135 | _ <- modifyClients (S.delete y) 136 | xprint x)) 137 | 138 | readEnv :: Applicative f => Loop v s f (Env v) 139 | readEnv = initLoop $ pure 140 | 141 | readEnvval :: Applicative f => Loop v s f v 142 | readEnvval = fmap (envvalL `getL`) readEnv 143 | 144 | readIOEnvval :: IORefLoop a s a 145 | readIOEnvval = initLoop $ \env -> readIORef (envvalL `getL` env) 146 | 147 | allClientsButThis :: IOLoop v s (Set Ref) 148 | allClientsButThis = 149 | initLoop $ \env -> 150 | fmap 151 | (S.delete ((acceptL .@ refL) `getL` env)) 152 | (readIORef (clientsL `getL` env)) 153 | 154 | -- Control.Monad.CatchIO 155 | ecatch :: Exception e => IOLoop v s a -> (e -> IOLoop v s a) -> IOLoop v s a 156 | ecatch (Loop k) f = 157 | Loop $ \env s -> 158 | k env s `catch` 159 | (\e -> 160 | let Loop l = f e 161 | in l env s) 162 | 163 | modifyClients :: (Set Ref -> Set Ref) -> IOLoop v s (Set Ref) 164 | modifyClients f = initLoop $ \env -> atomicModifyIORef_ (clientsL `getL` env) f 165 | -------------------------------------------------------------------------------- /test/Course/JsonParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.JsonParserSpec where 6 | 7 | import Data.Ratio ((%)) 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | 10 | import Course.Core 11 | import Course.JsonParser (jsonArray, jsonFalse, jsonNull, jsonNumber, 12 | jsonObject, jsonString, jsonTrue, jsonValue) 13 | import Course.JsonValue (JsonValue (..)) 14 | import Course.List (List (..)) 15 | import Course.Parser (ParseResult (..), isErrorResult, parse) 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "jsonString" $ do 20 | it "parse whole ASCII input" $ 21 | parse jsonString "\" abc\"" `shouldBe` Result "" " abc" 22 | it "parse only the first string of input" $ 23 | parse jsonString "\"abc\"def" `shouldBe` Result "def" "abc" 24 | it "parse back slash (\\)" $ 25 | parse jsonString "\"\\babc\"def" `shouldBe` Result "def" "\babc" 26 | it "parse unicode (\\u00abc)" $ 27 | parse jsonString "\"\\u00abc\"def" `shouldBe` Result "def" "«c" 28 | it "parse unicode (\\u00ff)" $ 29 | parse jsonString "\"\\u00ffabc\"def" `shouldBe` Result "def" "ÿabc" 30 | it "parse unicode (\\u00fa)" $ 31 | parse jsonString "\"\\u00faabc\"def" `shouldBe` Result "def" "úabc" 32 | it "parsing string without quotes is an error" $ 33 | isErrorResult (parse jsonString "abc") `shouldBe` True 34 | it "parsing string containing \\a is an error - \\a isn't a special character" $ 35 | isErrorResult (parse jsonString "\"\\abc\"def") `shouldBe` True 36 | 37 | describe "jsonNumber" $ do 38 | it "positive whole" $ parse jsonNumber "234" `shouldBe` Result "" (234 % 1) 39 | it "negative whole" $ parse jsonNumber "-234" `shouldBe` Result "" ((-234) % 1) 40 | it "positive decimal" $ parse jsonNumber "123.45" `shouldBe` Result "" (2469 % 20) 41 | it "negative whole (2)" $ parse jsonNumber "-123" `shouldBe` Result "" ((-123) % 1) 42 | it "negative decimal" $ parse jsonNumber "-123.45" `shouldBe` Result "" ((-2469) % 20) 43 | it "negative sign on its own is error" $ isErrorResult (parse jsonNumber "-") `shouldBe` True 44 | it "alphabetic characters is error" $ isErrorResult (parse jsonNumber "abc") `shouldBe` True 45 | 46 | describe "jsonTrue" $ do 47 | it "parses true" $ parse jsonTrue "true" `shouldBe` Result "" "true" 48 | it "TRUE (caps) is an error" $ isErrorResult (parse jsonTrue "TRUE") `shouldBe` True 49 | 50 | describe "jsonFalse" $ do 51 | it "parses false" $ parse jsonFalse "false" `shouldBe` Result "" "false" 52 | it "FALSE (caps) is an error" $ isErrorResult (parse jsonFalse "FALSE") `shouldBe` True 53 | 54 | describe "jsonNull" $ do 55 | it "parses null" $ parse jsonNull "null" `shouldBe` Result "" "null" 56 | it "NULL (caps) is an error" $ isErrorResult (parse jsonNull "NULL") `shouldBe` True 57 | 58 | describe "jsonArray" $ do 59 | it "[]" $ 60 | parse jsonArray "[]" 61 | `shouldBe` 62 | Result "" Nil 63 | it "[true]" $ 64 | parse jsonArray "[true]" 65 | `shouldBe` 66 | Result "" (JsonTrue :. Nil) 67 | it "[true, \"abc\"]" $ 68 | parse jsonArray "[true, \"abc\"]" 69 | `shouldBe` 70 | Result "" (JsonTrue :. JsonString "abc" :. Nil) 71 | it "[true, \"abc\", []]" $ 72 | parse jsonArray "[true, \"abc\", []]" 73 | `shouldBe` 74 | Result "" (JsonTrue :. JsonString "abc" :. JsonArray Nil :. Nil) 75 | it "[true, \"abc\", [false]]" $ do 76 | let 77 | result = 78 | Result "" 79 | ( JsonTrue 80 | :. JsonString "abc" 81 | :. JsonArray (JsonFalse :. Nil) 82 | :. Nil 83 | ) 84 | parse jsonArray "[true, \"abc\", [false]]" `shouldBe` result 85 | 86 | describe "jsonObject" $ do 87 | it "empty" $ 88 | parse jsonObject "{}" 89 | `shouldBe` 90 | Result "" Nil 91 | it "one key" $ 92 | parse jsonObject "{ \"key1\" : true }" 93 | `shouldBe` 94 | Result "" (("key1",JsonTrue) :. Nil) 95 | it "two keys" $ 96 | parse jsonObject "{ \"key1\" : true , \"key2\" : false }" 97 | `shouldBe` 98 | Result "" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) 99 | it "two keys and left over input" $ do 100 | let 101 | result = 102 | Result "xyz" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) 103 | parse jsonObject "{ \"key1\" : true , \"key2\" : false } xyz" `shouldBe` result 104 | 105 | describe "jsonValue" $ do 106 | it "true" $ 107 | parse jsonValue "true" 108 | `shouldBe` 109 | Result "" JsonTrue 110 | it "object" $ do 111 | let 112 | result = 113 | Result "" 114 | ( ("key1",JsonTrue) 115 | :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse:.Nil)) 116 | :. Nil 117 | ) 118 | parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] }" 119 | `shouldBe` 120 | result 121 | it "nested object" $ do 122 | let 123 | result = 124 | Result "" 125 | ( ("key1",JsonTrue) 126 | :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse :. Nil)) 127 | :. ("key3",JsonObject (("key4",JsonNull) :. Nil)) 128 | :. Nil 129 | ) 130 | input = 131 | "{ \"key1\" : true , \"key2\" : [7, false] , \"key3\" : { \"key4\" : null } }" 132 | parse jsonObject input `shouldBe` result 133 | -------------------------------------------------------------------------------- /src/Course/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.State where 7 | 8 | import Course.Core 9 | import qualified Prelude as P 10 | import Course.Optional 11 | import Course.List 12 | import Course.Functor 13 | import Course.Applicative 14 | import Course.Monad 15 | import qualified Data.Set as S 16 | 17 | -- $setup 18 | -- >>> import Test.QuickCheck.Function 19 | -- >>> import Data.List(nub) 20 | -- >>> import Test.QuickCheck 21 | -- >>> import qualified Prelude as P(fmap) 22 | -- >>> import Course.Core 23 | -- >>> import Course.List 24 | -- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap listh arbitrary 25 | 26 | -- A `State` is a function from a state value `s` to (a produced value `a`, and a resulting state `s`). 27 | newtype State s a = 28 | State { 29 | runState :: 30 | s 31 | -> (a, s) 32 | } 33 | 34 | -- | Run the `State` seeded with `s` and retrieve the resulting state. 35 | -- 36 | -- prop> \(Fun _ f) s -> exec (State f) s == snd (runState (State f) s) 37 | exec :: 38 | State s a 39 | -> s 40 | -> s 41 | exec = 42 | error "todo: Course.State#exec" 43 | 44 | -- | Run the `State` seeded with `s` and retrieve the resulting value. 45 | -- 46 | -- prop> \(Fun _ f) s -> eval (State f) s == fst (runState (State f) s) 47 | eval :: 48 | State s a 49 | -> s 50 | -> a 51 | eval = 52 | error "todo: Course.State#eval" 53 | 54 | -- | A `State` where the state also distributes into the produced value. 55 | -- 56 | -- >>> runState get 0 57 | -- (0,0) 58 | get :: 59 | State s s 60 | get = 61 | error "todo: Course.State#get" 62 | 63 | -- | A `State` where the resulting state is seeded with the given value. 64 | -- 65 | -- >>> runState (put 1) 0 66 | -- ((),1) 67 | put :: 68 | s 69 | -> State s () 70 | put = 71 | error "todo: Course.State#put" 72 | 73 | -- | Implement the `Functor` instance for `State s`. 74 | -- 75 | -- >>> runState ((+1) <$> State (\s -> (9, s * 2))) 3 76 | -- (10,6) 77 | instance Functor (State s) where 78 | (<$>) :: 79 | (a -> b) 80 | -> State s a 81 | -> State s b 82 | (<$>) = 83 | error "todo: Course.State#(<$>)" 84 | 85 | -- | Implement the `Applicative` instance for `State s`. 86 | -- 87 | -- >>> runState (pure 2) 0 88 | -- (2,0) 89 | -- 90 | -- >>> runState (pure (+1) <*> pure 0) 0 91 | -- (1,0) 92 | -- 93 | -- >>> import qualified Prelude as P 94 | -- >>> runState (State (\s -> ((+3), s P.++ ["apple"])) <*> State (\s -> (7, s P.++ ["banana"]))) [] 95 | -- (10,["apple","banana"]) 96 | instance Applicative (State s) where 97 | pure :: 98 | a 99 | -> State s a 100 | pure = 101 | error "todo: Course.State pure#instance (State s)" 102 | (<*>) :: 103 | State s (a -> b) 104 | -> State s a 105 | -> State s b 106 | (<*>) = 107 | error "todo: Course.State (<*>)#instance (State s)" 108 | 109 | -- | Implement the `Bind` instance for `State s`. 110 | -- 111 | -- >>> runState ((const $ put 2) =<< put 1) 0 112 | -- ((),2) 113 | -- 114 | -- >>> let modify f = State (\s -> ((), f s)) in runState (modify (+1) >>= \() -> modify (*2)) 7 115 | -- ((),16) 116 | instance Monad (State s) where 117 | (=<<) :: 118 | (a -> State s b) 119 | -> State s a 120 | -> State s b 121 | (=<<) = 122 | error "todo: Course.State (=<<)#instance (State s)" 123 | 124 | -- | Find the first element in a `List` that satisfies a given predicate. 125 | -- It is possible that no element is found, hence an `Optional` result. 126 | -- However, while performing the search, we sequence some `Monad` effect through. 127 | -- 128 | -- Note the similarity of the type signature to List#find 129 | -- where the effect appears in every return position: 130 | -- find :: (a -> Bool) -> List a -> Optional a 131 | -- findM :: (a -> f Bool) -> List a -> f (Optional a) 132 | -- 133 | -- >>> let p x = (\s -> (const $ pure (x == 'c')) =<< put (1+s)) =<< get in runState (findM p $ listh ['a'..'h']) 0 134 | -- (Full 'c',3) 135 | -- 136 | -- >>> let p x = (\s -> (const $ pure (x == 'i')) =<< put (1+s)) =<< get in runState (findM p $ listh ['a'..'h']) 0 137 | -- (Empty,8) 138 | findM :: 139 | Monad f => 140 | (a -> f Bool) 141 | -> List a 142 | -> f (Optional a) 143 | findM = 144 | error "todo: Course.State#findM" 145 | 146 | -- | Find the first element in a `List` that repeats. 147 | -- It is possible that no element repeats, hence an `Optional` result. 148 | -- 149 | -- /Tip:/ Use `findM` and `State` with a @Data.Set#Set@. 150 | -- 151 | -- prop> \xs -> case firstRepeat xs of Empty -> let xs' = hlist xs in nub xs' == xs'; Full x -> length (filter (== x) xs) > 1 152 | -- 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 153 | firstRepeat :: 154 | Ord a => 155 | List a 156 | -> Optional a 157 | firstRepeat = 158 | error "todo: Course.State#firstRepeat" 159 | 160 | -- | Remove all duplicate elements in a `List`. 161 | -- /Tip:/ Use `filtering` and `State` with a @Data.Set#Set@. 162 | -- 163 | -- prop> \xs -> firstRepeat (distinct xs) == Empty 164 | -- 165 | -- prop> \xs -> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs) 166 | distinct :: 167 | Ord a => 168 | List a 169 | -> List a 170 | distinct = 171 | error "todo: Course.State#distinct" 172 | 173 | -- | A happy number is a positive integer, where the sum of the square of its digits eventually reaches 1 after repetition. 174 | -- In contrast, a sad number (not a happy number) is where the sum of the square of its digits never reaches 1 175 | -- because it results in a recurring sequence. 176 | -- 177 | -- /Tip:/ Use `firstRepeat` with `produce`. 178 | -- 179 | -- /Tip:/ Use `join` to write a @square@ function. 180 | -- 181 | -- /Tip:/ Use library functions: @Optional#contains@, @Data.Char#digitToInt@. 182 | -- 183 | -- >>> isHappy 4 184 | -- False 185 | -- 186 | -- >>> isHappy 7 187 | -- True 188 | -- 189 | -- >>> isHappy 42 190 | -- False 191 | -- 192 | -- >>> isHappy 44 193 | -- True 194 | isHappy :: 195 | Integer 196 | -> Bool 197 | isHappy = 198 | error "todo: Course.State#isHappy" 199 | -------------------------------------------------------------------------------- /test/Course/StateTSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.StateTSpec where 5 | 6 | import qualified Prelude as P (String, (++)) 7 | 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | import Test.Hspec.QuickCheck (prop) 10 | import Test.QuickCheck ((===)) 11 | 12 | import Course.Applicative (pure, (<*>)) 13 | import Course.Core 14 | import Course.ExactlyOne (ExactlyOne (..)) 15 | import Course.Functor ((<$>)) 16 | import Course.Gens (forAllLists) 17 | import Course.List (List (..), flatMap, listh) 18 | import Course.Monad ((=<<), (>>=)) 19 | import Course.Optional (Optional (..)) 20 | import Course.State (put, runState) 21 | import Course.StateT (Logger (..), OptionalT (..), 22 | StateT (..), distinct', distinctF, 23 | distinctG, getT, log1, putT, 24 | runOptionalT, runState', state') 25 | 26 | spec :: Spec 27 | spec = do 28 | 29 | describe "Functor" $ do 30 | it "<$>" $ do 31 | let 32 | st = 33 | StateT (\s -> ((2, s) :. Nil)) 34 | runStateT ((+1) <$> st) 0 `shouldBe` ((3,0) :. Nil) 35 | 36 | describe "Applicative" $ do 37 | it "List (pure)" $ runStateT ((pure 2) :: StateT Int List Int) 0 `shouldBe` ((2,0) :. Nil) 38 | it "List (<*>)" $ runStateT (pure (+2) <*> ((pure 2) :: StateT Int List Int)) 0 `shouldBe` ((4,0) :. Nil) 39 | it "Optional" $ do 40 | let 41 | st = 42 | StateT (\s -> Full ((+2), s P.++ [1])) <*> (StateT (\s -> Full (2, s P.++ [2]))) 43 | runStateT st [0] `shouldBe` Full (4,[0,1,2]) 44 | it "List" $ do 45 | let 46 | st = 47 | StateT (\s -> ((+2), s P.++ [1]) :. ((+3), s P.++ [1]) :. Nil) 48 | <*> (StateT (\s -> (2, s P.++ [2]) :. Nil)) 49 | runStateT st [0] `shouldBe` ((4,[0,1,2]) :. (5,[0,1,2]) :. Nil) 50 | 51 | describe "Monad" $ do 52 | it "bind const" $ do 53 | let 54 | s n = 55 | StateT $ const (((), n) :. Nil) 56 | runStateT (const (s 2) =<< s 1) 0 `shouldBe` (((), 2) :. Nil) 57 | it "modify" $ do 58 | let 59 | modify f = 60 | StateT (\s -> pure ((), f s)) 61 | runStateT (modify (+1) >>= \() -> modify (*2)) 7 62 | `shouldBe` 63 | (((), 16) :. Nil) 64 | 65 | describe "state'" $ do 66 | it "lifts stately functions" $ 67 | runStateT (state' $ runState $ put 1) 0 `shouldBe` ExactlyOne ((), 1) 68 | 69 | describe "runState'" $ do 70 | it "runs identity states" $ 71 | runState' (state' $ runState $ put 1) 0 `shouldBe` ((),1) 72 | 73 | describe "getTTest" $ do 74 | it "returns it's input" $ 75 | runStateT (getT :: StateT Int List Int) 3 `shouldBe` ((3,3) :. Nil) 76 | 77 | describe "putTTest" $ do 78 | it "puts the state" $ 79 | runStateT (putT 2 :: StateT Int List ()) 0 `shouldBe` (((),2) :. Nil) 80 | 81 | describe "distinct'" $ do 82 | prop "removes adjacent duplicates" $ 83 | forAllLists $ \xs -> 84 | distinct' xs === distinct' (flatMap (\x -> x :. x :. Nil) xs) 85 | 86 | describe "distinctF" $ do 87 | it "Full case" $ 88 | distinctF (listh [1,2,3,2,1]) `shouldBe` Full (listh [1,2,3]) 89 | it "Empty case" $ 90 | distinctF (listh [1,2,3,2,1,101]) `shouldBe` Empty 91 | 92 | describe "OptionalT" $ do 93 | it "(<$>) for OptionalT" $ 94 | runOptionalT ((+1) <$> OptionalT (Full 1 :. Empty :. Nil)) 95 | `shouldBe` 96 | (Full 2 :. Empty :. Nil) 97 | 98 | describe "(<*>) for OptionalT" $ do 99 | it "one" $ do 100 | let 101 | ot = 102 | OptionalT Nil <*> OptionalT (Full 1 :. Full 2 :. Nil) 103 | runOptionalT ot `shouldBe` (Nil :: List (Optional Int)) 104 | it "two" $ do 105 | let 106 | ot = 107 | OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT Nil 108 | runOptionalT ot `shouldBe` (Nil :: List (Optional Int)) 109 | it "three" $ do 110 | let 111 | ot = 112 | OptionalT (Empty :. Nil) <*> OptionalT (Empty :. Nil) 113 | runOptionalT ot `shouldBe` (Empty :. Nil :: List (Optional Int)) 114 | it "four" $ do 115 | let 116 | ot = 117 | OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Empty :. Nil) 118 | runOptionalT ot `shouldBe` (Empty :. Empty :. Nil :: List (Optional Int)) 119 | it "five" $ do 120 | let 121 | ot = 122 | OptionalT (Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) 123 | runOptionalT ot `shouldBe` (Empty :. Nil :: List (Optional Int)) 124 | it "six" $ do 125 | let 126 | ot = 127 | OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) 128 | runOptionalT ot `shouldBe` (Full 2 :. Full 3 :. Empty :. Nil) 129 | it "seven" $ do 130 | let 131 | ot = 132 | OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT (Full 1 :. Empty :. Nil) 133 | runOptionalT ot `shouldBe` (Full 2 :. Empty :. Full 3 :. Empty :. Nil) 134 | 135 | describe "OptionalT Monad" $ do 136 | it "(=<<) for OptionalT" $ do 137 | let 138 | func a = 139 | OptionalT (Full (a+1) :. Full (a+2) :. Nil) 140 | ot = 141 | func =<< OptionalT (Full 1 :. Empty :. Nil) 142 | runOptionalT ot `shouldBe` (Full 2:.Full 3:.Empty:.Nil) 143 | 144 | describe "Logger" $ do 145 | it "(<$>) for Logger" $ 146 | (+3) <$> Logger (1 :. 2 :. Nil) 3 `shouldBe` Logger (1 :. 2 :. Nil) 6 147 | 148 | describe "Applicative" $ do 149 | it "pure" $ 150 | (pure "table" :: Logger Int P.String) `shouldBe` Logger Nil "table" 151 | it "<*>" $ 152 | Logger (1:.2:.Nil) (+7) <*> Logger (3:.4:.Nil) 3 153 | `shouldBe` 154 | Logger (1:.2:.3:.4:.Nil) 10 155 | 156 | describe "Functor" $ do 157 | it "(=<<) for Logger" $ do 158 | let 159 | func a = 160 | Logger (4:.5:.Nil) (a+3) 161 | (func =<< Logger (1:.2:.Nil) 3) 162 | `shouldBe` 163 | Logger (1:.2:.4:.5:.Nil) 6 164 | 165 | it "log1" $ 166 | log1 1 2 `shouldBe` Logger (1:.Nil) 2 167 | 168 | describe "distinctG" $ do 169 | it "Full case" $ do 170 | let 171 | expected = 172 | Logger 173 | (listh <$> ("even number: 2":."even number: 2":."even number: 6":.Nil)) 174 | (Full (1:.2:.3:.6:.Nil)) 175 | distinctG (1:.2:.3:.2:.6:.Nil) `shouldBe` expected 176 | it "Empty case" $ do 177 | let 178 | expected = 179 | Logger 180 | (listh <$> ("even number: 2":."even number: 2":."even number: 6":."aborting > 100: 106":.Nil)) 181 | Empty 182 | distinctG (listh [1,2,3,2,6,106]) `shouldBe` expected 183 | -------------------------------------------------------------------------------- /projects/NetworkServer/NetworkServer.markdown: -------------------------------------------------------------------------------- 1 | Chat Network Server 2 | =================== 3 | 4 | The goal of this exercise is to apply functional programming 5 | constructs to a more complex problem. We shall explore the benefits of 6 | functional programing in the large, embracing the presence of IO, 7 | program state and related difficulties in our code. 8 | 9 | Using the provided skeleton, the intention is to build a naive network 10 | chat server, using a textual, line based protocol. This project provides 11 | the required dependencies and structure to get a basic server up and 12 | running. 13 | 14 | Protocol 15 | -------- 16 | 17 | Clients send line-terminated instructions to the game server. 18 | 19 | Instructions begin with a case-insensitive command: 20 | 21 | * CHAT 22 | 23 | Send a message to all connected users. 24 | 25 | * ADD 26 | 27 | Add a number to the global counter and notify all connected users. 28 | 29 | Server messages are sent prefixed by a '>' character. 30 | 31 | 32 | Getting Started 33 | --------------- 34 | 35 | Some library code has been written for you. Some has been specified with types 36 | and some will need to be written from scratch. Use the wide array of tools 37 | available to achieve this. 38 | 39 | To run your server (although it will error out, until you have completed the 40 | implementation): 41 | 42 | ``` 43 | cabal configure 44 | cabal build 45 | ./dist/build/network-chat/network-chat 46 | ``` 47 | 48 | Start by taking a few minutes familiarising yourself with what is has 49 | been provided. You should be able to implement the problem primarily 50 | using functions provided in this project and those you have used to 51 | complete earlier course exercises. But remember this is _not_ an 52 | exercise to learn haskell APIs, so anything you think is missing or 53 | don't understand, ask straight away. 54 | 55 | Then you want to start by looking at the `error TODO` comments in 56 | `Network.Server.Chat.Loop` and `Network.Server.Chat.Chat`. 57 | 58 | Loop 59 | ---- 60 | 61 | Of note is the `Loop` data type. 62 | 63 | data Loop f a = 64 | Loop (Env v -> f a) 65 | 66 | This is a monad stack of reader (`(->) Env v`), that also includes an 67 | arbitrary monad on top (`f`). The inclusion of an arbitrary monad with the 68 | existing stack makes `Loop` a _monad transformer_. 69 | 70 | A significant part of this exercise is to build library components that combine 71 | `Loop` values to produce new values. For example, consider a `Loop` value that 72 | might read and produce the `Accept` value from the environment `Env`. 73 | 74 | Such a function can be provided for any monad (`f`) on the stack. Notice the 75 | current game state (`getUnfinished env`) and finished games (`getFinished env`) 76 | are read from the environment and then returned unchanged. 77 | 78 | accept :: 79 | Loop f Accept 80 | accept = 81 | Loop $ \env -> return (getAccept env) 82 | 83 | As part of this exercise, you will be thinking about which values you need to 84 | achieve the requirement and creating them as they are needed. 85 | 86 | Goals 87 | ----- 88 | 89 | * Be able to have multiple telnet sessions connect to your server and 90 | communicate. For example 91 | 92 | Session 1: 93 | ``` 94 | telnet localhost 6060 95 | Connected to localhost. 96 | Escape character is '^]'. 97 | CHAT hello everyone 98 | > h1 99 | > counter is at 5 100 | ``` 101 | 102 | Server 2: 103 | ``` 104 | telnet localhost 6060 105 | Connected to localhost. 106 | Escape character is '^]'. 107 | > hello everyone 108 | CHAT hi 109 | > counter is at 5 110 | ``` 111 | 112 | Server 3: 113 | ``` 114 | telnet localhost 6060 115 | Connected to localhost. 116 | Escape character is '^]'. 117 | > hello everyone 118 | > hi 119 | ADD 5 120 | > counter is at 5 121 | ``` 122 | 123 | * Maximise the amount of _pure_ code in your system. And, in turn minimise 124 | the amount of code tied to the Game transformer or even worse IO. 125 | 126 | * Bonus: 0 `hlint` issues. 127 | 128 | 129 | 130 | TicTacToe Network Server (Single Game) 131 | ====================================== 132 | 133 | NOTE: This assumes the chat server is completed. 134 | 135 | Now that we have basic chat functionality, it is time to extend our network 136 | server protocol to support a game of multi-user TicTacToe. There are a few 137 | simplifying assumptions for this problem: 138 | 139 | * Only one active game needs to be maintained by the server at a time. 140 | * Game players will not be manages, so any user may be able to manipulate the board at any time. 141 | 142 | 143 | ``` 144 | cabal configure 145 | cabal build 146 | ./dist/build/network-tictactoe/network-tictactoe 147 | ``` 148 | 149 | Protocol 150 | -------- 151 | 152 | We will need to extend out the server state and protocol. 153 | The game server will maintain a single game of tic-tac-toe and a history of 154 | completed games. 155 | 156 | Clients send line-terminated instructions to the game server. 157 | 158 | Instructions begin with a case-insensitive command: 159 | 160 | * MOVE 161 | 162 | Make a move on the current game board at the given position. 163 | 164 | * GAME 165 | 166 | View the current game board. 167 | 168 | * FINISHED 169 | 170 | View completed games. 171 | 172 | * TURN 173 | 174 | View whose turn it is to play on the current game board. 175 | 176 | * AT 177 | 178 | View which player is at the given position. 179 | 180 | The position may be a digit [1-9] indicating a numeric position, or it may be a 181 | case-insensitive cardinal direction. 182 | 183 | 1 2 3 184 | 4 5 6 185 | 7 8 9 186 | 187 | NW N NE 188 | W C E 189 | SW S SE 190 | 191 | Making a move at a position on a game board that has gone out of date with what 192 | that connected client believes to be the current game state fails. A client may 193 | update what they believe to be the game state with the `GAME` command. 194 | 195 | Getting Started 196 | --------------- 197 | 198 | Since you have written the chat server already, you should be familiar with 199 | most of the concepts required. To implement the TicTacToe part of the program 200 | you should `import Data.TicTacToe` from the previous project. 201 | 202 | You should expect to have to modify the `Game` monad transformer or its 203 | related types to incorporate the new state required 204 | 205 | 206 | TicTacToe Network Server (Multi-Game) 207 | ====================================== 208 | 209 | NOTE: This assumes the single game version of the TicTacToe server is completed. 210 | 211 | Now that we have basic game functionality, it is time to extend our network 212 | server protocol to support multiple concurrent games of multi-user TicTacToe. 213 | 214 | At this point, you are on your own. You should now have the tools and techniques 215 | required to discover and understand APIs based on their types. 216 | 217 | HINT: A good place to start may be either which has a good write up at or which has a good write up at . 218 | -------------------------------------------------------------------------------- /src/Course/JsonParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.JsonParser where 7 | 8 | import Course.Core 9 | import Course.Parser 10 | import Course.MoreParser 11 | import Course.JsonValue 12 | import Course.Functor 13 | import Course.Applicative 14 | import Course.Monad 15 | import Course.List 16 | import Course.Optional 17 | 18 | -- $setup 19 | -- >>> :set -XOverloadedStrings 20 | 21 | -- A special character is one of the following: 22 | -- * \b Backspace (ascii code 08) 23 | -- * \f Form feed (ascii code 0C) 24 | -- * \n New line 25 | -- * \r Carriage return 26 | -- * \t Tab 27 | -- * \v Vertical tab 28 | -- * \' Apostrophe or single quote (only valid in single quoted json strings) 29 | -- * \" Double quote (only valid in double quoted json strings) 30 | -- * \\ Backslash character 31 | data SpecialCharacter = 32 | BackSpace 33 | | FormFeed 34 | | NewLine 35 | | CarriageReturn 36 | | Tab 37 | | VerticalTab 38 | | SingleQuote 39 | | DoubleQuote 40 | | Backslash 41 | deriving (Eq, Ord, Show) 42 | 43 | -- NOTE: This is not inverse to @toSpecialCharacter@. 44 | fromSpecialCharacter :: 45 | SpecialCharacter 46 | -> Char 47 | fromSpecialCharacter BackSpace = 48 | chr 0x08 49 | fromSpecialCharacter FormFeed = 50 | chr 0x0C 51 | fromSpecialCharacter NewLine = 52 | '\n' 53 | fromSpecialCharacter CarriageReturn = 54 | '\r' 55 | fromSpecialCharacter Tab = 56 | '\t' 57 | fromSpecialCharacter VerticalTab = 58 | '\v' 59 | fromSpecialCharacter SingleQuote = 60 | '\'' 61 | fromSpecialCharacter DoubleQuote = 62 | '"' 63 | fromSpecialCharacter Backslash = 64 | '\\' 65 | 66 | -- NOTE: This is not inverse to @fromSpecialCharacter@. 67 | toSpecialCharacter :: 68 | Char 69 | -> Optional SpecialCharacter 70 | toSpecialCharacter c = 71 | let table = ('b', BackSpace) :. 72 | ('f', FormFeed) :. 73 | ('n', NewLine) :. 74 | ('r', CarriageReturn) :. 75 | ('t', Tab) :. 76 | ('v', VerticalTab) :. 77 | ('\'', SingleQuote) :. 78 | ('"' , DoubleQuote) :. 79 | ('\\', Backslash) :. 80 | Nil 81 | in snd <$> find ((==) c . fst) table 82 | 83 | -- | Parse a JSON string. Handle double-quotes, special characters, hexadecimal characters. See http://json.org for the full list of control characters in JSON. 84 | -- 85 | -- /Tip:/ Use `hex`, `fromSpecialCharacter`, `between`, `is`, `charTok`, `toSpecialCharacter`. 86 | -- 87 | -- >>> parse jsonString "\" abc\"" 88 | -- Result >< " abc" 89 | -- 90 | -- >>> parse jsonString "\"abc\"def" 91 | -- Result >def< "abc" 92 | -- 93 | -- >>> parse jsonString "\"\\babc\"def" 94 | -- Result >def< "\babc" 95 | -- 96 | -- >>> parse jsonString "\"\\u00abc\"def" 97 | -- Result >def< "\171c" 98 | -- 99 | -- >>> parse jsonString "\"\\u00ffabc\"def" 100 | -- Result >def< "\255abc" 101 | -- 102 | -- >>> parse jsonString "\"\\u00faabc\"def" 103 | -- Result >def< "\250abc" 104 | -- 105 | -- >>> isErrorResult (parse jsonString "abc") 106 | -- True 107 | -- 108 | -- >>> isErrorResult (parse jsonString "\"\\abc\"def") 109 | -- True 110 | jsonString :: 111 | Parser Chars 112 | jsonString = 113 | error "todo: Course.JsonParser#jsonString" 114 | 115 | -- | Parse a JSON rational. 116 | -- 117 | -- /Tip:/ Use @readFloats@. 118 | -- 119 | -- >>> parse jsonNumber "234" 120 | -- Result >< 234 % 1 121 | -- 122 | -- >>> parse jsonNumber "-234" 123 | -- Result >< (-234) % 1 124 | -- 125 | -- >>> parse jsonNumber "123.45" 126 | -- Result >< 2469 % 20 127 | -- 128 | -- >>> parse jsonNumber "-123" 129 | -- Result >< (-123) % 1 130 | -- 131 | -- >>> parse jsonNumber "-123.45" 132 | -- Result >< (-2469) % 20 133 | -- 134 | -- >>> isErrorResult (parse jsonNumber "-") 135 | -- True 136 | -- 137 | -- >>> isErrorResult (parse jsonNumber "abc") 138 | -- True 139 | jsonNumber :: 140 | Parser Rational 141 | jsonNumber = 142 | error "todo: Course.JsonParser#jsonNumber" 143 | 144 | -- | Parse a JSON true literal. 145 | -- 146 | -- /Tip:/ Use `stringTok`. 147 | -- 148 | -- >>> parse jsonTrue "true" 149 | -- Result >< "true" 150 | -- 151 | -- >>> isErrorResult (parse jsonTrue "TRUE") 152 | -- True 153 | jsonTrue :: 154 | Parser Chars 155 | jsonTrue = 156 | error "todo: Course.JsonParser#jsonTrue" 157 | 158 | -- | Parse a JSON false literal. 159 | -- 160 | -- /Tip:/ Use `stringTok`. 161 | -- 162 | -- >>> parse jsonFalse "false" 163 | -- Result >< "false" 164 | -- 165 | -- >>> isErrorResult (parse jsonFalse "FALSE") 166 | -- True 167 | jsonFalse :: 168 | Parser Chars 169 | jsonFalse = 170 | error "todo: Course.JsonParser#jsonFalse" 171 | 172 | -- | Parse a JSON null literal. 173 | -- 174 | -- /Tip:/ Use `stringTok`. 175 | -- 176 | -- >>> parse jsonNull "null" 177 | -- Result >< "null" 178 | -- 179 | -- >>> isErrorResult (parse jsonNull "NULL") 180 | -- True 181 | jsonNull :: 182 | Parser Chars 183 | jsonNull = 184 | error "todo: Course.JsonParser#jsonNull" 185 | 186 | -- | Parse a JSON array. 187 | -- 188 | -- /Tip:/ Use `betweenSepbyComma` and `jsonValue`. 189 | -- 190 | -- >>> parse jsonArray "[]" 191 | -- Result >< [] 192 | -- 193 | -- >>> parse jsonArray "[true]" 194 | -- Result >< [JsonTrue] 195 | -- 196 | -- >>> parse jsonArray "[true, \"abc\"]" 197 | -- Result >< [JsonTrue,JsonString "abc"] 198 | -- 199 | -- >>> parse jsonArray "[true, \"abc\", []]" 200 | -- Result >< [JsonTrue,JsonString "abc",JsonArray []] 201 | -- 202 | -- >>> parse jsonArray "[true, \"abc\", [false]]" 203 | -- Result >< [JsonTrue,JsonString "abc",JsonArray [JsonFalse]] 204 | jsonArray :: 205 | Parser (List JsonValue) 206 | jsonArray = 207 | error "todo: Course.JsonParser#jsonArray" 208 | 209 | -- | Parse a JSON object. 210 | -- 211 | -- /Tip:/ Use `jsonString`, `charTok`, `betweenSepbyComma` and `jsonValue`. 212 | -- 213 | -- >>> parse jsonObject "{}" 214 | -- Result >< [] 215 | -- 216 | -- >>> parse jsonObject "{ \"key1\" : true }" 217 | -- Result >< [("key1",JsonTrue)] 218 | -- 219 | -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : false }" 220 | -- Result >< [("key1",JsonTrue),("key2",JsonFalse)] 221 | -- 222 | -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : false } xyz" 223 | -- Result >xyz< [("key1",JsonTrue),("key2",JsonFalse)] 224 | jsonObject :: 225 | Parser Assoc 226 | jsonObject = 227 | error "todo: Course.JsonParser#jsonObject" 228 | 229 | -- | Parse a JSON value. 230 | -- 231 | -- /Tip:/ Use `spaces`, `jsonNull`, `jsonTrue`, `jsonFalse`, `jsonArray`, `jsonString`, `jsonObject` and `jsonNumber`. 232 | -- 233 | -- >>> parse jsonValue "true" 234 | -- Result >< JsonTrue 235 | -- 236 | -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] }" 237 | -- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational (7 % 1),JsonFalse])] 238 | -- 239 | -- >>> parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] , \"key3\" : { \"key4\" : null } }" 240 | -- Result >< [("key1",JsonTrue),("key2",JsonArray [JsonRational (7 % 1),JsonFalse]),("key3",JsonObject [("key4",JsonNull)])] 241 | jsonValue :: 242 | Parser JsonValue 243 | jsonValue = 244 | error "todo: Course.JsonParser#jsonValue" 245 | 246 | -- | Read a file into a JSON value. 247 | -- 248 | -- /Tip:/ Use @System.IO#readFile@ and `jsonValue`. 249 | readJsonValue :: 250 | FilePath 251 | -> IO (ParseResult JsonValue) 252 | readJsonValue = 253 | error "todo: Course.JsonParser#readJsonValue" 254 | -------------------------------------------------------------------------------- /test/Course/ListSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.ListSpec where 5 | 6 | import qualified Prelude as P (length) 7 | 8 | import Test.Hspec (Spec, describe, it, shouldBe) 9 | import Test.Hspec.QuickCheck (prop) 10 | import Test.QuickCheck (forAllShrink) 11 | 12 | import Course.Core 13 | import Course.Gens (forAllLists, genIntegerAndList, genList, 14 | genListOfLists, genThreeLists, 15 | genTwoLists, shrinkIntegerAndList, 16 | shrinkList, shrinkListOfLists, 17 | shrinkThreeLists, shrinkTwoLists) 18 | import Course.List (List (..), filter, find, flatMap, 19 | flatten, flattenAgain, foldLeft, headOr, 20 | hlist, infinity, largeList, length, 21 | lengthGT4, listh, map, produce, product, 22 | reverse, seqOptional, sum, take, (++)) 23 | import Course.Optional (Optional (..)) 24 | 25 | spec :: Spec 26 | spec = do 27 | describe "headOr" $ do 28 | it "headOr on non-empty list" $ headOr 3 (1 :. 2 :. Nil) `shouldBe` 1 29 | it "headOr on empty list" $ headOr 3 Nil `shouldBe` 3 30 | prop "headOr on infinity always 0" $ \x -> x `headOr` infinity == 0 31 | prop "headOr on empty list always the default" $ \x -> x `headOr` Nil == (x :: Integer) 32 | 33 | describe "productTest" $ do 34 | it "product of empty list" $ product Nil `shouldBe` 1 35 | it "product of 1..3" $ product (1 :. 2 :. 3 :. Nil) `shouldBe` 6 36 | it "product of 1..4" $ product (1 :. 2 :. 3 :. 4 :. Nil) `shouldBe` 24 37 | 38 | describe "sum" $ do 39 | it "sum 1..3" $ sum (1 :. 2 :. 3 :. Nil) `shouldBe` 6 40 | it "sum 1..4" $ sum (1 :. 2 :. 3 :. 4 :. Nil) `shouldBe` 10 41 | prop "subtracting each element in a list from its sum is always 0" $ 42 | forAllShrink genList shrinkList (\x -> foldLeft (-) (sum x) x == 0) 43 | 44 | describe "length" $ do 45 | it "length 1..3" $ length (1 :. 2 :. 3 :. Nil) `shouldBe` 3 46 | prop "summing a list of 1s is equal to its length" $ 47 | forAllLists (\x -> P.length (hlist x) == length x) 48 | 49 | describe "map" $ do 50 | it "add 10 on list" $ 51 | map (+10) (1 :. 2 :. 3 :. Nil) `shouldBe` (11 :. 12 :. 13 :. Nil) 52 | prop "headOr after map" $ 53 | \x -> headOr (x :: Integer) (map (+1) infinity) == 1 54 | prop "map id is id" $ 55 | forAllLists (\x -> map id x == x) 56 | 57 | describe "filter" $ do 58 | it "filter even" $ 59 | filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` (2 :. 4 :. Nil) 60 | prop "filter (const True) is identity (headOr)" $ 61 | \x -> headOr x (filter (const True) infinity) == 0 62 | prop "filter (const True) is identity" $ 63 | forAllLists (\x -> filter (const True) x == x) 64 | prop "filter (const False) is the empty list" $ 65 | forAllLists (\x -> filter (const False) x == Nil) 66 | 67 | describe "(++)" $ do 68 | it "(1..6)" $ 69 | (1 :. 2 :. 3 :. Nil) ++ (4 :. 5 :. 6 :. Nil) `shouldBe` listh [1,2,3,4,5,6] 70 | prop "append empty to infinite" $ 71 | \x -> headOr x (Nil ++ infinity) == 0 72 | prop "append anything to infinity" $ 73 | forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (y ++ infinity) == headOr 0 y) 74 | prop "associativity" $ 75 | forAllShrink genThreeLists shrinkThreeLists (\(x,y,z) -> (x ++ y) ++ z == x ++ (y ++ z)) 76 | prop "append to empty list" $ 77 | forAllLists (\x -> x ++ Nil == x) 78 | 79 | describe "flatten" $ do 80 | it "(1..9)" $ 81 | flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) `shouldBe` listh [1,2,3,4,5,6,7,8,9] 82 | prop "flatten (infinity :. y)" $ 83 | forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatten (infinity :. y :. Nil)) == 0) 84 | prop "flatten (y :. infinity)" $ 85 | forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y) 86 | prop "sum of lengths == length of flattened" $ 87 | forAllShrink genListOfLists shrinkListOfLists (\x -> sum (map length x) == length (flatten x)) 88 | 89 | describe "flatMap" $ do 90 | it "lists of Integer" $ 91 | flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) `shouldBe` listh [1,2,3,2,3,4,3,4,5] 92 | prop "flatMap id flattens a list of lists" $ 93 | forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatMap id (infinity :. y :. Nil)) == 0) 94 | prop "flatMap id on a list of lists take 2" $ 95 | forAllShrink genIntegerAndList shrinkIntegerAndList (\(x, y) -> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y) 96 | prop "flatMap id == flatten" $ 97 | forAllShrink genListOfLists shrinkListOfLists (\x -> flatMap id x == flatten x) 98 | 99 | describe "flattenAgain" $ do 100 | prop "lists of Integer" $ 101 | forAllShrink genListOfLists shrinkListOfLists (\x -> flatten x == flattenAgain x) 102 | 103 | describe "seqOptional" $ do 104 | it "all Full" $ 105 | seqOptional (Full 1 :. Full 10 :. Nil) `shouldBe` Full (1 :. 10 :. Nil) 106 | it "empty list" $ 107 | let empty = Nil :: List (Optional Integer) 108 | in seqOptional empty `shouldBe` Full Nil 109 | it "contains Empty" $ 110 | seqOptional (Full 1 :. Full 10 :. Empty :. Nil) `shouldBe` Empty 111 | it "Empty at head of infinity" $ 112 | seqOptional (Empty :. map Full infinity) `shouldBe` Empty 113 | 114 | describe "find" $ do 115 | it "find no matches" $ 116 | find even (1 :. 3 :. 5 :. Nil) `shouldBe` Empty 117 | it "empty list" $ find even Nil `shouldBe` Empty 118 | it "find only even" $ 119 | find even (1 :. 2 :. 3 :. 5 :. Nil) `shouldBe` Full 2 120 | it "find first, not second even" $ 121 | find even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` Full 2 122 | it "find on infinite list" $ 123 | find (const True) infinity `shouldBe` Full 0 124 | 125 | describe "lengthGT4" $ do 126 | it "list of length 3" $ 127 | lengthGT4 (1 :. 3 :. 5 :. Nil) `shouldBe` False 128 | it "empty list" $ 129 | lengthGT4 Nil `shouldBe` False 130 | it "list of length 5" $ 131 | lengthGT4 (1 :. 2 :. 3 :. 4 :. 5 :. Nil) `shouldBe` True 132 | it "infinite list" $ 133 | lengthGT4 infinity `shouldBe` True 134 | 135 | describe "reverse" $ do 136 | it "empty list" $ 137 | reverse Nil `shouldBe` (Nil :: List Integer) 138 | it "reverse . reverse on largeList" $ 139 | take 1 (reverse (reverse largeList)) `shouldBe` (1 :. Nil) 140 | prop "reverse then append is same as append then reverse" $ 141 | forAllShrink genTwoLists shrinkTwoLists (\(x, y) -> reverse x ++ reverse y == reverse (y ++ x)) 142 | prop "" $ 143 | forAllLists (\x -> reverse (x :. Nil) == x :. Nil) 144 | 145 | describe "produce" $ do 146 | it "increment" $ 147 | let (x:.y:.z:.w:._) = produce (+1) 0 148 | in (x:.y:.z:.w:.Nil) `shouldBe` (0:.1:.2:.3:.Nil) 149 | it "double" $ 150 | let (x:.y:.z:.w:._) = produce (*2) 1 151 | in (x:.y:.z:.w:.Nil) `shouldBe` (1:.2:.4:.8:.Nil) 152 | -------------------------------------------------------------------------------- /CHEATSHEET.md: -------------------------------------------------------------------------------- 1 | ## Cheatsheet 2 | 3 | ### Vocabulary 4 | 5 | |**Symbol**|**Pronunciation** |**Notes** | 6 | |----------|---------------------|------------------------------------------------| 7 | |`:.` |cons |Adds an element to the front of a list | 8 | |`<$>` |eff-map |Member of the Functor type class | 9 | |`<*>` |app, apply, spaceship|Member of the Applicative type class | 10 | |`>>=` |bind |Member of the Monad type class | 11 | |`bool` |bool |if/then/else with arguments in the reverse order| 12 | 13 | ### Equivalent expressions 14 | 15 | Here are some expressions and their neater, more idiomatic alternatives. 16 | 17 | **Function application** 18 | 19 | `\x -> f x` may be replaced with `f` 20 | 21 | **Composition** 22 | 23 | `\x -> f (g x)` may be replaced with `f . g` 24 | 25 | ### Follow the types 26 | 27 | Rather than thinking operationally, focus on finding values for the types that the compiler is telling you you need. 28 | Once you have a compiling program it's easier to look at what you have and decide if it solves your problem. 29 | 30 | ### Use type holes 31 | 32 | Following on from the previous point, use type holes to discover the types of the values you need to 33 | provide. A type hole is an underscore, or a name prefixed by an underscore (`_`). When GHC sees a 34 | type hole, it will produce a compiler error that tells you the type of the value that should be in 35 | its place. 36 | 37 | As an example, let's assume we're attempting to write a definition for `List.product` using 38 | `foldRight`, but we're not sure how to apply `foldRight` to get our solution. We can start by adding 39 | some type holes. 40 | 41 | ```haskell 42 | product :: 43 | List Int 44 | -> Int 45 | product ns = 46 | foldRight _f _n ns 47 | ``` 48 | 49 | We can now reload the course code in GHCi and see what it tells us. 50 | 51 | ``` 52 | λ> :r 53 | [ 5 of 26] Compiling Course.List ( src/Course/List.hs, interpreted ) 54 | 55 | src/Course/List.hs:95:13: error: 56 | • Found hole: _f :: Int -> Int -> Int 57 | Or perhaps ‘_f’ is mis-spelled, or not in scope 58 | • In the first argument of ‘foldRight’, namely ‘_f’ 59 | In the expression: foldRight _f _n ns 60 | In an equation for ‘product’: product ns = foldRight _f _n ns 61 | • Relevant bindings include 62 | ns :: List Int (bound at src/Course/List.hs:94:9) 63 | product :: List Int -> Int (bound at src/Course/List.hs:94:1) 64 | 65 | src/Course/List.hs:95:16: error: 66 | • Found hole: _n :: Int 67 | Or perhaps ‘_n’ is mis-spelled, or not in scope 68 | • In the second argument of ‘foldRight’, namely ‘_n’ 69 | In the expression: foldRight _f _n ns 70 | In an equation for ‘product’: product ns = foldRight _f _n ns 71 | • Relevant bindings include 72 | ns :: List Int (bound at src/Course/List.hs:94:9) 73 | product :: List Int -> Int (bound at src/Course/List.hs:94:1) 74 | Failed, modules loaded: Course.Core, Course.ExactlyOne, Course.Optional, Course.Validation. 75 | ``` 76 | 77 | GHC is telling us a few helpful things here for each of our holes: 78 | 79 | - The type of the hole: `Found hole: _f :: Int -> Int -> Int` 80 | - Where it found the hole: 81 | ``` 82 | In the first argument of ‘foldRight’, namely ‘_f’ 83 | In the expression: foldRight _f _n ns 84 | In an equation for ‘product’: product ns = foldRight _f _n ns 85 | ``` 86 | - Bindings that are relevant to working out the type of the hole: 87 | ``` 88 | Relevant bindings include 89 | ns :: List Int (bound at src/Course/List.hs:94:9) 90 | product :: List Int -> Int (bound at src/Course/List.hs:94:1) 91 | ``` 92 | 93 | Armed with this information we now have two smaller sub-problems to solve: choosing a function of 94 | type `Int -> Int -> Int`, and choosing a value of type `Int`. 95 | 96 | Keep in mind that this example is just for demonstrating the mechanics of type holes. The pay off 97 | from deploying them increases as the difficulty and complexity of your problem increases, as they 98 | allow you to break your problem into pieces while telling you the type of each piece. 99 | 100 | ### Use `:type` to ask GHC the type of expressions 101 | 102 | If you've forgotten the type of an expression, or want to check if part of a solution type checks 103 | and has the type that you expect, use `:type` or `:t` in GHCi. 104 | 105 | ``` 106 | λ> :t (:.) 107 | (:.) :: t -> List t -> List t 108 | λ> :t (:.) 5 109 | (:.) 5 :: Num t => List t -> List t 110 | λ> :t Nil 111 | Nil :: List t 112 | λ> :t (:.) 5 Nil 113 | (:.) 5 Nil :: Num t => List t 114 | λ> (:.) 5 Nil 115 | [5] 116 | ``` 117 | 118 | ### Use `:info` to ask GHC questions 119 | 120 | If you ever want to know what an identifier is, you can ask GHCi using `:info` or just `:i`. For 121 | example, if you see `List` somewhere in your code and want to know more about it, enter `:i List` in 122 | GHCi. As shown below, it will print the constructors for values of that type, as well as the 123 | instances for any type classes that are in scope. 124 | 125 | ``` 126 | λ> :i List 127 | data List t = Nil | t :. (List t) 128 | -- Defined at src/Course/List.hs:34:1 129 | instance [safe] Eq t => Eq (List t) 130 | -- Defined at src/Course/List.hs:37:13 131 | instance [safe] Ord t => Ord (List t) 132 | -- Defined at src/Course/List.hs:37:17 133 | instance [safe] Show t => Show (List t) 134 | -- Defined at src/Course/List.hs:42:10 135 | instance [safe] IsString (List Char) 136 | -- Defined at src/Course/List.hs:662:10 137 | instance [safe] Functor List 138 | -- Defined at src/Course/Functor.hs:54:10 139 | instance [safe] Extend List 140 | -- Defined at src/Course/Extend.hs:49:10 141 | instance [safe] Applicative List 142 | -- Defined at src/Course/Applicative.hs:65:10 143 | instance [safe] Monad List -- Defined at src/Course/Monad.hs:46:10 144 | instance [safe] Traversable List 145 | -- Defined at src/Course/Traversable.hs:33:10 146 | ``` 147 | 148 | ### Providing functions 149 | 150 | If you're ever stuck providing a function as an argument or return value, insert a lambda with a 151 | type hole. Continue this process recursively until you need to provide a simple value, then follow 152 | the definitions back out. 153 | 154 | Following on from our type holes example, if we're trying to solve `product` with `foldRight` and we 155 | know the first argument to `foldRight` is a function, start by inserting the lambda. 156 | 157 | ```haskell 158 | product :: 159 | List Int 160 | -> Int 161 | product ns = 162 | foldRight (\a b -> _c) _n ns 163 | ``` 164 | 165 | After reloading this code, GHCi will tell us the type of `_c`, which in this case is `Int`. From the 166 | previous type hole example, we know that both `a` and `b` are type `Int` (`_f :: Int -> Int -> 167 | Int`), so it looks like we should do something with two `Int`s to produce an `Int`. A few operations 168 | come to mind, but given we're defining `product`, let's go with multiplication. 169 | 170 | ```haskell 171 | product ns = 172 | foldRight (\a b -> a * b) _n ns 173 | ``` 174 | 175 | It type checks. From here we'd need to pick an `Int` to replace `_n` and we'd have a solution that 176 | at least type checks. 177 | 178 | If `_c` had the type of another function, we'd simply insert another lambda in its place and 179 | continue recursing. Alternatively, if `_c` had type `WhoosyWhatsits` and we didn't know anything 180 | about that type or how to construct it, we could just ask GHCi using `:i WhoosyWhatsits` and 181 | continue from there. 182 | 183 | ### Handling arguments 184 | 185 | When you're not sure what to do with a function argument, try pattern matching it and looking at the 186 | values that are brought into scope. 187 | 188 | ```haskell 189 | data Bar = Bar Chars Int Chars 190 | 191 | foo :: Bar -> Int 192 | foo (Bar _ n _) = n 193 | ``` 194 | 195 | If your argument is a sum type that has multiple constructors, use `case` to pattern match and 196 | handle each case individually. 197 | 198 | ```haskell 199 | data Baz = 200 | C1 Int 201 | | C2 Chars Int 202 | 203 | quux :: Baz -> Int 204 | quux baz = 205 | case baz of 206 | C1 n -> n 207 | C2 _ n -> n 208 | ``` 209 | 210 | You can also nest pattern matches as needed. 211 | 212 | ```haskell 213 | data Thingo = 214 | X Int 215 | | Y (Optional Int) 216 | 217 | f :: Thingo -> List Int 218 | f t = 219 | case t of 220 | X n -> n :. Nil 221 | Y (Full n) -> n :. Nil 222 | Y Empty -> Nil 223 | ``` 224 | 225 | Finally, when you're not sure how to pattern match the argument because you don't know what its 226 | constructors are, use `:info` as described above to find out. 227 | 228 | ``` 229 | λ> :i Baz 230 | data Baz = C1 Int | C2 Chars Int 231 | ``` 232 | -------------------------------------------------------------------------------- /src/Course/MonadTutorial.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Course.MonadTutorial where 4 | 5 | import Control.Category(Category((.))) 6 | import Control.Monad(Monad(..), (=<<)) 7 | import Data.Eq(Eq) 8 | import Data.Foldable(foldr) 9 | import Data.Functor(Functor(fmap)) 10 | import Data.Int(Int) 11 | import Data.String(IsString(fromString)) 12 | import Prelude(Show) 13 | import System.IO(IO) 14 | 15 | {- 16 | 17 | -------------------------------------------------------------------------------- 18 | WARNING: DO NOT PROCEED 19 | ----------------------- 20 | 21 | It is strongly advised that pre-requisite exercises have been covered prior to 22 | utilising this tutorial. Refusing this advice increases likelihood of a crash 23 | and burn result. 24 | 25 | Please complete the following exercises before proceeding: 26 | * Course/Functor 27 | * Course/Applicative 28 | -------------------------------------------------------------------------------- 29 | 30 | In this source file, you will find a recurring pattern: 31 | 32 | * A data structure definition. 33 | * A function named @bind@ for that data structure. The bind function will 34 | follow a specific pattern in its type: 35 | 36 | @(a -> f b) -> f a -> f b@ 37 | 38 | * A function named @pure@ for that data structure. The pure function will 39 | follow a specific pattern in its type: 40 | 41 | @a -> f a@ 42 | 43 | * A function named @sequence@ for that data structure. The sequence 44 | function will follow a specific pattern in its type: 45 | 46 | @[f a] -> f [a] 47 | 48 | Note that the sequence functions are written in terms of the bind and pure 49 | functions for that data type. The goal is to first acknowledge the repeating 50 | code in the sequence functions, and then construct a plan to refactor out the 51 | similarities. Ultimately, there should be only a single sequence function that is 52 | written in terms of "things that have bind and pure functions." 53 | 54 | A type-class denoting "things that have bind and pure functions" is provided. It 55 | is named @BindAndPure@. 56 | 57 | Examine the existing data structures, their implementations of bind and pure, 58 | then implement a single sequence function that generalises all the specific 59 | sequence functions. 60 | 61 | The data structures given are: 62 | * Id 63 | * Optional 64 | * IntReader 65 | * Reader 66 | * IntState 67 | * State 68 | * Or 69 | * ListFree 70 | * IntReaderFree 71 | * ReaderFree 72 | * Free 73 | * IO 74 | 75 | -} 76 | 77 | data Id a = 78 | Id a 79 | deriving (Eq, Show) 80 | 81 | bindId :: 82 | (a -> Id b) 83 | -> Id a 84 | -> Id b 85 | bindId f (Id a) = 86 | f a 87 | 88 | pureId :: 89 | a 90 | -> Id a 91 | pureId = 92 | Id 93 | 94 | sequenceId :: 95 | [Id a] 96 | -> Id [a] 97 | sequenceId = 98 | foldr (\a as -> 99 | bindId (\a' -> 100 | bindId (\as' -> 101 | pureId (a' : as')) as) a) 102 | (pureId []) 103 | 104 | ---- 105 | 106 | data Optional a = 107 | Empty 108 | | Full a 109 | deriving (Eq, Show) 110 | 111 | bindOptional :: 112 | (a -> Optional b) 113 | -> Optional a 114 | -> Optional b 115 | bindOptional _ Empty = 116 | Empty 117 | bindOptional f (Full a) = 118 | f a 119 | 120 | pureOptional :: 121 | a 122 | -> Optional a 123 | pureOptional = 124 | Full 125 | 126 | sequenceOptional :: 127 | [Optional a] 128 | -> Optional [a] 129 | sequenceOptional = 130 | foldr (\a as -> 131 | bindOptional (\a' -> 132 | bindOptional (\as' -> 133 | pureOptional (a' : as')) as) a) 134 | (pureOptional []) 135 | 136 | ---- 137 | 138 | data IntReader a = 139 | IntReader (Int -> a) 140 | 141 | bindIntReader :: 142 | (a -> IntReader b) 143 | -> IntReader a 144 | -> IntReader b 145 | bindIntReader f (IntReader g) = 146 | IntReader (\x -> let IntReader r = f (g x) in r x) 147 | 148 | pureIntReader :: 149 | a 150 | -> IntReader a 151 | pureIntReader = 152 | IntReader . return 153 | 154 | sequenceIntReader :: 155 | [IntReader a] 156 | -> IntReader [a] 157 | sequenceIntReader = 158 | foldr (\a as -> 159 | bindIntReader (\a' -> 160 | bindIntReader (\as' -> 161 | pureIntReader (a' : as')) as) a) 162 | (pureIntReader []) 163 | 164 | ---- 165 | 166 | data Reader r a = 167 | Reader (r -> a) 168 | 169 | bindReader :: 170 | (a -> Reader r b) 171 | -> Reader r a 172 | -> Reader r b 173 | bindReader f (Reader g) = 174 | Reader (\x -> let Reader r = f (g x) in r x) 175 | 176 | pureReader :: 177 | a 178 | -> Reader r a 179 | pureReader = 180 | Reader . return 181 | 182 | sequenceReader :: 183 | [Reader r a] 184 | -> Reader r [a] 185 | sequenceReader = 186 | foldr (\a as -> 187 | bindReader (\a' -> 188 | bindReader (\as' -> 189 | pureReader (a' : as')) as) a) 190 | (pureReader []) 191 | 192 | ---- 193 | 194 | data IntState a = 195 | IntState (Int -> (a, Int)) 196 | 197 | bindIntState :: 198 | (a -> IntState b) 199 | -> IntState a 200 | -> IntState b 201 | bindIntState f (IntState g) = 202 | IntState (\i -> 203 | let (a, j) = g i 204 | IntState h = f a 205 | in h j) 206 | 207 | pureIntState :: 208 | a 209 | -> IntState a 210 | pureIntState a = 211 | IntState (\i -> (a, i)) 212 | 213 | sequenceIntState :: 214 | [IntState a] 215 | -> IntState [a] 216 | sequenceIntState = 217 | foldr (\a as -> 218 | bindIntState (\a' -> 219 | bindIntState (\as' -> 220 | pureIntState (a' : as')) as) a) 221 | (pureIntState []) 222 | 223 | ---- 224 | 225 | data State s a = 226 | State (s -> (a, s)) 227 | 228 | bindState :: 229 | (a -> State s b) 230 | -> State s a 231 | -> State s b 232 | bindState f (State g) = 233 | State (\s -> 234 | let (a, t) = g s 235 | State h = f a 236 | in h t) 237 | 238 | pureState :: 239 | a 240 | -> State s a 241 | pureState a = 242 | State (\s -> (a, s)) 243 | 244 | sequenceState :: 245 | [State s a] 246 | -> State s [a] 247 | sequenceState = 248 | foldr (\a as -> 249 | bindState (\a' -> 250 | bindState (\as' -> 251 | pureState (a' : as')) as) a) 252 | (pureState []) 253 | 254 | ---- 255 | 256 | data Or t a = 257 | This t 258 | | That a 259 | deriving (Eq, Show) 260 | 261 | bindOr :: 262 | (a -> Or t b) 263 | -> Or t a 264 | -> Or t b 265 | bindOr _ (This t) = 266 | This t 267 | bindOr f (That a) = 268 | f a 269 | 270 | pureOr :: 271 | a 272 | -> Or t a 273 | pureOr = 274 | That 275 | 276 | sequenceOr :: 277 | [Or t a] 278 | -> Or t [a] 279 | sequenceOr = 280 | foldr (\a as -> 281 | bindOr (\a' -> 282 | bindOr (\as' -> 283 | pureOr (a' : as')) as) a) 284 | (pureOr []) 285 | 286 | ---- 287 | 288 | data ListFree a = 289 | ListDone a 290 | | ListMore [ListFree a] 291 | deriving (Eq, Show) 292 | 293 | bindListFree :: 294 | (a -> ListFree b) 295 | -> ListFree a 296 | -> ListFree b 297 | bindListFree f (ListDone a) = 298 | f a 299 | bindListFree f (ListMore r) = 300 | ListMore (fmap (bindListFree f) r) 301 | 302 | pureListFree :: 303 | a 304 | -> ListFree a 305 | pureListFree = 306 | ListDone 307 | 308 | sequenceListFree :: 309 | [ListFree a] 310 | -> ListFree [a] 311 | sequenceListFree = 312 | foldr (\a as -> 313 | bindListFree (\a' -> 314 | bindListFree (\as' -> 315 | pureListFree (a' : as')) as) a) 316 | (pureListFree []) 317 | 318 | ---- 319 | 320 | data IntReaderFree a = 321 | IntReaderDone a 322 | | IntReaderMore [IntReaderFree a] 323 | deriving (Eq, Show) 324 | 325 | bindIntReaderFree :: 326 | (a -> IntReaderFree b) 327 | -> IntReaderFree a 328 | -> IntReaderFree b 329 | bindIntReaderFree f (IntReaderDone a) = 330 | f a 331 | bindIntReaderFree f (IntReaderMore r) = 332 | IntReaderMore (fmap (bindIntReaderFree f) r) 333 | 334 | pureIntReaderFree :: 335 | a 336 | -> IntReaderFree a 337 | pureIntReaderFree = 338 | IntReaderDone 339 | 340 | sequenceIntReaderFree :: 341 | [IntReaderFree a] 342 | -> IntReaderFree [a] 343 | sequenceIntReaderFree = 344 | foldr (\a as -> 345 | bindIntReaderFree (\a' -> 346 | bindIntReaderFree (\as' -> 347 | pureIntReaderFree (a' : as')) as) a) 348 | (pureIntReaderFree []) 349 | 350 | ---- 351 | 352 | data ReaderFree r a = 353 | ReaderDone a 354 | | ReaderMore (Reader r (ReaderFree r a)) 355 | 356 | bindReaderFree :: 357 | (a -> ReaderFree r b) 358 | -> ReaderFree r a 359 | -> ReaderFree r b 360 | bindReaderFree f (ReaderDone a) = 361 | f a 362 | bindReaderFree f (ReaderMore (Reader r)) = 363 | ReaderMore (Reader (bindReaderFree f . r)) 364 | 365 | pureReaderFree :: 366 | a 367 | -> ReaderFree r a 368 | pureReaderFree = 369 | ReaderDone 370 | 371 | sequenceReaderFree :: 372 | [ReaderFree r a] 373 | -> ReaderFree r [a] 374 | sequenceReaderFree = 375 | foldr (\a as -> 376 | bindReaderFree (\a' -> 377 | bindReaderFree (\as' -> 378 | pureReaderFree (a' : as')) as) a) 379 | (pureReaderFree []) 380 | 381 | ---- 382 | 383 | data Free f a = 384 | Done a 385 | | More (f (Free f a)) 386 | 387 | bindFree :: 388 | Functor f => 389 | (a -> Free f b) 390 | -> Free f a 391 | -> Free f b 392 | bindFree f (Done a) = 393 | f a 394 | bindFree f (More r) = 395 | More (fmap (bindFree f) r) 396 | 397 | pureFree :: 398 | a 399 | -> Free f a 400 | pureFree = 401 | Done 402 | 403 | sequenceFree :: 404 | Functor f => 405 | [Free f a] 406 | -> Free f [a] 407 | sequenceFree = 408 | foldr (\a as -> 409 | bindFree (\a' -> 410 | bindFree (\as' -> 411 | pureFree (a' : as')) as) a) 412 | (pureFree []) 413 | 414 | ---- 415 | 416 | -- data IO = … 417 | 418 | bindIO :: 419 | (a -> IO b) 420 | -> IO a 421 | -> IO b 422 | bindIO f o = 423 | f =<< o 424 | 425 | pureIO :: 426 | a 427 | -> IO a 428 | pureIO = 429 | return 430 | 431 | sequenceIO :: 432 | [IO a] 433 | -> IO [a] 434 | sequenceIO = 435 | foldr (\a as -> 436 | bindIO (\a' -> 437 | bindIO (\as' -> 438 | pureIO (a' : as')) as) a) 439 | (pureIO []) 440 | 441 | ---- 442 | 443 | class BindAndPure f where 444 | bind :: 445 | (a -> f b) 446 | -> f a 447 | -> f b 448 | pure :: 449 | a 450 | -> f a 451 | 452 | -------------------------------------------------------------------------------- /src/Course/Cheque.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | {- 6 | 7 | Write a function (dollars) that accepts a `String` and returns a `String`. 8 | It will accept a numeric value as input, representing an amount of money, and convert to its transcribed English. 9 | 10 | For example, the input "1.11" will result in a return value of "one dollar and eleven cents" 11 | 12 | Invalid characters should be ignored, meaning that every input string has an output string. 13 | The empty string produces "zero dollars and zero cents" 14 | 15 | There is a `test` function below that lists more examples of input and output. There are also functions and 16 | data structures that may assist you in deriving the result. It is not compulsory that they are used. 17 | 18 | -} 19 | 20 | module Course.Cheque where 21 | 22 | import Course.Core 23 | import Course.Optional 24 | import Course.List 25 | import Course.Functor 26 | import Course.Applicative 27 | import Course.Monad 28 | 29 | -- $setup 30 | -- >>> :set -XOverloadedStrings 31 | 32 | -- The representation of the grouping of each exponent of one thousand. ["thousand", "million", ...] 33 | illion :: 34 | List Chars 35 | illion = 36 | let preillion :: 37 | List (Chars -> Chars) 38 | preillion = 39 | listh [ 40 | const "" 41 | , const "un" 42 | , const "do" 43 | , const "tre" 44 | , const "quattuor" 45 | , const "quin" 46 | , const "sex" 47 | , const "septen" 48 | , const "octo" 49 | , \q -> if "n" `isPrefixOf` q then "novem" else "noven" 50 | ] 51 | postillion :: 52 | List Chars 53 | postillion = 54 | listh [ 55 | "vigintillion" 56 | , "trigintillion" 57 | , "quadragintillion" 58 | , "quinquagintillion" 59 | , "sexagintillion" 60 | , "septuagintillion" 61 | , "octogintillion" 62 | , "nonagintillion" 63 | , "centillion" 64 | , "decicentillion" 65 | , "viginticentillion" 66 | , "trigintacentillion" 67 | , "quadragintacentillion" 68 | , "quinquagintacentillion" 69 | , "sexagintacentillion" 70 | , "septuagintacentillion" 71 | , "octogintacentillion" 72 | , "nonagintacentillion" 73 | , "ducentillion" 74 | , "deciducentillion" 75 | , "vigintiducentillion" 76 | , "trigintaducentillion" 77 | , "quadragintaducentillion" 78 | , "quinquagintaducentillion" 79 | , "sexagintaducentillion" 80 | , "septuagintaducentillion" 81 | , "octogintaducentillion" 82 | , "nonagintaducentillion" 83 | , "trecentillion" 84 | , "decitrecentillion" 85 | , "vigintitrecentillion" 86 | , "trigintatrecentillion" 87 | , "quadragintatrecentillion" 88 | , "quinquagintatrecentillion" 89 | , "sexagintatrecentillion" 90 | , "septuagintatrecentillion" 91 | , "octogintatrecentillion" 92 | , "nonagintatrecentillion" 93 | , "quadringentillion" 94 | , "deciquadringentillion" 95 | , "vigintiquadringentillion" 96 | , "trigintaquadringentillion" 97 | , "quadragintaquadringentillion" 98 | , "quinquagintaquadringentillion" 99 | , "sexagintaquadringentillion" 100 | , "septuagintaquadringentillion" 101 | , "octogintaquadringentillion" 102 | , "nonagintaquadringentillion" 103 | , "quingentillion" 104 | , "deciquingentillion" 105 | , "vigintiquingentillion" 106 | , "trigintaquingentillion" 107 | , "quadragintaquingentillion" 108 | , "quinquagintaquingentillion" 109 | , "sexagintaquingentillion" 110 | , "septuagintaquingentillion" 111 | , "octogintaquingentillion" 112 | , "nonagintaquingentillion" 113 | , "sescentillion" 114 | , "decisescentillion" 115 | , "vigintisescentillion" 116 | , "trigintasescentillion" 117 | , "quadragintasescentillion" 118 | , "quinquagintasescentillion" 119 | , "sexagintasescentillion" 120 | , "septuagintasescentillion" 121 | , "octogintasescentillion" 122 | , "nonagintasescentillion" 123 | , "septingentillion" 124 | , "deciseptingentillion" 125 | , "vigintiseptingentillion" 126 | , "trigintaseptingentillion" 127 | , "quadragintaseptingentillion" 128 | , "quinquagintaseptingentillion" 129 | , "sexagintaseptingentillion" 130 | , "septuagintaseptingentillion" 131 | , "octogintaseptingentillion" 132 | , "nonagintaseptingentillion" 133 | , "octingentillion" 134 | , "decioctingentillion" 135 | , "vigintioctingentillion" 136 | , "trigintaoctingentillion" 137 | , "quadragintaoctingentillion" 138 | , "quinquagintaoctingentillion" 139 | , "sexagintaoctingentillion" 140 | , "septuagintaoctingentillion" 141 | , "octogintaoctingentillion" 142 | , "nonagintaoctingentillion" 143 | , "nongentillion" 144 | , "decinongentillion" 145 | , "vigintinongentillion" 146 | , "trigintanongentillion" 147 | , "quadragintanongentillion" 148 | , "quinquagintanongentillion" 149 | , "sexagintanongentillion" 150 | , "septuagintanongentillion" 151 | , "octogintanongentillion" 152 | , "nonagintanongentillion" 153 | ] 154 | in listh [ 155 | "" 156 | , "thousand" 157 | , "million" 158 | , "billion" 159 | , "trillion" 160 | , "quadrillion" 161 | , "quintillion" 162 | , "sextillion" 163 | , "septillion" 164 | , "octillion" 165 | , "nonillion" 166 | , "decillion" 167 | , "undecillion" 168 | , "duodecillion" 169 | , "tredecillion" 170 | , "quattuordecillion" 171 | , "quindecillion" 172 | , "sexdecillion" 173 | , "septendecillion" 174 | , "octodecillion" 175 | , "novemdecillion" 176 | ] ++ lift2 ((++) =<<) preillion postillion 177 | 178 | -- A data type representing the digits zero to nine. 179 | data Digit = 180 | Zero 181 | | One 182 | | Two 183 | | Three 184 | | Four 185 | | Five 186 | | Six 187 | | Seven 188 | | Eight 189 | | Nine 190 | deriving (Eq, Ord) 191 | 192 | showDigit :: 193 | Digit 194 | -> Chars 195 | showDigit Zero = 196 | "zero" 197 | showDigit One = 198 | "one" 199 | showDigit Two = 200 | "two" 201 | showDigit Three = 202 | "three" 203 | showDigit Four = 204 | "four" 205 | showDigit Five = 206 | "five" 207 | showDigit Six = 208 | "six" 209 | showDigit Seven = 210 | "seven" 211 | showDigit Eight = 212 | "eight" 213 | showDigit Nine = 214 | "nine" 215 | 216 | -- A data type representing one, two or three digits, which may be useful for grouping. 217 | data Digit3 = 218 | D1 Digit 219 | | D2 Digit Digit 220 | | D3 Digit Digit Digit 221 | deriving Eq 222 | 223 | -- Possibly convert a character to a digit. 224 | fromChar :: 225 | Char 226 | -> Optional Digit 227 | fromChar '0' = 228 | Full Zero 229 | fromChar '1' = 230 | Full One 231 | fromChar '2' = 232 | Full Two 233 | fromChar '3' = 234 | Full Three 235 | fromChar '4' = 236 | Full Four 237 | fromChar '5' = 238 | Full Five 239 | fromChar '6' = 240 | Full Six 241 | fromChar '7' = 242 | Full Seven 243 | fromChar '8' = 244 | Full Eight 245 | fromChar '9' = 246 | Full Nine 247 | fromChar _ = 248 | Empty 249 | 250 | -- | Take a numeric value and produce its English output. 251 | -- 252 | -- >>> dollars "0" 253 | -- "zero dollars and zero cents" 254 | -- 255 | -- >>> dollars "1" 256 | -- "one dollar and zero cents" 257 | -- 258 | -- >>> dollars "0.1" 259 | -- "zero dollars and ten cents" 260 | -- 261 | -- >>> dollars "1." 262 | -- "one dollar and zero cents" 263 | -- 264 | -- >>> dollars "0." 265 | -- "zero dollars and zero cents" 266 | -- 267 | -- >>> dollars "0.0" 268 | -- "zero dollars and zero cents" 269 | -- 270 | -- >>> dollars ".34" 271 | -- "zero dollars and thirty-four cents" 272 | -- 273 | -- >>> dollars "0.3456789" 274 | -- "zero dollars and thirty-four cents" 275 | -- 276 | -- >>> dollars "1.0" 277 | -- "one dollar and zero cents" 278 | -- 279 | -- >>> dollars "1.01" 280 | -- "one dollar and one cent" 281 | -- 282 | -- >>> dollars "a1a" 283 | -- "one dollar and zero cents" 284 | -- 285 | -- >>> dollars "a1a.a0.7b" 286 | -- "one dollar and seven cents" 287 | -- 288 | -- >>> dollars "100" 289 | -- "one hundred dollars and zero cents" 290 | -- 291 | -- >>> dollars "100.0" 292 | -- "one hundred dollars and zero cents" 293 | -- 294 | -- >>> dollars "100.00" 295 | -- "one hundred dollars and zero cents" 296 | -- 297 | -- >>> dollars "100.00000" 298 | -- "one hundred dollars and zero cents" 299 | -- 300 | -- >>> dollars "1000456.13" 301 | -- "one million four hundred and fifty-six dollars and thirteen cents" 302 | -- 303 | -- >>> dollars "1001456.13" 304 | -- "one million one thousand four hundred and fifty-six dollars and thirteen cents" 305 | -- 306 | -- >>> dollars "16000000456.13" 307 | -- "sixteen billion four hundred and fifty-six dollars and thirteen cents" 308 | -- 309 | -- >>> dollars "100.45" 310 | -- "one hundred dollars and forty-five cents" 311 | -- 312 | -- >>> dollars "100.07" 313 | -- "one hundred dollars and seven cents" 314 | -- 315 | -- >>> dollars "9abc9def9ghi.jkl9mno" 316 | -- "nine hundred and ninety-nine dollars and ninety cents" 317 | -- 318 | -- >>> dollars "12345.67" 319 | -- "twelve thousand three hundred and forty-five dollars and sixty-seven cents" 320 | -- 321 | -- >>> dollars "456789123456789012345678901234567890123456789012345678901234567890.12" 322 | -- "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" 323 | dollars :: 324 | Chars 325 | -> Chars 326 | dollars = 327 | error "todo: Course.Cheque#dollars" 328 | -------------------------------------------------------------------------------- /src/Course/StateT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Course.StateT where 8 | 9 | import Course.Core 10 | import Course.ExactlyOne 11 | import Course.Optional 12 | import Course.List 13 | import Course.Functor 14 | import Course.Applicative 15 | import Course.Monad 16 | import Course.State 17 | import qualified Data.Set as S 18 | import qualified Prelude as P 19 | 20 | -- $setup 21 | -- >>> import Test.QuickCheck 22 | -- >>> import qualified Prelude as P(fmap) 23 | -- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap listh arbitrary 24 | 25 | -- | A `StateT` is a function from a state value `s` to a functor f of (a produced value `a`, and a resulting state `s`). 26 | newtype StateT s f a = 27 | StateT { 28 | runStateT :: 29 | s 30 | -> f (a, s) 31 | } 32 | 33 | -- | Implement the `Functor` instance for @StateT s f@ given a @Functor f@. 34 | -- 35 | -- >>> runStateT ((+1) <$> (pure 2) :: StateT Int List Int) 0 36 | -- [(3,0)] 37 | instance Functor f => Functor (StateT s f) where 38 | (<$>) :: 39 | (a -> b) 40 | -> StateT s f a 41 | -> StateT s f b 42 | (<$>) = 43 | error "todo: Course.StateT (<$>)#instance (StateT s f)" 44 | 45 | -- | Implement the `Applicative` instance for @StateT s f@ given a @Monad f@. 46 | -- 47 | -- >>> runStateT (pure 2) 0 48 | -- (2,0) 49 | -- 50 | -- >>> runStateT ((pure 2) :: StateT Int List Int) 0 51 | -- [(2,0)] 52 | -- 53 | -- >>> runStateT (pure (+2) <*> ((pure 2) :: StateT Int List Int)) 0 54 | -- [(4,0)] 55 | -- 56 | -- >>> import qualified Prelude as P 57 | -- >>> runStateT (StateT (\s -> Full ((+2), s P.++ [1])) <*> (StateT (\s -> Full (2, s P.++ [2])))) [0] 58 | -- Full (4,[0,1,2]) 59 | -- 60 | -- >>> runStateT (StateT (\s -> ((+2), s P.++ [1]) :. ((+3), s P.++ [1]) :. Nil) <*> (StateT (\s -> (2, s P.++ [2]) :. Nil))) [0] 61 | -- [(4,[0,1,2]),(5,[0,1,2])] 62 | instance Monad f => Applicative (StateT s f) where 63 | pure :: 64 | a 65 | -> StateT s f a 66 | pure = 67 | error "todo: Course.StateT pure#instance (StateT s f)" 68 | (<*>) :: 69 | StateT s f (a -> b) 70 | -> StateT s f a 71 | -> StateT s f b 72 | (<*>) = 73 | error "todo: Course.StateT (<*>)#instance (StateT s f)" 74 | 75 | -- | Implement the `Monad` instance for @StateT s f@ given a @Monad f@. 76 | -- Make sure the state value is passed through in `bind`. 77 | -- 78 | -- >>> runStateT ((const $ putT 2) =<< putT 1) 0 79 | -- ((),2) 80 | -- 81 | -- >>> let modify f = StateT (\s -> pure ((), f s)) in runStateT (modify (+1) >>= \() -> modify (*2)) 7 82 | -- ((),16) 83 | instance Monad f => Monad (StateT s f) where 84 | (=<<) :: 85 | (a -> StateT s f b) 86 | -> StateT s f a 87 | -> StateT s f b 88 | (=<<) = 89 | error "todo: Course.StateT (=<<)#instance (StateT s f)" 90 | 91 | -- | A `State'` is `StateT` specialised to the `ExactlyOne` functor. 92 | type State' s a = 93 | StateT s ExactlyOne a 94 | 95 | -- | Provide a constructor for `State'` values 96 | -- 97 | -- >>> runStateT (state' $ runState $ put 1) 0 98 | -- ExactlyOne ((),1) 99 | state' :: 100 | (s -> (a, s)) 101 | -> State' s a 102 | state' = 103 | error "todo: Course.StateT#state'" 104 | 105 | -- | Provide an unwrapper for `State'` values. 106 | -- 107 | -- >>> runState' (state' $ runState $ put 1) 0 108 | -- ((),1) 109 | runState' :: 110 | State' s a 111 | -> s 112 | -> (a, s) 113 | runState' = 114 | error "todo: Course.StateT#runState'" 115 | 116 | -- | Run the `StateT` seeded with `s` and retrieve the resulting state. 117 | execT :: 118 | Functor f => 119 | StateT s f a 120 | -> s 121 | -> f s 122 | execT = 123 | error "todo: Course.StateT#execT" 124 | 125 | -- | Run the `State` seeded with `s` and retrieve the resulting state. 126 | exec' :: 127 | State' s a 128 | -> s 129 | -> s 130 | exec' = 131 | error "todo: Course.StateT#exec'" 132 | 133 | -- | Run the `StateT` seeded with `s` and retrieve the resulting value. 134 | evalT :: 135 | Functor f => 136 | StateT s f a 137 | -> s 138 | -> f a 139 | evalT = 140 | error "todo: Course.StateT#evalT" 141 | 142 | -- | Run the `State` seeded with `s` and retrieve the resulting value. 143 | eval' :: 144 | State' s a 145 | -> s 146 | -> a 147 | eval' = 148 | error "todo: Course.StateT#eval'" 149 | 150 | -- | A `StateT` where the state also distributes into the produced value. 151 | -- 152 | -- >>> (runStateT (getT :: StateT Int List Int) 3) 153 | -- [(3,3)] 154 | getT :: 155 | Applicative f => 156 | StateT s f s 157 | getT = 158 | error "todo: Course.StateT#getT" 159 | 160 | -- | A `StateT` where the resulting state is seeded with the given value. 161 | -- 162 | -- >>> runStateT (putT 2) 0 163 | -- ((),2) 164 | -- 165 | -- >>> runStateT (putT 2 :: StateT Int List ()) 0 166 | -- [((),2)] 167 | putT :: 168 | Applicative f => 169 | s 170 | -> StateT s f () 171 | putT = 172 | error "todo: Course.StateT#putT" 173 | 174 | -- | Remove all duplicate elements in a `List`. 175 | -- 176 | -- /Tip:/ Use `filtering` and `State'` with a @Data.Set#Set@. 177 | -- 178 | -- prop> \xs -> distinct' xs == distinct' (flatMap (\x -> x :. x :. Nil) xs) 179 | distinct' :: 180 | (Ord a, Num a) => 181 | List a 182 | -> List a 183 | distinct' = 184 | error "todo: Course.StateT#distinct'" 185 | 186 | -- | Remove all duplicate elements in a `List`. 187 | -- However, if you see a value greater than `100` in the list, 188 | -- abort the computation by producing `Empty`. 189 | -- 190 | -- /Tip:/ Use `filtering` and `StateT` over `Optional` with a @Data.Set#Set@. 191 | -- 192 | -- >>> distinctF $ listh [1,2,3,2,1] 193 | -- Full [1,2,3] 194 | -- 195 | -- >>> distinctF $ listh [1,2,3,2,1,101] 196 | -- Empty 197 | distinctF :: 198 | (Ord a, Num a) => 199 | List a 200 | -> Optional (List a) 201 | distinctF = 202 | error "todo: Course.StateT#distinctF" 203 | 204 | -- | An `OptionalT` is a functor of an `Optional` value. 205 | data OptionalT f a = 206 | OptionalT { 207 | runOptionalT :: 208 | f (Optional a) 209 | } 210 | 211 | -- | Implement the `Functor` instance for `OptionalT f` given a Functor f. 212 | -- 213 | -- >>> runOptionalT $ (+1) <$> OptionalT (Full 1 :. Empty :. Nil) 214 | -- [Full 2,Empty] 215 | instance Functor f => Functor (OptionalT f) where 216 | (<$>) = 217 | error "todo: Course.StateT (<$>)#instance (OptionalT f)" 218 | 219 | -- | Implement the `Applicative` instance for `OptionalT f` given a Monad f. 220 | -- 221 | -- /Tip:/ Use `onFull` to help implement (<*>). 222 | -- 223 | -- >>> runOptionalT $ OptionalT Nil <*> OptionalT (Full 1 :. Full 2 :. Nil) 224 | -- [] 225 | -- 226 | -- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT Nil 227 | -- [] 228 | -- 229 | -- >>> runOptionalT $ OptionalT (Empty :. Nil) <*> OptionalT (Empty :. Nil) 230 | -- [Empty] 231 | -- 232 | -- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Empty :. Nil) 233 | -- [Empty,Empty] 234 | -- 235 | -- >>> runOptionalT $ OptionalT (Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) 236 | -- [Empty] 237 | -- 238 | -- >>> runOptionalT $ OptionalT (Full (+1) :. Empty :. Nil) <*> OptionalT (Full 1 :. Full 2 :. Nil) 239 | -- [Full 2,Full 3,Empty] 240 | -- 241 | -- >>> runOptionalT $ OptionalT (Full (+1) :. Full (+2) :. Nil) <*> OptionalT (Full 1 :. Empty :. Nil) 242 | -- [Full 2,Empty,Full 3,Empty] 243 | instance Monad f => Applicative (OptionalT f) where 244 | pure = 245 | error "todo: Course.StateT pure#instance (OptionalT f)" 246 | (<*>) = 247 | error "todo: Course.StateT (<*>)#instance (OptionalT f)" 248 | 249 | -- | Implement the `Monad` instance for `OptionalT f` given a Monad f. 250 | -- 251 | -- >>> runOptionalT $ (\a -> OptionalT (Full (a+1) :. Full (a+2) :. Nil)) =<< OptionalT (Full 1 :. Empty :. Nil) 252 | -- [Full 2,Full 3,Empty] 253 | instance Monad f => Monad (OptionalT f) where 254 | (=<<) = 255 | error "todo: Course.StateT (=<<)#instance (OptionalT f)" 256 | 257 | -- | A `Logger` is a pair of a list of log values (`[l]`) and an arbitrary value (`a`). 258 | data Logger l a = 259 | Logger (List l) a 260 | deriving (Eq, Show) 261 | 262 | -- | Implement the `Functor` instance for `Logger 263 | -- 264 | -- >>> (+3) <$> Logger (listh [1,2]) 3 265 | -- Logger [1,2] 6 266 | instance Functor (Logger l) where 267 | (<$>) = 268 | error "todo: Course.StateT (<$>)#instance (Logger l)" 269 | 270 | -- | Implement the `Applicative` instance for `Logger`. 271 | -- 272 | -- >>> pure "table" :: Logger Int P.String 273 | -- Logger [] "table" 274 | -- 275 | -- >>> Logger (listh [1,2]) (+7) <*> Logger (listh [3,4]) 3 276 | -- Logger [1,2,3,4] 10 277 | instance Applicative (Logger l) where 278 | pure = 279 | error "todo: Course.StateT pure#instance (Logger l)" 280 | (<*>) = 281 | error "todo: Course.StateT (<*>)#instance (Logger l)" 282 | 283 | -- | Implement the `Monad` instance for `Logger`. 284 | -- The `bind` implementation must append log values to maintain associativity. 285 | -- 286 | -- >>> (\a -> Logger (listh [4,5]) (a+3)) =<< Logger (listh [1,2]) 3 287 | -- Logger [1,2,4,5] 6 288 | instance Monad (Logger l) where 289 | (=<<) = 290 | error "todo: Course.StateT (=<<)#instance (Logger l)" 291 | 292 | -- | A utility function for producing a `Logger` with one log value. 293 | -- 294 | -- >>> log1 1 2 295 | -- Logger [1] 2 296 | log1 :: 297 | l 298 | -> a 299 | -> Logger l a 300 | log1 = 301 | error "todo: Course.StateT#log1" 302 | 303 | -- | Remove all duplicate integers from a list. Produce a log as you go. 304 | -- If there is an element above 100, then abort the entire computation and produce no result. 305 | -- However, always keep a log. If you abort the computation, produce a log with the value, 306 | -- "aborting > 100: " followed by the value that caused it. 307 | -- If you see an even number, produce a log message, "even number: " followed by the even number. 308 | -- Other numbers produce no log message. 309 | -- 310 | -- /Tip:/ Use `filtering` and `StateT` over (`OptionalT` over `Logger` with a @Data.Set#Set@). 311 | -- 312 | -- >>> distinctG $ listh [1,2,3,2,6] 313 | -- Logger ["even number: 2","even number: 2","even number: 6"] (Full [1,2,3,6]) 314 | -- 315 | -- >>> distinctG $ listh [1,2,3,2,6,106] 316 | -- Logger ["even number: 2","even number: 2","even number: 6","aborting > 100: 106"] Empty 317 | distinctG :: 318 | (Integral a, Show a) => 319 | List a 320 | -> Logger Chars (Optional (List a)) 321 | distinctG = 322 | error "todo: Course.StateT#distinctG" 323 | 324 | onFull :: 325 | Applicative f => 326 | (t -> f (Optional a)) 327 | -> Optional t 328 | -> f (Optional a) 329 | onFull g o = 330 | case o of 331 | Empty -> 332 | pure Empty 333 | Full a -> 334 | g a 335 | -------------------------------------------------------------------------------- /src/Course/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.Applicative where 7 | 8 | import Course.Core 9 | import Course.ExactlyOne 10 | import Course.Functor 11 | import Course.List 12 | import Course.Optional 13 | import qualified Prelude as P(fmap, return, (>>=)) 14 | 15 | -- | All instances of the `Applicative` type-class must satisfy three laws. 16 | -- These laws are not checked by the compiler. These laws are given as: 17 | -- 18 | -- * The law of associative composition 19 | -- `∀a b c. ((.) <$> a <*> b <*> c) ≅ (a <*> (b <*> c))` 20 | -- 21 | -- * The law of identity 22 | -- `∀x. pure id <*> x ≅ x` 23 | -- 24 | -- * The law of homomorphism 25 | -- `∀f x. pure f <*> pure x ≅ pure (f x)` 26 | -- 27 | -- * The law of composition 28 | -- `∀u v w. pure (.) <*> u <*> v <*> w ≅ u <*> (v <*> w)` 29 | 30 | class Functor f => Applicative f where 31 | pure :: 32 | a -> f a 33 | (<*>) :: 34 | f (a -> b) 35 | -> f a 36 | -> f b 37 | 38 | infixl 4 <*> 39 | 40 | -- | Insert into ExactlyOne. 41 | -- 42 | -- prop> \x -> pure x == ExactlyOne x 43 | -- 44 | -- >>> ExactlyOne (+10) <*> ExactlyOne 8 45 | -- ExactlyOne 18 46 | instance Applicative ExactlyOne where 47 | pure :: 48 | a 49 | -> ExactlyOne a 50 | pure = 51 | error "todo: Course.Applicative pure#instance ExactlyOne" 52 | (<*>) :: 53 | ExactlyOne (a -> b) 54 | -> ExactlyOne a 55 | -> ExactlyOne b 56 | (<*>) = 57 | error "todo: Course.Applicative (<*>)#instance ExactlyOne" 58 | 59 | -- | Insert into a List. 60 | -- 61 | -- prop> \x -> pure x == x :. Nil 62 | -- 63 | -- >>> (+1) :. (*2) :. Nil <*> 1 :. 2 :. 3 :. Nil 64 | -- [2,3,4,2,4,6] 65 | instance Applicative List where 66 | pure :: 67 | a 68 | -> List a 69 | pure = 70 | error "todo: Course.Applicative pure#instance List" 71 | (<*>) :: 72 | List (a -> b) 73 | -> List a 74 | -> List b 75 | (<*>) = 76 | error "todo: Course.Apply (<*>)#instance List" 77 | 78 | -- | Insert into an Optional. 79 | -- 80 | -- prop> \x -> pure x == Full x 81 | -- 82 | -- >>> Full (+8) <*> Full 7 83 | -- Full 15 84 | -- 85 | -- >>> Empty <*> Full 7 86 | -- Empty 87 | -- 88 | -- >>> Full (+8) <*> Empty 89 | -- Empty 90 | instance Applicative Optional where 91 | pure :: 92 | a 93 | -> Optional a 94 | pure = 95 | error "todo: Course.Applicative pure#instance Optional" 96 | (<*>) :: 97 | Optional (a -> b) 98 | -> Optional a 99 | -> Optional b 100 | (<*>) = 101 | error "todo: Course.Apply (<*>)#instance Optional" 102 | 103 | -- | Insert into a constant function. 104 | -- 105 | -- >>> ((+) <*> (+10)) 3 106 | -- 16 107 | -- 108 | -- >>> ((+) <*> (+5)) 3 109 | -- 11 110 | -- 111 | -- >>> ((+) <*> (+5)) 1 112 | -- 7 113 | -- 114 | -- >>> ((*) <*> (+10)) 3 115 | -- 39 116 | -- 117 | -- >>> ((*) <*> (+2)) 3 118 | -- 15 119 | -- 120 | -- prop> \x y -> pure x y == x 121 | instance Applicative ((->) t) where 122 | pure :: 123 | a 124 | -> ((->) t a) 125 | pure = 126 | error "todo: Course.Applicative pure#((->) t)" 127 | (<*>) :: 128 | ((->) t (a -> b)) 129 | -> ((->) t a) 130 | -> ((->) t b) 131 | (<*>) = 132 | error "todo: Course.Apply (<*>)#instance ((->) t)" 133 | 134 | 135 | -- | Apply a binary function in the environment. 136 | -- 137 | -- >>> lift2 (+) (ExactlyOne 7) (ExactlyOne 8) 138 | -- ExactlyOne 15 139 | -- 140 | -- >>> lift2 (+) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) 141 | -- [5,6,6,7,7,8] 142 | -- 143 | -- >>> lift2 (+) (Full 7) (Full 8) 144 | -- Full 15 145 | -- 146 | -- >>> lift2 (+) (Full 7) Empty 147 | -- Empty 148 | -- 149 | -- >>> lift2 (+) Empty (Full 8) 150 | -- Empty 151 | -- 152 | -- >>> lift2 (+) length sum (listh [4,5,6]) 153 | -- 18 154 | lift2 :: 155 | Applicative f => 156 | (a -> b -> c) 157 | -> f a 158 | -> f b 159 | -> f c 160 | lift2 = 161 | error "todo: Course.Applicative#lift2" 162 | 163 | -- | Apply a ternary function in the environment. 164 | -- /can be written using `lift2` and `(<*>)`./ 165 | -- 166 | -- >>> lift3 (\a b c -> a + b + c) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) 167 | -- ExactlyOne 24 168 | -- 169 | -- >>> lift3 (\a b c -> a + b + c) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) 170 | -- [11,12,13,12,13,14,12,13,14,13,14,15,13,14,15,14,15,16] 171 | -- 172 | -- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) 173 | -- Full 24 174 | -- 175 | -- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty 176 | -- Empty 177 | -- 178 | -- >>> lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) 179 | -- Empty 180 | -- 181 | -- >>> lift3 (\a b c -> a + b + c) Empty Empty (Full 9) 182 | -- Empty 183 | -- 184 | -- >>> lift3 (\a b c -> a + b + c) length sum product (listh [4,5,6]) 185 | -- 138 186 | lift3 :: 187 | Applicative f => 188 | (a -> b -> c -> d) 189 | -> f a 190 | -> f b 191 | -> f c 192 | -> f d 193 | lift3 = 194 | error "todo: Course.Applicative#lift3" 195 | 196 | -- | Apply a quaternary function in the environment. 197 | -- /can be written using `lift3` and `(<*>)`./ 198 | -- 199 | -- >>> lift4 (\a b c d -> a + b + c + d) (ExactlyOne 7) (ExactlyOne 8) (ExactlyOne 9) (ExactlyOne 10) 200 | -- ExactlyOne 34 201 | -- 202 | -- >>> lift4 (\a b c d -> a + b + c + d) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) (9 :. 10 :. Nil) 203 | -- [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] 204 | -- 205 | -- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) 206 | -- Full 34 207 | -- 208 | -- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) 209 | -- Empty 210 | -- 211 | -- >>> lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) 212 | -- Empty 213 | -- 214 | -- >>> lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) 215 | -- Empty 216 | -- 217 | -- >>> lift4 (\a b c d -> a + b + c + d) length sum product (sum . filter even) (listh [4,5,6]) 218 | -- 148 219 | lift4 :: 220 | Applicative f => 221 | (a -> b -> c -> d -> e) 222 | -> f a 223 | -> f b 224 | -> f c 225 | -> f d 226 | -> f e 227 | lift4 = 228 | error "todo: Course.Applicative#lift4" 229 | 230 | -- | Apply a nullary function in the environment. 231 | lift0 :: 232 | Applicative f => 233 | a 234 | -> f a 235 | lift0 = 236 | error "todo: Course.Applicative#lift0" 237 | 238 | -- | Apply a unary function in the environment. 239 | -- /can be written using `lift0` and `(<*>)`./ 240 | -- 241 | -- >>> lift1 (+1) (ExactlyOne 2) 242 | -- ExactlyOne 3 243 | -- 244 | -- >>> lift1 (+1) Nil 245 | -- [] 246 | -- 247 | -- >>> lift1 (+1) (1 :. 2 :. 3 :. Nil) 248 | -- [2,3,4] 249 | lift1 :: 250 | Applicative f => 251 | (a -> b) 252 | -> f a 253 | -> f b 254 | lift1 = 255 | error "todo: Course.Applicative#lift1" 256 | 257 | -- | Apply, discarding the value of the first argument. 258 | -- Pronounced, right apply. 259 | -- 260 | -- >>> (1 :. 2 :. 3 :. Nil) *> (4 :. 5 :. 6 :. Nil) 261 | -- [4,5,6,4,5,6,4,5,6] 262 | -- 263 | -- >>> (1 :. 2 :. Nil) *> (4 :. 5 :. 6 :. Nil) 264 | -- [4,5,6,4,5,6] 265 | -- 266 | -- >>> (1 :. 2 :. 3 :. Nil) *> (4 :. 5 :. Nil) 267 | -- [4,5,4,5,4,5] 268 | -- 269 | -- >>> Full 7 *> Full 8 270 | -- Full 8 271 | -- 272 | -- 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) 273 | -- 274 | -- prop> \x y -> Full x *> Full y == Full y 275 | (*>) :: 276 | Applicative f => 277 | f a 278 | -> f b 279 | -> f b 280 | (*>) = 281 | error "todo: Course.Applicative#(*>)" 282 | 283 | -- | Apply, discarding the value of the second argument. 284 | -- Pronounced, left apply. 285 | -- 286 | -- >>> (1 :. 2 :. 3 :. Nil) <* (4 :. 5 :. 6 :. Nil) 287 | -- [1,1,1,2,2,2,3,3,3] 288 | -- 289 | -- >>> (1 :. 2 :. Nil) <* (4 :. 5 :. 6 :. Nil) 290 | -- [1,1,1,2,2,2] 291 | -- 292 | -- >>> (1 :. 2 :. 3 :. Nil) <* (4 :. 5 :. Nil) 293 | -- [1,1,2,2,3,3] 294 | -- 295 | -- >>> Full 7 <* Full 8 296 | -- Full 7 297 | -- 298 | -- 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) 299 | -- 300 | -- prop> \x y -> Full x <* Full y == Full x 301 | (<*) :: 302 | Applicative f => 303 | f b 304 | -> f a 305 | -> f b 306 | (<*) = 307 | error "todo: Course.Applicative#(<*)" 308 | 309 | -- | Sequences a list of structures to a structure of list. 310 | -- 311 | -- >>> sequence (ExactlyOne 7 :. ExactlyOne 8 :. ExactlyOne 9 :. Nil) 312 | -- ExactlyOne [7,8,9] 313 | -- 314 | -- >>> sequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) 315 | -- [[1,1],[1,2],[2,1],[2,2],[3,1],[3,2]] 316 | -- 317 | -- >>> sequence (Full 7 :. Empty :. Nil) 318 | -- Empty 319 | -- 320 | -- >>> sequence (Full 7 :. Full 8 :. Nil) 321 | -- Full [7,8] 322 | -- 323 | -- >>> sequence ((*10) :. (+2) :. Nil) 6 324 | -- [60,8] 325 | sequence :: 326 | Applicative f => 327 | List (f a) 328 | -> f (List a) 329 | sequence = 330 | error "todo: Course.Applicative#sequence" 331 | 332 | -- | Replicate an effect a given number of times. 333 | -- 334 | -- >>> replicateA 4 (ExactlyOne "hi") 335 | -- ExactlyOne ["hi","hi","hi","hi"] 336 | -- 337 | -- >>> replicateA 4 (Full "hi") 338 | -- Full ["hi","hi","hi","hi"] 339 | -- 340 | -- >>> replicateA 4 Empty 341 | -- Empty 342 | -- 343 | -- >>> replicateA 4 (*2) 5 344 | -- [10,10,10,10] 345 | -- 346 | -- >>> replicateA 3 ('a' :. 'b' :. 'c' :. Nil) 347 | -- ["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"] 348 | replicateA :: 349 | Applicative f => 350 | Int 351 | -> f a 352 | -> f (List a) 353 | replicateA = 354 | error "todo: Course.Applicative#replicateA" 355 | 356 | -- | Filter a list with a predicate that produces an effect. 357 | -- 358 | -- >>> filtering (ExactlyOne . even) (4 :. 5 :. 6 :. Nil) 359 | -- ExactlyOne [4,6] 360 | -- 361 | -- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) 362 | -- Full [4,5,6] 363 | -- 364 | -- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) 365 | -- Full [4,5,6,7] 366 | -- 367 | -- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) 368 | -- Empty 369 | -- 370 | -- >>> filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 371 | -- [9,10,11,12] 372 | -- 373 | -- >>> filtering (const $ True :. True :. Nil) (1 :. 2 :. 3 :. Nil) 374 | -- [[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3],[1,2,3]] 375 | -- 376 | filtering :: 377 | Applicative f => 378 | (a -> f Bool) 379 | -> List a 380 | -> f (List a) 381 | filtering = 382 | error "todo: Course.Applicative#filtering" 383 | 384 | ----------------------- 385 | -- SUPPORT LIBRARIES -- 386 | ----------------------- 387 | 388 | instance Applicative IO where 389 | pure = 390 | P.return 391 | f <*> a = 392 | f P.>>= \f' -> P.fmap f' a 393 | 394 | return :: 395 | Applicative f => 396 | a 397 | -> f a 398 | return = 399 | pure 400 | 401 | fail :: 402 | Applicative f => 403 | Chars 404 | -> f a 405 | fail = 406 | error . hlist 407 | 408 | (>>) :: 409 | Applicative f => 410 | f a 411 | -> f b 412 | -> f b 413 | (>>) = 414 | (*>) 415 | --------------------------------------------------------------------------------