├── chapter5 ├── cabal.project.local ├── Setup.hs ├── ChangeLog.md ├── src │ └── Main.hs ├── chapter5.cabal ├── LICENSE └── stack.yaml ├── chapter4 ├── Setup.hs ├── ChangeLog.md ├── chapter4.cabal ├── LICENSE └── stack.yaml ├── chapter8 ├── Setup.hs ├── ChangeLog.md ├── chapter8.cabal ├── src │ └── Main.hs └── LICENSE ├── .gitattributes ├── 9781484244791.jpg ├── chapter14 ├── ChangeLog.md ├── uuagc_options ├── Setup.hs ├── src │ ├── Main.hs │ └── Chapter14 │ │ └── Simple.ag ├── chapter14.cabal ├── test │ └── Tasty.hs └── LICENSE ├── errata.md ├── elm ├── src │ ├── Simple.elm │ ├── Elm.elm │ └── RetrieveProduct.elm └── elm.json ├── README.md ├── Contributing.md ├── Chapter12.hs ├── LICENSE.txt ├── Chapter14Generics.hs ├── Chapter05.hs ├── Chapter12b.hs ├── Chapter10.hs ├── LiquidHaskell.hs ├── Chapter09.hs ├── Chapter03.hs ├── Spock.hs ├── Chapter04.hs ├── Chapter11.hs ├── Chapter02.hs ├── Chapter07.hs └── Chapter06.hs /chapter5/cabal.project.local: -------------------------------------------------------------------------------- 1 | profiling: True 2 | -------------------------------------------------------------------------------- /chapter4/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter5/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter8/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /9781484244791.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-haskell/HEAD/9781484244791.jpg -------------------------------------------------------------------------------- /chapter4/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for chapter4 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /chapter5/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for chapter5 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /chapter8/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for chapter8 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /chapter14/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for chapter14 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /chapter5/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = putStrLn $ show result 5 | 6 | result :: Integer 7 | result = foldr (*) 1 [1 .. 100000] 8 | -------------------------------------------------------------------------------- /chapter14/uuagc_options: -------------------------------------------------------------------------------- 1 | file : "src/Chapter14/Simple.ag" 2 | options : data, semfuns, catas, pretty, wrappers, rename, 3 | module "Chapter14.Simple", haskellsyntax, signatures 4 | -------------------------------------------------------------------------------- /chapter14/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.UUAGC (uuagcLibUserHook) 3 | import UU.UUAGC (uuagc) 4 | 5 | main = defaultMainWithHooks (uuagcLibUserHook uuagc) 6 | -------------------------------------------------------------------------------- /errata.md: -------------------------------------------------------------------------------- 1 | # Errata for *Book Title* 2 | 3 | On **page xx** [Summary of error]: 4 | 5 | Details of error here. Highlight key pieces in **bold**. 6 | 7 | *** 8 | 9 | On **page xx** [Summary of error]: 10 | 11 | Details of error here. Highlight key pieces in **bold**. 12 | 13 | *** -------------------------------------------------------------------------------- /chapter14/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Chapter14.Simple 4 | 5 | executeExpr :: Expr -> String -> Int 6 | executeExpr e s = 7 | let syn = wrap_Expr (sem_Expr e) (Inh_Expr s) -- returns Syn_Expr 8 | in result_Syn_Expr syn 9 | 10 | main :: IO () 11 | main = putStrLn "Hello, Haskell!" 12 | -------------------------------------------------------------------------------- /elm/src/Simple.elm: -------------------------------------------------------------------------------- 1 | import Browser 2 | import Html exposing (..) 3 | 4 | main = Browser.sandbox { init = init, update = \_ model -> model, view = view } 5 | 6 | type alias Model = { currentName : String } 7 | 8 | init : Model 9 | init = { currentName = "Alejandro" } 10 | 11 | view : Model -> Html () 12 | view model 13 | = div [] [ text "Hello, ", text model.currentName, text "!"] 14 | 15 | -- view2 : Model -> Html Msg 16 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Simple.ag: -------------------------------------------------------------------------------- 1 | data Expr 2 | | Plus left :: Expr right :: Expr 3 | | Times left :: Expr right :: Expr 4 | | AmountOf c :: Char 5 | 6 | attr Expr 7 | inh string :: String 8 | syn result :: Int 9 | 10 | sem Expr 11 | | Plus lhs.result = @left.result + @right.result 12 | | Times lhs.result = @left.result * @right.result 13 | | AmountOf lhs.result = { length $ filter (== @c) @lhs.string } 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Practical Haskell*](https://www.apress.com/9781484244791) by Alejandro Serrano Mena (Apress, 2019). 4 | 5 | [comment]: #cover 6 | ![Cover image](9781484244791.jpg) 7 | 8 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 9 | 10 | ## Releases 11 | 12 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 13 | 14 | ## Contributions 15 | 16 | See the file Contributing.md for more information on how you can contribute to this repository. -------------------------------------------------------------------------------- /Contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! -------------------------------------------------------------------------------- /elm/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.0", 7 | "dependencies": { 8 | "direct": { 9 | "elm/browser": "1.0.1", 10 | "elm/core": "1.0.2", 11 | "elm/html": "1.0.0", 12 | "elm/http": "2.0.0", 13 | "elm/json": "1.1.2" 14 | }, 15 | "indirect": { 16 | "elm/bytes": "1.0.7", 17 | "elm/file": "1.0.1", 18 | "elm/time": "1.0.0", 19 | "elm/url": "1.0.0", 20 | "elm/virtual-dom": "1.0.2" 21 | } 22 | }, 23 | "test-dependencies": { 24 | "direct": {}, 25 | "indirect": {} 26 | } 27 | } -------------------------------------------------------------------------------- /chapter4/chapter4.cabal: -------------------------------------------------------------------------------- 1 | -- Initial chapter4.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: chapter4 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alejandro Serrano Mena 11 | maintainer: trupill@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | -- exposed-modules: 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.11 && <5, containers, exceptions 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /chapter5/chapter5.cabal: -------------------------------------------------------------------------------- 1 | -- Initial chapter5.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: chapter5 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alejandro Serrano Mena 11 | maintainer: trupill@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable chapter5 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.11 && <4.12 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /chapter8/chapter8.cabal: -------------------------------------------------------------------------------- 1 | -- Initial chapter8.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: chapter8 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alejandro Serrano Mena 11 | maintainer: trupill@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable chapter8 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >= 4, monad-par, deepseq 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | ghc-options: -Wall -threaded 26 | -------------------------------------------------------------------------------- /Chapter12.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 4 | {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Chapter12 where 7 | 8 | data Zero 9 | data Succ n 10 | 11 | data Vect n a where 12 | VNil :: Vect Zero a 13 | VCons :: a -> Vect n a -> Vect (Succ n) a 14 | 15 | headVect :: Vect (Succ n) a -> a 16 | headVect (VCons x _) = x 17 | 18 | {- 19 | class Plus x y z | x y -> z, x z -> y 20 | instance Plus Zero x x 21 | instance Plus x y z => Plus (Succ x) y (Succ z) 22 | -} 23 | 24 | append :: Vect x a -> Vect y a -> Vect (Plus x y) a 25 | append VNil ys = ys 26 | append (VCons x xs) ys = VCons x (append xs ys) 27 | 28 | type family Plus x y where 29 | Plus Zero x = x 30 | Plus (Succ x) y = Succ (Plus x y) 31 | -------------------------------------------------------------------------------- /chapter8/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.DeepSeq 4 | import Control.Monad.Par 5 | 6 | main :: IO () 7 | main = print (findTwoFactors 1024 3047) 8 | 9 | findFactors :: Integer -> [Integer] 10 | findFactors 1 = [1] 11 | findFactors n = let oneFactor = findFactor n 2 12 | in oneFactor : (findFactors $ n `div` oneFactor) 13 | 14 | findFactor :: Integer -> Integer -> Integer 15 | findFactor n m | n == m = n 16 | | n `mod` m == 0 = m 17 | | otherwise = findFactor n (m + 1) 18 | 19 | findTwoFactorsPre :: Integer -> Integer -> ([Integer],[Integer]) 20 | findTwoFactorsPre x y = (findFactors x, findFactors y) 21 | 22 | findTwoFactors :: Integer -> Integer -> ([Integer],[Integer]) 23 | findTwoFactors x y = runPar $ do 24 | factorsXVar <- spawnP $ findFactors x 25 | let factorsY = findFactors y 26 | _ = rnf factorsY 27 | factorsX <- get factorsXVar 28 | return (factorsX, factorsY) 29 | -------------------------------------------------------------------------------- /chapter14/chapter14.cabal: -------------------------------------------------------------------------------- 1 | -- Initial chapter14.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: chapter14 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alejandro Serrano Mena 11 | maintainer: trupill@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Custom 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable uuagc-examples 19 | hs-source-dirs: src 20 | build-depends: base >= 4 21 | ghc-options: -Wall 22 | other-modules: Chapter14.Simple 23 | main-is: Main.hs 24 | default-language: Haskell2010 25 | 26 | test-suite Tasty 27 | type: exitcode-stdio-1.0 28 | build-depends: base >= 4, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, hspec 29 | hs-source-dirs: test 30 | main-is: Tasty.hs 31 | default-language: Haskell2010 -------------------------------------------------------------------------------- /elm/src/Elm.elm: -------------------------------------------------------------------------------- 1 | import Browser 2 | import Html exposing (..) 3 | import Html.Attributes exposing (..) 4 | import Html.Events exposing (onInput, onClick) 5 | 6 | main = Browser.sandbox { init = init, update = update, view = view } 7 | 8 | type alias Model = { currentName : String, textboxName : String } 9 | 10 | init : Model 11 | init = { currentName = "Alejandro", textboxName = "Alejandro" } 12 | 13 | type Msg = TextboxChanged String 14 | | MakeCurrent 15 | 16 | update : Msg -> Model -> Model 17 | update msg model = case msg of 18 | TextboxChanged nm -> { model | textboxName = nm } 19 | MakeCurrent -> { model | currentName = model.textboxName } 20 | 21 | view : Model -> Html Msg 22 | view model 23 | = div [] 24 | [ div [] [ text "Hello, ", text model.currentName, text "!"] 25 | , input [ placeholder "Write your name here" 26 | , value model.textboxName 27 | , onInput TextboxChanged ] [] 28 | , button [ onClick MakeCurrent ] [ text "Greet me!" ] 29 | ] 30 | 31 | -- view2 : Model -> Html Msg 32 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Freeware License, some rights reserved 2 | 3 | Copyright (c) 2019 Alejandro Serrano Mena 4 | 5 | Permission is hereby granted, free of charge, to anyone obtaining a copy 6 | of this software and associated documentation files (the "Software"), 7 | to work with the Software within the limits of freeware distribution and fair use. 8 | This includes the rights to use, copy, and modify the Software for personal use. 9 | Users are also allowed and encouraged to submit corrections and modifications 10 | to the Software for the benefit of other users. 11 | 12 | It is not allowed to reuse, modify, or redistribute the Software for 13 | commercial use in any way, or for a user’s educational materials such as books 14 | or blog articles without prior permission from the copyright holder. 15 | 16 | The above copyright notice and this permission notice need to be included 17 | in all copies or substantial portions of the software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | SOFTWARE. 26 | 27 | 28 | -------------------------------------------------------------------------------- /chapter14/test/Tasty.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.HUnit as HU 5 | import Data.Maybe 6 | import Test.Hspec 7 | 8 | main :: IO () 9 | main = defaultMain allTests 10 | 11 | data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) 12 | | Leaf 13 | deriving (Eq, Show) 14 | 15 | treeInsert :: Ord a => a -> BinaryTree a -> BinaryTree a 16 | treeInsert x Leaf = Node x Leaf Leaf 17 | treeInsert x (Node y l r) | x <= y = Node y (treeInsert x l) r 18 | | otherwise = Node y l (treeInsert x r) 19 | 20 | treeMerge :: Ord a => BinaryTree a -> BinaryTree a -> BinaryTree a 21 | treeMerge t Leaf = t 22 | treeMerge t (Node x l r) = treeInsert x $ treeMerge (treeMerge t l) r 23 | 24 | hunitTestInsertOnLeaf :: TestTree 25 | hunitTestInsertOnLeaf = HU.testCase "Insert 'a' on empty tree" $ 26 | assertEqual "Insertion is wrong" 27 | (treeInsert 'a' Leaf) (Node 'a' Leaf Leaf) 28 | 29 | allTests :: TestTree 30 | allTests = testGroup "Tasty Tests" [ 31 | testGroup "HUnit Tests" [ hunitTestInsertOnLeaf ] 32 | ] 33 | 34 | main2 = hspec $ do 35 | describe "Insertion in binary tree" $ do 36 | it "Inserts correctly 1 in empty tree" $ 37 | True -- treeInsert 1 Leaf @?= Node 1 Leaf Leaf 38 | it "Finds 1 after inserting it on a tree" $ 39 | isJust $ undefined -- treeFind 1 $ treeInsert 1 (Node 2 Leaf Leaf) 40 | it "Gets the minimum correctly" $ 41 | pendingWith "Needs to be implemented" 42 | -------------------------------------------------------------------------------- /Chapter14Generics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE DefaultSignatures #-} 10 | module Chapter14Generics where 11 | 12 | import GHC.Generics 13 | import GHC.TypeLits 14 | import Data.Proxy 15 | 16 | class GetAll t a where 17 | getall :: Proxy t -> a -> [t] 18 | default getall :: (Generic a, GGetAll t (Rep a)) => Proxy t -> a -> [t] 19 | getall p = ggetall p . from 20 | 21 | instance {-# OVERLAPS #-} GetAll t t where 22 | getall p x = [x] 23 | instance {-# OVERLAPPABLE #-} GetAll t s where 24 | getall p x = [] 25 | 26 | instance GetAll a [a] 27 | 28 | data Tree a = Node a | Branch (Tree a) (Tree a) 29 | deriving (Show, Eq, Generic) 30 | instance GetAll a (Tree a) 31 | 32 | class GGetAll t (f :: * -> *) where 33 | ggetall :: Proxy t -> f x -> [t] 34 | 35 | instance (GGetAll t f, GGetAll t g) => GGetAll t (f :+: g) where 36 | ggetall p (L1 x) = ggetall p x 37 | ggetall p (R1 y) = ggetall p y 38 | 39 | instance (GGetAll t f) => GGetAll t (M1 v i f) where 40 | ggetall p (M1 x) = ggetall p x 41 | 42 | instance (GGetAll t f, GGetAll t g) => GGetAll t (f :*: g) where 43 | ggetall p (x :*: y) = ggetall p x ++ ggetall p y 44 | 45 | instance GGetAll t U1 where 46 | ggetall p U1 = [] 47 | 48 | instance (GetAll t s) => GGetAll t (Rec0 s) where 49 | ggetall p (K1 x) = getall p x -------------------------------------------------------------------------------- /chapter14/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Alejandro Serrano Mena 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alejandro Serrano Mena nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /chapter4/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Alejandro Serrano Mena 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alejandro Serrano Mena nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /chapter5/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Alejandro Serrano Mena 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alejandro Serrano Mena nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /chapter8/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Alejandro Serrano Mena 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alejandro Serrano Mena nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /elm/src/RetrieveProduct.elm: -------------------------------------------------------------------------------- 1 | import Browser 2 | import Html exposing (..) 3 | import Html.Attributes exposing (..) 4 | import Html.Events exposing (onInput, onClick) 5 | import Http 6 | import Json.Decode exposing (Decoder, map2, field, string) 7 | 8 | main = Browser.element { init = init 9 | , update = update 10 | , subscriptions = \_ -> Sub.none 11 | , view = view 12 | } 13 | 14 | type alias Product = { name : String, description : String } 15 | 16 | productDecoder : Decoder Product 17 | productDecoder = map2 Product (field "name" string) (field "description" string) 18 | 19 | type alias Model = { productId : String, productStatus : ProductStatus } 20 | type ProductStatus = JustStarted 21 | | LoadingProduct 22 | | Error 23 | | ProductData Product 24 | 25 | init : () -> (Model, Cmd Msg) 26 | init _ = ( { productId = "", productStatus = JustStarted } , Cmd.none ) 27 | 28 | type Msg = TextboxChanged String | Load | ReceivedInfo (Result Http.Error Product) 29 | 30 | update : Msg -> Model -> (Model, Cmd Msg) 31 | update msg model = case msg of 32 | TextboxChanged pid -> ({ model | productId = pid }, Cmd.none) 33 | Load -> ( { model | productStatus = LoadingProduct } 34 | , Http.get 35 | { url = "http://practical.haskell/product/" ++ model.productId 36 | , expect = Http.expectJson ReceivedInfo productDecoder 37 | } ) 38 | ReceivedInfo result -> case result of 39 | Ok p -> ({ model | productStatus = ProductData p }, Cmd.none) 40 | Err _ -> ({ model | productStatus = Error }, Cmd.none) 41 | 42 | view : Model -> Html Msg 43 | view model = h1 [] [] -- Exercise to the reader -------------------------------------------------------------------------------- /chapter4/stack.yaml: -------------------------------------------------------------------------------- 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 | # Resolver to choose 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 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 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 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-12.20 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /Chapter05.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Chapter05 where 3 | 4 | import Data.List 5 | import Control.DeepSeq 6 | 7 | data TimeMachine = TM { manufacturer :: String, year :: Integer } 8 | deriving (Eq, Show) 9 | 10 | timeMachinesFrom :: String -> Integer -> [TimeMachine] 11 | timeMachinesFrom mf y = TM mf y : timeMachinesFrom mf (y+1) 12 | timelyIncMachines :: [TimeMachine] 13 | timelyIncMachines = timeMachinesFrom "Timely Inc." 100 14 | 15 | tm1 = take 3 timelyIncMachines 16 | tm2 = find (\(TM { year = y }) -> y > 2018) timelyIncMachines 17 | tm3 = length timelyIncMachines 18 | tm4 = find (\(TM { year = y }) -> y == 10) timelyIncMachines 19 | 20 | allNumbers :: [Integer] 21 | allNumbers = allNumbersFrom 1 22 | allNumbersFrom :: Integer -> [Integer] 23 | allNumbersFrom n = n : allNumbersFrom (n+1) 24 | an1 = zip allNumbers "abcd" 25 | an2 = zip [1 .. ] "abcd" 26 | 27 | fibonacci :: [Integer] 28 | fibonacci = 0 : 1 : zipWith (+) fibonacci (tail fibonacci) 29 | 30 | infinite2020Machines :: [TimeMachine] 31 | infinite2020Machines = TM "Timely Inc." 2020 : infinite2020Machines 32 | tm5 = take 3 $ repeat $ TM "Timely Inc." 2020 33 | specialOffer :: [TimeMachine] 34 | specialOffer = cycle [TM m 2005, TM m 1994, TM m 908] 35 | where m = "Timely Inc." 36 | tm6 = take 4 specialOffer 37 | 38 | fibonacci2 :: [Integer] 39 | fibonacci2 = map fst $ iterate (\(n,n1) -> (n1,n+n1)) (0,1) 40 | 41 | sumForce :: [Integer] -> Integer 42 | sumForce xs = sumForce' xs 0 43 | where sumForce' [] z = z 44 | sumForce' (y:ys) z = let s = z + y in s `seq` sumForce' ys s 45 | 46 | sumYears :: [TimeMachine] -> Integer 47 | sumYears xs = sumYears' xs 0 48 | where sumYears' [] z = z 49 | sumYears' (TM _ !y :ys) z = let !s = z + y in sumYears' ys s 50 | 51 | data ListL a = ListL !Integer [a] 52 | 53 | data Person = Person String String deriving Show 54 | data Client = GovOrg {-# UNPACK #-} !Int String 55 | | Company {-# UNPACK #-} !Int String Person String 56 | | Individual {-# UNPACK #-} !Int Person 57 | deriving Show 58 | 59 | instance NFData Client where 60 | rnf (GovOrg i n) = i `deepseq` n `deepseq` () 61 | rnf (Company i n (Person f l) r) = i `deepseq` n `deepseq` f `deepseq` l 62 | `deepseq` r `deepseq` () 63 | rnf (Individual i (Person f l)) = i `deepseq` f `deepseq` l `deepseq` () 64 | 65 | -------------------------------------------------------------------------------- /chapter5/stack.yaml: -------------------------------------------------------------------------------- 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 | # Resolver to choose 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 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 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 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-12.21 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | 66 | build: 67 | library-profiling: true 68 | executable-profiling: true 69 | -------------------------------------------------------------------------------- /Chapter12b.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE EmptyCase #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | module Chapter12b where 10 | 11 | import Data.Singletons.TH hiding (Min) 12 | 13 | $(singletons [d| 14 | data Nat = Zero | Succ Nat 15 | deriving (Show, Eq) 16 | |]) 17 | 18 | $(promote [d| 19 | plus :: Nat -> Nat -> Nat 20 | plus Zero y = y 21 | plus (Succ x) y = Succ (plus x y) 22 | 23 | min :: Nat -> Nat -> Nat 24 | min Zero _ = Zero 25 | min _ Zero = Zero 26 | min (Succ x) (Succ y) = Succ (min x y) 27 | |]) 28 | 29 | -- data Nat = Zero | Succ Nat 30 | 31 | data Vect n a where 32 | VNil :: Vect Zero a 33 | VCons :: a -> Vect n a -> Vect (Succ n) a 34 | 35 | {- 36 | type family Plus x y where 37 | Plus Zero x = x 38 | Plus (Succ x) y = Succ (Plus x y) 39 | -} 40 | 41 | $(promote [d| 42 | data Range = Empty | Open Nat | Closed Nat Nat 43 | 44 | infinite :: Range 45 | infinite = Open Zero 46 | |]) 47 | 48 | $(promote [d| 49 | data Comparison = Less' | Equal' | Greater' 50 | 51 | compare' :: Nat -> Nat -> Comparison 52 | compare' Zero Zero = Equal' 53 | compare' Zero (Succ _) = Less' 54 | compare' (Succ _) Zero = Greater' 55 | compare' (Succ x) (Succ y) = compare' x y 56 | 57 | restrictFrom :: Nat -> Range -> Range 58 | restrictFrom _ Empty = Empty 59 | restrictFrom n (Open f) = restrictFrom1 n f (compare' n f) 60 | restrictFrom n (Closed f t) = restrictFrom2 n f t (compare' n f) (compare' n t) 61 | 62 | restrictFrom1 :: Nat -> Nat -> Comparison -> Range 63 | restrictFrom1 n _ Greater' = Open n 64 | restrictFrom1 _ f Equal' = Open f 65 | restrictFrom1 _ f Less' = Open f 66 | 67 | restrictFrom2 :: Nat -> Nat -> Nat -> Comparison -> Comparison -> Range 68 | restrictFrom2 _ _ _ Greater' Greater' = Empty 69 | restrictFrom2 _ _ _ Greater' Equal' = Empty 70 | restrictFrom2 n _ t Greater' Less' = Closed n t 71 | restrictFrom2 _ f t Equal' _ = Closed f t 72 | restrictFrom2 _ f t Less' _ = Closed f t 73 | |]) 74 | 75 | data Offer a (r :: Range) where 76 | Present :: a -> Offer a Infinite 77 | PercentDiscount :: Float -> Offer a Infinite 78 | AbsoluteDiscount :: Float -> Offer a Infinite 79 | From :: SNat n -> Offer a d -> Offer a (RestrictFrom n d) 80 | 81 | zero :: SNat Zero 82 | zero = sing -- results in SZero 83 | one :: SNat (Succ Zero) 84 | one = sing -- results in SSucc SZero 85 | two :: SNat (Succ (Succ Zero)) 86 | two = sing -- results in SSucc (SSucc SZero) 87 | three :: SNat (Succ (Succ (Succ Zero))) 88 | three = sing -- results in SSucc (SSucc (SSucc SZero)) 89 | -------------------------------------------------------------------------------- /Chapter10.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Monad.Trans 4 | import Data.Conduit 5 | import qualified Data.Conduit.Binary as B 6 | import qualified Data.Conduit.List as L 7 | import qualified Data.Conduit.Text as T 8 | import Data.Text 9 | import Data.Monoid 10 | import qualified Data.Text.Lazy.Builder as B 11 | import qualified Data.Text.Lazy.Builder.Int as B 12 | import qualified Data.Text.Lazy as LT 13 | 14 | main :: IO() 15 | main = runConduitRes $ 16 | B.sourceFile "clients.db" .| T.decode T.utf8 .| 17 | T.lines .| winnersFile .| L.concatMap (\x -> [x, "\n"]) .| 18 | T.encode T.utf8 .| B.sinkFile "clientsWinners.db" 19 | 20 | winnersFile :: (Monad m, MonadIO m) => ConduitT Text Text m () 21 | winnersFile = undefined -- same as previous chapter, but using Text 22 | 23 | data Client i = GovOrg { clientId :: i, clientName :: String } 24 | | Company { clientId :: i, clientName :: String 25 | , person :: Person, duty :: String } 26 | | Individual { clientId :: i, person :: Person } 27 | deriving (Show, Eq, Ord) 28 | -- Eq and Ord will be introduced in Chapter 4 29 | 30 | data Person = Person { firstName :: String, lastName :: String } 31 | deriving (Show, Eq, Ord) 32 | 33 | 34 | saveClients :: FilePath -> [Client Int] -> IO () 35 | saveClients fpath clients = runConduitRes $ 36 | L.sourceList clients .| L.map clientToText 37 | .| L.concatMap (\x -> [x, "\n"]) -- write '\n' between clients 38 | .| T.encode T.utf8 .| B.sinkFile fpath 39 | 40 | clientToText :: Client Int -> Text 41 | clientToText (GovOrg i n) = 42 | "client(gov," <> escapeString (show i) <> "," <> escapeString n <> ")" 43 | clientToText (Company i n p d) = 44 | "client(com," <> escapeString (show i) <> "," <> escapeString n <> "," 45 | <> personToText p <> "," <> escapeString d <> ")" 46 | clientToText (Individual i p) = 47 | "client(ind," <> escapeString (show i) <> "," <> personToText p <> ")" 48 | 49 | personToText :: Person -> Text 50 | personToText (Person f l) = "person(" <> escapeString f <> "," <> escapeString l <> ")" 51 | 52 | escapeString :: String -> Text 53 | escapeString = replace "\n" "\\n" . replace "," "\\," . 54 | replace "(" "\\(" . replace ")" "\\(" . pack 55 | 56 | clientToTextB :: Client Int -> B.Builder 57 | clientToTextB (GovOrg i n) = 58 | "client(gov," <> B.decimal i <> B.singleton ',' 59 | <> B.fromText (escapeString n) <> B.singleton ')' 60 | clientToTextB (Company i n p d) = 61 | "client(com," <> B.decimal i <> B.singleton ',' 62 | <> B.fromText (escapeString n) <> B.singleton ',' 63 | <> personToTextB p <> B.singleton ',' 64 | <> B.fromText (escapeString d) <> B.singleton ')' 65 | clientToTextB (Individual i p) = 66 | "client(ind," <> B.decimal i <> B.singleton ',' 67 | <> personToTextB p <> B.singleton ')' 68 | 69 | personToTextB :: Person -> B.Builder 70 | personToTextB (Person f l) = 71 | "person(" <> B.fromText (escapeString f) <> B.singleton ',' 72 | <> B.fromText (escapeString l) <> B.singleton ')' 73 | 74 | saveClientsB :: FilePath -> [Client Int] -> IO () 75 | saveClientsB fpath clients = runConduitRes $ 76 | L.sourceList clients .| L.map clientToTextB .| L.map (LT.toStrict . B.toLazyText) 77 | .| L.concatMap (\x -> [x, "\n"]) -- write '\n' between clients 78 | .| T.encode T.utf8 .| B.sinkFile fpath 79 | -------------------------------------------------------------------------------- /LiquidHaskell.hs: -------------------------------------------------------------------------------- 1 | {-@ LIQUID "--no-termination" @-} 2 | module LiquidHaskell where 3 | 4 | import Data.Set 5 | 6 | data Tree a = Empty | Node (Tree a) a (Tree a) 7 | deriving (Show, Eq, Ord) 8 | 9 | {-@ measure treeSize @-} 10 | {-@ treeSize :: Tree a -> Nat @-} 11 | treeSize :: Tree a -> Int 12 | treeSize Empty = 0 13 | treeSize (Node l _ r) = 1 + treeSize l + treeSize r 14 | 15 | {-@ measure treeElements @-} 16 | treeElements :: (Ord a) => Tree a -> Set a 17 | treeElements Empty = empty 18 | treeElements (Node l x r) = singleton x `union` treeElements l `union` treeElements r 19 | 20 | {-@ treeInsert :: x: a -> v: Tree a -> {w: Tree a | treeSize w = treeSize v + 1 && member x (treeElements w) } @-} 21 | treeInsert :: Ord a => a -> Tree a -> Tree a 22 | treeInsert x Empty = Node Empty x Empty 23 | treeInsert x (Node l y r) 24 | | x <= y = Node (treeInsert x l) y r -- for example, if I forger to do the insertion recursively 25 | | otherwise = Node l y (treeInsert x r) -- for example, if I write y instead of x I get an error 26 | 27 | {- 28 | /home/serras/beginning-haskell-chapter12/LiquidHaskell.hs:24:17-26: Error: Liquid Type Mismatch 29 | 30 | 24 | | x <= y = Node l y r 31 | ^^^^^^^^^^ 32 | 33 | Inferred type 34 | VV : {v : (Tree a) | LiquidHaskell.treeSize v == (1 + LiquidHaskell.treeSize l) + LiquidHaskell.treeSize r 35 | && LiquidHaskell.treeElements v == Set_cup (Set_cup (Set_sng y) (LiquidHaskell.treeElements l)) (LiquidHaskell.treeElements r) 36 | && LiquidHaskell.treeSize v >= 0} 37 | 38 | not a subtype of Required type 39 | VV : {VV : (Tree a) | LiquidHaskell.treeSize VV == LiquidHaskell.treeSize ?a + 1 40 | && Set_mem x (LiquidHaskell.treeElements VV)} 41 | -} 42 | 43 | {- 44 | /home/serras/beginning-haskell-chapter12/LiquidHaskell.hs:25:17-41: Error: Liquid Type Mismatch 45 | 46 | 25 | | otherwise = Node l y (treeInsert y r) 47 | ^^^^^^^^^^^^^^^^^^^^^^^^^ 48 | 49 | Inferred type 50 | VV : {v : (Tree a) | LiquidHaskell.treeSize v == (1 + LiquidHaskell.treeSize l) + LiquidHaskell.treeSize ?b 51 | && LiquidHaskell.treeElements v == Set_cup (Set_cup (Set_sng y) (LiquidHaskell.treeElements l)) (LiquidHaskell.treeElements ?b) 52 | && LiquidHaskell.treeSize v >= 0} 53 | 54 | not a subtype of Required type 55 | VV : {VV : (Tree a) | LiquidHaskell.treeSize VV == LiquidHaskell.treeSize ?a + 1 56 | && Set_mem x (LiquidHaskell.treeElements VV)} 57 | -} 58 | 59 | data SearchTree a = EmptyS | NodeS a (SearchTree a) (SearchTree a) 60 | deriving (Show, Eq, Ord) 61 | 62 | {-@ data SearchTree a = EmptyS 63 | | NodeS { x:: a 64 | , left :: SearchTree {v: a | v <= x} 65 | , right :: SearchTree {v: a | v > x} } 66 | @-} 67 | 68 | {- 69 | wrong :: a -> SearchTree a -> SearchTree a -> SearchTree a 70 | wrong x t1 t2 = NodeS x t1 t2 71 | -} 72 | {- 73 | /home/serras/beginning-haskell-chapter12/LiquidHaskell.hs:69:17-26: Error: Liquid Type Mismatch 74 | 75 | 69 | wrong x t1 t2 = NodeS x t1 t2 76 | ^^^^^^^^^^ 77 | 78 | Inferred type 79 | VV : a 80 | 81 | not a subtype of Required type 82 | VV : {VV : a | VV <= x} 83 | 84 | In Context 85 | x : a 86 | 87 | 88 | /home/serras/beginning-haskell-chapter12/LiquidHaskell.hs:69:17-29: Error: Liquid Type Mismatch 89 | 90 | 69 | wrong x t1 t2 = NodeS x t1 t2 91 | ^^^^^^^^^^^^^ 92 | 93 | Inferred type 94 | VV : a 95 | 96 | not a subtype of Required type 97 | VV : {VV : a | VV > x} 98 | 99 | In Context 100 | x : a 101 | -} 102 | 103 | treeInsertS :: Ord a => a -> SearchTree a -> SearchTree a 104 | treeInsertS x EmptyS = NodeS x EmptyS EmptyS 105 | treeInsertS x (NodeS y l r) 106 | | x <= y = NodeS y (treeInsertS x l) r 107 | | otherwise = NodeS y l (treeInsertS x r) 108 | 109 | {- 110 | /home/serras/beginning-haskell-chapter12/LiquidHaskell.hs:106:26-40: Error: Liquid Type Mismatch 111 | 112 | 106 | | x <= y = NodeS x (treeInsertS y l) r -- if I mistake, I get an error 113 | ^^^^^^^^^^^^^^^ 114 | 115 | Inferred type 116 | VV : a 117 | 118 | not a subtype of Required type 119 | VV : {VV : a | VV <= x} 120 | 121 | In Context 122 | x : a 123 | -} 124 | 125 | -- Try to write a merge function, on both binary trees and search trees 126 | -- Think about properties such as: how does the elements and size look like? -------------------------------------------------------------------------------- /Chapter09.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language ScopedTypeVariables #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language DeriveGeneric #-} 5 | {-# language DeriveAnyClass #-} 6 | import Data.Conduit 7 | import qualified Data.Conduit.List as L 8 | import Control.Monad.State 9 | import Control.Monad.Trans 10 | import System.Random 11 | import qualified Data.ByteString.Char8 as BS 12 | import qualified Data.Conduit.Binary as B 13 | import Data.Monoid 14 | import Data.Conduit.Network 15 | import Network.Socket 16 | import System.Environment 17 | import Data.Binary (Binary) 18 | import GHC.Generics (Generic) 19 | import qualified Data.Conduit.Serialization.Binary as S 20 | import Control.Monad.Trans 21 | import Data.Csv (FromRecord, ToRecord) 22 | import qualified Data.Csv as Csv 23 | import qualified Data.Csv.Conduit as Csv 24 | import System.IO.Error 25 | 26 | a = runConduitPure $ L.sourceList [1 .. 5] .| L.fold (+) 0 27 | b = runConduitPure $ L.sourceList [1 .. 20] .| L.filter odd .| L.map (\x -> x*x) .| L.fold (+) 0 28 | c = runConduitPure $ L.unfold (\x -> Just (x,x+1)) 1 .| L.isolate 10 .| L.consume 29 | 30 | -- data Person = Person String String deriving Show 31 | data Client i = Company { id :: Int, person :: Person } 32 | | Individual { id :: Int, person :: Person } 33 | | GovOrg { id :: Int, name :: String } 34 | deriving Show 35 | 36 | people :: Monad m => ConduitT (Client i) Person m () 37 | people = do client <- await 38 | case client of 39 | Nothing -> return () 40 | Just c -> do case c of 41 | Company { person = p } -> yield p 42 | Individual { person = p } -> yield p 43 | _ -> return () 44 | people 45 | 46 | d = runConduitPure $ L.sourceList [ GovOrg 1 "NASA", Individual 2 (Person "A" "S")] .| people .| L.consume 47 | 48 | countGovOrgs :: MonadState Int m => ConduitT (Client i) Void m Int 49 | countGovOrgs = do client <- await 50 | case client of 51 | Nothing -> do n <- lift $ get 52 | return n 53 | Just c -> do case c of 54 | GovOrg { } -> lift $ modify (+1) 55 | _ -> return () 56 | countGovOrgs 57 | 58 | main = let clients = [ GovOrg 1 "Zas", Individual 2 (Person "Alejandro" "Serrano")] 59 | conduitGovOrgs = L.sourceList clients .| countGovOrgs 60 | in print $ execState (runConduit conduitGovOrgs) 0 61 | 62 | winners :: ConduitT (Client i) (Client i, Bool, Int) IO () 63 | winners = do client <- await 64 | case client of 65 | Nothing -> return () 66 | Just c -> do (w :: Bool) <- lift $ randomIO 67 | (y :: Int) <- lift $ randomRIO (0, 3000) 68 | yield (c, w, y) 69 | winners 70 | 71 | winnersFile :: (Monad m, MonadIO m) 72 | => ConduitT BS.ByteString BS.ByteString m () 73 | winnersFile = do 74 | client <- await 75 | case client of 76 | Nothing -> return () 77 | Just c -> do (w :: Bool) <- liftIO $ randomIO 78 | (y :: Int ) <- liftIO $ randomRIO (0, 3000) 79 | yield $ c <> BS.pack (" " ++ show w ++ " " ++ show y) 80 | winnersFile 81 | 82 | main2 :: IO () 83 | main2 = runConduitRes $ B.sourceFile "clients.db" .| B.lines .| winnersFile .| B.sinkFile "clientsWinners.db" 84 | 85 | isWinner :: ConduitT BS.ByteString BS.ByteString IO () 86 | isWinner = do client <- await 87 | case client of 88 | Nothing -> return () 89 | Just c -> do 90 | lift $ BS.putStrLn c 91 | (w :: Bool) <- liftIO $ randomIO 92 | (y :: Int ) <- liftIO $ randomRIO (0, 3000) 93 | yield $ c <> BS.pack (" " ++ show w ++ " " ++ show y) 94 | isWinner 95 | 96 | serverApp :: AppData -> IO () 97 | serverApp d = runConduit $ appSource d .| isWinner .| appSink d 98 | 99 | mainServer :: IO () 100 | mainServer = withSocketsDo $ runTCPServer (serverSettings 8900 "*") serverApp 101 | 102 | mainClient :: IO () 103 | mainClient = withSocketsDo $ do 104 | (name:_) <- getArgs 105 | runTCPClient (clientSettings 8900 "127.0.0.1") (clientApp name) 106 | 107 | clientApp :: String -> AppData -> IO () 108 | clientApp name d = do runConduit $ (yield $ BS.pack name) .| appSink d 109 | runConduit $ appSource d .| (do Just w <- await 110 | lift $ BS.putStrLn w) 111 | 112 | data Person = Person { firstName :: String, lastName :: String } 113 | deriving (Show, Read, Generic, Binary, FromRecord, ToRecord) 114 | -- instance Binary Person 115 | 116 | mainEnc :: IO () 117 | mainEnc = runConduitRes $ 118 | L.sourceList clients.| S.conduitEncode .| B.sinkFile "people.db" 119 | where clients = [Person "Alejandro" "Serrano", Person " Doctor" "Who?"] 120 | 121 | mainDec :: IO () 122 | mainDec = runConduitRes $ 123 | B.sourceFile "people.db" .| S.conduitDecode 124 | .| L.mapM_ (\(p :: Person) -> lift $ putStrLn $ show p) 125 | 126 | mainDec2 :: IO () 127 | mainDec2 = runConduitRes $ 128 | B.sourceFile "people.db" 129 | .| Csv.fromCsvLiftError (userError . show) Csv.defaultDecodeOptions Csv.NoHeader 130 | .| L.mapM_ (\(p :: Person) -> lift $ putStrLn $ show p) 131 | -------------------------------------------------------------------------------- /Chapter03.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language ViewPatterns #-} 3 | {-# language PatternSynonyms #-} 4 | {-# language TransformListComp #-} 5 | {-# language RecordWildCards #-} 6 | module Chapter03 where 7 | 8 | import Data.List 9 | import Data.Function (on) 10 | import GHC.Exts 11 | 12 | -- Parametric polymorphism 13 | 14 | maybeString (Just _) = "Just" 15 | maybeString Nothing = "Nothing" 16 | 17 | data Client i = GovOrg { clientId :: i, clientName :: String } 18 | | Company { clientId :: i, clientName :: String 19 | , person :: Person, duty :: String } 20 | | Individual { clientId :: i, person :: Person } 21 | deriving (Show, Eq, Ord) 22 | -- Eq and Ord will be introduced in Chapter 4 23 | 24 | data Person = Person { firstName :: String, lastName :: String } 25 | deriving (Show, Eq, Ord) 26 | 27 | nttf = GovOrg 'n' "NTTF" 28 | 29 | data Triple a b c = Triple a b c 30 | data SamePair a = SamePair a a 31 | 32 | -- Exercise 33 | 34 | swapTriple (x,y,z) = (y,z,x) 35 | 36 | duplicate x = (x,x) 37 | 38 | nothing _ = Nothing 39 | 40 | index [] = [] 41 | index [x] = [(0,x)] 42 | index (x:xs) = let indexed@((n,_):_) = index xs 43 | in (n+1,x):indexed 44 | 45 | maybeA [] = 'a' 46 | 47 | -- Functions as parameters 48 | 49 | fnExample1 = map succ [1,2,3] 50 | 51 | apply3f2 :: (Integer -> Integer) -> Integer -> Integer 52 | apply3f2 f x = 3 * f (x + 2) 53 | 54 | equalTuples :: [(Integer,Integer)] -> [Bool] 55 | equalTuples t = map (\(x,y) -> x == y) t 56 | 57 | sayHello :: [String] -> [String] 58 | sayHello names = map (\name -> case name of 59 | "Alejandro" -> "Hello, writer" 60 | _ -> "Welcome, " ++ name 61 | ) names 62 | 63 | sayHello2 :: [String] -> [String] 64 | sayHello2 names = map (\case "Alejandro" -> "Hello, writer" 65 | name -> "Welcome, " ++ name 66 | ) names 67 | 68 | multiplyByN :: Integer -> (Integer -> Integer) 69 | multiplyByN n = \x -> n*x 70 | 71 | double1 list = map (\x -> x * 2) list 72 | double2 = \list -> map (\x -> x * 2) list 73 | double3 = map (\x -> x * 2) 74 | double4 = map (*2) 75 | 76 | duplicateOdds1 list = map (*2) $ filter odd list 77 | duplicateOdds2 = map (*2) . filter odd 78 | 79 | -- More on modules 80 | 81 | permutationsStartingWith :: Char -> String -> [String] 82 | permutationsStartingWith letter 83 | = filter (\l -> head l == letter) . permutations 84 | 85 | -- Smart constructors and views 86 | 87 | data Range = Range Integer Integer deriving Show 88 | 89 | range :: Integer -> Integer -> Range 90 | range a b = if a <= b then Range a b else error "a must be <= b" 91 | 92 | data RangeObs = R Integer Integer deriving Show 93 | 94 | r :: Range -> RangeObs 95 | r (Range a b) = R a b 96 | 97 | prettyRange :: Range -> String 98 | prettyRange rng = case rng of 99 | (r -> R a b) -> "[" ++ show a ++ "," ++ show b ++ "]" 100 | 101 | pattern R2 :: Integer -> Integer -> Range 102 | pattern R2 a b <- Range a b 103 | where R2 a b = range a b 104 | 105 | -- Folds 106 | 107 | data InfNumber a = MinusInfinity 108 | | Number a 109 | | PlusInfinity 110 | deriving Show 111 | 112 | infMax MinusInfinity x = x 113 | infMax x MinusInfinity = x 114 | infMax PlusInfinity _ = PlusInfinity 115 | infMax _ PlusInfinity = PlusInfinity 116 | infMax (Number a) (Number b) = Number (max a b) 117 | 118 | -- Filters 119 | 120 | bothFilters :: (a -> Bool) -> [a] -> ([a],[a]) 121 | bothFilters p list = (filter p list, filter (not . p) list) 122 | 123 | skipUntilGov :: [Client a] -> [Client a] 124 | skipUntilGov = dropWhile (\case { GovOrg {} -> False ; _ -> True }) 125 | 126 | isIndividual :: Client a -> Bool 127 | isIndividual (Individual {}) = True 128 | isIndividual _ = False 129 | 130 | checkAnalytics :: [Client a] -> (Bool, Bool) 131 | checkAnalytics cs = (any isIndividual cs, not $ all isIndividual cs) 132 | 133 | compareClient :: Client a -> Client a -> Ordering 134 | compareClient (Individual{person = p1}) (Individual{person = p2}) 135 | = compare (firstName p1) (firstName p2) 136 | compareClient (Individual {}) _ = GT 137 | compareClient _ (Individual {}) = LT 138 | compareClient c1 c2 = compare (clientName c1) (clientName c2) 139 | 140 | listOfClients 141 | = [ Individual 2 (Person "H. G." "Wells") 142 | , GovOrg 3 "NTTF" -- National Time Travel Foundation 143 | , Company 4 "Wormhole Inc." (Person "Karl" "Schwarzschild") "Physicist" 144 | , Individual 5 (Person "Doctor" "") 145 | , Individual 6 (Person "Sarah" "Jane") 146 | ] 147 | 148 | companyDutiesAnalytics :: [Client a] -> [String] 149 | companyDutiesAnalytics = map (duty . head) . 150 | sortBy (\x y -> compare (length y) (length x)) . 151 | groupBy (\x y -> duty x == duty y) . 152 | filter isCompany 153 | where isCompany (Company {}) = True 154 | isCompany _ = False 155 | 156 | companyDutiesAnalytics2 :: [Client a] -> [String] 157 | companyDutiesAnalytics2 = map (duty . head) . 158 | sortBy (flip (compare `on` length)) . 159 | groupBy ((==) `on` duty) . 160 | filter isCompany 161 | where isCompany (Company {}) = True 162 | isCompany _ = False 163 | 164 | -- Lists containing tuples 165 | 166 | enum :: Int -> Int -> [Int] 167 | enum a b | a > b = [] 168 | enum a b = a : enum (a+1) b 169 | 170 | withPositions :: [a] -> [(Int,a)] 171 | withPositions list = zip (enum 1 $ length list) list 172 | 173 | withPositions2 :: [a] -> [(Int,a)] 174 | withPositions2 list = zip [1 .. length list] list 175 | 176 | -- List comprehensions 177 | 178 | duplicateOdds3 :: [Integer] -> [Integer] 179 | duplicateOdds3 list = map (*2) $ filter odd list 180 | 181 | duplicateOdds4 list = [ 2 * x | x <- list, odd x ] 182 | 183 | companyAnalytics :: [Client a] -> [(String, [(Person, String)])] 184 | companyAnalytics clients = [ (the clientName, zip person duty) 185 | | client@(Company { .. }) <- clients 186 | , then sortWith by duty 187 | , then group by clientName using groupWith 188 | , then sortWith by length client 189 | ] 190 | -------------------------------------------------------------------------------- /Spock.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language ScopedTypeVariables #-} 3 | {-# language RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, 5 | MultiParamTypeClasses, FlexibleContexts, GADTs, 6 | OverloadedStrings, GeneralizedNewtypeDeriving, 7 | ScopedTypeVariables, TypeApplications, FlexibleInstances #-} 8 | import Web.Spock 9 | import Web.Spock.Config 10 | import Network.HTTP.Types 11 | import Database.Persist.TH 12 | import qualified Database.Persist.Sqlite as Db 13 | import Data.Text as T 14 | import Control.Monad.Logger 15 | import Control.Monad.Trans 16 | import qualified Text.Blaze.Html5 as H 17 | import qualified Text.Blaze.Html5.Attributes as A 18 | import Data.Text.Lazy (toStrict) 19 | import Text.Blaze.Html.Renderer.Text (renderHtml) 20 | import Text.Hamlet 21 | 22 | import Text.Digestive 23 | import Text.Digestive.Util 24 | import Text.Digestive.Blaze.Html5 25 | import Web.Spock.Digestive 26 | 27 | -- USE 'shakespeare'!!!! 28 | 29 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 30 | Country json 31 | name String 32 | canWeSend Bool default=True 33 | UniqueCountryName name 34 | deriving Show 35 | Client json 36 | firstName String 37 | lastName String 38 | address String 39 | country CountryId 40 | age Int 41 | UniqueClient firstName lastName address country 42 | deriving Show 43 | Product json 44 | name String 45 | description String 46 | price Double 47 | inStock Int 48 | deriving Show 49 | Purchase json 50 | client ClientId 51 | product ProductId 52 | number Int 53 | amount Double 54 | deriving Show 55 | |] 56 | 57 | main :: IO () 58 | main = main1 59 | 60 | main1 :: IO () 61 | main1 = do 62 | cfg <- defaultSpockCfg () PCNoDatabase () 63 | runSpock 3000 (spock cfg app) 64 | 65 | main2 :: IO () 66 | main2 = do 67 | Db.runSqlite "example.db" $ Db.runMigration migrateAll 68 | runNoLoggingT $ 69 | Db.withSqlitePool "example.db" 10 $ \pool -> liftIO $ do 70 | cfg <- defaultSpockCfg () (PCPool pool) () 71 | runSpock 3000 (spock cfg app2) 72 | 73 | app :: SpockM () () () () 74 | app = do 75 | get "about" $ 76 | html $ mconcat [ "" 77 | , "

