git.iko.soy/production-haskell
on master help sign in
swap
db2639514 ahead, 0 behind
26 files changed+1720−760
since splitsnapshots
unifiedsplit
flake.nix+24 hw.md+25 seminars/1/README.md−17 seminars/1/package.yaml+6−1 seminars/1/src/Task.hs+357−301 seminars/1/stack.yaml+2−2 seminars/1/task.cabal+12−6 seminars/1/test/Main.hs+6−1 seminars/1/test/Tests.hs+85−432 seminars/2/package.yaml+19 seminars/2/src/Task.hs+398 seminars/2/stack.yaml+7 seminars/2/task.cabal+44 seminars/2/test/Main.hs+10 seminars/2/test/Tests.hs+439 seminars/calc/.gitignore+2 seminars/calc/CHANGELOG.md+11 seminars/calc/LICENSE+26 seminars/calc/README.md+1 seminars/calc/Setup.hs+2 seminars/calc/app/Main.hs+6 seminars/calc/calc.cabal+76 seminars/calc/package.yaml+62 seminars/calc/src/Lib.hs+27 seminars/calc/stack.yaml+71 seminars/calc/test/Spec.hs+2
flake.nixnew file+24
@@ -0,0 +1,24 @@
1+{
2+ inputs = {
3+ nixpkgs.url = "github:NixOS/nixpkgs";
4+ flake-utils.url = "github:numtide/flake-utils";
5+ };
6+
7+ outputs = { self, flake-utils, nixpkgs }:
8+ let
9+ supportedSystems =
10+ [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];
11+ compilerVersion = "982";
12+ in flake-utils.lib.eachSystem supportedSystems (system:
13+ let pkgs = import nixpkgs { inherit system; };
14+ in {
15+ devShells.default = pkgs.mkShell {
16+ buildInputs = with pkgs; [
17+ haskell.compiler."ghc${compilerVersion}"
18+ (pkgs.haskell-language-server.override {
19+ supportedGhcVersions = [ compilerVersion ];
20+ })
21+ ];
22+ };
23+ });
24+}
hw.mdnew file+25
@@ -0,0 +1,25 @@
1+# Homework
2+
3+The task is to recreate a portion of the functionality of the unix utility [`wc`](https://linux.die.net/man/1/wc).
4+
5+## Functionality
6+
7+1. `-c, --bytes` (2 point)
8+2. `-m, --chars` (2 point)
9+3. `-l, --lines` (4 points)
10+
11+Properly parsing the CLI arguments into a separate data structure will give you 2 additional points for a total of 10.
12+
13+Please see the [`wc` docs](https://linux.die.net/man/1/wc) for what every option should do.
14+
15+The binary should accept one additional CLI argument -- a path to the file to read. You do not need to read from stdin.
16+
17+The program should run in constant memory.
18+
19+## Implementation
20+
21+You should use the [`nightly-2024-10-11`](https://www.stackage.org/nightly-2024-10-11) stack snapshot in your project.
22+
23+You should use the [streamly](https://hackage.haskell.org/package/streamly) family of packages for streaming functionality. Using a streaming package will help ensure constant memory.
24+
25+You should use the [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative) package to parse CLI arguments.
seminars/1/README.mddeleted−17
@@ -1,17 +0,0 @@
1−# 🎒📓💻 Task 2
2−
3−**NOTE: If you just fork this repository it will not be graded. Ask your supervisor for a special GitHub classroom URL.**
4−
5−## How to do the task
6−
7−Your task is to write a valid definition for every function declared in `src/Task.hs`. All functions have a comment describing what the function needs to do with some examples.
8−
9−There are predefined tests for you to check your answer. You can look at the tests for some more usage examples in `test/Tests.hs`.
10−
11−After defining all functions you then need to commit **and push** your code to your repository. An automated script will then check your solution and give you feedback as a CI result in your GitHub repository.
12−
13−## FAQ
14−
15−> Can I add extra functions in the `Task.hs` file?
16−
17−Yes, you can, but you can not remove existing functions.
seminars/1/package.yaml+6−1
@@ -4,6 +4,10 @@ license: Unlicense
44
55dependencies:
66 - base >= 4.7 && < 5
7+ - QuickCheck
8+
9+default-extensions:
10+ - EmptyDataDeriving
711
812library:
913 source-dirs: src
@@ -14,5 +18,6 @@ tests:
1418 main: Main.hs
1519 dependencies:
1620 - tasty
17− - tasty-hunit
21+ - tasty-hspec
22+ - hspec
1823 - task
seminars/1/src/Task.hs+357−301
@@ -1,332 +1,388 @@
11module Task
2− ( -- * List Monoids
3− constructFirstMonoid,
4− destructFirstMonoid,
5− FirstMonoid,
6− constructLastMonoid,
7− destructLastMonoid,
8− LastMonoid,
9−
10− -- * Todo List
11− Priority (..),
12− Completion (..),
13− TaskManager (..),
14− MyTaskManager,
15−
16− -- * Coffee
17− DebitCard (..),
18− Coffee (..),
19− CoffeeExtra (..),
20− HasPrice (..),
21− chargeCoffee,
22− PaymentMethod (..),
23− Customer (..),
24− payForCoffee,
25− applyPayment,
26− buyCoffee,
27− saveTheDiabetic,
28− calculateSugarDanger,
2+ ( regroup,
3+ safeHead,
4+ safeLast,
5+ withoutLast,
6+ indexed,
7+ alternating,
8+ constructTree,
9+ leftmost,
10+ rightmost,
11+ treeSum,
12+ insert,
13+ insertAll,
14+ treeSize,
15+ getInt, getString, twoAndHello
16+ , StringList
2917 )
3018where
3119
32−-- _ _ _ __ __ _ _
33−-- | | (_)___| |_ | \/ | ___ _ __ ___ (_) __| |___
34−-- | | | / __| __| | |\/| |/ _ \| '_ \ / _ \| |/ _` / __|
35−-- | |___| \__ \ |_ | | | | (_) | | | | (_) | | (_| \__ \
36−-- |_____|_|___/\__| |_| |_|\___/|_| |_|\___/|_|\__,_|___/
20+import Numeric.Natural
21+import Test.QuickCheck
22+
23+data IntAndString = IntAndStringCons Int String
24+
25+getInt :: IntAndString -> Int
26+getInt (IntAndStringCons int _) = int
27+
28+getString :: IntAndString -> String
29+getString (IntAndStringCons _ string) = string
3730
38−-- Write a datatype and a Monoid instance for it such that:
31+twoAndHello :: IntAndString
32+twoAndHello = IntAndStringCons 2 "Hello"
33+
34+-- Implement a function which regroups a nested tuple as the types would suggest.
3935--
40−-- (destructFirstMonoid . fold . fmap constructFirstMonoid) == safeHead
36+-- >>> regroup (8, ("Hello", True))
37+-- ("Hello", 8, True)
38+regroup :: (,) a ((,) b c) -> (,,) b a c
39+-- regroup :: (a, (b, c)) -> (b, a, c)
40+regroup (a, (b, c)) = (b, a, c)
41+
42+data StringList = Cons String StringList | Nil
43+data List a = ListCons a (List a) | Nil'
44+--data [] a = (:) a ([] a) | []
45+
46+oneTwoThree :: List Int
47+oneTwoThree = ListCons 1 (ListCons 2 (ListCons 3 Nil'))
48+-- oneTwoThree = (:) 1 ((:) 2 ((:) 3 []))
49+-- oneTwoThree = [1, 2, 3]
50+
51+helloWorldList :: StringList
52+helloWorldList = Cons "Hello" (Cons "World" Nil)
53+
54+-- data Maybe a = Just a | Nothing
55+
56+stringListHead :: StringList -> Maybe String
57+stringListHead x = case x of
58+ Cons string string_list' -> Just string
59+ Nil -> Nothing
60+-- _ _ _ _ __ __
61+-- | | (_)___| |_ ___| |_ _ _ / _|/ _|
62+-- | | | / __| __| / __| __| | | | |_| |_
63+-- | |___| \__ \ |_ \__ \ |_| |_| | _| _|
64+-- |_____|_|___/\__| |___/\__|\__,_|_| |_|
65+
66+-- Implement a function that returns the first element of a list, if there is one.
67+-- Hint: `Maybe a` is already defined as so:
4168--
42−-- (constructFirstMonoid and destructFirstMonoid would wrap and
43−-- unwrap the `FirstMonoid`)
69+-- data Maybe a = Just a | Nothing
4470--
45−-- In other words, it needs to have a monoid instance such that `fold`ing
46−-- a list of `FirstMonoid`s should return the first element
71+-- If the list has any elements return `Just` the first element, else return `Nothing`.
4772--
48−-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) [1, 2, 3]
73+-- >>> safeHead [1, 2, 3]
4974-- Just 1
5075--
51−-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) []
76+-- >>> safeHead []
5277-- Nothing
53−data FirstMonoid a
54−
55−instance Semigroup (FirstMonoid a)
56−
57−instance Monoid (FirstMonoid a)
58−
59−-- Warps an `a` in a `FirstMonoid`.
60−constructFirstMonoid :: a -> FirstMonoid a
61−constructFirstMonoid = error "TODO: constructFirstMonoid"
78+safeHead :: [a] -> Maybe a
79+safeHead [] = Nothing
80+safeHead (x:_) = Just x
6281
63−-- Unwraps the `a` from a `FirstMonoid`, if there is one.
64−destructFirstMonoid :: FirstMonoid a -> Maybe a
65−destructFirstMonoid = error "TODO: destructFirstMonoid"
66−
67−-- Write a datatype and a Monoid instance for it such that:
82+-- Same as `safeHead`, but returns the last element.
83+--
84+-- >>> safeLast [1, 2, 3]
85+-- Just 3
6886--
69−-- (destructLastMonoid . fold . fmap constructLastMonoid) == safeLast
87+-- >>> safeLast []
88+-- Nothing
89+safeLast :: [a] -> Maybe a
90+safeLast [] = Nothing
91+safeLast [x] = Just x
92+safeLast (_:xs) = safeLast xs
93+
94+-- Returns the same list without the last element.
7095--
71−-- (constructLastMonoid and destructLastMonoid would wrap and
72−-- unwrap the `LastMonoid`)
96+-- >>> withoutLast [1, 2, 3, 4]
97+-- [1, 2, 3]
7398--
74−-- In other words, it needs to have a monoid instance such that `fold`ing
75−-- a list of `LastMonoid`s should return the last element
99+-- >>> withoutLast []
100+-- []
101+withoutLast :: [a] -> [a]
102+withoutLast [] = []
103+withoutLast [x] = []
104+withoutLast (x:xs) = x:(withoutLast xs)
105+
106+-- Returns the element at a given index if there is one.
107+-- Otherwise, return Nothing.
76108--
77−-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) [1, 2, 3]
78−-- Just 3
109+-- >>> indexed 2 [7, 6, 5, 4]
110+-- Just 5
79111--
80−-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) []
112+-- >>> indexed 8 [6, 5, 4]
81113-- Nothing
82−data LastMonoid a
83−
84−instance Semigroup (LastMonoid a)
85−
86−instance Monoid (LastMonoid a)
114+indexed :: Natural -> [a] -> Maybe a
115+indexed 0 (x:_) = Just x
116+indexed number [] = Nothing
117+indexed number (_:xs) = indexed (number-1) xs
87118
88−-- Warps an `a` in a `LastMonoid`.
89−constructLastMonoid :: a -> LastMonoid a
90−constructLastMonoid = error "TODO: constructLastMonoid"
91−
92−-- Unwraps the `a` from a `LastMonoid`, if there is one.
93−destructLastMonoid :: LastMonoid a -> Maybe a
94−destructLastMonoid = error "TODO: destructLastMonoid"
95−
96−-- _____ _ _ _ _
97−-- |_ _|__ __| | ___ | | (_)___| |_
98−-- | |/ _ \ / _` |/ _ \ | | | / __| __|
99−-- | | (_) | (_| | (_) | | |___| \__ \ |_
100−-- |_|\___/ \__,_|\___/ |_____|_|___/\__|
101−
102−-- Your task is to create a todo list backend, which supports adding tasks,
103−-- changing the priority of tasks, completing tasks, renaming tasks, and
104−-- displaying tasks as a list in order of descending priority.
105−
106−-- | The priority of a task.
107−data Priority = Low | Medium | High
119+-- Is an infinite list, alternating the sign of every other element.
120+--
121+-- >>> alternating
122+-- [1, -2, 3, -4, 5, -6, ...
123+alternating :: [Integer]
124+alternating = cut rising
125+ where
126+ cut (x1:x2:xs) = x1:(-x2):cut xs
127+ rising = 1 : map (+ 1) rising
128+-- ____ _ _
129+-- | __ )(_)_ __ __ _ _ __ _ _ | |_ _ __ ___ ___
130+-- | _ \| | '_ \ / _` | '__| | | | | __| '__/ _ \/ _ \
131+-- | |_) | | | | | (_| | | | |_| | | |_| | | __/ __/
132+-- |____/|_|_| |_|\__,_|_| \__, | \__|_| \___|\___|
133+-- |___/
134+
135+-- In this section you will implement what essentially is the Set from the
136+-- standard library. If you literally open the source code of the standard
137+-- library, it should look extremely similar to what you are doing here.
138+
139+-- Define a binary tree structure.
140+--
141+-- This is a wiki page, but you probably shouldn't open it:
142+-- https://en.wikipedia.org/wiki/Binary_tree
143+--
144+-- Hint: a tree is either:
145+-- 1. the end of the tree (an empty node with no elements)
146+-- (it should literally contain nothing)
147+-- 2. a node which contains an element and two branches (left and right).
148+-- (in this context a 'branch' and a 'tree' is the same thing)
149+--
150+-- In case you didn't get it, a tree should have two constructors.
151+data Tree a = Branch a (Tree a) (Tree a) | EmptyBranch
108152 deriving (Show, Eq)
109153
110−-- | The completion status of a task.
111−data Completion = Completed | NotCompleted
112− deriving (Show, Eq, Ord)
113−
114−class TaskManager t where
115− -- | Returns an empty task manager backend (it should have no tasks).
116− emptyTaskManager :: t
117−
118− -- | Gets the list of all tasks, sorted by priority in the order:
119− -- High, Medium, Low
120− --
121− -- Ordering of tasks with the same priority is not defined
122− -- (You can do whatever you want)
123− getPriorityList :: t -> [(Completion, Priority, String)]
124−
125− -- | Creates a new task with the given name and priority.
126− -- Tasks are uniquely identified by their name.
127− -- When a task is newly created its status should be 'NotCompleted'.
128− --
129− -- If there is already a task with the given name, then the
130− -- behavior is undefined. (You can do whatever you want)
131− createTask :: String -> Priority -> t -> t
132−
133− -- | Toggles a task with the given name.
134− -- If the task has the status 'Completed', then it would become 'NotCompleted'.
135− -- If the task has the status 'NotCompleted', then it would become 'Completed'.
136− --
137− -- Needless to say, toggling the same task twice should be
138− -- equivalent to not doing anything.
139− --
140− -- If there is no tasks with the given name, then it does nothing.
141− toggleTaskCompletion :: String -> t -> t
142−
143− -- | Removes the task with the given name.
144− -- If there isn't a task with the given name, then it does nothing.
145− removeTask :: String -> t -> t
146−
147− -- | Sets the priority of the task with the given name.
148− -- If there isn't a task with the given name, then it does nothing.
149− modifyPriority :: String -> Priority -> t -> t
150−
151− -- | Renames the task with the given name to have a new name.
152− -- The first argument is the old name, the second argument is the new name.
153− -- If there isn't a task with the given name, then it does nothing.
154− -- If the new name clashes with an existing task, then the
155− -- behavior is undefined. (You can do whatever you want)
156− renameTask :: String -> String -> t -> t
157−
158−-- The task manager you are creating.
159−data MyTaskManager
160−
161−-- TODO: You have to make your 'MyTaskManager' an instance of
162−-- the 'TaskManager' typeclass.
163−instance TaskManager MyTaskManager
154+instance Functor Tree where
155+ fmap _ EmptyBranch = EmptyBranch
156+ fmap f (Branch b leftb rightb) = Branch (f b) (fmap f leftb) (fmap f rightb)
164157
165−-- ____ __ __
166−-- / ___|___ / _|/ _| ___ ___
167−-- | | / _ \| |_| |_ / _ \/ _ \
168−-- | |__| (_) | _| _| __/ __/
169−-- \____\___/|_| |_| \___|\___|
170−--
171−-- /~~~~~~~~~~~~~~~~~~~/|
172−-- / /######/ / |
173−-- / /______/ / |
174−-- ========================= /||
175−-- |_______________________|/ ||
176−-- | \****/ \__,,__/ ||
177−-- |===\**/ __,,__ ||
178−-- |______________\====/%____||
179−-- | ___ /~~~~\ % / |
180−-- _| |===|=== / \%_/ |
181−-- | | |###| |########| | /
182−-- |____\###/______\######/__|/
183−-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
158+instance Arbitrary a => Arbitrary (Tree a) where
159+ arbitrary = oneof [
160+ pure EmptyBranch,
161+ do
162+ a <- arbitrary
163+ lbr <- arbitrary
164+ rbr <- arbitrary
165+ return (Branch a lbr rbr)
166+ ]
184167
185−-- | Just a typealias to make types more readable.
186−type RUBAmount = Integer
187168
188−-- | Represents a cup of coffee with extra ingredients added.
189−data Coffee
190− = Coffee
191− { -- | The price of the coffee itself
192− -- (without the cost of the extra ingredients.)
193− cost :: RUBAmount,
194− -- | The extra ingredients added to the coffee.
195− extras :: [CoffeeExtra]
196− }
197− deriving (Eq, Show)
169+-- ^ Don't worry about this 'deriving' business. It is needed for tests
170+-- to compile. It will be explained later.
198171
199−-- Extra ingredients added to the coffee.
200−data CoffeeExtra
201− = Cream
202− | AlmondMilk
203− | SoyMilk
204− | OatMilk
205− | Cinnamon
206− | WhiteSugar
207− | BrownSugar
208− deriving (Eq, Show)
209−
210−-- | A typeclass representing objects, for which the price can be calculated.
211−class HasPrice x where
212− -- | Calculated the price of the item.
213− price :: x -> RUBAmount
214−
215−-- I have already made a 'CoffeeExtra' an instance of 'HasPrice' for you.
216−-- You should use this in price calculations.
217−instance HasPrice CoffeeExtra where
218− price Cream = 50
219− price AlmondMilk = 70
220− price SoyMilk = 80
221− price OatMilk = 65
222− price Cinnamon = 20
223− price WhiteSugar = 15
224− price BrownSugar = 35
225−
226−-- TODO: You want to make 'Coffee' an instance of 'HasPrice'.
227−instance HasPrice Coffee
228−
229−-- | A debit card.
230−-- Note: the balance can be negative.
231−data DebitCard
232− = DebitCard
233− { balance :: RUBAmount,
234− cardId :: Int
235− }
236− deriving (Eq, Show)
237−
238−-- | Given a coffee and a debit card, deduce the total price of the coffee from
239−-- the debit card. Return the given debit card with the reduced balance.
172+-- This next function is contrived but we need this since you can define
173+-- constructors however you want.
174+-- If you have trouble with this one, don't hesitate to ask for help.
240175--
241−-- If the balance of the debit card after deducing the price of the coffee
242−-- would become negative, return 'Nothing' from the function.
243−chargeCoffee :: Coffee -> DebitCard -> Maybe DebitCard
244−chargeCoffee = error "TODO: chargeCoffee"
245−
246−-- | How was the coffee charged.
247−data PaymentMethod
248− = -- | The coffee was charged using a debit card.
249− Card
250− { -- | The debit card with the balance deduced.
251− chargedCard :: DebitCard
252− }
253− | -- | The coffee was charged with cash.
254− Cash
255− { -- | The leftover money from the payment.
256− -- (We assume that the person pays with all of the cash he has.)
257− change :: RUBAmount
258− }
259− deriving (Eq, Show)
260−
261−-- | Represents a coffee shop customer with all of the money he has on him.
262−data Customer
263− = Customer
264− { -- | All of the debit hards the person has on him.
265− -- Sorted in order of descending preference.
266− -- (He would prefer to use the first card in the list.)
267− cards :: [DebitCard],
268− -- | The amount of cash the customer has on him.
269− cash :: RUBAmount
270− }
271− deriving (Eq, Show)
272−
273−-- You have some new privacy-invading piece of ... technology, which
274−-- automatically scans the customer, determines how he would prefer to pay and
275−-- charges him automatically.
276−
277−-- | This function determines how the given customer would prefer to pay for the
278−-- coffee he wants.
279−--
280−-- The customer would always prefer to pay with a debit card if it is possible.
281−-- The customer has a strict preference in the cards he carries with him:
282−-- he would always like to pay with the first card in his wallet (the list). If
283−-- the first card doesn't have enough money on it, then he would prefer to use
284−-- the second card, and so on.
285−--
286−-- If non of the cards have enough balance to cover the coffee, then the
287−-- customer will have to pay in cash.
288−--
289−-- NOTE: The customer can only buy a coffee with strictly one payment method.
290−-- (Only one card or cash)
291−payForCoffee :: Customer -> Coffee -> Maybe PaymentMethod
292−payForCoffee = error "TODO: payForCoffee"
293−
294−-- | This function should apply the chosen payment method to the customer.
295−-- In other words, it needs to apply the charge to the customer himself
296−-- (update the debit card or update the amount of cash he currently has)
176+-- Constructs a tree from the given elements.
177+-- The first element is the root of the tree and the rest of the elements
178+-- are the alternating left and right children.
297179--
298−-- If the specified card is not present in the 'Customer' structure, then
299−-- do nothing.
180+-- You are expected to partition pluck the first element from the list and
181+-- split the rest into two lists, which you recursively pass to the same
182+-- function to get the left and right branches of the tree.
300183--
301−-- NOTE: You can not change the order of the cards.
302−applyPayment :: Customer -> PaymentMethod -> Customer
303−applyPayment = error "TODO: applyPayment"
304−
305−-- | Performs the full payment (as in 'payForCoffee') and
306−-- returns the modified customer (as in 'applyPayment').
307−buyCoffee :: Customer -> Coffee -> Maybe Customer
308−buyCoffee = error "TODO: buyCoffee"
309−
310−-- | You know that due to a medical condition the customer needs to watch his
311−-- sugar intake. The new privacy-invading piece of ... technology can now
312−-- automatically apply filters to coffee orders.
313−--
314−-- You have to make a filter, which removes any occurrences of sugar
315−-- (either WhiteSugar or BrownSugar) from the ordered cups of coffee and
316−-- return the filtered orders and the amount of money the customer saves by
317−-- being healthy (sugar costs money after all). So, you also have to count how
318−-- much the total sugar would have cost.
319−--
320−-- NOTE: You can not change the order of the coffee.
321−saveTheDiabetic :: [Coffee] -> (RUBAmount, [Coffee])
322−saveTheDiabetic = error "TODO: saveTheDiabetic"
323−
324−-- | And just to torment those who love sugar lets make a function which
325−-- calculates health hazard (sugar content) of the given orders.
184+-- >>> constructTree [1, 2, 3]
185+-- 1
186+-- / \
187+-- 2 3
188+--
189+-- >>> constructTree [1, 2, 3, 4, 5, 6]
190+-- 1
191+-- / \
192+-- 2 3
193+-- / \ /
194+-- 4 6 5
195+--
196+-- So every recursive step should look something like this:
197+-- [c, l, r, l, r, l, r, ...
198+-- c
199+-- / \
200+-- l r
201+-- / \ / \
202+-- l l r r
203+-- .............
204+constructTree :: [a] -> Tree a
205+constructTree [] = EmptyBranch
206+constructTree (x:xs) = Branch x (constructTree leftBranch) (constructTree rightBranch)
207+ where
208+ split (a:b:xs) = (a:aTail, b:bTail)
209+ where
210+ (aTail, bTail) = split xs
211+ split [] = ([], [])
212+ split [x] = ([x], [])
213+ (leftBranch, rightBranch) = split xs
214+
215+-- Returns the leftmost element of the given tree.
216+--
217+-- For this tree the result should be 2:
218+-- 1
219+-- / \
220+-- 2 3
221+--
222+-- For this tree the result should be 4:
223+-- 1
224+-- / \
225+-- 2 3
226+-- / \ /
227+-- 4 6 5
228+leftmost :: Tree a -> Maybe a
229+leftmost EmptyBranch = Nothing
230+leftmost (Branch a EmptyBranch _) = Just a
231+leftmost (Branch _ br _) = leftmost br
232+
233+-- Returns the rightmost element of the given tree.
234+--
235+-- For this tree the result should be 3:
236+-- 1
237+-- / \
238+-- 2 3
239+--
240+-- For this tree the result should be 3:
241+-- 1
242+-- / \
243+-- 2 3
244+-- / \ /
245+-- 4 6 5
246+rightmost :: Tree a -> Maybe a
247+rightmost EmptyBranch = Nothing
248+rightmost (Branch a _ EmptyBranch) = Just a
249+rightmost (Branch _ _ br) = rightmost br
250+
251+-- Returns the sum of all elements in the tree
252+--
253+-- For this tree the result should be 6:
254+-- 1
255+-- / \
256+-- 2 3
257+--
258+-- For this tree the result should be 21:
259+-- 1
260+-- / \
261+-- 2 3
262+-- / \ /
263+-- 4 6 5
264+treeSum :: Tree Integer -> Integer
265+treeSum EmptyBranch = 0
266+treeSum (Branch a brl brr) = a + treeSum brl + treeSum brr
267+
268+
269+-- Returns the number of elements in the tree.
270+--
271+-- For this tree the result should be 3:
272+-- 1
273+-- / \
274+-- 2 3
275+--
276+-- For this tree the result should be 6:
277+-- 1
278+-- / \
279+-- 2 3
280+-- / \ /
281+-- 4 6 5
282+treeSize :: Tree a -> Integer
283+treeSize EmptyBranch = 0
284+treeSize (Branch _ brl brr) = 1 + treeSize brl + treeSize brr
285+
286+-- Insert the given integer into the tree, maintaining this property:
287+-- For every node in the tree all elements in the left subtree should be
288+-- smaller than the node element and all elements in the right subtree
289+-- should be greater or equal to the node element.
290+--
291+-- a forall e in b. e < a
292+-- / \
293+-- b c forall e in c. e > a
294+--
295+-- Assume that the input tree already satisfies the property.
296+--
297+-- If the elements is already in the tree, replace the old element with the
298+-- new element. Thus, this function should not produce duplicates in the tree.
299+--
300+-- So, given the number 5 as input and this tree:
301+-- 2
302+-- / \
303+-- 1 3
304+-- the function should produce this tree:
305+-- 2
306+-- / \
307+-- 1 3
308+-- \
309+-- 5
310+--
311+-- And given the number 2 as input and this tree:
312+-- 7
313+-- / \
314+-- 2 9
315+-- / \ /
316+-- 1 5 8
317+-- the function should produce this tree:
318+-- 7
319+-- / \
320+-- 2 9
321+-- / \ /
322+-- 1 5 8
323+--
324+-- And given the number 7 as input and this tree:
325+-- 6
326+-- / \
327+-- 2 9
328+-- / \ /
329+-- 1 5 8
330+-- the function should produce this tree:
331+-- 6
332+-- / \
333+-- 2 9
334+-- / \ /
335+-- 1 5 8
336+-- /
337+-- 7
338+--
339+-- And given the number 3 as input and this tree:
340+-- 7
341+-- / \
342+-- 2 9
343+-- / \ /
344+-- 1 5 8
345+-- the function should produce this tree:
346+-- 7
347+-- / \
348+-- 2 9
349+-- / \ /
350+-- 1 5 8
351+-- /
352+-- 3
353+--
354+-- Also, see comments for function insertAll for more examples of how this
355+-- function should behave.
356+insert :: Integer -> Tree Integer -> Tree Integer
357+insert a EmptyBranch = Branch a EmptyBranch EmptyBranch
358+insert a (Branch n brl brr) = if a < n then (Branch n (insert a brl) brr) else if a > n then (Branch n brl (insert a brr)) else Branch n brl brr
359+
360+-- Insert all integers from the list into the given tree using the insert
361+-- function defined above.
362+--
363+-- >>> insertAll [1, 2, 3] <empty tree>
364+-- 1
365+-- \
366+-- 2
367+-- \
368+-- 3
369+--
370+-- >>> insertAll [2, 3, 1] <empty tree>
371+-- 2
372+-- / \
373+-- 1 3
326374--
327−-- The only ingredient that elevates the danger level is, of course, sugar:
375+-- >>> insertAll [3, 2, 1] <empty tree>
376+-- 3
377+-- /
378+-- 2
379+-- /
380+-- 1
328381--
329−-- WhiteSugar: 2 extra danger points
330−-- BrownSugar: 1 extra danger point
331−calculateSugarDanger :: [Coffee] -> Int
332−calculateSugarDanger = error "TODO: calculateSugarDanger"
382+-- >>> insertAll [8, 8, 10, 8] <empty tree>
383+-- 8
384+-- \
385+-- 10
386+insertAll :: [Integer] -> Tree Integer -> Tree Integer
387+insertAll (x:xs) tr = insertAll xs (insert x tr)
388+insertAll [] tr = tr
seminars/1/stack.yaml+2−2
@@ -1,7 +1,7 @@
1−resolver: lts-22.6
1+resolver: nightly-2024-10-11
22
33packages:
44- .
55
66ghc-options:
7− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
7+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
seminars/1/task.cabal+12−6
@@ -1,15 +1,14 @@
11cabal-version: 2.2
22
3−-- This file has been generated from package.yaml by hpack version 0.36.0.
3+-- This file has been generated from package.yaml by hpack version 0.37.0.
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: e7ce4d16c67bf724ae661c06d421b31bdf4a8955874528858483b7ed2f59e002
7+-- hash: 1b0c813b975b6ea7c4b067f19ac27bf2fff67bb285ba03838c6f210bd92d4acc
88
99name: task
1010version: 0.1.0.0
1111license: Unlicense
12−license-file: LICENSE
1312build-type: Simple
1413
1514library
@@ -21,8 +20,11 @@ library
2120 Paths_task
2221 hs-source-dirs:
2322 src
23+ default-extensions:
24+ EmptyDataDeriving
2425 build-depends:
25− base >=4.7 && <5
26+ QuickCheck
27+ , base >=4.7 && <5
2628 default-language: Haskell2010
2729
2830test-suite task-tests
@@ -35,9 +37,13 @@ test-suite task-tests
3537 Paths_task
3638 hs-source-dirs:
3739 test
40+ default-extensions:
41+ EmptyDataDeriving
3842 build-depends:
39− base >=4.7 && <5
43+ QuickCheck
44+ , base >=4.7 && <5
45+ , hspec
4046 , task
4147 , tasty
42− , tasty-hunit
48+ , tasty-hspec
4349 default-language: Haskell2010
seminars/1/test/Main.hs+6−1
@@ -4,7 +4,12 @@ module Main
44where
55
66import Test.Tasty
7+import Test.Tasty.Hspec
78import Tests
89
910main :: IO ()
10−main = defaultMain tests
11+main = do
12+ tests' <- testSpecs tests
13+ defaultMain
14+ ( testGroup "tests" tests'
15+ )
seminars/1/test/Tests.hs+85−432
@@ -3,437 +3,90 @@ module Tests
33 )
44where
55
6−import Data.Foldable
7−import Data.Function
8−import Data.List
96import Task
10−import Test.Tasty
11−import Test.Tasty.HUnit
7+import Test.Hspec
128
13−tests :: TestTree
14−tests = testGroup "Tests"
15− [ testGroup "List Monoids"
16− [ testCase "FirstMonoid" $ do
17− let getFirst = destructFirstMonoid . fold . fmap constructFirstMonoid
18− getFirst [1 :: Int, 2, 3] @=? Just 1
19− getFirst [] @=? (Nothing :: Maybe ())
20− getFirst [True, False] @=? Just True
21− getFirst [True, True, False] @=? Just True
22− getFirst [1 .. 1000] @=? Just (1 :: Int)
23− getFirst [100 .. 1000] @=? Just (100 :: Int)
24− getFirst [6, 2, 7, 398, 1984, 383, -1020] @=? Just (6 :: Int)
25− , testCase "LastMonoid" $ do
26− let getLast = destructLastMonoid . fold . fmap constructLastMonoid
27− getLast [1 :: Int, 2, 3] @=? Just 3
28− getLast [] @=? (Nothing :: Maybe ())
29− getLast [1 .. 1000] @=? Just (1000 :: Int)
30− getLast [100 .. 10000] @=? Just (10000 :: Int)
31− getLast [6, 2, 7, 398, 1984, 383, -1020, 498] @=? Just (498 :: Int)
32− getLast [True, False] @=? Just False
33− getLast [True, True, False] @=? Just False
34− getLast [True, True, False, True] @=? Just True
35− ]
36− , testGroup "Todo List" $
37− let createTasks :: [(String, Priority)] -> MyTaskManager
38− createTasks = foldl (\t (a, b) -> createTask a b t) emptyTaskManager
39− getPrioritySets :: MyTaskManager -> [[(Completion, String)]]
40− getPrioritySets =
41− fmap (sort . fmap (\(a, _, b) -> (a, b)))
42− . groupBy ((==) `on` (\(_, p, _) -> p))
43− . getPriorityList
44− in
45− [ testCase "emptyTaskManager" $
46− getPriorityList (emptyTaskManager :: MyTaskManager) @=? []
47− , testCase "createTask" $ do
48− getPrioritySets
49− ( createTasks
50− [ ("a", Low),
51− ("aaa", Medium),
52− ("AAAAAAAAAA", High)
53− ]
54− )
55− @=? [ [(NotCompleted, "AAAAAAAAAA")],
56− [(NotCompleted, "aaa")],
57− [(NotCompleted, "a")]
58− ]
59− getPrioritySets
60− ( createTasks
61− [ ("a", Low),
62− ("AAAAAAAAAA", High)
63− ]
64− )
65− @=? [ [(NotCompleted, "AAAAAAAAAA")],
66− [(NotCompleted, "a")]
67− ]
68− getPrioritySets
69− ( createTasks
70− [ ("a", Low),
71− ("AAAAAAAAAA", High),
72− ("aaa", Medium),
73− ("oh HaiMark", Medium)
74− ]
75− )
76− @=? [ [(NotCompleted, "AAAAAAAAAA")],
77− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
78− [(NotCompleted, "a")]
79− ]
80− getPrioritySets
81− ( createTasks
82− [ ("a", Low),
83− ("AAAAAAAAAA", High),
84− ("aaa", Medium),
85− ("oh HaiMark", Medium),
86− ("OH NO", High)
87− ]
88− )
89− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
90− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
91− [(NotCompleted, "a")]
92− ]
93− , testCase "toggleTaskCompletion" $ do
94− getPrioritySets
95− ( toggleTaskCompletion "AAAAAAAAAA" . createTasks $
96− [ ("a", Low),
97− ("AAAAAAAAAA", High),
98− ("aaa", Medium),
99− ("oh HaiMark", Medium),
100− ("OH NO", High)
101− ]
102− )
103− @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
104− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
105− [(NotCompleted, "a")]
106− ]
107− getPrioritySets
108− ( toggleTaskCompletion "AAAAAAAAAA" . toggleTaskCompletion "AAAAAAAAAA" . createTasks $
109− [ ("a", Low),
110− ("AAAAAAAAAA", High),
111− ("aaa", Medium),
112− ("oh HaiMark", Medium),
113− ("OH NO", High)
114− ]
115− )
116− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
117− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
118− [(NotCompleted, "a")]
119− ]
120− getPrioritySets
121− ( toggleTaskCompletion "a"
122− . toggleTaskCompletion "not here"
123− . toggleTaskCompletion "AAAAAAAAAA"
124− . createTasks
125− $ [ ("a", Low),
126− ("AAAAAAAAAA", High),
127− ("aaa", Medium),
128− ("oh HaiMark", Medium),
129− ("OH NO", High)
130− ]
131− )
132− @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
133− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
134− [(Completed, "a")]
135− ]
136− , testCase "removeTask" $ do
137− getPrioritySets
138− ( removeTask "AAAAAAAAAA"
139− . createTasks
140− $ [ ("a", Low),
141− ("AAAAAAAAAA", High),
142− ("aaa", Medium),
143− ("oh HaiMark", Medium),
144− ("OH NO", High)
145− ]
146− )
147− @=? [ [(NotCompleted, "OH NO")],
148− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
149− [(NotCompleted, "a")]
150− ]
151− getPrioritySets
152− ( removeTask "AAAAAAAAAA" . removeTask "AAAAAAAAAA"
153− . createTasks
154− $ [ ("a", Low),
155− ("AAAAAAAAAA", High),
156− ("aaa", Medium),
157− ("oh HaiMark", Medium),
158− ("OH NO", High)
159− ]
160− )
161− @=? [ [(NotCompleted, "OH NO")],
162− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
163− [(NotCompleted, "a")]
164− ]
165− getPrioritySets
166− ( removeTask "aaa" . removeTask "oh HaiMark"
167− . removeTask "AAAAAAAAAA"
168− . removeTask "AAAAAAAAAA"
169− . createTasks
170− $ [ ("a", Low),
171− ("AAAAAAAAAA", High),
172− ("aaa", Medium),
173− ("oh HaiMark", Medium),
174− ("OH NO", High)
175− ]
176− )
177− @=? [ [(NotCompleted, "OH NO")],
178− [(NotCompleted, "a")]
179− ]
180− , testCase "modifyPriority" $ do
181− getPrioritySets
182− ( modifyPriority "aaa" High . createTasks $
183− [ ("a", Low),
184− ("AAAAAAAAAA", High),
185− ("aaa", Medium),
186− ("oh HaiMark", Medium),
187− ("OH NO", High)
188− ]
189− )
190− @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO"), (NotCompleted, "aaa")],
191− [(NotCompleted, "oh HaiMark")],
192− [(NotCompleted, "a")]
193− ]
194− getPrioritySets
195− ( modifyPriority "aaa" High
196− . toggleTaskCompletion "a"
197− . modifyPriority "a" High
198− . createTasks
199− $ [ ("a", Low),
200− ("AAAAAAAAAA", High),
201− ("aaa", Medium),
202− ("oh HaiMark", Medium),
203− ("OH NO", High)
204− ]
205− )
206− @=? [ [ (Completed, "a"),
207− (NotCompleted, "AAAAAAAAAA"),
208− (NotCompleted, "OH NO"),
209− (NotCompleted, "aaa")
210− ],
211− [(NotCompleted, "oh HaiMark")]
212− ]
213− getPrioritySets
214− ( modifyPriority "aaa" High
215− . modifyPriority "a" High
216− . modifyPriority "a" High
217− . modifyPriority "oh HaiMark" High
218− . createTasks
219− $ [ ("a", Low),
220− ("AAAAAAAAAA", High),
221− ("aaa", Medium),
222− ("oh HaiMark", Medium),
223− ("OH NO", High)
224− ]
225− )
226− @=? [ [ (NotCompleted, "AAAAAAAAAA"),
227− (NotCompleted, "OH NO"),
228− (NotCompleted, "a"),
229− (NotCompleted, "aaa"),
230− (NotCompleted, "oh HaiMark")
231− ]
232− ]
233− getPrioritySets
234− ( modifyPriority "aaa" High
235− . modifyPriority "a" High
236− . modifyPriority "ntestCase here sihji" High
237− . modifyPriority "oh HaiMark" Low
238− . modifyPriority "a" High
239− . modifyPriority "oh HaiMark" High
240− . createTasks
241− $ [ ("a", Low),
242− ("AAAAAAAAAA", High),
243− ("aaa", Medium),
244− ("oh HaiMark", Medium),
245− ("OH NO", High)
246− ]
247− )
248− @=? [ [ (NotCompleted, "AAAAAAAAAA"),
249− (NotCompleted, "OH NO"),
250− (NotCompleted, "a"),
251− (NotCompleted, "aaa")
252− ],
253− [(NotCompleted, "oh HaiMark")]
254− ]
255− , testCase "renameTask" $ do
256− getPrioritySets
257− ( renameTask "AAAAAAAAAA" "henlo"
258− . createTasks
259− $ [ ("a", Low),
260− ("AAAAAAAAAA", High),
261− ("aaa", Medium),
262− ("oh HaiMark", Medium),
263− ("OH NO", High)
264− ]
265− )
266− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
267− [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
268− [(NotCompleted, "a")]
269− ]
270− getPrioritySets
271− ( renameTask "AAAAAAAAAA" "henlo"
272− . toggleTaskCompletion "a"
273− . renameTask "oh HaiMark" "iz task"
274− . createTasks
275− $ [ ("a", Low),
276− ("AAAAAAAAAA", High),
277− ("aaa", Medium),
278− ("oh HaiMark", Medium),
279− ("OH NO", High)
280− ]
281− )
282− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
283− [(NotCompleted, "aaa"), (NotCompleted, "iz task")],
284− [(Completed, "a")]
285− ]
286− getPrioritySets
287− ( renameTask "AAAAAAAAAA" "henlo"
288− . toggleTaskCompletion "iz task"
289− . renameTask "oh HaiMark" "iz task"
290− . renameTask "iz not here" "ajajaj"
291− . createTasks
292− $ [ ("a", Low),
293− ("AAAAAAAAAA", High),
294− ("aaa", Medium),
295− ("oh HaiMark", Medium),
296− ("OH NO", High)
297− ]
298− )
299− @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
300− [(Completed, "iz task"), (NotCompleted, "aaa")],
301− [(NotCompleted, "a")]
302− ]
303− ]
304− , testGroup "Coffee"
305− [ testCase "HasPrice Coffee" $ do
306− price (Coffee 2 [OatMilk, Cinnamon]) @=? 2 + price OatMilk + price Cinnamon
307− price (Coffee 2 [Cinnamon, Cinnamon]) @=? 2 + price Cinnamon + price Cinnamon
308− price (Coffee 2 []) @=? 2
309− price (Coffee 2 [Cinnamon, Cream, Cinnamon])
310− @=? 2
311− + price Cinnamon
312− + price Cinnamon
313− + price Cream
314− , testCase "chargeCoffee" $ do
315− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 199 69)
316− @=? Just (DebitCard 112 69)
317− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 87 69)
318− @=? Just (DebitCard 0 69)
319− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 86 69)
320− @=? Nothing
321− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 0 69)
322− @=? Nothing
323− chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard (-2189) 69)
324− @=? Nothing
325− chargeCoffee (Coffee 2 [OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
326− @=? Just (DebitCard 97 69)
327− chargeCoffee (Coffee 2 [WhiteSugar, OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
328− @=? Just (DebitCard 82 69)
329− , let coffee = Coffee 2 [OatMilk, Cinnamon]
330− in testCase "payForCoffee" $ do
331− payForCoffee (Customer [DebitCard 199 69] 0) coffee
332− @=? Just (Card (DebitCard 112 69))
333− payForCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
334− @=? Just (Card (DebitCard 112 69))
335− payForCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
336− @=? Just (Card (DebitCard 112 69))
337− payForCoffee (Customer [DebitCard 87 8, DebitCard 111 12, DebitCard 199 69] 0) coffee
338− @=? Just (Card (DebitCard 0 8))
339− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0) coffee
340− @=? Nothing
341− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
342− @=? Just (Cash 0)
343− payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
344− @=? Nothing
345− , testCase "applyPayment" $ do
346− applyPayment (Customer [DebitCard 199 69] 0) (Card (DebitCard 112 69))
347− @=? Customer [DebitCard 112 69] 0
348− applyPayment (Customer [DebitCard 111 12, DebitCard 199 69] 2) (Card (DebitCard 112 69))
349− @=? Customer [DebitCard 111 12, DebitCard 112 69] 2
350− applyPayment (Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 112 69))
351− @=? Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 112 69] 0
352− applyPayment (Customer [DebitCard 112 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 0 8))
353− @=? Customer [DebitCard 0 8, DebitCard 111 12, DebitCard 199 69] 0
354− applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Cash 0)
355− @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 0
356− applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Card (DebitCard 0 13))
357− @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112
358− , let coffee = Coffee 2 [OatMilk, Cinnamon]
359− in testCase "buyCoffee" $ do
360− buyCoffee (Customer [DebitCard 199 69] 0) coffee
361− @=? Just (Customer [DebitCard 112 69] 0)
362− buyCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
363− @=? Just (Customer [DebitCard 86 12, DebitCard 112 69] 2)
364− buyCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
365− @=? Just (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 112 69] 0)
366− buyCoffee (Customer [DebitCard 87 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
367− @=? Just (Customer [DebitCard 0 8, DebitCard 86 12, DebitCard 199 69] 0)
368− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 84 69] 0) coffee
369− @=? Nothing
370− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
371− @=? Just (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0)
372− buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
373− @=? Nothing
374− , testCase "saveTheDiabetic" $ do
375− saveTheDiabetic
376− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
377− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
378− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
379− ]
380− @=? ( 150,
381− [ Coffee 0 [Cinnamon],
382− Coffee 0 [Cinnamon],
383− Coffee 0 [Cinnamon]
384− ]
385− )
386− saveTheDiabetic
387− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
388− Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
389− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
390− ]
391− @=? ( 215,
392− [ Coffee 0 [Cinnamon, SoyMilk],
393− Coffee 0 [Cinnamon],
394− Coffee 0 [Cinnamon]
395− ]
396− )
397− saveTheDiabetic
398− [ Coffee 0 [Cinnamon, SoyMilk],
399− Coffee 0 [Cinnamon],
400− Coffee 0 [Cinnamon],
401− Coffee 69 []
402− ]
403− @=? ( 0,
404− [ Coffee 0 [Cinnamon, SoyMilk],
405− Coffee 0 [Cinnamon],
406− Coffee 0 [Cinnamon],
407− Coffee 69 []
408− ]
409− )
410− saveTheDiabetic
411− []
412− @=? ( 0,
413− []
414− )
415− , testCase "calculateSugarDanger" $ do
416− calculateSugarDanger
417− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
418− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
419− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
420− ]
421− @=? 9
422− calculateSugarDanger
423− [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
424− Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
425− Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
426− Coffee 0 []
427− ]
428− @=? 14
429− calculateSugarDanger
430− [ Coffee 0 [Cinnamon, SoyMilk],
431− Coffee 0 [Cinnamon],
432− Coffee 0 [Cinnamon]
433− ]
434− @=? 0
435− calculateSugarDanger
436− []
437− @=? 0
438− ]
439− ]
9+tests :: Spec
10+tests = do
11+ it "regroup" $ do
12+ regroup (1 :: Int, (2 :: Int, 3 :: Int)) `shouldBe` (2, 1, 3)
13+ regroup ("1", ("2", "3")) `shouldBe` ("2", "1", "3")
14+ regroup (True, (False, True)) `shouldBe` (False, True, True)
15+ it "safeHead" $ do
16+ safeHead [1 :: Int, 2, 3] `shouldBe` Just 1
17+ safeHead [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` Just 1294
18+ safeHead [] `shouldBe` (Nothing :: Maybe ())
19+ it "safeLast" $ do
20+ safeLast [1 :: Int, 2, 3] `shouldBe` Just 3
21+ safeLast [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` Just 9
22+ safeLast [] `shouldBe` (Nothing :: Maybe ())
23+ it "withoutLast" $ do
24+ withoutLast [1 :: Int, 2, 3] `shouldBe` [1, 2]
25+ withoutLast [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` [1294, 2, 3, 4, 5, 6, 7, 7]
26+ withoutLast [] `shouldBe` ([] :: [()])
27+ it "indexed" $ do
28+ indexed 2 [1 :: Int, 2, 3] `shouldBe` Just 3
29+ indexed 0 [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` Just 1294
30+ indexed 1080 [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` Nothing
31+ indexed 4 [1294 :: Int, 2, 3, 4, 5, 6, 7, 7, 9] `shouldBe` Just 5
32+ indexed 0 [] `shouldBe` (Nothing :: Maybe ())
33+ indexed 297 [] `shouldBe` (Nothing :: Maybe ())
34+ it "alternating" $ do
35+ take 10 alternating `shouldBe` [1, -2, 3, -4, 5, -6, 7, -8, 9, -10]
36+ alternating !! 42 `shouldBe` 43
37+ alternating !! 69 `shouldBe` -70
38+ alternating !! 420 `shouldBe` 421
39+ it "leftmost" $ do
40+ (leftmost . constructTree) [1 :: Int, 2, 3, 4, 5] `shouldBe` Just 4
41+ (leftmost . constructTree) [1 :: Int, 2, 3, 4] `shouldBe` Just 4
42+ (leftmost . constructTree) [1 :: Int, 2, 3, 99, 5] `shouldBe` Just 99
43+ (leftmost . constructTree) [8 :: Int, 7, 6, 5, 4, 1, 2, 3, 4, 5] `shouldBe` Just 3
44+ it "rightmost" $ do
45+ (rightmost . constructTree) [1 :: Int, 2, 3, 4, 5] `shouldBe` Just 3
46+ (rightmost . constructTree) [1 :: Int, 2, 3, 4] `shouldBe` Just 3
47+ (rightmost . constructTree) [1 :: Int, 2, 99, 5, 5] `shouldBe` Just 99
48+ (rightmost . constructTree) [8 :: Int, 7, 6, 5, 4, 1, 2, 3, 4, 5] `shouldBe` Just 2
49+ it "treeSum" $ do
50+ (treeSum . constructTree) [1, 2, 3, 4, 5] `shouldBe` sum [1, 2, 3, 4, 5]
51+ (treeSum . constructTree) [1, 2, 3, 4] `shouldBe` sum [1, 2, 3, 4]
52+ (treeSum . constructTree) [1, 2, 3, 5, 99] `shouldBe` sum [1, 2, 3, 5, 99]
53+ (treeSum . constructTree) [8, 7, 6, 5, 4, 1, 2, 3, 4, 5] `shouldBe` sum [8, 7, 6, 5, 4, 1, 2, 3, 4, 5]
54+ (treeSum . constructTree . take 100) [5 ..] `shouldBe` (sum . take 100) [5 ..]
55+ (treeSum . constructTree . take 100) [2 ..] `shouldBe` (sum . take 100) [2 ..]
56+ it "treeSize" $ do
57+ let test list = treeSize (constructTree list) `shouldBe` fromIntegral (length list)
58+ test $ replicate 11 ()
59+ test $ replicate 16 (8 :: Int)
60+ test [5, 2, 5, 7, 7, 3, 2, 7, 7 :: Int]
61+ it "insert" $ do
62+ constructTree [1 :: Int] `shouldNotBe` constructTree [1, 2]
63+ constructTree [1 :: Int] `shouldNotBe` constructTree []
64+ (insert 3 . insert 1 . insert 2 . constructTree) [] `shouldBe` constructTree [2, 1, 3]
65+ (insert 71 . insert 65 . insert 56 . insert 54 . insert 45 . insert 35 . insert 15 . insert 5 . constructTree) [50, 30, 60, 10, 55, 40, 70]
66+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
67+ (insert 71 . insert 54 . insert 45 . insert 35 . insert 15 . insert 65 . insert 56 . insert 5 . constructTree) [50, 30, 60, 10, 55, 40, 70]
68+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
69+ (insert 35 . insert 15 . insert 65 . insert 71 . insert 54 . insert 45 . insert 56 . insert 5 . constructTree) [50, 30, 60, 10, 55, 40, 70]
70+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
71+ (insert 35 . insert 54 . insert 45 . insert 56 . insert 5 . insert 15 . insert 65 . insert 71 . constructTree) [50, 30, 60, 10, 55, 40, 70]
72+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
73+ (insert 56 . insert 5 . insert 15 . insert 65 . insert 35 . insert 54 . insert 45 . insert 71 . constructTree) [50, 30, 60, 10, 55, 40, 70]
74+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
75+ (insert 56 . insert 56 . insert 5 . insert 5 . insert 15 . insert 65 . insert 35 . insert 54 . insert 45 . insert 71 . constructTree) [50, 30, 60, 10, 55, 40, 70]
76+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
77+ it "insertAll" $ do
78+ constructTree [1 :: Int] `shouldNotBe` constructTree [1, 2]
79+ constructTree [1 :: Int] `shouldNotBe` constructTree []
80+ (insertAll [2, 3, 1] . constructTree) [] `shouldBe` constructTree [2, 1, 3]
81+ (insertAll [71, 65, 56, 54, 45, 35, 15, 5] . constructTree) [50, 30, 60, 10, 55, 40, 70]
82+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
83+ (insertAll [71, 54, 45, 35, 15, 65, 56, 5] . constructTree) [50, 30, 60, 10, 55, 40, 70]
84+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
85+ (insertAll [35, 15, 65, 71, 54, 45, 56, 5] . constructTree) [50, 30, 60, 10, 55, 40, 70]
86+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
87+ (insertAll [35, 54, 45, 56, 5, 15, 65, 71] . constructTree) [50, 30, 60, 10, 55, 40, 70]
88+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
89+ (insertAll [56, 5, 15, 65, 35, 54, 45, 71] . constructTree) [50, 30, 60, 10, 55, 40, 70]
90+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
91+ (insertAll [56, 5, 15, 65, 35, 54, 45, 71, 5, 56, 35] . constructTree) [50, 30, 60, 10, 55, 40, 70]
92+ `shouldBe` constructTree [50, 30, 60, 10, 55, 40, 70, 5, 54, 35, 65, 15, 56, 45, 71]
seminars/2/package.yamlnew file+19
@@ -0,0 +1,19 @@
1+name: task
2+version: 0.1.0.0
3+license: Unlicense
4+
5+dependencies:
6+ - base >= 4.7 && < 5
7+ - random
8+
9+library:
10+ source-dirs: src
11+
12+tests:
13+ task-tests:
14+ source-dirs: test
15+ main: Main.hs
16+ dependencies:
17+ - tasty
18+ - tasty-hunit
19+ - task
seminars/2/src/Task.hsnew file+398
@@ -0,0 +1,398 @@
1+module Task
2+ ( -- * List Monoids
3+ constructFirstMonoid,
4+ destructFirstMonoid,
5+ FirstMonoid,
6+ constructLastMonoid,
7+ destructLastMonoid,
8+ LastMonoid,
9+
10+ -- * Todo List
11+ Priority (..),
12+ Completion (..),
13+ TaskManager (..),
14+ MyTaskManager,
15+
16+ -- * Coffee
17+ DebitCard (..),
18+ Coffee (..),
19+ CoffeeExtra (..),
20+ HasPrice (..),
21+ chargeCoffee,
22+ PaymentMethod (..),
23+ Customer (..),
24+ payForCoffee,
25+ applyPayment,
26+ buyCoffee,
27+ saveTheDiabetic,
28+ calculateSugarDanger,
29+ runStRandom, genStIntDouble
30+ , foo
31+ )
32+where
33+
34+import System.Random
35+import Control.Monad
36+
37+newtype State m s a = State { runState :: s -> (s, m a) }
38+newtype Reader m s a = Reader { runReader :: s -> m a }
39+type Foo s s' a = State (Reader Identity s') s a
40+
41+instance Functor (State s) where
42+ -- fmap :: (a -> b) -> functor a -> functor b
43+ fmap f (State g) = State (\s -> let (s', a) = g s in (s', f a))
44+ -- fmap f (State g) = State (fmap (fmap f) g)
45+
46+instance Applicative (State s) where
47+ pure a = State (\s -> (s, a))
48+ (<*>) = ap
49+
50+instance Monad (State s) where
51+ -- (>>=) :: State s a -> (a -> State s b) -> State s b
52+ State g >>= f = State $ \s -> let (s', a) = g s in
53+ let State h = f a in
54+ h s'
55+
56+get :: State s s
57+get = State (\s -> (s, s))
58+
59+put :: s -> State s ()
60+put s = State (\_ -> (s, ()))
61+
62+stRandom :: Random a => State StdGen a
63+stRandom = do
64+ s <- get
65+ let (r, s') = random s
66+ put s'
67+ return r
68+
69+runStRandom :: State StdGen a -> a
70+runStRandom (State g) = snd (g (mkStdGen 8))
71+
72+genStIntDouble :: State StdGen (Int, Double)
73+genStIntDouble = do
74+ int <- stRandom
75+ double <- stRandom
76+ return (int, double)
77+
78+foo :: State StdGen [(Int, Double)]
79+foo = sequenceA [genStIntDouble, genStIntDouble]
80+
81+-- fold [] = mempty
82+-- fold (x: xs) = x <> fold xs
83+
84+-- _ _ _ __ __ _ _
85+-- | | (_)___| |_ | \/ | ___ _ __ ___ (_) __| |___
86+-- | | | / __| __| | |\/| |/ _ \| '_ \ / _ \| |/ _` / __|
87+-- | |___| \__ \ |_ | | | | (_) | | | | (_) | | (_| \__ \
88+-- |_____|_|___/\__| |_| |_|\___/|_| |_|\___/|_|\__,_|___/
89+
90+-- Write a datatype and a Monoid instance for it such that:
91+--
92+-- (destructFirstMonoid . fold . fmap constructFirstMonoid) == safeHead
93+--
94+-- (constructFirstMonoid and destructFirstMonoid would wrap and
95+-- unwrap the `FirstMonoid`)
96+--
97+-- In other words, it needs to have a monoid instance such that `fold`ing
98+-- a list of `FirstMonoid`s should return the first element
99+--
100+-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) [1, 2, 3]
101+-- Just 1
102+--
103+-- >>> (destructFirstMonoid . fold . fmap constructFirstMonoid) []
104+-- Nothing
105+data FirstMonoid a = FirstMonoid (Maybe a)
106+
107+-- class Semigroup a where
108+-- (<>) :: a -> a -> a
109+
110+-- instance Semigroup [a] where
111+-- [] <> xs = xs
112+-- (x : xs) <> ys = x (xs <> ys)
113+
114+instance Semigroup (FirstMonoid a) where
115+ FirstMonoid Nothing <> a = a
116+ FirstMonoid (Just a) <> _ = FirstMonoid (Just a)
117+
118+instance Monoid (FirstMonoid a) where
119+ mempty = FirstMonoid Nothing
120+
121+-- Warps an `a` in a `FirstMonoid`.
122+constructFirstMonoid :: a -> FirstMonoid a
123+constructFirstMonoid a = FirstMonoid (Just a)
124+
125+-- Unwraps the `a` from a `FirstMonoid`, if there is one.
126+destructFirstMonoid :: FirstMonoid a -> Maybe a
127+destructFirstMonoid (FirstMonoid a) = a
128+
129+-- Write a datatype and a Monoid instance for it such that:
130+--
131+-- (destructLastMonoid . fold . fmap constructLastMonoid) == safeLast
132+--
133+-- (constructLastMonoid and destructLastMonoid would wrap and
134+-- unwrap the `LastMonoid`)
135+--
136+-- In other words, it needs to have a monoid instance such that `fold`ing
137+-- a list of `LastMonoid`s should return the last element
138+--
139+-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) [1, 2, 3]
140+-- Just 3
141+--
142+-- >>> (destructLastMonoid . fold . fmap constructLastMonoid) []
143+-- Nothing
144+data LastMonoid a = LastMonoid (Maybe a)
145+
146+instance Semigroup (LastMonoid a) where
147+ a <> LastMonoid Nothing = a
148+ _ <> LastMonoid (Just a) = LastMonoid (Just a)
149+
150+
151+instance Monoid (LastMonoid a) where
152+ mempty = LastMonoid Nothing
153+
154+-- Warps an `a` in a `LastMonoid`.
155+constructLastMonoid :: a -> LastMonoid a
156+constructLastMonoid a = LastMonoid (Just a)
157+
158+-- Unwraps the `a` from a `LastMonoid`, if there is one.
159+destructLastMonoid :: LastMonoid a -> Maybe a
160+destructLastMonoid (LastMonoid a) = a
161+
162+-- _____ _ _ _ _
163+-- |_ _|__ __| | ___ | | (_)___| |_
164+-- | |/ _ \ / _` |/ _ \ | | | / __| __|
165+-- | | (_) | (_| | (_) | | |___| \__ \ |_
166+-- |_|\___/ \__,_|\___/ |_____|_|___/\__|
167+
168+-- Your task is to create a todo list backend, which supports adding tasks,
169+-- changing the priority of tasks, completing tasks, renaming tasks, and
170+-- displaying tasks as a list in order of descending priority.
171+
172+-- | The priority of a task.
173+data Priority = Low | Medium | High
174+ deriving (Show, Eq)
175+
176+-- | The completion status of a task.
177+data Completion = Completed | NotCompleted
178+ deriving (Show, Eq, Ord)
179+
180+class TaskManager t where
181+ -- | Returns an empty task manager backend (it should have no tasks).
182+ emptyTaskManager :: t
183+
184+ -- | Gets the list of all tasks, sorted by priority in the order:
185+ -- High, Medium, Low
186+ --
187+ -- Ordering of tasks with the same priority is not defined
188+ -- (You can do whatever you want)
189+ getPriorityList :: t -> [(Completion, Priority, String)]
190+
191+ -- | Creates a new task with the given name and priority.
192+ -- Tasks are uniquely identified by their name.
193+ -- When a task is newly created its status should be 'NotCompleted'.
194+ --
195+ -- If there is already a task with the given name, then the
196+ -- behavior is undefined. (You can do whatever you want)
197+ createTask :: String -> Priority -> t -> t
198+
199+ -- | Toggles a task with the given name.
200+ -- If the task has the status 'Completed', then it would become 'NotCompleted'.
201+ -- If the task has the status 'NotCompleted', then it would become 'Completed'.
202+ --
203+ -- Needless to say, toggling the same task twice should be
204+ -- equivalent to not doing anything.
205+ --
206+ -- If there is no tasks with the given name, then it does nothing.
207+ toggleTaskCompletion :: String -> t -> t
208+
209+ -- | Removes the task with the given name.
210+ -- If there isn't a task with the given name, then it does nothing.
211+ removeTask :: String -> t -> t
212+
213+ -- | Sets the priority of the task with the given name.
214+ -- If there isn't a task with the given name, then it does nothing.
215+ modifyPriority :: String -> Priority -> t -> t
216+
217+ -- | Renames the task with the given name to have a new name.
218+ -- The first argument is the old name, the second argument is the new name.
219+ -- If there isn't a task with the given name, then it does nothing.
220+ -- If the new name clashes with an existing task, then the
221+ -- behavior is undefined. (You can do whatever you want)
222+ renameTask :: String -> String -> t -> t
223+
224+-- The task manager you are creating.
225+data MyTaskManager
226+
227+-- TODO: You have to make your 'MyTaskManager' an instance of
228+-- the 'TaskManager' typeclass.
229+instance TaskManager MyTaskManager
230+
231+-- ____ __ __
232+-- / ___|___ / _|/ _| ___ ___
233+-- | | / _ \| |_| |_ / _ \/ _ \
234+-- | |__| (_) | _| _| __/ __/
235+-- \____\___/|_| |_| \___|\___|
236+--
237+-- /~~~~~~~~~~~~~~~~~~~/|
238+-- / /######/ / |
239+-- / /______/ / |
240+-- ========================= /||
241+-- |_______________________|/ ||
242+-- | \****/ \__,,__/ ||
243+-- |===\**/ __,,__ ||
244+-- |______________\====/%____||
245+-- | ___ /~~~~\ % / |
246+-- _| |===|=== / \%_/ |
247+-- | | |###| |########| | /
248+-- |____\###/______\######/__|/
249+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
250+
251+-- | Just a typealias to make types more readable.
252+type RUBAmount = Integer
253+
254+-- | Represents a cup of coffee with extra ingredients added.
255+data Coffee
256+ = Coffee
257+ { -- | The price of the coffee itself
258+ -- (without the cost of the extra ingredients.)
259+ cost :: RUBAmount,
260+ -- | The extra ingredients added to the coffee.
261+ extras :: [CoffeeExtra]
262+ }
263+ deriving (Eq, Show)
264+
265+-- Extra ingredients added to the coffee.
266+data CoffeeExtra
267+ = Cream
268+ | AlmondMilk
269+ | SoyMilk
270+ | OatMilk
271+ | Cinnamon
272+ | WhiteSugar
273+ | BrownSugar
274+ deriving (Eq, Show)
275+
276+-- | A typeclass representing objects, for which the price can be calculated.
277+class HasPrice x where
278+ -- | Calculated the price of the item.
279+ price :: x -> RUBAmount
280+
281+-- I have already made a 'CoffeeExtra' an instance of 'HasPrice' for you.
282+-- You should use this in price calculations.
283+instance HasPrice CoffeeExtra where
284+ price Cream = 50
285+ price AlmondMilk = 70
286+ price SoyMilk = 80
287+ price OatMilk = 65
288+ price Cinnamon = 20
289+ price WhiteSugar = 15
290+ price BrownSugar = 35
291+
292+-- TODO: You want to make 'Coffee' an instance of 'HasPrice'.
293+instance HasPrice Coffee
294+
295+-- | A debit card.
296+-- Note: the balance can be negative.
297+data DebitCard
298+ = DebitCard
299+ { balance :: RUBAmount,
300+ cardId :: Int
301+ }
302+ deriving (Eq, Show)
303+
304+-- | Given a coffee and a debit card, deduce the total price of the coffee from
305+-- the debit card. Return the given debit card with the reduced balance.
306+--
307+-- If the balance of the debit card after deducing the price of the coffee
308+-- would become negative, return 'Nothing' from the function.
309+chargeCoffee :: Coffee -> DebitCard -> Maybe DebitCard
310+chargeCoffee = error "TODO: chargeCoffee"
311+
312+-- | How was the coffee charged.
313+data PaymentMethod
314+ = -- | The coffee was charged using a debit card.
315+ Card
316+ { -- | The debit card with the balance deduced.
317+ chargedCard :: DebitCard
318+ }
319+ | -- | The coffee was charged with cash.
320+ Cash
321+ { -- | The leftover money from the payment.
322+ -- (We assume that the person pays with all of the cash he has.)
323+ change :: RUBAmount
324+ }
325+ deriving (Eq, Show)
326+
327+-- | Represents a coffee shop customer with all of the money he has on him.
328+data Customer
329+ = Customer
330+ { -- | All of the debit hards the person has on him.
331+ -- Sorted in order of descending preference.
332+ -- (He would prefer to use the first card in the list.)
333+ cards :: [DebitCard],
334+ -- | The amount of cash the customer has on him.
335+ cash :: RUBAmount
336+ }
337+ deriving (Eq, Show)
338+
339+-- You have some new privacy-invading piece of ... technology, which
340+-- automatically scans the customer, determines how he would prefer to pay and
341+-- charges him automatically.
342+
343+-- | This function determines how the given customer would prefer to pay for the
344+-- coffee he wants.
345+--
346+-- The customer would always prefer to pay with a debit card if it is possible.
347+-- The customer has a strict preference in the cards he carries with him:
348+-- he would always like to pay with the first card in his wallet (the list). If
349+-- the first card doesn't have enough money on it, then he would prefer to use
350+-- the second card, and so on.
351+--
352+-- If non of the cards have enough balance to cover the coffee, then the
353+-- customer will have to pay in cash.
354+--
355+-- NOTE: The customer can only buy a coffee with strictly one payment method.
356+-- (Only one card or cash)
357+payForCoffee :: Customer -> Coffee -> Maybe PaymentMethod
358+payForCoffee = error "TODO: payForCoffee"
359+
360+-- | This function should apply the chosen payment method to the customer.
361+-- In other words, it needs to apply the charge to the customer himself
362+-- (update the debit card or update the amount of cash he currently has)
363+--
364+-- If the specified card is not present in the 'Customer' structure, then
365+-- do nothing.
366+--
367+-- NOTE: You can not change the order of the cards.
368+applyPayment :: Customer -> PaymentMethod -> Customer
369+applyPayment = error "TODO: applyPayment"
370+
371+-- | Performs the full payment (as in 'payForCoffee') and
372+-- returns the modified customer (as in 'applyPayment').
373+buyCoffee :: Customer -> Coffee -> Maybe Customer
374+buyCoffee = error "TODO: buyCoffee"
375+
376+-- | You know that due to a medical condition the customer needs to watch his
377+-- sugar intake. The new privacy-invading piece of ... technology can now
378+-- automatically apply filters to coffee orders.
379+--
380+-- You have to make a filter, which removes any occurrences of sugar
381+-- (either WhiteSugar or BrownSugar) from the ordered cups of coffee and
382+-- return the filtered orders and the amount of money the customer saves by
383+-- being healthy (sugar costs money after all). So, you also have to count how
384+-- much the total sugar would have cost.
385+--
386+-- NOTE: You can not change the order of the coffee.
387+saveTheDiabetic :: [Coffee] -> (RUBAmount, [Coffee])
388+saveTheDiabetic = error "TODO: saveTheDiabetic"
389+
390+-- | And just to torment those who love sugar lets make a function which
391+-- calculates health hazard (sugar content) of the given orders.
392+--
393+-- The only ingredient that elevates the danger level is, of course, sugar:
394+--
395+-- WhiteSugar: 2 extra danger points
396+-- BrownSugar: 1 extra danger point
397+calculateSugarDanger :: [Coffee] -> Int
398+calculateSugarDanger = error "TODO: calculateSugarDanger"
seminars/2/stack.yamlnew file+7
@@ -0,0 +1,7 @@
1+resolver: nightly-2024-10-11
2+
3+packages:
4+- .
5+
6+ghc-options:
7+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists
seminars/2/task.cabalnew file+44
@@ -0,0 +1,44 @@
1+cabal-version: 2.2
2+
3+-- This file has been generated from package.yaml by hpack version 0.37.0.
4+--
5+-- see: https://github.com/sol/hpack
6+--
7+-- hash: 15a870ebff263dd9493d8624136d4468bfa3ade7fad4a0cb1b9a047b79b109d8
8+
9+name: task
10+version: 0.1.0.0
11+license: Unlicense
12+build-type: Simple
13+
14+library
15+ exposed-modules:
16+ Task
17+ other-modules:
18+ Paths_task
19+ autogen-modules:
20+ Paths_task
21+ hs-source-dirs:
22+ src
23+ build-depends:
24+ base >=4.7 && <5
25+ , random
26+ default-language: Haskell2010
27+
28+test-suite task-tests
29+ type: exitcode-stdio-1.0
30+ main-is: Main.hs
31+ other-modules:
32+ Tests
33+ Paths_task
34+ autogen-modules:
35+ Paths_task
36+ hs-source-dirs:
37+ test
38+ build-depends:
39+ base >=4.7 && <5
40+ , random
41+ , task
42+ , tasty
43+ , tasty-hunit
44+ default-language: Haskell2010
seminars/2/test/Main.hsnew file+10
@@ -0,0 +1,10 @@
1+module Main
2+ ( main,
3+ )
4+where
5+
6+import Test.Tasty
7+import Tests
8+
9+main :: IO ()
10+main = defaultMain tests
seminars/2/test/Tests.hsnew file+439
@@ -0,0 +1,439 @@
1+module Tests
2+ ( tests,
3+ )
4+where
5+
6+import Data.Foldable
7+import Data.Function
8+import Data.List
9+import Task
10+import Test.Tasty
11+import Test.Tasty.HUnit
12+
13+tests :: TestTree
14+tests = testGroup "Tests"
15+ [ testGroup "List Monoids"
16+ [ testCase "FirstMonoid" $ do
17+ let getFirst = destructFirstMonoid . fold . fmap constructFirstMonoid
18+ getFirst [1 :: Int, 2, 3] @=? Just 1
19+ getFirst [] @=? (Nothing :: Maybe ())
20+ getFirst [True, False] @=? Just True
21+ getFirst [True, True, False] @=? Just True
22+ getFirst [1 .. 1000] @=? Just (1 :: Int)
23+ getFirst [100 .. 1000] @=? Just (100 :: Int)
24+ getFirst [6, 2, 7, 398, 1984, 383, -1020] @=? Just (6 :: Int)
25+ , testCase "LastMonoid" $ do
26+ let getLast = destructLastMonoid . fold . fmap constructLastMonoid
27+ getLast [1 :: Int, 2, 3] @=? Just 3
28+ getLast [] @=? (Nothing :: Maybe ())
29+ getLast [1 .. 1000] @=? Just (1000 :: Int)
30+ getLast [100 .. 10000] @=? Just (10000 :: Int)
31+ getLast [6, 2, 7, 398, 1984, 383, -1020, 498] @=? Just (498 :: Int)
32+ getLast [True, False] @=? Just False
33+ getLast [True, True, False] @=? Just False
34+ getLast [True, True, False, True] @=? Just True
35+ ]
36+ , testGroup "Todo List" $
37+ let createTasks :: [(String, Priority)] -> MyTaskManager
38+ createTasks = foldl (\t (a, b) -> createTask a b t) emptyTaskManager
39+ getPrioritySets :: MyTaskManager -> [[(Completion, String)]]
40+ getPrioritySets =
41+ fmap (sort . fmap (\(a, _, b) -> (a, b)))
42+ . groupBy ((==) `on` (\(_, p, _) -> p))
43+ . getPriorityList
44+ in
45+ [ testCase "emptyTaskManager" $
46+ getPriorityList (emptyTaskManager :: MyTaskManager) @=? []
47+ , testCase "createTask" $ do
48+ getPrioritySets
49+ ( createTasks
50+ [ ("a", Low),
51+ ("aaa", Medium),
52+ ("AAAAAAAAAA", High)
53+ ]
54+ )
55+ @=? [ [(NotCompleted, "AAAAAAAAAA")],
56+ [(NotCompleted, "aaa")],
57+ [(NotCompleted, "a")]
58+ ]
59+ getPrioritySets
60+ ( createTasks
61+ [ ("a", Low),
62+ ("AAAAAAAAAA", High)
63+ ]
64+ )
65+ @=? [ [(NotCompleted, "AAAAAAAAAA")],
66+ [(NotCompleted, "a")]
67+ ]
68+ getPrioritySets
69+ ( createTasks
70+ [ ("a", Low),
71+ ("AAAAAAAAAA", High),
72+ ("aaa", Medium),
73+ ("oh HaiMark", Medium)
74+ ]
75+ )
76+ @=? [ [(NotCompleted, "AAAAAAAAAA")],
77+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
78+ [(NotCompleted, "a")]
79+ ]
80+ getPrioritySets
81+ ( createTasks
82+ [ ("a", Low),
83+ ("AAAAAAAAAA", High),
84+ ("aaa", Medium),
85+ ("oh HaiMark", Medium),
86+ ("OH NO", High)
87+ ]
88+ )
89+ @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
90+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
91+ [(NotCompleted, "a")]
92+ ]
93+ , testCase "toggleTaskCompletion" $ do
94+ getPrioritySets
95+ ( toggleTaskCompletion "AAAAAAAAAA" . createTasks $
96+ [ ("a", Low),
97+ ("AAAAAAAAAA", High),
98+ ("aaa", Medium),
99+ ("oh HaiMark", Medium),
100+ ("OH NO", High)
101+ ]
102+ )
103+ @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
104+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
105+ [(NotCompleted, "a")]
106+ ]
107+ getPrioritySets
108+ ( toggleTaskCompletion "AAAAAAAAAA" . toggleTaskCompletion "AAAAAAAAAA" . createTasks $
109+ [ ("a", Low),
110+ ("AAAAAAAAAA", High),
111+ ("aaa", Medium),
112+ ("oh HaiMark", Medium),
113+ ("OH NO", High)
114+ ]
115+ )
116+ @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
117+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
118+ [(NotCompleted, "a")]
119+ ]
120+ getPrioritySets
121+ ( toggleTaskCompletion "a"
122+ . toggleTaskCompletion "not here"
123+ . toggleTaskCompletion "AAAAAAAAAA"
124+ . createTasks
125+ $ [ ("a", Low),
126+ ("AAAAAAAAAA", High),
127+ ("aaa", Medium),
128+ ("oh HaiMark", Medium),
129+ ("OH NO", High)
130+ ]
131+ )
132+ @=? [ [(Completed, "AAAAAAAAAA"), (NotCompleted, "OH NO")],
133+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
134+ [(Completed, "a")]
135+ ]
136+ , testCase "removeTask" $ do
137+ getPrioritySets
138+ ( removeTask "AAAAAAAAAA"
139+ . createTasks
140+ $ [ ("a", Low),
141+ ("AAAAAAAAAA", High),
142+ ("aaa", Medium),
143+ ("oh HaiMark", Medium),
144+ ("OH NO", High)
145+ ]
146+ )
147+ @=? [ [(NotCompleted, "OH NO")],
148+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
149+ [(NotCompleted, "a")]
150+ ]
151+ getPrioritySets
152+ ( removeTask "AAAAAAAAAA" . removeTask "AAAAAAAAAA"
153+ . createTasks
154+ $ [ ("a", Low),
155+ ("AAAAAAAAAA", High),
156+ ("aaa", Medium),
157+ ("oh HaiMark", Medium),
158+ ("OH NO", High)
159+ ]
160+ )
161+ @=? [ [(NotCompleted, "OH NO")],
162+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
163+ [(NotCompleted, "a")]
164+ ]
165+ getPrioritySets
166+ ( removeTask "aaa" . removeTask "oh HaiMark"
167+ . removeTask "AAAAAAAAAA"
168+ . removeTask "AAAAAAAAAA"
169+ . createTasks
170+ $ [ ("a", Low),
171+ ("AAAAAAAAAA", High),
172+ ("aaa", Medium),
173+ ("oh HaiMark", Medium),
174+ ("OH NO", High)
175+ ]
176+ )
177+ @=? [ [(NotCompleted, "OH NO")],
178+ [(NotCompleted, "a")]
179+ ]
180+ , testCase "modifyPriority" $ do
181+ getPrioritySets
182+ ( modifyPriority "aaa" High . createTasks $
183+ [ ("a", Low),
184+ ("AAAAAAAAAA", High),
185+ ("aaa", Medium),
186+ ("oh HaiMark", Medium),
187+ ("OH NO", High)
188+ ]
189+ )
190+ @=? [ [(NotCompleted, "AAAAAAAAAA"), (NotCompleted, "OH NO"), (NotCompleted, "aaa")],
191+ [(NotCompleted, "oh HaiMark")],
192+ [(NotCompleted, "a")]
193+ ]
194+ getPrioritySets
195+ ( modifyPriority "aaa" High
196+ . toggleTaskCompletion "a"
197+ . modifyPriority "a" High
198+ . createTasks
199+ $ [ ("a", Low),
200+ ("AAAAAAAAAA", High),
201+ ("aaa", Medium),
202+ ("oh HaiMark", Medium),
203+ ("OH NO", High)
204+ ]
205+ )
206+ @=? [ [ (Completed, "a"),
207+ (NotCompleted, "AAAAAAAAAA"),
208+ (NotCompleted, "OH NO"),
209+ (NotCompleted, "aaa")
210+ ],
211+ [(NotCompleted, "oh HaiMark")]
212+ ]
213+ getPrioritySets
214+ ( modifyPriority "aaa" High
215+ . modifyPriority "a" High
216+ . modifyPriority "a" High
217+ . modifyPriority "oh HaiMark" High
218+ . createTasks
219+ $ [ ("a", Low),
220+ ("AAAAAAAAAA", High),
221+ ("aaa", Medium),
222+ ("oh HaiMark", Medium),
223+ ("OH NO", High)
224+ ]
225+ )
226+ @=? [ [ (NotCompleted, "AAAAAAAAAA"),
227+ (NotCompleted, "OH NO"),
228+ (NotCompleted, "a"),
229+ (NotCompleted, "aaa"),
230+ (NotCompleted, "oh HaiMark")
231+ ]
232+ ]
233+ getPrioritySets
234+ ( modifyPriority "aaa" High
235+ . modifyPriority "a" High
236+ . modifyPriority "ntestCase here sihji" High
237+ . modifyPriority "oh HaiMark" Low
238+ . modifyPriority "a" High
239+ . modifyPriority "oh HaiMark" High
240+ . createTasks
241+ $ [ ("a", Low),
242+ ("AAAAAAAAAA", High),
243+ ("aaa", Medium),
244+ ("oh HaiMark", Medium),
245+ ("OH NO", High)
246+ ]
247+ )
248+ @=? [ [ (NotCompleted, "AAAAAAAAAA"),
249+ (NotCompleted, "OH NO"),
250+ (NotCompleted, "a"),
251+ (NotCompleted, "aaa")
252+ ],
253+ [(NotCompleted, "oh HaiMark")]
254+ ]
255+ , testCase "renameTask" $ do
256+ getPrioritySets
257+ ( renameTask "AAAAAAAAAA" "henlo"
258+ . createTasks
259+ $ [ ("a", Low),
260+ ("AAAAAAAAAA", High),
261+ ("aaa", Medium),
262+ ("oh HaiMark", Medium),
263+ ("OH NO", High)
264+ ]
265+ )
266+ @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
267+ [(NotCompleted, "aaa"), (NotCompleted, "oh HaiMark")],
268+ [(NotCompleted, "a")]
269+ ]
270+ getPrioritySets
271+ ( renameTask "AAAAAAAAAA" "henlo"
272+ . toggleTaskCompletion "a"
273+ . renameTask "oh HaiMark" "iz task"
274+ . createTasks
275+ $ [ ("a", Low),
276+ ("AAAAAAAAAA", High),
277+ ("aaa", Medium),
278+ ("oh HaiMark", Medium),
279+ ("OH NO", High)
280+ ]
281+ )
282+ @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
283+ [(NotCompleted, "aaa"), (NotCompleted, "iz task")],
284+ [(Completed, "a")]
285+ ]
286+ getPrioritySets
287+ ( renameTask "AAAAAAAAAA" "henlo"
288+ . toggleTaskCompletion "iz task"
289+ . renameTask "oh HaiMark" "iz task"
290+ . renameTask "iz not here" "ajajaj"
291+ . createTasks
292+ $ [ ("a", Low),
293+ ("AAAAAAAAAA", High),
294+ ("aaa", Medium),
295+ ("oh HaiMark", Medium),
296+ ("OH NO", High)
297+ ]
298+ )
299+ @=? [ [(NotCompleted, "OH NO"), (NotCompleted, "henlo")],
300+ [(Completed, "iz task"), (NotCompleted, "aaa")],
301+ [(NotCompleted, "a")]
302+ ]
303+ ]
304+ , testGroup "Coffee"
305+ [ testCase "HasPrice Coffee" $ do
306+ price (Coffee 2 [OatMilk, Cinnamon]) @=? 2 + price OatMilk + price Cinnamon
307+ price (Coffee 2 [Cinnamon, Cinnamon]) @=? 2 + price Cinnamon + price Cinnamon
308+ price (Coffee 2 []) @=? 2
309+ price (Coffee 2 [Cinnamon, Cream, Cinnamon])
310+ @=? 2
311+ + price Cinnamon
312+ + price Cinnamon
313+ + price Cream
314+ , testCase "chargeCoffee" $ do
315+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 199 69)
316+ @=? Just (DebitCard 112 69)
317+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 87 69)
318+ @=? Just (DebitCard 0 69)
319+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 86 69)
320+ @=? Nothing
321+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard 0 69)
322+ @=? Nothing
323+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon]) (DebitCard (-2189) 69)
324+ @=? Nothing
325+ chargeCoffee (Coffee 2 [OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
326+ @=? Just (DebitCard 97 69)
327+ chargeCoffee (Coffee 2 [WhiteSugar, OatMilk, Cinnamon, WhiteSugar]) (DebitCard 199 69)
328+ @=? Just (DebitCard 82 69)
329+ , let coffee = Coffee 2 [OatMilk, Cinnamon]
330+ in testCase "payForCoffee" $ do
331+ payForCoffee (Customer [DebitCard 199 69] 0) coffee
332+ @=? Just (Card (DebitCard 112 69))
333+ payForCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
334+ @=? Just (Card (DebitCard 112 69))
335+ payForCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
336+ @=? Just (Card (DebitCard 112 69))
337+ payForCoffee (Customer [DebitCard 87 8, DebitCard 111 12, DebitCard 199 69] 0) coffee
338+ @=? Just (Card (DebitCard 0 8))
339+ payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0) coffee
340+ @=? Nothing
341+ payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
342+ @=? Just (Cash 0)
343+ payForCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
344+ @=? Nothing
345+ , testCase "applyPayment" $ do
346+ applyPayment (Customer [DebitCard 199 69] 0) (Card (DebitCard 112 69))
347+ @=? Customer [DebitCard 112 69] 0
348+ applyPayment (Customer [DebitCard 111 12, DebitCard 199 69] 2) (Card (DebitCard 112 69))
349+ @=? Customer [DebitCard 111 12, DebitCard 112 69] 2
350+ applyPayment (Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 112 69))
351+ @=? Customer [DebitCard (-12) 8, DebitCard 111 12, DebitCard 112 69] 0
352+ applyPayment (Customer [DebitCard 112 8, DebitCard 111 12, DebitCard 199 69] 0) (Card (DebitCard 0 8))
353+ @=? Customer [DebitCard 0 8, DebitCard 111 12, DebitCard 199 69] 0
354+ applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Cash 0)
355+ @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 0
356+ applyPayment (Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112) (Card (DebitCard 0 13))
357+ @=? Customer [DebitCard 111 8, DebitCard 111 12, DebitCard 110 69] 112
358+ , let coffee = Coffee 2 [OatMilk, Cinnamon]
359+ in testCase "buyCoffee" $ do
360+ buyCoffee (Customer [DebitCard 199 69] 0) coffee
361+ @=? Just (Customer [DebitCard 112 69] 0)
362+ buyCoffee (Customer [DebitCard 86 12, DebitCard 199 69] 2) coffee
363+ @=? Just (Customer [DebitCard 86 12, DebitCard 112 69] 2)
364+ buyCoffee (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
365+ @=? Just (Customer [DebitCard (-12) 8, DebitCard 86 12, DebitCard 112 69] 0)
366+ buyCoffee (Customer [DebitCard 87 8, DebitCard 86 12, DebitCard 199 69] 0) coffee
367+ @=? Just (Customer [DebitCard 0 8, DebitCard 86 12, DebitCard 199 69] 0)
368+ buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 84 69] 0) coffee
369+ @=? Nothing
370+ buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 87) coffee
371+ @=? Just (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 82 69] 0)
372+ buyCoffee (Customer [DebitCard 86 8, DebitCard 86 12, DebitCard 81 69] 86) coffee
373+ @=? Nothing
374+ , testCase "saveTheDiabetic" $ do
375+ saveTheDiabetic
376+ [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
377+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
378+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
379+ ]
380+ @=? ( 150,
381+ [ Coffee 0 [Cinnamon],
382+ Coffee 0 [Cinnamon],
383+ Coffee 0 [Cinnamon]
384+ ]
385+ )
386+ saveTheDiabetic
387+ [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
388+ Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
389+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
390+ ]
391+ @=? ( 215,
392+ [ Coffee 0 [Cinnamon, SoyMilk],
393+ Coffee 0 [Cinnamon],
394+ Coffee 0 [Cinnamon]
395+ ]
396+ )
397+ saveTheDiabetic
398+ [ Coffee 0 [Cinnamon, SoyMilk],
399+ Coffee 0 [Cinnamon],
400+ Coffee 0 [Cinnamon],
401+ Coffee 69 []
402+ ]
403+ @=? ( 0,
404+ [ Coffee 0 [Cinnamon, SoyMilk],
405+ Coffee 0 [Cinnamon],
406+ Coffee 0 [Cinnamon],
407+ Coffee 69 []
408+ ]
409+ )
410+ saveTheDiabetic
411+ []
412+ @=? ( 0,
413+ []
414+ )
415+ , testCase "calculateSugarDanger" $ do
416+ calculateSugarDanger
417+ [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
418+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
419+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon]
420+ ]
421+ @=? 9
422+ calculateSugarDanger
423+ [ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon, BrownSugar, SoyMilk],
424+ Coffee 0 [WhiteSugar, BrownSugar, WhiteSugar, WhiteSugar, Cinnamon],
425+ Coffee 0 [WhiteSugar, BrownSugar, Cinnamon],
426+ Coffee 0 []
427+ ]
428+ @=? 14
429+ calculateSugarDanger
430+ [ Coffee 0 [Cinnamon, SoyMilk],
431+ Coffee 0 [Cinnamon],
432+ Coffee 0 [Cinnamon]
433+ ]
434+ @=? 0
435+ calculateSugarDanger
436+ []
437+ @=? 0
438+ ]
439+ ]
seminars/calc/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+.stack-work/
2+*~
seminars/calc/CHANGELOG.mdnew file+11
@@ -0,0 +1,11 @@
1+# Changelog for `calc`
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
6+and this project adheres to the
7+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
8+
9+## Unreleased
10+
11+## 0.1.0.0 - YYYY-MM-DD
seminars/calc/LICENSEnew file+26
@@ -0,0 +1,26 @@
1+Copyright 2025 Author name here
2+
3+Redistribution and use in source and binary forms, with or without
4+modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this
7+ list of conditions and the following disclaimer.
8+
9+2. Redistributions in binary form must reproduce the above copyright notice,
10+ this list of conditions and the following disclaimer in the documentation
11+ and/or other materials provided with the distribution.
12+
13+3. Neither the name of the copyright holder nor the names of its 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 COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
18+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
20+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
21+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
22+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
23+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
24+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
seminars/calc/README.mdnew file+1
@@ -0,0 +1 @@
1+# calc
seminars/calc/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
seminars/calc/app/Main.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Lib
4+
5+main :: IO ()
6+main = server
seminars/calc/calc.cabalnew file+76
@@ -0,0 +1,76 @@
1+cabal-version: 2.2
2+
3+-- This file has been generated from package.yaml by hpack version 0.37.0.
4+--
5+-- see: https://github.com/sol/hpack
6+
7+name: calc
8+version: 0.1.0.0
9+description: Please see the README on GitHub at <https://github.com/githubuser/calc#readme>
10+homepage: https://github.com/githubuser/calc#readme
11+bug-reports: https://github.com/githubuser/calc/issues
12+author: Author name here
13+maintainer: example@example.com
14+copyright: 2025 Author name here
15+license: BSD-3-Clause
16+license-file: LICENSE
17+build-type: Simple
18+extra-source-files:
19+ README.md
20+ CHANGELOG.md
21+
22+source-repository head
23+ type: git
24+ location: https://github.com/githubuser/calc
25+
26+library
27+ exposed-modules:
28+ Lib
29+ other-modules:
30+ Paths_calc
31+ autogen-modules:
32+ Paths_calc
33+ hs-source-dirs:
34+ src
35+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
36+ build-depends:
37+ base >=4.7 && <5
38+ , mtl
39+ , scotty
40+ , text
41+ default-language: Haskell2010
42+
43+executable calc-exe
44+ main-is: Main.hs
45+ other-modules:
46+ Paths_calc
47+ autogen-modules:
48+ Paths_calc
49+ hs-source-dirs:
50+ app
51+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
52+ build-depends:
53+ base >=4.7 && <5
54+ , calc
55+ , mtl
56+ , scotty
57+ , text
58+ default-language: Haskell2010
59+
60+test-suite calc-test
61+ type: exitcode-stdio-1.0
62+ main-is: Spec.hs
63+ other-modules:
64+ Paths_calc
65+ autogen-modules:
66+ Paths_calc
67+ hs-source-dirs:
68+ test
69+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
70+ build-depends:
71+ base >=4.7 && <5
72+ , calc
73+ , mtl
74+ , scotty
75+ , text
76+ default-language: Haskell2010
seminars/calc/package.yamlnew file+62
@@ -0,0 +1,62 @@
1+name: calc
2+version: 0.1.0.0
3+github: "githubuser/calc"
4+license: BSD-3-Clause
5+author: "Author name here"
6+maintainer: "example@example.com"
7+copyright: "2025 Author name here"
8+
9+extra-source-files:
10+- README.md
11+- CHANGELOG.md
12+
13+# Metadata used when publishing your package
14+# synopsis: Short description of your package
15+# category: Web
16+
17+# To avoid duplicated efforts in documentation and dealing with the
18+# complications of embedding Haddock markup inside cabal files, it is
19+# common to point users to the README.md file.
20+description: Please see the README on GitHub at <https://github.com/githubuser/calc#readme>
21+
22+dependencies:
23+- base >= 4.7 && < 5
24+- scotty
25+- text
26+- mtl
27+
28+ghc-options:
29+- -Wall
30+- -Wcompat
31+- -Widentities
32+- -Wincomplete-record-updates
33+- -Wincomplete-uni-patterns
34+- -Wmissing-export-lists
35+- -Wmissing-home-modules
36+- -Wpartial-fields
37+- -Wredundant-constraints
38+
39+library:
40+ source-dirs: src
41+
42+executables:
43+ calc-exe:
44+ main: Main.hs
45+ source-dirs: app
46+ ghc-options:
47+ - -threaded
48+ - -rtsopts
49+ - -with-rtsopts=-N
50+ dependencies:
51+ - calc
52+
53+tests:
54+ calc-test:
55+ main: Spec.hs
56+ source-dirs: test
57+ ghc-options:
58+ - -threaded
59+ - -rtsopts
60+ - -with-rtsopts=-N
61+ dependencies:
62+ - calc
seminars/calc/src/Lib.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Lib
5+ ( server
6+ ) where
7+
8+import Web.Scotty
9+import Data.IORef
10+import qualified Data.Text.Lazy
11+import Control.Monad.Trans
12+
13+server :: IO ()
14+server = do
15+ result <- newIORef 0
16+ scotty 3000 $ do
17+ get "/:word" $ do
18+ beam <- pathParam "word"
19+ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
20+ post "/add/:number" $ do
21+ number :: Int <- pathParam "number"
22+ result <- lift $ atomicModifyIORef result (\x -> (x + number, x + number))
23+ -- modifyIORef :: IORef a -> (a -> a) -> IO ()
24+ -- atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b
25+ text $ Data.Text.Lazy.pack $ show result
26+
27+-- pure :: a -> ActionT IO a
seminars/calc/stack.yamlnew file+71
@@ -0,0 +1,71 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# A 'specific' Stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# snapshot: lts-22.28
12+# snapshot: nightly-2024-07-05
13+# snapshot: ghc-9.6.6
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# snapshot: ./custom-snapshot.yaml
19+# snapshot: https://example.com/snapshots/2024-01-01.yaml
20+snapshot: nightly-2024-10-11
21+
22+nix:
23+ enable: true
24+ packages:
25+ - zlib
26+
27+# User packages to be built.
28+# Various formats can be used as shown in the example below.
29+#
30+# packages:
31+# - some-directory
32+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
33+# subdirs:
34+# - auto-update
35+# - wai
36+packages:
37+- .
38+# Dependency packages to be pulled from upstream that are not in the snapshot.
39+# These entries can reference officially published versions as well as
40+# forks / in-progress versions pinned to a git hash. For example:
41+#
42+# extra-deps:
43+# - acme-missiles-0.3
44+# - git: https://github.com/commercialhaskell/stack.git
45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
46+#
47+# extra-deps: []
48+
49+# Override default flag values for project packages and extra-deps
50+# flags: {}
51+
52+# Extra package databases containing global packages
53+# extra-package-dbs: []
54+
55+# Control whether we use the GHC we find on the path
56+# system-ghc: true
57+#
58+# Require a specific version of Stack, using version ranges
59+# require-stack-version: -any # Default
60+# require-stack-version: ">=3.1"
61+#
62+# Override the architecture used by Stack, especially useful on Windows
63+# arch: i386
64+# arch: x86_64
65+#
66+# Extra directories used by Stack for building
67+# extra-include-dirs: [/path/to/dir]
68+# extra-lib-dirs: [/path/to/dir]
69+#
70+# Allow a newer minor version of GHC than the snapshot specifies
71+# compiler-check: newer-minor
seminars/calc/test/Spec.hsnew file+2
@@ -0,0 +1,2 @@
1+main :: IO ()
2+main = putStrLn "Test suite not yet implemented"