Hello Practical Haskell!

" 78 | , ""] 79 | 80 | hookAnyAll $ \_route -> do 81 | setStatus notFound404 82 | html "

Not found :(

" 83 | 84 | app2 :: SpockM Db.SqlBackend () () () 85 | app2 = do 86 | get "products" $ do 87 | (products :: [Db.Entity Product]) <- runQuery $ \conn -> 88 | flip Db.runSqlPersistM conn $ 89 | Db.selectList [] [] 90 | html $ toStrict $ renderHtml [shamlet| 91 | 92 | 93 |

Products 94 | 95 | 96 | 100 |
Name 97 | Description 98 | $forall Db.Entity _ p <- products 99 |
#{productName p} 101 | #{productDescription p} 102 | |] 103 | 104 | get ("product" var) $ \(productId :: Integer) -> do 105 | product <- runQuery $ \conn -> -- pool taken care of 106 | flip Db.runSqlPersistM conn $ 107 | Db.get $ ProductKey (Db.SqlBackendKey $ fromIntegral productId) 108 | case product of 109 | Just (Product { .. }) -> 110 | {- 111 | html $ mconcat [ "" 112 | , "

" 113 | , T.pack productName 114 | , "

" 115 | , "

" 116 | , T.pack productDescription 117 | , "

" 118 | , "" ] 119 | -} 120 | {- 121 | html $ toStrict $ renderHtml $ 122 | H.html $ do 123 | H.head $ 124 | H.title "Time Machine Store" 125 | H.body $ do 126 | H.h1 $ H.toHtml productName 127 | H.p H.! A.id "descr" $ H.toHtml productDescription 128 | -} 129 | html $ toStrict $ renderHtml [shamlet| 130 | 131 | 132 | Time Machine Store 133 | <body> 134 | <h1>#{productName} 135 | <p id=descr>#{productDescription} 136 | |] 137 | Nothing -> do setStatus notFound404 138 | html "<h1>Not found :(</h1>" 139 | 140 | get ("json" <//> "product" <//> var) $ \(productId :: Integer) -> do 141 | product <- runQuery $ \conn -> -- pool taken care of 142 | flip Db.runSqlPersistM conn $ 143 | Db.get $ ProductKey (Db.SqlBackendKey $ fromIntegral productId) 144 | case product of 145 | Just p -> json p 146 | Nothing -> setStatus notFound404 147 | 148 | get "new-product" $ do 149 | view <- getForm "product" productForm 150 | let view' = fmap H.toHtml view 151 | html $ toStrict $ renderHtml $ 152 | H.html $ do 153 | H.head $ H.title "Time Machine Store" 154 | H.body $ productView view' 155 | 156 | post "new-product" $ do 157 | (view,product) <- runForm "product" productForm 158 | case product of 159 | Just p -> do 160 | ProductKey (Db.SqlBackendKey newId) <- runQuery $ \conn -> -- pool taken care of 161 | flip Db.runSqlPersistM conn $ Db.insert p 162 | redirect $ mconcat ["/product/", T.pack $ show newId] 163 | Nothing -> do 164 | let view' = fmap H.toHtml view 165 | html $ toStrict $ renderHtml $ 166 | H.html $ do 167 | H.head $ H.title "Time Machine Store" 168 | H.body $ productView view' 169 | 170 | countryForm :: Monad m => Form String m Country 171 | countryForm = Country <$> "name" .: string Nothing 172 | <*> "send" .: bool (Just True) 173 | 174 | productForm :: Monad m => Form String m Product 175 | productForm = Product <$> "name" .: string Nothing 176 | <*> "description" .: string Nothing 177 | <*> "price" .: validate isANumber (string Nothing) 178 | <*> "inStock" .: check "Must be >= 0" (>= 0) 179 | (validate isANumber (string Nothing)) 180 | 181 | isANumber :: (Num a, Read a) => String -> Result String a 182 | isANumber = maybe (Error "Not a number") Success . readMaybe 183 | 184 | productView :: View H.Html -> H.Html 185 | productView view = do 186 | form view "/new-product" $ do 187 | label "name" view "Name:" 188 | inputText "name" view 189 | H.br 190 | inputTextArea Nothing Nothing "description" view 191 | H.br 192 | label "price" view "Price:" 193 | inputText "price" view 194 | errorList "price" view 195 | label "inStock" view "# in Stock:" 196 | inputText "inStock" view 197 | errorList "inStock" view 198 | H.br 199 | inputSubmit "Submit" 200 | -------------------------------------------------------------------------------- /Chapter04.hs: -------------------------------------------------------------------------------- 1 | module Chapter04 where 2 | 3 | import qualified Data.Map as M 4 | import qualified Data.Set as S 5 | import Data.Tree 6 | import Data.Graph 7 | 8 | m1 = M.singleton "hello" 3 9 | m2 = M.fromList [("hello",1),("bye",2),("hello",3)] 10 | m3 = let m1' = M.singleton "hello" 3 11 | m2' = M.insert "bye" 2 m1' 12 | m3' = M.insert "hello" 5 m2' 13 | m4' = M.insertWith (+) "hello" 7 m3' 14 | in (m1',m2',m3',m4') 15 | m4 = M.fromList [("hello",3),("bye",4)] 16 | m5 = M.adjust (+7) "hello" m4 17 | m6 = M.alter (\(Just v) -> Just (v+7)) "hello" m4 18 | m7 = let m1' = M.fromList [("hello",3),("bye",4)] 19 | m2' = M.fromList [("hello",5),("welcome",6)] 20 | in (m1' `M.union` m2', M.intersectionWith (-) m1' m2') 21 | 22 | s = let set1 = S.insert "welcome" $ S.singleton "hello" 23 | set2 = S.fromList ["hello","bye"] 24 | in ( set1 `S.intersection` set2 25 | , "welcome" `S.member` set1 26 | , S.map length set2 ) 27 | 28 | -- data Tree a = Node { rootLabel :: a, subForest :: Forest a } 29 | -- type Forest a = [Tree a] 30 | type Predicate a = a -> Bool 31 | 32 | preOrder :: (a -> b) -> Tree a -> [b] 33 | preOrder f (Node v subtrees) 34 | = let subtreesTraversed = concat $ map (preOrder f) subtrees 35 | in f v : subtreesTraversed 36 | 37 | pictureTree :: Tree Int 38 | pictureTree = Node 1 [ Node 2 [ Node 3 [] 39 | , Node 4 [] 40 | , Node 5 [] ] 41 | , Node 6 [] ] 42 | 43 | t1 = preOrder show pictureTree 44 | t2 = flatten pictureTree 45 | t3 = levels pictureTree 46 | t4 = fmap (*2) pictureTree 47 | 48 | timeMachineGraph :: [(String, String, [String])] 49 | timeMachineGraph = 50 | [("wood","wood",["walls"]), ("plastic","plastic",["walls","wheels"]) 51 | ,("aluminum","aluminum",["wheels","door"]),("walls","walls",["done"]) 52 | ,("wheels","wheels",["done"]),("door","door",["done"]),("done","done",[])] 53 | 54 | timeMachinePrecedence 55 | :: (Graph, Vertex -> (String,String,[String]), String -> Maybe Vertex) 56 | timeMachinePrecedence = graphFromEdges timeMachineGraph 57 | 58 | timeMachineTravel :: Graph 59 | timeMachineTravel = buildG (103,2013) 60 | [(1302,1614),(1614,1302),(1302,2013),(2013,1302),(1614,2013) 61 | ,(2013,1408),(1408,1993),(1408,917),(1993,917),(907,103),(103,917)] 62 | 63 | g1 = let (g,v,_) = timeMachinePrecedence 64 | in map (\x -> let (k,_,_) = v x in k) $ topSort g 65 | g2 = path timeMachineTravel 1302 917 66 | g3 = reachable timeMachineTravel 1302 67 | g4 = filter (\(Node { subForest = s }) -> s /= []) $ scc timeMachineTravel 68 | g5 = map flattenSCC $ stronglyConnComp timeMachineGraph 69 | 70 | class Nameable n where 71 | name :: n -> String 72 | 73 | initial :: Nameable n => n -> Char 74 | initial n = head (name n) 75 | 76 | data Person = Person { firstName :: String, lastName :: String } 77 | deriving (Show, Eq, Ord, Read) 78 | data Client i = GovOrg { clientId :: i, clientName :: String } 79 | | Company { clientId :: i, clientName :: String 80 | , person :: Person, duty :: String } 81 | | Individual { clientId :: i, person :: Person } 82 | deriving (Show, Eq, Ord) 83 | 84 | instance Nameable (Client i) where 85 | name Individual { person = Person { firstName = f, lastName = n } } 86 | = f ++ " " ++ n 87 | name c = clientName c 88 | 89 | data Complex = C Double Double deriving (Show, Eq) 90 | 91 | instance Num Complex where 92 | (C a1 b1) + (C a2 b2) = C (a1 + a2) (b1 + b2) 93 | (C a1 b1) - (C a2 b2) = C (a1 - a2) (b1 - b2) 94 | (C a1 b1) * (C a2 b2) = C (a1*a2-b1*b2) (a1*b2+b1*a2) 95 | negate (C a b) = C (negate a) (negate b) 96 | fromInteger n = C (fromInteger n) 0 97 | abs (C a b) = C (sqrt $ a*a+b*b) 0 98 | signum c@(C a b) = let C n _ = abs c in C (a / n) (b / n) 99 | 100 | data TravelGuide = TravelGuide { title :: String 101 | , authors :: [String] 102 | , price :: Double } 103 | deriving (Show, Eq, Ord) 104 | 105 | data BinaryTree1 = Node1 TravelGuide BinaryTree1 BinaryTree1 106 | | Leaf1 107 | deriving Show 108 | 109 | treeFind1 :: TravelGuide -> BinaryTree1 -> Maybe TravelGuide 110 | treeFind1 t (Node1 v l r) = case compare t v of 111 | EQ -> Just v 112 | LT -> treeFind1 t l 113 | GT -> treeFind1 t r 114 | treeFind1 _ Leaf1 = Nothing 115 | 116 | treeInsert1 :: TravelGuide -> BinaryTree1 -> BinaryTree1 117 | treeInsert1 t n@(Node1 v l r) = case compare t v of 118 | EQ -> n 119 | LT -> Node1 v (treeInsert1 t l) r 120 | GT -> Node1 v l (treeInsert1 t r) 121 | treeInsert1 t Leaf1 = Node1 t Leaf1 Leaf1 122 | 123 | data BinaryTree2 a = Node2 a (BinaryTree2 a) (BinaryTree2 a) 124 | | Leaf2 125 | deriving Show 126 | 127 | treeFind2 :: Ord a => a -> BinaryTree2 a -> Maybe a 128 | treeFind2 t (Node2 v l r) = case compare t v of 129 | EQ -> Just v 130 | LT -> treeFind2 t l 131 | GT -> treeFind2 t r 132 | treeFind2 _ Leaf2 = Nothing 133 | 134 | newtype TGByPrice = TGByPrice TravelGuide deriving Eq 135 | 136 | instance Ord TGByPrice where 137 | (TGByPrice (TravelGuide t1 a1 p1)) <= (TGByPrice (TravelGuide t2 a2 p2)) = 138 | p1 < p2 || (p1 == p2 && (t1 < t2 || (t1 == t2 && a1 <= a2))) 139 | 140 | data BinaryTree3 v c = Node3 v c (BinaryTree3 v c) (BinaryTree3 v c) 141 | | Leaf3 142 | deriving (Show, Eq, Ord) 143 | 144 | treeInsert3 :: (Ord v, Ord c) 145 | => v -> c -> BinaryTree3 v c -> BinaryTree3 v c 146 | treeInsert3 v c (Node3 v2 c2 l r) 147 | = case compare v v2 of 148 | EQ -> Node3 v2 c2 l r 149 | LT -> Node3 v2 (min c c2) (treeInsert3 v c l) r 150 | GT -> Node3 v2 (min c c2) l (treeInsert3 v c r) 151 | treeInsert3 v c Leaf3 = Node3 v c Leaf3 Leaf3 152 | 153 | treeInsert4 :: (Ord v, Monoid c) 154 | => v -> c -> BinaryTree3 v c -> BinaryTree3 v c 155 | treeInsert4 v c (Node3 v2 c2 l r) 156 | = case compare v v2 of 157 | EQ -> Node3 v2 c2 l r 158 | LT -> let newLeft = treeInsert4 v c l 159 | newCache = c2 <> cached newLeft <> cached r 160 | in Node3 v2 newCache newLeft r 161 | GT -> let newRight = treeInsert4 v c r 162 | newCache = c2 <> cached l <> cached newRight 163 | in Node3 v2 newCache l newRight 164 | treeInsert4 v c Leaf3 = Node3 v c Leaf3 Leaf3 165 | 166 | cached :: Monoid c => BinaryTree3 v c -> c 167 | cached (Node3 _ c _ _) = c 168 | cached Leaf3 = mempty 169 | 170 | newtype Min = Min Double deriving Show 171 | 172 | instance Semigroup Min where 173 | Min x <> Min y = Min $ min x y 174 | 175 | instance Monoid Min where 176 | mempty = Min infinity where infinity = 1/0 177 | mappend = (<>) -- use the definition from Semigroup 178 | -------------------------------------------------------------------------------- /Chapter11.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, 2 | MultiParamTypeClasses, FlexibleContexts, GADTs, 3 | OverloadedStrings, GeneralizedNewtypeDeriving, 4 | ScopedTypeVariables, TypeApplications #-} 5 | module Chapter11 where 6 | 7 | import Database.Esqueleto ((^.)) 8 | import qualified Database.Esqueleto as E 9 | import Database.Persist 10 | import Database.Persist.TH 11 | import Database.Persist.Sqlite 12 | import Control.Monad.Logger 13 | import Control.Monad.Trans 14 | import Data.Maybe (catMaybes) 15 | import Data.Char 16 | 17 | data Gender = Male | Female 18 | deriving (Show, Read, Eq) 19 | derivePersistField "Gender" 20 | 21 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 22 | Country 23 | name String 24 | UniqueCountryName name 25 | deriving Show 26 | Client 27 | firstName String 28 | lastName String 29 | address String 30 | country CountryId 31 | age Int 32 | UniqueClient firstName lastName address country 33 | deriving Show 34 | Product 35 | name String 36 | price Double 37 | amount Int 38 | inStock Int 39 | deriving Show 40 | Purchase 41 | client ClientId 42 | product ProductId 43 | number Int 44 | amount Double 45 | deriving Show 46 | |] 47 | 48 | exampleConn = runNoLoggingT $ 49 | withSqliteConn @(NoLoggingT IO) @SqlBackend "example.db" $ \conn -> 50 | liftIO $ flip runSqlPersistM conn $ do 51 | spain <- insert $ Country "Spain" 52 | _client1 <- insert $ Client "Alejandro" "Serrano" 53 | "Home Town, 1" spain 25 54 | return () 55 | 56 | exampleConn2 = runSqlite @IO @SqlBackend "example.db" $ do 57 | spain <- insert $ Country "Spain" 58 | _client1 <- insert $ Client "Alejandro" "Serrano" 59 | "Home Town, 1" spain 25 60 | return () 61 | 62 | examplePool = runNoLoggingT $ 63 | withSqlitePool @(NoLoggingT IO) @SqlBackend "example.db" 10 $ \pool -> 64 | liftIO $ flip runSqlPersistMPool pool $ do 65 | spain <- insert $ Country "Spain" 66 | _client1 <- insert $ Client "Alejandro" "Serrano" 67 | "Home Town, 1" spain 25 68 | return () 69 | 70 | ejemplico = runSqlite @IO @SqlBackend "example.db" $ do 71 | spain <- insert $ Country "Spain" 72 | _client1 <- insert $ Client "Alejandro" "Serrano" "Home Town, 1" spain 25 73 | return () 74 | 75 | getPurchaseClient p = get (purchaseClient p) -- returns Maybe Client 76 | getClientById n = get $ ClientKey (SqlBackendKey $ fromIntegral n) 77 | 78 | getClientByInfo :: MonadIO m => String -> String -> String -> String -> SqlPersistT m (Maybe Client) 79 | getClientByInfo fName lName addr cnName = do 80 | cn <- getBy $ UniqueCountryName cnName 81 | case cn of 82 | Just (Entity cId _) -> 83 | do cl <- getBy $ UniqueClient fName lName addr cId 84 | case cl of 85 | Just (Entity _ client) -> return $ Just client 86 | Nothing -> return Nothing 87 | Nothing -> return Nothing 88 | 89 | getAdultsOfSpainAndGermany :: MonadIO m => SqlPersistT m [Entity Client] 90 | getAdultsOfSpainAndGermany = do 91 | es <- getBy $ UniqueCountryName "Spain" 92 | de <- getBy $ UniqueCountryName "Germany" 93 | let countries = map entityKey (catMaybes [es, de]) 94 | selectList [ ClientCountry <-.countries, ClientAge >=. 18 ] [] 95 | 96 | countAdultsOfSpainAndGermany :: MonadIO m => SqlPersistT m Int 97 | countAdultsOfSpainAndGermany = do 98 | es <- getBy $ UniqueCountryName "Spain" 99 | de <- getBy $ UniqueCountryName "Germany" 100 | let countries = map entityKey (catMaybes [es, de]) 101 | count [ ClientCountry <-.countries, ClientAge >=. 18 ] 102 | 103 | getAdultsOfSpainAndUS :: MonadIO m => SqlPersistT m [Entity Client] 104 | getAdultsOfSpainAndUS = do 105 | Just (Entity spId _) <- getBy $ UniqueCountryName "Spain" 106 | Just (Entity usId _) <- getBy $ UniqueCountryName "United States of America" 107 | selectList ( [ ClientCountry ==. spId, ClientAge >=. 18 ] 108 | ||. [ ClientCountry ==. usId, ClientAge >=. 21 ] ) 109 | [] 110 | 111 | getProductsPage n = selectList [ ] [ Asc ProductPrice, LimitTo 10, OffsetBy ((n-1)*10) ] 112 | 113 | getCountriesWithBigBuyers :: MonadIO m => SqlPersistT m [Country] 114 | getCountriesWithBigBuyers = do -- returns [Country] 115 | buyers <- selectKeysList [ ] [ ] 116 | buyersPurchases <- mapM (\b -> count [ PurchaseClient ==. b ] >>= \c -> return (b,c)) buyers 117 | let buyersPurchases' = filter (\(_,c) -> c > 3) buyersPurchases 118 | mapM (\(b,_) -> do Just cl <- get b 119 | Just cn <- get $ clientCountry cl 120 | return cn) 121 | buyersPurchases' 122 | 123 | getPeopleOver25 :: MonadIO m => SqlPersistT m [Entity Client] 124 | getPeopleOver25 = -- returns [Entity Client] 125 | E.select $ 126 | E.from $ \client -> do 127 | E.where_ (client ^. ClientAge E.>. E.val 25) 128 | E.orderBy [ E.asc (client ^. ClientLastName), E.asc (client ^. ClientFirstName) ] 129 | return client 130 | 131 | getPeopleOver25FromSpainOrGermany :: MonadIO m => SqlPersistT m [Entity Client] 132 | getPeopleOver25FromSpainOrGermany = -- returns [Entity Client] 133 | E.select $ 134 | E.from $ \(client, country) -> do 135 | E.where_ ( client ^. ClientAge E.>. (E.val 25) 136 | E.&&. country ^. CountryName `E.in_` E.valList [ "Spain", "Germany" ] 137 | E.&&. client ^. ClientCountry E.==. country ^. CountryId ) 138 | E.orderBy [ E.asc (client ^. ClientLastName), E.asc (client ^. ClientFirstName) ] 139 | return client 140 | 141 | getPeopleOver25FromSpainOrGermanyJoin :: MonadIO m => SqlPersistT m [Entity Client] 142 | getPeopleOver25FromSpainOrGermanyJoin = -- returns [Entity Client] 143 | E.select $ 144 | E.from $ \(client `E.InnerJoin` country) -> do 145 | E.on (client ^. ClientCountry E.==. country ^. CountryId) 146 | E.where_ ( client ^. ClientAge E.>. (E.val 25) 147 | E.&&. country ^. CountryName `E.in_` E.valList [ "Spain", "Germany" ]) 148 | E.orderBy [ E.asc (client ^. ClientLastName), E.asc (client ^. ClientFirstName) ] 149 | return client 150 | 151 | getMoneyByClient :: MonadIO m => SqlPersistT m [(Entity Client, E.Value (Maybe Double))] 152 | getMoneyByClient = -- returns [(Entity Client, Value (Maybe Double))] 153 | E.select $ 154 | E.from $ \(client `E.LeftOuterJoin` purchase) -> do 155 | E.on (client ^. ClientId E.==. purchase ^. PurchaseClient) 156 | E.groupBy (client ^. ClientId) 157 | let s = E.sum_ (purchase ^. PurchaseAmount) 158 | return (client, s) 159 | 160 | capitalizeNamesSlow :: MonadIO m => SqlPersistT m () 161 | capitalizeNamesSlow = do 162 | clients <- selectList [] [] 163 | mapM_ (\(Entity ident client) -> 164 | let c:rest = clientFirstName client 165 | in replace ident $ client { clientFirstName = (toUpper c):rest }) 166 | clients 167 | 168 | discount :: MonadIO m => SqlPersistT m () 169 | discount = do 170 | updateWhere [ ProductPrice <=. 10000 ] [ ProductPrice *=. 0.9 ] 171 | updateWhere [ ProductPrice >. 10000 ] [ ProductPrice *=. 0.97 ] 172 | 173 | betterDiscount :: MonadIO m => SqlPersistT m () 174 | betterDiscount = E.update $ \product -> do 175 | let totalAmount = E.sub_select $ 176 | E.from $ \purchase -> do 177 | E.where_ $ product ^. ProductId E.==. purchase ^. PurchaseProduct 178 | E.groupBy (purchase ^. PurchaseProduct) 179 | return $ E.sum_ (purchase ^. PurchaseAmount) 180 | E.where_ $ E.isNothing totalAmount E.||. totalAmount E.<. E.just (E.val (10 :: Double)) 181 | E.set product [ ProductPrice E.*=. E.val 0.9 ] 182 | 183 | cleanProductStock :: MonadIO m => SqlPersistT m () 184 | cleanProductStock = deleteWhere [ ProductInStock ==. 0 ] 185 | 186 | cleanProductStock' :: MonadIO m => SqlPersistT m () 187 | cleanProductStock' = E.delete $ 188 | E.from $ \product -> do 189 | E.where_ $ product ^. ProductInStock E.==. E.val 0 190 | E.&&. (E.notExists $ E.from $ \purchase -> 191 | E.where_ (purchase ^. PurchaseProduct E.==. product ^. ProductId)) 192 | -------------------------------------------------------------------------------- /Chapter02.hs: -------------------------------------------------------------------------------- 1 | {-# language ViewPatterns #-} 2 | {-# language NamedFieldPuns #-} 3 | {-# language RecordWildCards #-} 4 | module Chapter02 where 5 | 6 | -- Basic types 7 | 8 | firstOrEmpty :: [[Char]] -> [Char] 9 | firstOrEmpty lst = if not (null lst) then head lst else "empty" 10 | 11 | lst1 +++ lst2 = if null lst1 {- check emptyness -} 12 | then lst2 -- base case 13 | else (head lst1) : (tail lst1 +++ lst2) 14 | 15 | reverse2 list = if null list 16 | then [] 17 | else reverse2 (tail list) +++ [head list] 18 | 19 | maxmin list = if null (tail list) 20 | then (head list, head list) 21 | else ( if (head list) > fst (maxmin (tail list)) 22 | then head list 23 | else fst (maxmin (tail list)) 24 | , if (head list) < snd (maxmin (tail list)) 25 | then head list 26 | else snd (maxmin (tail list)) 27 | ) 28 | 29 | maxmin2 list = let h = head list 30 | in if null (tail list) 31 | then (h, h) 32 | else ( if h > t_max then h else t_max 33 | , if h < t_min then h else t_min ) 34 | where t = maxmin2 (tail list) 35 | t_max = fst t 36 | t_min = snd t 37 | 38 | -- Data types 39 | 40 | data Client0 = GovOrg0 String 41 | | Company0 String Integer String String 42 | | Individual0 String String Bool 43 | deriving Show 44 | 45 | data Client = GovOrg String 46 | | Company String Integer Person String 47 | | Individual Person Bool 48 | deriving Show 49 | data Person = Person String String Gender 50 | deriving Show 51 | data Gender = Male | Female 52 | deriving Show 53 | 54 | clientName1 :: Client -> String 55 | clientName1 client = case client of 56 | GovOrg name -> name 57 | Company name id person resp -> name 58 | Individual person ads -> 59 | case person of 60 | Person fNm lNm gender -> fNm ++ " " ++ lNm 61 | 62 | clientName2 :: Client -> String 63 | clientName2 client = case client of 64 | GovOrg name -> name 65 | Company name _ _ _ -> name 66 | Individual (Person fNm lNm _) _ -> fNm ++ " " ++ lNm 67 | 68 | companyName1 :: Client -> String 69 | companyName1 client = case client of 70 | Company name _ _ _ -> name 71 | 72 | companyName2 :: Client -> Maybe String 73 | companyName2 client = case client of 74 | Company name _ _ _ -> Just name 75 | _ -> Nothing 76 | f :: Client -> String 77 | f client = case client of 78 | Company _ _ (Person name _ _) "Boss" -> name ++ " is the boss" 79 | _ -> "There is no boss" 80 | 81 | g :: Client -> String 82 | g client = case client of 83 | Company _ _ (Person name _ _) pos -> 84 | case pos of "Boss" -> name ++ " is the boss" 85 | _ -> "There is no boss" 86 | 87 | clientName3 (GovOrg name) = name 88 | clientName3 (Company name _ _ _) = name 89 | clientName3 (Individual (Person fNm lNm _) _) = fNm ++ " " ++ lNm 90 | 91 | fibonacci 0 = 0 92 | fibonacci 1 = 1 93 | fibonacci n = fibonacci (n-1) + fibonacci (n-2) 94 | 95 | (++++) :: [a] -> [a] -> [a] 96 | list1 ++++ list2 = case list1 of 97 | [] -> list2 98 | x:xs -> x:(xs ++++ list2) 99 | 100 | (+++++) :: [a] -> [a] -> [a] 101 | [] +++++ list2 = list2 102 | (x:xs) +++++ list2 = x:(xs +++++ list2) 103 | 104 | sorted :: [Integer] -> Bool 105 | sorted [] = True 106 | sorted [_] = True 107 | sorted (x:y:zs) = x < y && sorted (y:zs) 108 | 109 | maxmin3 [x] = (x,x) 110 | maxmin3 (x:xs) = ( if x > xs_max then x else xs_max 111 | , if x < xs_min then x else xs_min 112 | ) where (xs_max, xs_min) = maxmin3 xs 113 | 114 | -- Guards 115 | 116 | ifibonacci :: Integer -> Maybe Integer 117 | ifibonacci n = if n < 0 118 | then Nothing 119 | else case n of 120 | 0 -> Just 0 121 | 1 -> Just 1 122 | n' -> let Just f1 = ifibonacci (n'-1) 123 | Just f2 = ifibonacci (n'-2) 124 | in Just (f1 + f2) 125 | 126 | ifibonacci2 :: Integer -> Maybe Integer 127 | ifibonacci2 n | n < 0 = Nothing 128 | ifibonacci2 0 = Just 0 129 | ifibonacci2 1 = Just 1 130 | ifibonacci2 n | otherwise = let Just f1 = ifibonacci2 (n-1) 131 | Just f2 = ifibonacci2 (n-2) 132 | in Just (f1 + f2) 133 | binom _ 0 = 1 134 | binom x y | x == y = 1 135 | binom n k = (binom (n-1) (k-1)) + (binom (n-1) k) 136 | 137 | multipleOf :: Integer -> Integer -> Bool 138 | multipleOf x y = (mod x y) == 0 139 | 140 | specialMultiples :: Integer -> String 141 | specialMultiples n | multipleOf n 2 = show n ++ " is multiple of 2" 142 | specialMultiples n | multipleOf n 3 = show n ++ " is multiple of 3" 143 | specialMultiples n | multipleOf n 5 = show n ++ " is multiple of 5" 144 | specialMultiples n | otherwise = show n ++ " is a beautiful number" 145 | 146 | specialMultiples2 :: Integer -> String 147 | specialMultiples2 n 148 | | multipleOf n 2 = show n ++ " is multiple of 2" 149 | | multipleOf n 3 = show n ++ " is multiple of 3" 150 | | multipleOf n 5 = show n ++ " is multiple of 5" 151 | | otherwise = show n ++ " is a beautiful number" 152 | 153 | -- View patterns 154 | 155 | responsibility :: Client -> String 156 | responsibility (Company _ _ _ r) = r 157 | responsibility _ = "Unknown" 158 | 159 | specialClient :: Client -> Bool 160 | specialClient (clientName1 -> "Mr. Alejandro") = True 161 | specialClient (responsibility -> "Director") = True 162 | specialClient _ = False 163 | 164 | -- Records 165 | 166 | data ClientR = GovOrgR { clientRName :: String } 167 | | CompanyR { clientRName :: String 168 | , companyId :: Integer 169 | , person :: PersonR 170 | , duty :: String } 171 | | IndividualR { person :: PersonR } 172 | deriving Show 173 | 174 | data PersonR = PersonR { firstName :: String 175 | , lastName :: String 176 | } deriving Show 177 | 178 | greet1, greet2, greet3 :: ClientR -> String 179 | 180 | greet1 IndividualR { person = PersonR { firstName = fn } } = "Hi, " ++ fn 181 | greet1 CompanyR { clientRName = c } = "Hi, " ++ c 182 | greet1 GovOrgR { } = "Welcome" 183 | 184 | greet2 IndividualR { person = PersonR { firstName } } = "Hi, " ++ firstName 185 | greet2 CompanyR { clientRName } = "Hi, " ++ clientRName 186 | greet2 GovOrgR { } = "Welcome" 187 | 188 | greet3 IndividualR { person = PersonR { .. } } = "Hi, " ++ firstName 189 | greet3 CompanyR { .. } = "Hi, " ++ clientRName 190 | greet3 GovOrgR { } = "Welcome" 191 | 192 | -- Default values 193 | 194 | data ConnType = TCP | UDP 195 | data UseProxy = NoProxy | Proxy String 196 | data TimeOut = NoTimeOut | TimeOut Integer 197 | data Connection = Connection 198 | 199 | connect :: String -> ConnType -> Integer -> UseProxy 200 | -> Bool -> Bool -> TimeOut -> Connection 201 | connect = undefined 202 | 203 | connectUrl :: String -> Connection 204 | connectUrl u = connect u TCP 0 NoProxy False False NoTimeOut 205 | 206 | data ConnOptions = ConnOptions { connType :: ConnType 207 | , connSpeed :: Integer 208 | , connProxy :: UseProxy 209 | , connCaching :: Bool 210 | , connKeepAlive :: Bool 211 | , connTimeOut :: TimeOut 212 | } 213 | 214 | connect' :: String -> ConnOptions -> Connection 215 | connect' url options = undefined 216 | 217 | connDefault :: ConnOptions 218 | connDefault = ConnOptions TCP 0 NoProxy False False NoTimeOut 219 | 220 | -------------------------------------------------------------------------------- /Chapter07.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | module Chapter07 where 3 | 4 | import Data.List 5 | import Control.Monad 6 | import Control.Monad.Logic 7 | import Control.Monad.Reader 8 | import Control.Monad.Writer hiding (Product) 9 | import Data.Set (Set) 10 | import qualified Data.Set as S 11 | 12 | join :: Maybe (Maybe a) -> Maybe a 13 | join Nothing = Nothing 14 | join (Just Nothing) = Nothing 15 | join (Just (Just x)) = Just x 16 | 17 | broken1 :: Integer -> [Integer] 18 | broken1 n = [n-1, n+1] 19 | broken2 :: Integer -> [Integer] 20 | broken2 n = [1024, n+2] 21 | b = broken1 73 `mplus` broken2 73 22 | 23 | -- Association Rules 24 | 25 | -- Clients 26 | data Client = GovOrg { clientName :: String } 27 | | Company { clientName :: String 28 | , person :: Person, duty :: String } 29 | | Individual { person :: Person } 30 | deriving (Show, Eq, Ord) 31 | 32 | data ClientKind = KindGovOrg | KindCompany | KindIndividual 33 | deriving (Show, Eq, Ord) 34 | 35 | data Person = Person { firstName :: String, lastName :: String 36 | , gender :: Gender } 37 | deriving (Show, Eq, Ord) 38 | 39 | data Gender = Male | Female | UnknownGender deriving (Show, Eq, Ord) 40 | 41 | -- Products 42 | data Product = Product { productId :: Integer, productType :: ProductType } 43 | deriving (Show, Eq, Ord) 44 | 45 | data ProductType = TimeMachine | TravelGuide | Tool | Trip 46 | deriving (Show, Eq, Ord) 47 | 48 | data Purchase = Purchase { client :: Client, products :: [Product] } 49 | deriving (Show, Eq, Ord) 50 | 51 | data PurchaseInfo = InfoClientKind ClientKind 52 | | InfoClientDuty String 53 | | InfoClientGender Gender 54 | | InfoPurchasedProduct Integer 55 | | InfoPurchasedProductType ProductType 56 | deriving (Show, Eq, Ord) 57 | 58 | newtype Transaction = Transaction (Set PurchaseInfo) 59 | deriving (Eq, Ord) 60 | 61 | clientToPurchaseInfo :: Client -> Set PurchaseInfo 62 | clientToPurchaseInfo = undefined 63 | 64 | productsToPurchaseInfo :: [Product] -> Set PurchaseInfo 65 | productsToPurchaseInfo = foldr 66 | (\(Product i t) pinfos -> S.insert (InfoPurchasedProduct i) $ 67 | S.insert (InfoPurchasedProductType t) pinfos) 68 | S.empty 69 | 70 | purchaseToTransaction :: Purchase -> Transaction 71 | purchaseToTransaction (Purchase c p) = 72 | Transaction $ clientToPurchaseInfo c `S.union` productsToPurchaseInfo p 73 | 74 | newtype FrequentSet = FrequentSet (Set PurchaseInfo) 75 | deriving (Eq, Ord) 76 | 77 | data AssocRule = AssocRule (Set PurchaseInfo) (Set PurchaseInfo) 78 | deriving (Eq, Ord) 79 | instance Show AssocRule where 80 | show (AssocRule a b) = show a ++ " => " ++ show b 81 | 82 | setSupport :: [Transaction] -> FrequentSet -> Double 83 | setSupport trans (FrequentSet sElts) = 84 | let total = length trans 85 | f (Transaction tElts) = sElts `S.isSubsetOf` tElts 86 | supp = length (filter f trans) 87 | in fromIntegral supp / fromIntegral total 88 | 89 | ruleConfidence :: [Transaction] -> AssocRule -> Double 90 | ruleConfidence trans (AssocRule a b) = 91 | setSupport trans (FrequentSet $ a `S.union` b) 92 | / setSupport trans (FrequentSet a) 93 | 94 | generateL1 :: Double -> [Transaction] -> [FrequentSet] 95 | generateL1 minSupport transactions = 96 | noDups $ do Transaction t <- transactions 97 | e <- S.toList t 98 | let fs = FrequentSet $ S.singleton e 99 | guard $ setSupport transactions fs > minSupport 100 | return fs 101 | 102 | -- noDups removes duplicates in a list 103 | noDups :: Ord a => [a] -> [a] 104 | noDups = S.toList . S.fromList 105 | 106 | generateNextLk :: Double -> [Transaction] -> (Int, [FrequentSet]) 107 | -> Maybe ([FrequentSet], (Int, [FrequentSet])) 108 | generateNextLk _ _ (_, []) = Nothing 109 | generateNextLk minSupport transactions (k, lk) = 110 | let lk1 = noDups $ do FrequentSet a <- lk 111 | FrequentSet b <- lk 112 | guard $ S.size (a `S.intersection` b) == k - 1 113 | let fs = FrequentSet $ a `S.union` b 114 | guard $ setSupport transactions fs > minSupport 115 | return fs 116 | in Just (lk1, (k+1, lk1)) 117 | 118 | generateAssocRules :: Double -> [Transaction] -> [FrequentSet] 119 | -> [AssocRule] 120 | generateAssocRules minConfidence transactions sets = 121 | do FrequentSet fs <- sets 122 | subset@(_:_) <- powerset $ S.toList fs 123 | let ssubset = S.fromList subset 124 | rule = AssocRule ssubset (fs `S.difference` ssubset) 125 | guard $ ruleConfidence transactions rule > minConfidence 126 | return rule 127 | 128 | powerset :: [a] -> [[a]] 129 | powerset [] = [[]] 130 | powerset (x:xs) = powerset xs ++ map (x:) (powerset xs) 131 | 132 | apriori :: Double -> Double -> [Transaction] -> [AssocRule] 133 | apriori minSupport minConfidence transactions = 134 | generateAssocRules minConfidence transactions 135 | $ concat $ unfoldr (generateNextLk minSupport transactions) 136 | (1, generateL1 minSupport transactions) 137 | 138 | -- Search problems 139 | 140 | paths1 :: [(Int,Int)] -> Int -> Int -> [[Int]] 141 | paths1 edges start end = 142 | do (e_start, e_end) <- edges 143 | guard $ e_start == start 144 | subpath <- paths1 edges e_end end 145 | return $ start:subpath 146 | 147 | paths2 :: [(Int,Int)] -> Int -> Int -> [[Int]] 148 | paths2 edges start end = 149 | let e_paths = do (e_start, e_end) <- edges 150 | guard $ e_start == start 151 | subpath <- paths2 edges e_end end 152 | return $ start:subpath 153 | in if start == end 154 | then return [end] `mplus` e_paths 155 | else e_paths 156 | 157 | graph1 :: [(Int, Int)] 158 | graph1 = [(2013,501),(2013,1004),(501,2558),(1004,2558)] 159 | pg1 = paths2 graph1 2013 2558 160 | graph2 :: [(Int, Int)] 161 | graph2 = [(2013,501),(501,2558),(501,1004),(1004,501),(2013,2558)] 162 | 163 | pathsL :: [(Int,Int)] -> Int -> Int -> Logic [Int] 164 | pathsL edges start end = 165 | let e_paths = do (e_start, e_end) <- choices edges 166 | guard $ e_start == start 167 | subpath <- pathsL edges e_end end 168 | return $ start:subpath 169 | in if start == end then return [end] `mplus` e_paths else e_paths 170 | 171 | choices :: [a] -> Logic a 172 | choices = msum . map return 173 | 174 | pathsLFair :: [(Int,Int)] -> Int -> Int -> Logic [Int] 175 | pathsLFair edges start end = 176 | let e_paths = choices edges >>- \(e_start, e_end) -> 177 | guard (e_start == start) >> 178 | pathsLFair edges e_end end >>- \subpath -> 179 | return $ start:subpath 180 | in if start == end then return [end] `interleave` e_paths else e_paths 181 | 182 | pg2a = observeMany 3 $ pathsL graph2 2013 2558 183 | pg2b = observeMany 3 $ pathsLFair graph2 2013 2558 184 | 185 | -- Monads and lists, redux 186 | 187 | addPrefix :: String -> Reader String String 188 | addPrefix s = ask >>= \p -> return $ p ++ s 189 | 190 | addPrefixL :: [String] -> Reader String [String] 191 | addPrefixL = mapM addPrefix 192 | 193 | r1 = runReader (addPrefixL ["one","two"]) "**-" 194 | 195 | logInformation :: [String] -> Writer String () 196 | logInformation = mapM_ (\s -> tell (s ++ "\n")) 197 | 198 | w1 = runWriter $ logInformation ["one","two"] 199 | 200 | factorialSteps :: Integer -> Writer (Sum Integer) Integer 201 | factorialSteps n = foldM (\f x -> tell (Sum 1) >> return (f*x)) 1 [1 .. n] 202 | 203 | powerset2 :: [a] -> [[a]] 204 | powerset2 = filterM (\_ -> [False,True]) 205 | 206 | -- Monad combinators 207 | 208 | pathsWriter :: [(Int,Int)] -> Int -> Int -> [[Int]] 209 | pathsWriter edges start end = map execWriter (pathsWriter' edges start end) 210 | 211 | pathsWriter' :: [(Int,Int)] -> Int -> Int -> [Writer [Int] ()] 212 | pathsWriter' edges start end = 213 | let e_paths = do (e_start, e_end) <- edges 214 | guard $ e_start == start 215 | subpath <- pathsWriter' edges e_end end 216 | return $ do tell [start] 217 | subpath 218 | in if start == end then tell [start] : e_paths else e_paths 219 | 220 | pathsWriterT' :: [(Int,Int)] -> Int -> Int -> WriterT [Int] [] () 221 | pathsWriterT' edges start end = 222 | let e_paths = do (e_start, e_end) <- lift edges 223 | guard $ e_start == start 224 | tell [start] 225 | pathsWriterT' edges e_end end 226 | in if start == end then tell [start] `mplus` e_paths else e_paths 227 | 228 | pathsWriterT :: [(Int,Int)] -> Int -> Int -> [[Int]] 229 | pathsWriterT edges start end = execWriterT (pathsWriterT' edges start end) 230 | 231 | readerWriterExample :: ReaderT Int (Writer String) Int 232 | readerWriterExample = do x <- ask 233 | lift . tell $ show x 234 | return $ x + 1 235 | 236 | readerWriterExample2 :: (MonadReader Int m, MonadWriter String m) => m Int 237 | readerWriterExample2 = do x <- ask 238 | tell $ show x 239 | return $ x + 1 240 | -------------------------------------------------------------------------------- /Chapter06.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | module Chapter06 where 6 | 7 | import Data.List 8 | import qualified Data.Map as M 9 | import Lens.Micro.Platform 10 | import Data.Maybe 11 | import qualified Control.Monad.State as S 12 | import qualified Control.Monad.Reader as R 13 | import qualified Control.Monad.RWS as RWS 14 | import Data.Monoid 15 | import Control.Monad 16 | 17 | -- K-means 18 | 19 | class Ord v => Vector v where 20 | distance :: v -> v -> Double 21 | centroid :: [v] -> v 22 | class Vector v => Vectorizable e v where 23 | toVector :: e -> v 24 | 25 | instance Vector (Double, Double) where 26 | distance (a,b) (c,d) = sqrt $ (c-a)*(c-a) + (d-b)*(d-b) 27 | centroid lst = let (u,v) = foldr (\(a,b) (c,d) -> (a+c,b+d)) (0,0) lst 28 | n = fromIntegral $ length lst 29 | in (u / n, v / n) 30 | instance Vectorizable (Double,Double) (Double,Double) where 31 | toVector = id 32 | 33 | clusterAssignmentPhase :: (Ord v, Vector v, Vectorizable e v) 34 | => [v] -> [e] -> M.Map v [e] 35 | clusterAssignmentPhase centroids points = 36 | let initialMap = M.fromList $ zip centroids (repeat []) 37 | in foldr (\p m -> let chosenC = minimumBy (compareDistance p) centroids 38 | in M.adjust (p:) chosenC m) 39 | initialMap points 40 | where compareDistance p x y = compare (distance x $ toVector p) 41 | (distance y $ toVector p) 42 | 43 | newCentroidPhase :: (Vector v, Vectorizable e v) => M.Map v [e] -> [(v,v)] 44 | newCentroidPhase = M.toList . fmap (centroid . map toVector) 45 | 46 | shouldStop :: (Vector v) => [(v,v)] -> Double -> Bool 47 | shouldStop centroids threshold = 48 | foldr (\(x,y) s -> s + distance x y) 0.0 centroids < threshold 49 | 50 | kMeans :: (Vector v, Vectorizable e v) 51 | => (Int -> [e] -> [v]) -- initialization function 52 | -> Int -- number of centroids 53 | -> [e] -- the information 54 | -> Double -- threshold 55 | -> [v] -- final centroids 56 | kMeans i k points = kMeans' (i k points) points 57 | 58 | kMeans' :: (Vector v, Vectorizable e v) 59 | => [v] -> [e] -> Double -> [v] 60 | kMeans' centroids points threshold = 61 | let assignments = clusterAssignmentPhase centroids points 62 | oldNewCentroids = newCentroidPhase assignments 63 | newCentroids = map snd oldNewCentroids 64 | in if shouldStop oldNewCentroids threshold 65 | then newCentroids 66 | else kMeans' newCentroids points threshold 67 | 68 | initializeSimple :: Int -> [e] -> [(Double,Double)] 69 | initializeSimple 0 _ = [] 70 | initializeSimple n v = (fromIntegral n, fromIntegral n) 71 | : initializeSimple (n-1) v 72 | 73 | -- LENSES 74 | -- Hand-written 75 | data Client0 i = GovOrg0 i String 76 | | Company0 i String Person0 String 77 | | Individual0 i Person0 78 | data Person0 = Person0 String String 79 | 80 | firstName0 :: Lens' Person0 String 81 | firstName0 = lens (\(Person0 f _) -> f) 82 | (\(Person0 _ l) newF -> Person0 newF l) 83 | 84 | lastName0 :: Lens' Person0 String 85 | lastName0 = lens (\(Person0 _ l) -> l) 86 | (\(Person0 f _) newL -> Person0 f newL) 87 | 88 | identifier0 :: Lens (Client0 i) (Client0 j) i j 89 | identifier0 = lens (\case (GovOrg0 i _) -> i 90 | (Company0 i _ _ _) -> i 91 | (Individual0 i _) -> i) 92 | (\client newId -> case client of 93 | GovOrg0 _ n -> GovOrg0 newId n 94 | Company0 _ n p r -> Company0 newId n p r 95 | Individual0 _ p -> Individual0 newId p) 96 | 97 | fullName0 :: Lens' Person0 String 98 | fullName0 = lens (\(Person0 f l) -> f ++ " " ++ l) 99 | (\_ newFullName -> case words newFullName of 100 | f:l:_ -> Person0 f l 101 | _ -> error "Incorrect name") 102 | 103 | 104 | -- Auto-generated 105 | data Client i = GovOrg { _identifier :: i, _name :: String } 106 | | Company { _identifier :: i, _name :: String 107 | , _person :: Person, _duty :: String } 108 | | Individual { _identifier :: i, _person :: Person } 109 | deriving Show 110 | data Person = Person { _firstName :: String, _lastName :: String } 111 | deriving Show 112 | makeLenses ''Client 113 | makeLenses ''Person 114 | 115 | fullName :: Lens' Person String 116 | fullName = lens (\(Person f l) -> f ++ " " ++ l) 117 | (\_ newFullName -> case words newFullName of 118 | f:l:_ -> Person f l 119 | _ -> error "Incorrect name") 120 | 121 | -- K-means with lenses 122 | 123 | data KMeansState e v = KMeansState { _centroids :: [v], _points :: [e] 124 | , _err :: Double, _threshold :: Double 125 | , _steps :: Int } 126 | 127 | makeLenses ''KMeansState 128 | 129 | initializeStateL :: (Int -> [e] -> [v]) 130 | -> Int -> [e] -> Double -> KMeansState e v 131 | initializeStateL i n pts t = KMeansState (i n pts) pts (1.0/0.0) t 0 132 | 133 | kMeansL :: (Vector v, Vectorizable e v) 134 | => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 135 | kMeansL i n pts t = view centroids $ kMeansL' (initializeStateL i n pts t) 136 | 137 | kMeansL' :: (Vector v, Vectorizable e v) 138 | => KMeansState e v -> KMeansState e v 139 | kMeansL' state = 140 | let assignments = clusterAssignmentPhaseL state 141 | state1 = state & centroids.traversed 142 | %~ (\c -> centroid 143 | $ fmap toVector 144 | $ M.findWithDefault [] c assignments) 145 | state2 = state1 & err .~ sum (zipWith distance (state^.centroids) 146 | (state1^.centroids)) 147 | state3 = state2 & steps +~ 1 148 | in if state3^.err < state3^.threshold then state3 else kMeansL' state3 149 | 150 | clusterAssignmentPhaseL :: (Vector v, Vectorizable e v) 151 | => KMeansState e v -> M.Map v [e] 152 | clusterAssignmentPhaseL = undefined 153 | 154 | -- Monads 155 | 156 | purchasesByClientId = undefined 157 | numberItemsByPurchaseId = undefined 158 | productIdByPurchaseId = undefined 159 | priceByProductId = undefined 160 | 161 | meanPurchase :: Integer -- the client identifier 162 | -> Double -- the mean purchase 163 | meanPurchase clientId = let p = purchasesByClientId clientId 164 | in foldr (+) 0.0 $ catMaybes $ map purchaseValue p 165 | 166 | purchaseValue :: Integer -> Maybe Double 167 | purchaseValue purchaseId = 168 | case numberItemsByPurchaseId purchaseId of 169 | Nothing -> Nothing 170 | Just n -> case productIdByPurchaseId purchaseId of 171 | Nothing -> Nothing 172 | Just prId -> case priceByProductId prId of 173 | Nothing -> Nothing 174 | Just price -> Just $ (fromInteger n) * price 175 | 176 | thenDo :: Maybe a -> (a -> Maybe b) -> Maybe b 177 | thenDo Nothing _ = Nothing 178 | thenDo (Just x) f = f x 179 | 180 | purchaseValue2 :: Integer -> Maybe Double 181 | purchaseValue2 purchaseId = 182 | numberItemsByPurchaseId purchaseId `thenDo` (\n -> 183 | productIdByPurchaseId purchaseId `thenDo` (\productId -> 184 | priceByProductId productId `thenDo` (\price -> 185 | Just $ fromInteger n * price ))) 186 | 187 | type State s a = s -> (a, s) 188 | 189 | thenDoS :: State s a -> (a -> State s b) -> State s b 190 | -- thenDoS :: (s -> (a,s)) -> (a -> s -> (b,s)) -> s -> (b,s) 191 | thenDoS f g s = let (resultOfF, stateAfterF) = f s 192 | in g resultOfF stateAfterF 193 | 194 | data KMeansState2 v = KMeansState2 { centroids2 :: [v] 195 | , threshold2 :: Double 196 | , steps2 :: Int } 197 | 198 | newCentroids2 :: (Vector v, Vectorizable e v) => M.Map v [e] -> [v] 199 | newCentroids2 = M.elems . fmap (centroid . map toVector) 200 | 201 | clusterAssignments2 :: (Vector v, Vectorizable e v) 202 | => [v] -> [e] -> M.Map v [e] 203 | clusterAssignments2 centrs points = 204 | let initialMap = M.fromList $ zip centrs (repeat []) 205 | in foldr (\p m -> let chosenC = minimumBy (compareDistance p) centrs 206 | in M.adjust (p:) chosenC m) 207 | initialMap points 208 | where compareDistance p x y = compare (distance x $ toVector p) 209 | (distance y $ toVector p) 210 | 211 | kMeans2' :: (Vector v, Vectorizable e v) => [e] -> State (KMeansState2 v) [v] 212 | kMeans2' points = 213 | (\s -> (centroids2 s,s)) `thenDoS` (\prevCentrs -> 214 | (\s -> (clusterAssignments2 prevCentrs points, s)) `thenDoS` (\assignments -> 215 | (\s -> (newCentroids2 assignments, s)) `thenDoS` (\newCentrs -> 216 | (\s -> ((), s { centroids2 = newCentrs })) `thenDoS` (\_ -> 217 | (\s -> ((), s { steps2 = steps2 s + 1 })) `thenDoS` (\_ -> 218 | (\s -> (threshold2 s, s)) `thenDoS` (\t -> 219 | (\s -> (sum $ zipWith distance prevCentrs newCentrs, s)) `thenDoS` (\err -> 220 | if err < t then (\s -> (newCentrs, s)) else (kMeans2' points) ))))))) 221 | 222 | initialState2 :: (Vector v, Vectorizable e v) 223 | => (Int -> [e] -> [v]) -> Int -> [e] -> Double 224 | -> KMeansState2 v 225 | initialState2 i k pts t = KMeansState2 (i k pts) t 0 226 | 227 | kMeans2 :: (Vector v, Vectorizable e v) 228 | => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 229 | kMeans2 i k pts t = fst $ kMeans2' pts (initialState2 i k pts t) 230 | 231 | remain :: a -> (s -> (a,s)) 232 | remain x = \s -> (x,s) 233 | 234 | access :: (s -> a) -> (s -> (a,s)) 235 | access f = \s -> (f s, s) 236 | 237 | modify :: (s -> s) -> (s -> ((), s)) 238 | modify f = \s -> ((), f s) 239 | 240 | kMeans2b' :: (Vector v, Vectorizable e v) 241 | => [e] -> State (KMeansState2 v) [v] 242 | kMeans2b' points = 243 | access centroids2 `thenDoS` (\prevCentrs -> 244 | remain (clusterAssignments2 prevCentrs points) `thenDoS` (\assignments -> 245 | remain (newCentroids2 assignments) `thenDoS` (\newCentrs -> 246 | modify (\s -> s { centroids2 = newCentrs }) `thenDoS` (\_ -> 247 | modify (\s -> s { steps2 = steps2 s + 1 }) `thenDoS` (\_ -> 248 | access threshold2 `thenDoS` (\t -> 249 | remain (sum $ zipWith distance prevCentrs newCentrs) `thenDoS` (\err -> 250 | if err < t then remain newCentrs else kMeans2b' points ))))))) 251 | 252 | -- do notation 253 | 254 | purchaseValueWithDo :: Integer -> Maybe Double 255 | purchaseValueWithDo purchaseId 256 | = do n <- numberItemsByPurchaseId purchaseId 257 | productId <- productIdByPurchaseId purchaseId 258 | price <- priceByProductId productId 259 | return $ fromInteger n * price 260 | 261 | -- State + lenses 262 | 263 | data KMeansState3 v = KMeansState3 { _centroids3 :: [v] 264 | , _threshold3 :: Double 265 | , _steps3 :: Int } 266 | makeLenses ''KMeansState3 267 | 268 | kMeans3' :: (Vector v, Vectorizable e v) 269 | => [e] -> S.State (KMeansState3 v) [v] 270 | kMeans3' points = do prevCentrs <- use centroids3 271 | let assignments = clusterAssignments2 prevCentrs points 272 | newCentrs = newCentroids2 assignments 273 | centroids3 .= newCentrs 274 | steps3 += 1 275 | let err = sum $ zipWith distance prevCentrs newCentrs 276 | t <- use threshold3 277 | if err < t then return newCentrs else kMeans3' points 278 | 279 | -- Reader monad 280 | data Settings e v = Settings { i :: Int -> [e] -> [v], k :: Int 281 | , th :: Double, user :: Person } 282 | 283 | kMeansMain :: (Vector v, Vectorizable e v) 284 | => [e] -> R.Reader (Settings e v) [v] 285 | kMeansMain points = do i' <- R.asks i 286 | k' <- R.asks k 287 | t' <- R.asks th 288 | return $ kMeans i' k' points t' 289 | 290 | compareClusters :: (Vector v, Vectorizable e v) 291 | => [e] -> R.Reader (Settings e v) ([v], [v]) 292 | compareClusters points = do c1 <- kMeansMain points 293 | c2 <- R.local (\s -> s { k = k s + 1 }) 294 | (kMeansMain points) 295 | return (c1, c2) 296 | 297 | kMeans4' :: (Vector v, Vectorizable e v) 298 | => [e] -> RWS.RWS Double (Sum Int) [v] () 299 | kMeans4' points = do prevCentrs <- RWS.get 300 | let assignments = clusterAssignments2 prevCentrs points 301 | newCentrs = newCentroids2 assignments 302 | RWS.put newCentrs 303 | RWS.tell (Sum 1) 304 | t <- RWS.ask 305 | let err = sum $ zipWith distance prevCentrs newCentrs 306 | unless (err < t) $ kMeans4' points 307 | 308 | 309 | kMeans4 :: (Vector v, Vectorizable e v) 310 | => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> ([v], Sum Int) 311 | kMeans4 i n pts t = RWS.execRWS (kMeans4' pts) t (i n pts) 312 | --------------------------------------------------------------------------------