├── 9781430262503.jpg ├── LICENSE.txt ├── README.md ├── appendixB ├── Setup.hs ├── appendixB.cabal └── src │ └── Main.hs ├── chapter1 ├── Setup.hs ├── chapter1.cabal └── src │ └── Main.hs ├── chapter10 ├── Setup.hs ├── chapter10.cabal └── src │ ├── Args.hs │ ├── Chapter10 │ ├── Builder.hs │ ├── Parser.hs │ ├── TypeClasses.hs │ └── Types.hs │ └── Main.hs ├── chapter11 ├── Setup.hs ├── chapter11.cabal └── src │ ├── Chapter11 │ ├── Database.hs │ ├── Gender.hs │ ├── Query.hs │ └── Update.hs │ └── Main.hs ├── chapter12 ├── Setup.hs ├── chapter12.cabal ├── fay │ ├── Simple.hs │ ├── Simple.html │ ├── ToScotty.hs │ └── ToScotty.html └── src │ ├── Chapter12 │ └── Database.hs │ ├── ScottyMain.hs │ └── YesodMain.hs ├── chapter13 ├── Setup.hs ├── chapter13.cabal └── src │ └── Chapter13 │ ├── CategoriesFnDeps.hs │ ├── CategoriesTyFams.hs │ ├── CheckPresents.idr │ ├── CheckPresentsFnDeps.hs │ ├── CheckPresentsPromoted.hs │ ├── CheckPresentsTyFams.hs │ ├── CheckRangesPromoted.hs │ ├── Database.hs │ ├── DatabaseSpliced.hs │ ├── GADTs.hs │ ├── Initial.hs │ ├── ListL.idr │ ├── Numbers.hs │ ├── Numbers.idr │ ├── Tree.idr │ ├── Users.hs │ └── VectorsLits.hs ├── chapter14 ├── Setup.hs ├── chapter14.cabal ├── offer-description.html ├── src │ ├── Chapter14 │ │ ├── Description.ag │ │ ├── Expr.ag │ │ ├── Expr2.ag │ │ ├── ExprMonad.hs │ │ ├── ExprType.ag │ │ ├── OfferType.ag │ │ ├── Origami.hs │ │ ├── Presents.ag │ │ ├── Simple.ag │ │ └── SimpleNoAG.hs │ └── Main.hs └── uuagc_options ├── chapter15 ├── Setup.hs ├── chapter15.cabal ├── src │ └── Chapter15 │ │ ├── BinaryTree.hs │ │ ├── BinaryTreeFV.idr │ │ └── RevFV.idr └── test │ ├── HSpec.hs │ └── Tasty.hs ├── chapter16 ├── Setup.hs ├── chapter16.cabal └── src │ └── Chapter16 │ └── FreeMonads.hs ├── chapter2 ├── Setup.hs ├── chapter2.cabal └── src │ └── Chapter2 │ ├── DataTypes.hs │ ├── DefaultValues.hs │ ├── Section2 │ └── Example.hs │ └── SimpleFunctions.hs ├── chapter3 ├── Setup.hs ├── chapter3.cabal └── src │ └── Chapter3 │ ├── Comprehensions.hs │ ├── FnsParams.hs │ ├── Lists.hs │ ├── MoreModules.hs │ ├── Origami.hs │ └── ParamPoly.hs ├── chapter4 ├── Setup.hs ├── chapter4.cabal └── src │ └── Chapter4 │ ├── Containers.hs │ ├── FunctorsFoldables.hs │ ├── MinimumPrice.hs │ └── TypeClasses.hs ├── chapter5 ├── .gitignore ├── Setup.hs ├── chapter5.cabal ├── profiling-example.hp └── src │ ├── Chapter5 │ ├── Annotations.hs │ ├── Infinite.hs │ └── Problems.hs │ └── Main.hs ├── chapter6 ├── Setup.hs ├── chapter6.cabal └── src │ └── Chapter6 │ ├── CombinatorsState.hs │ ├── IncompleteData.hs │ ├── KMeans.hs │ ├── KMeansLens.hs │ ├── KMeansRWS.hs │ ├── KMeansState.hs │ ├── KMeansStateLens.hs │ ├── Lens.hs │ ├── Lens2.hs │ ├── ReaderWriter.hs │ ├── STRef.hs │ ├── StateLenses.hs │ └── Vector.hs ├── chapter7 ├── Setup.hs ├── chapter7.cabal └── src │ ├── Chapter7 │ ├── APriori │ │ ├── FirstImpl.hs │ │ ├── Types.hs │ │ └── WithMonads.hs │ ├── CombiningMonads.hs │ ├── Graph.hs │ ├── MonadPlus.hs │ ├── MoreThanOneValue.hs │ └── UnderAMonad.hs │ └── Main.hs ├── chapter8 ├── Setup.hs ├── chapter8.cabal └── src │ ├── Chapter8 │ └── APriori │ │ ├── Par.hs │ │ ├── Par2.hs │ │ └── Types.hs │ ├── Distr.hs │ ├── Par.hs │ └── Stm.hs ├── chapter9 ├── Setup.hs ├── chapter9.cabal └── src │ ├── Basic.hs │ ├── Chapter9 │ └── Types.hs │ ├── Client.hs │ ├── Exceptions.hs │ ├── Server.hs │ └── Streams.hs └── contributing.md /9781430262503.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/beg-haskell/aaacbf047d553e6177c38807e662cc465409dffd/9781430262503.jpg -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/beg-haskell/aaacbf047d553e6177c38807e662cc465409dffd/LICENSE.txt -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Beginning Haskell*](http://www.apress.com/9781430262503) by Alejandro Serrano Mena (Apress, 2014). 4 | 5 | ![Cover image](9781430262503.jpg) 6 | 7 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 8 | 9 | ## Releases 10 | 11 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 12 | 13 | ## Contributions 14 | 15 | See the file Contributing.md for more information on how you can contribute to this repository. 16 | -------------------------------------------------------------------------------- /appendixB/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /appendixB/appendixB.cabal: -------------------------------------------------------------------------------- 1 | name: appendixB 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable tardis 8 | build-depends: base >= 4, tardis 9 | hs-source-dirs: src 10 | ghc-options: -Wall 11 | main-is: Main.hs 12 | 13 | -------------------------------------------------------------------------------- /appendixB/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.Tardis 6 | 7 | main :: IO () 8 | main = print $ sumListTardis [1,2,3,4] 9 | 10 | sumListTardis :: [Int] -> [(Int,Int)] 11 | sumListTardis lst = evalTardis (sumListTardis' lst) (0, 0) 12 | 13 | sumListTardis' :: [Int] -> Tardis Int Int [(Int,Int)] 14 | sumListTardis' (x:xs) = do 15 | sumFw <- getPast 16 | let newFw = sumFw + x 17 | sendFuture $ newFw 18 | rec let newBw = sumBw + x 19 | sendPast $ newBw 20 | sumBw <- getFuture 21 | rest <- sumListTardis' xs 22 | return $ (newFw, newBw):rest 23 | sumListTardis' [] = return [] 24 | -------------------------------------------------------------------------------- /chapter1/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter1/chapter1.cabal: -------------------------------------------------------------------------------- 1 | name: chapter1 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable chapter1 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | build-depends: base >= 4 11 | ghc-options: -Wall 12 | 13 | -------------------------------------------------------------------------------- /chapter1/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | 5 | main::IO() 6 | main = undefined -------------------------------------------------------------------------------- /chapter10/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter10/chapter10.cabal: -------------------------------------------------------------------------------- 1 | name: chapter10 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable chapter10 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | build-depends: base >= 4, conduit, bytestring, text, random, mtl, attoparsec, attoparsec-conduit, aeson, unordered-containers, lens, lens-aeson 11 | ghc-options: -Wall 12 | other-modules: Chapter10.Builder, Chapter10.Parser, Chapter10.TypeClasses 13 | 14 | executable chapter10-args 15 | hs-source-dirs: src 16 | main-is: Args.hs 17 | build-depends: base >= 4, optparse-applicative 18 | ghc-options: -Wall 19 | -------------------------------------------------------------------------------- /chapter10/src/Args.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Options.Applicative 4 | 5 | data Args = Args String Bool -- data type holding the arguments 6 | deriving Show 7 | 8 | args :: Parser Args -- read the arguments 9 | args = Args <$> strOption (long "file" <> help "Database of clients to load") 10 | <*> switch (long "json" <> help "Whether the database uses JSON") 11 | 12 | argsInfo :: ParserInfo Args -- define arguments + help text 13 | argsInfo = info args fullDesc 14 | 15 | main :: IO () 16 | main = do Args fPath json <- execParser argsInfo 17 | print (fPath, json) 18 | -------------------------------------------------------------------------------- /chapter10/src/Chapter10/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Chapter10.Builder where 4 | 5 | import Data.Conduit 6 | import qualified Data.Conduit.Binary as B 7 | import qualified Data.Conduit.List as L 8 | import qualified Data.Conduit.Text as T 9 | import Data.Monoid 10 | import Data.Text.Lazy 11 | import Data.Text as T 12 | import qualified Data.Text.Lazy.Builder as B 13 | import qualified Data.Text.Lazy.Builder.Int as B 14 | 15 | import Chapter10.Types 16 | 17 | saveClients :: FilePath -> [Client Int] -> IO () 18 | saveClients fpath clients = runResourceT $ 19 | L.sourceList clients $$ L.map clientToText' =$= L.map (toStrict . B.toLazyText) 20 | =$= L.concatMap (\x -> [x, "\n"]) -- write '\n' between clients 21 | =$= T.encode T.utf8 =$ B.sinkFile fpath 22 | 23 | clientToText :: Client Int -> T.Text 24 | clientToText (GovOrg i n) = 25 | "client(gov," <> escapeString (show i) <> "," <> escapeString n <> ")" 26 | clientToText (Company i n p d) = 27 | "client(com," <> escapeString (show i) <> "," <> escapeString n <> "," 28 | <> personToText p <> "," <> escapeString d <> ")" 29 | clientToText (Individual i p) = 30 | "client(ind," <> escapeString (show i) <> "," <> personToText p <> ")" 31 | 32 | personToText :: Person -> T.Text 33 | personToText (Person f l) = "person(" <> escapeString f <> "," <> escapeString l <> ")" 34 | 35 | escapeString :: String -> T.Text 36 | escapeString = T.replace "\n" "\\n" . T.replace "," "\\," . 37 | T.replace "(" "\\(" . T.replace ")" "\\(" . T.pack 38 | 39 | clientToText' :: Client Int -> B.Builder 40 | clientToText' (GovOrg i n) = 41 | "client(gov," <> B.decimal i <> B.singleton ',' 42 | <> B.fromText (escapeString n) <> B.singleton ')' 43 | clientToText' (Company i n p d) = 44 | "client(com," <> B.decimal i <> B.singleton ',' 45 | <> B.fromText (escapeString n) <> B.singleton ',' 46 | <> personToText' p <> B.singleton ',' 47 | <> B.fromText (escapeString d) <> B.singleton ')' 48 | clientToText' (Individual i p) = 49 | "client(ind," <> B.decimal i <> B.singleton ',' 50 | <> personToText' p <> B.singleton ')' 51 | 52 | personToText' :: Person -> B.Builder 53 | personToText' (Person f l) = 54 | "person(" <> B.fromText (escapeString f) <> B.singleton ',' 55 | <> B.fromText (escapeString l) <> B.singleton ')' 56 | 57 | -------------------------------------------------------------------------------- /chapter10/src/Chapter10/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Chapter10.Parser where 4 | 5 | import Control.Applicative 6 | import Data.Text 7 | import Data.Attoparsec.Text 8 | 9 | import Data.Conduit 10 | import Data.Conduit.Attoparsec 11 | import qualified Data.Conduit.Binary as B 12 | import qualified Data.Conduit.Text as T 13 | 14 | import Chapter10.Types 15 | 16 | data GreetingYear = GreetingYear Text Int 17 | data GreetingYear' = GreetingYear' Greeting Int 18 | 19 | data Greeting = Hello | Bye 20 | 21 | greetingYearParser :: Parser GreetingYear 22 | greetingYearParser = GreetingYear <$> (string "hello" <|> string "bye") <*> decimal 23 | 24 | greetingYearParserSpace :: Parser GreetingYear 25 | greetingYearParserSpace = (\g _ y -> GreetingYear g y) <$> 26 | (string "hello" <|> string "bye") <*> char ' ' <*> decimal 27 | 28 | greetingYearParserSpace' :: Parser GreetingYear 29 | greetingYearParserSpace' = GreetingYear <$> (string "hello" <|> string "bye") <* char ' ' <*> decimal 30 | 31 | 32 | aChar :: Parser Char 33 | aChar = (const ',') <$> (string "\\,") 34 | <|> (const '\n') <$> (string "\\n") 35 | <|> (const '(') <$> (string "\\(") 36 | <|> (const ')') <$> (string "\\)") 37 | <|> satisfy (notInClass ",\n()") 38 | 39 | aString' :: Parser String 40 | aString' = ((:) <$> aChar <*> aString') <|> (pure "") 41 | 42 | aString :: Parser String 43 | aString = many aChar 44 | 45 | aPerson :: Parser Person 46 | aPerson = Person <$ string "person(" <*> aString <* char ',' <*> aString <* char ')' 47 | 48 | aClient :: Parser (Client Int) 49 | aClient = GovOrg <$ string "client(gov," <*> (decimal "Only integer ids") 50 | <* char ',' <*> aString <* char ')' 51 | <|> Company <$ string "client(com," <*> decimal 52 | <* char ',' <*> aString <* char ',' 53 | <*> aPerson <* char ',' <*> aString <* char ')' 54 | <|> Individual <$ string "client(ind," <*> decimal 55 | <* char ',' <*> aPerson <* char ')' 56 | 57 | parseClients :: Parser [Client Int] 58 | parseClients = sepBy aClient (char '\n') 59 | 60 | loadClients :: FilePath -> IO [Client Int] 61 | loadClients fPath = runResourceT $ 62 | B.sourceFile fPath $$ T.decode T.utf8 =$ sinkParser parseClients 63 | 64 | -------------------------------------------------------------------------------- /chapter10/src/Chapter10/TypeClasses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | 3 | module Chapter10.TypeClasses where 4 | 5 | import Control.Applicative 6 | import Data.Foldable 7 | import Data.Monoid 8 | import Data.Traversable 9 | 10 | data BinaryTree2 a = Node2 a (BinaryTree2 a) (BinaryTree2 a) 11 | | Leaf2 12 | deriving (Show, Functor, Foldable, Traversable) 13 | 14 | {- 15 | instance Functor BinaryTree2 where 16 | fmap f (Node2 x l r) = Node2 (f x) (fmap f l) (fmap f r) 17 | fmap _ Leaf2 = Leaf2 18 | 19 | instance Foldable BinaryTree2 where 20 | foldMap f (Node2 x l r) = (f x) <> (foldMap f l) <> (foldMap f r) 21 | foldMap _ Leaf2 = mempty 22 | 23 | instance Traversable BinaryTree2 where 24 | traverse f (Node2 x l r) = Node2 <$> f x <*> traverse f l <*> traverse f r 25 | traverse _ Leaf2 = pure Leaf2 26 | -} 27 | -------------------------------------------------------------------------------- /chapter10/src/Chapter10/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, DeriveGeneric, OverloadedStrings #-} 2 | 3 | module Chapter10.Types where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Types 7 | import Control.Lens ((^?)) 8 | import Control.Lens.Aeson 9 | import Data.Text 10 | import GHC.Generics 11 | import Control.Applicative 12 | 13 | import Data.Conduit 14 | import qualified Data.Conduit.Binary as B 15 | import qualified Data.Conduit.List as L 16 | import qualified Data.ByteString.Lazy as LB 17 | 18 | import qualified Data.HashMap.Strict as M 19 | 20 | data Client i = GovOrg { clientId :: i, clientName :: String } 21 | | Company { clientId :: i, clientName :: String 22 | , person :: Person, duty :: String } 23 | | Individual { clientId :: i, person :: Person } 24 | deriving (Show, Generic) 25 | 26 | data Person = Person { firstName :: String, lastName :: String } 27 | deriving (Show, Read, Generic) 28 | 29 | {- 30 | instance ToJSON i => ToJSON (Client i) 31 | instance FromJSON i => FromJSON (Client i) 32 | instance ToJSON Person 33 | instance FromJSON Person 34 | -} 35 | 36 | clientToJSON :: Client Integer -> Value 37 | clientToJSON (GovOrg i n) = 38 | object [ "type" .= String "govorg" 39 | , "id" .= Number (fromInteger i) 40 | , "name" .= String (pack n) ] 41 | clientToJSON (Company i n p d) = 42 | object [ "type" .= String "company" 43 | , "id" .= Number (fromInteger i) 44 | , "name" .= String (pack n) 45 | , "person" .= personToJSON p 46 | , "duty" .= String (pack d) ] 47 | clientToJSON (Individual i p) = 48 | object [ "type" .= String "individual" 49 | , "id" .= Number (fromInteger i) 50 | , "person" .= personToJSON p ] 51 | 52 | personToJSON :: Person -> Value 53 | personToJSON (Person f l) = object [ "first" .= String (pack f) 54 | , "last" .= String (pack l) ] 55 | {- 56 | jsonToPerson :: Value -> Maybe Person 57 | jsonToPerson (Object o) = do String f <- M.lookup "first" o 58 | String l <- M.lookup "last" o 59 | return $ Person (unpack f) (unpack l) 60 | jsonToPerson _ = Nothing 61 | -} 62 | 63 | jsonToPersonLens :: Value -> Maybe Person 64 | jsonToPersonLens j = do String f <- j ^? key "first" 65 | String l <- j ^? key "last" 66 | return $ Person (unpack f) (unpack l) 67 | 68 | jsonToClient :: FromJSON i => Value -> Parser (Client i) 69 | jsonToClient (Object o) = 70 | case M.lookup "type" o of 71 | Just (String "govorg") -> GovOrg <$> o .: "id" <*> o .: "name" 72 | Just (String "company") -> Company <$> o .: "id" <*> o .: "name" 73 | <*> o .: "person" <*> o .: "duty" 74 | Just (String "individual") -> Individual <$> o .: "id" <*> o .: "person" 75 | _ -> Control.Applicative.empty 76 | jsonToClient _ = Control.Applicative.empty 77 | 78 | jsonToPerson :: Value -> Parser Person 79 | jsonToPerson (Object o) = Person <$> o .: "first" <*> o .: "last" 80 | jsonToPerson _ = Control.Applicative.empty 81 | 82 | instance ToJSON (Client Integer) where 83 | toJSON = clientToJSON 84 | instance ToJSON Person where 85 | toJSON = personToJSON 86 | 87 | instance FromJSON i => FromJSON (Client i) where 88 | parseJSON = jsonToClient 89 | instance FromJSON Person where 90 | parseJSON = jsonToPerson 91 | 92 | saveClients :: FilePath -> [Client Integer] -> IO () 93 | saveClients fPath clients = runResourceT $ 94 | yield (toJSON clients) $$ L.map (LB.toStrict . encode) =$ B.sinkFile fPath 95 | 96 | 97 | -------------------------------------------------------------------------------- /chapter10/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.Trans 6 | import Data.Conduit 7 | import qualified Data.Conduit.Binary as B 8 | import qualified Data.Conduit.List as L 9 | import qualified Data.Conduit.Text as T 10 | import Data.Monoid 11 | import Data.Text 12 | import System.Random 13 | 14 | import Chapter10.Builder 15 | import Chapter10.Parser 16 | import Chapter10.TypeClasses 17 | 18 | main :: IO() 19 | main = runResourceT $ 20 | B.sourceFile "clients.db" $$ T.decode T.utf8 =$= 21 | T.lines =$= winnersFile =$= L.concatMap (\x -> [x, "\n"]) =$= 22 | T.encode T.utf8 =$ B.sinkFile "clientsWinners.db" 23 | 24 | winnersFile :: (Monad m, MonadIO m) => Conduit Text m Text 25 | winnersFile = do client <- await 26 | case client of 27 | Nothing -> return () 28 | Just c -> do (w :: Bool) <- liftIO $ randomIO 29 | (y :: Int ) <- liftIO $ randomRIO (0, 3000) 30 | yield $ c <> " " <> (pack $ show w) <> " " <> (pack $ show y) 31 | winnersFile 32 | -------------------------------------------------------------------------------- /chapter11/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter11/chapter11.cabal: -------------------------------------------------------------------------------- 1 | name: chapter11 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable chapter11 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | build-depends: 11 | base >= 4, 12 | persistent, 13 | persistent-sqlite, 14 | persistent-template, 15 | persistent-postgresql, 16 | esqueleto, 17 | time, 18 | transformers 19 | ghc-options: -Wall 20 | other-modules: 21 | Chapter11.Database, 22 | Chapter11.Gender, 23 | Chapter11.Query, 24 | Chapter11.Update 25 | 26 | -------------------------------------------------------------------------------- /chapter11/src/Chapter11/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, 2 | TypeFamilies, EmptyDataDecls, 3 | FlexibleContexts, GADTs, 4 | OverloadedStrings #-} 5 | 6 | module Chapter11.Database where 7 | 8 | import Database.Persist.TH 9 | import Data.Time.Clock 10 | 11 | import Chapter11.Gender 12 | 13 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 14 | Country 15 | name String 16 | canWeSend Bool default=False 17 | UniqueCountryName name 18 | deriving Show 19 | Client 20 | firstName String 21 | lastName String 22 | address String 23 | country CountryId 24 | gender Gender Maybe 25 | age Int Maybe 26 | UniqueClient firstName lastName address country 27 | deriving Show 28 | Product 29 | name String 30 | description String 31 | price Double 32 | inStock Int 33 | deriving Show 34 | Purchase 35 | client ClientId 36 | product ProductId 37 | number Int 38 | amount Double 39 | deriving Show 40 | |] 41 | -------------------------------------------------------------------------------- /chapter11/src/Chapter11/Gender.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter11.Gender where 4 | 5 | import Database.Persist.TH 6 | 7 | data Gender = Male | Female 8 | deriving (Show, Read, Eq) 9 | derivePersistField "Gender" 10 | -------------------------------------------------------------------------------- /chapter11/src/Chapter11/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, TypeFamilies #-} 2 | 3 | module Chapter11.Query where 4 | 5 | import Control.Monad 6 | import qualified Database.Persist as P -- only Persistent 7 | import Database.Esqueleto -- Persistent + Esqueleto 8 | import Database.Persist.Sqlite (runSqlite) 9 | 10 | import Chapter11.Database 11 | -- import Chapter11.Gender 12 | 13 | getClientById :: (P.PersistQuery m, P.PersistMonadBackend m ~ P.PersistEntityBackend Client) => Int -> m (Maybe Client) 14 | getClientById n = get $ Key (PersistInt64 $ fromIntegral n) 15 | 16 | -- getPurchaseClient :: Purchase -> m (Maybe Client) 17 | getPurchaseClient p = get (purchaseClient p) 18 | 19 | -- getPurchaseClient' :: Int -> m (Maybe Client) 20 | getPurchaseClient' pId = do p <- get $ Key (PersistInt64 $ fromIntegral pId) 21 | case p of 22 | Just p' -> get $ purchaseClient p' 23 | Nothing -> return Nothing 24 | 25 | -- getClientByInfo :: String -> String -> String -> String -> m (Maybe Client) 26 | getClientByInfo fName lName addr cnName = do 27 | cn <- getBy $ UniqueCountryName cnName 28 | case cn of 29 | Just (Entity cId _) -> 30 | do cl <- getBy $ UniqueClient fName lName addr cId 31 | case cl of 32 | Just (Entity _ client) -> return $ Just client 33 | Nothing -> return Nothing 34 | Nothing -> return Nothing 35 | 36 | -- getAdultsOfSpainAndGermany :: m [Entity Client] 37 | getAdultsOfSpainAndGermany = do 38 | Just (Entity spId _) <- getBy $ UniqueCountryName "Spain" 39 | Just (Entity geId _) <- getBy $ UniqueCountryName "Germany" 40 | P.selectList [ ClientCountry P.<-. [spId, geId], ClientAge P.>=. Just 18 ] [] 41 | 42 | -- countAdultsOfSpainAndGermany :: m Integer 43 | countAdultsOfSpainAndGermany = do 44 | Just (Entity spId _) <- getBy $ UniqueCountryName "Spain" 45 | Just (Entity geId _) <- getBy $ UniqueCountryName "Germany" 46 | P.count [ ClientCountry P.<-. [spId, geId], ClientAge P.>=. Just 18 ] 47 | 48 | -- getAdultsOfSpainAndUS :: m [Entity Client] 49 | getAdultsOfSpainAndUS = do 50 | Just (Entity spId _) <- getBy $ UniqueCountryName "Spain" 51 | Just (Entity usId _) <- getBy $ UniqueCountryName "United States of America" 52 | P.selectList ( [ ClientCountry P.==. spId, ClientAge P.>=. Just 18 ] 53 | P.||. [ ClientCountry P.==. usId, ClientAge P.>=. Just 21 ] ) 54 | [ P.Desc ClientAge ] 55 | 56 | -- getProductsPage :: Int -> m [Entity Product] 57 | getProductsPage n = P.selectList [ ] [ P.Asc ProductPrice, P.LimitTo 10, P.OffsetBy ((n-1)*10) ] 58 | 59 | -- getCountriesWithBigBuyers :: m [Country] 60 | getCountriesWithBigBuyers = do 61 | buyers <- P.selectKeysList [ ] [ ] 62 | buyersAndPurchases <- mapM (\b -> P.count [ PurchaseClient P.==. b ] >>= \c -> return (b,c)) buyers 63 | let buyersAndPurchases' = filter (\(_,c) -> c > 3) buyersAndPurchases 64 | mapM (\(b,_) -> do Just cl <- get b 65 | Just cn <- get $ clientCountry cl 66 | return cn) 67 | buyersAndPurchases' 68 | 69 | -- getPeopleOver25 :: m [Entity Client] 70 | getPeopleOver25 = 71 | select $ 72 | from $ \client -> do 73 | where_ (client ^. ClientAge >. just (val 25)) 74 | orderBy [ asc (client ^. ClientLastName), asc (client ^. ClientFirstName) ] 75 | return client 76 | 77 | -- getPeopleOver25FromSpainOrGermany :: m [Entity Client] 78 | getPeopleOver25FromSpainOrGermany = 79 | select $ 80 | from $ \(client, country) -> do 81 | where_ ( client ^. ClientAge >. just (val 25) 82 | &&. country ^. CountryName `in_` valList [ "Spain", "Germany" ] 83 | &&. client ^. ClientCountry ==. country ^. CountryId ) 84 | return client 85 | 86 | -- getPeopleOver25FromSpainOrGermanyJoin :: m [Entity Client] 87 | getPeopleOver25FromSpainOrGermanyJoin = 88 | select $ 89 | from $ \(client `InnerJoin` country) -> do 90 | on (client ^. ClientCountry ==. country ^. CountryId) 91 | where_ ( client ^. ClientAge >. just (val 25) 92 | &&. country ^. CountryName `in_` valList [ "Spain", "Germany" ]) 93 | orderBy [ asc (client ^. ClientLastName), asc (client ^. ClientFirstName) ] 94 | return client 95 | 96 | -- getMoneyByClient :: m [(Entity Client, Value (Maybe Double))] 97 | getMoneyByClient = 98 | select $ 99 | from $ \(client `LeftOuterJoin` purchase) -> do 100 | on (client ^. ClientId ==. purchase ^. PurchaseClient) 101 | groupBy (client ^. ClientId) 102 | let s = sum_ (purchase ^. PurchaseAmount) 103 | return (client, s) 104 | -------------------------------------------------------------------------------- /chapter11/src/Chapter11/Update.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} 2 | 3 | module Chapter11.Update where 4 | 5 | import Control.Monad 6 | import qualified Database.Persist as P -- only Persistent 7 | import Database.Esqueleto -- Persistent + Esqueleto 8 | import Database.Persist.Sqlite (runSqlite) 9 | import Data.Char 10 | 11 | import Chapter11.Database 12 | -- import Chapter11.Gender 13 | 14 | -- capitalizeNamesSlow :: m () 15 | capitalizeNamesSlow = do 16 | clients <- P.selectList [] [] 17 | mapM_ (\(Entity ident client) -> 18 | let c:rest = clientFirstName client 19 | in P.replace ident $ client { clientFirstName = (toUpper c):rest }) 20 | clients 21 | 22 | -- discount :: m () 23 | discount = do 24 | P.updateWhere [ ProductPrice P.<=. 10000 ] [ ProductPrice P.*=. 0.9 ] 25 | P.updateWhere [ ProductPrice P.>. 10000 ] [ ProductPrice P.*=. 0.97 ] 26 | 27 | -- betterDiscount :: m () 28 | betterDiscount = update $ \product -> do 29 | let totalAmount = sub_select $ 30 | from $ \purchase -> do 31 | where_ $ product ^. ProductId ==. purchase ^. PurchaseProduct 32 | groupBy (purchase ^. PurchaseProduct) 33 | return $ sum_ (purchase ^. PurchaseAmount) 34 | where_ $ isNothing totalAmount ||. totalAmount <. just (val 10) 35 | set product [ ProductPrice *=. val 0.9 ] 36 | 37 | -- cleanProductStock :: m () 38 | cleanProductStock = P.deleteWhere [ ProductInStock P.==. 0 ] 39 | 40 | -- cleanProductStock' :: m () 41 | cleanProductStock' = 42 | delete $ 43 | from $ \product -> do 44 | where_ $ product ^. ProductInStock ==. val 0 45 | &&. (notExists $ from $ \purchase -> 46 | where_ (purchase ^. PurchaseProduct ==. product ^. ProductId)) 47 | -------------------------------------------------------------------------------- /chapter11/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class 6 | -- import Database.Persist -- only Persistent 7 | import Database.Esqueleto -- Persistent + Esqueleto 8 | import Database.Persist.Sqlite 9 | import Data.Time.Clock 10 | 11 | import Chapter11.Database 12 | import Chapter11.Gender 13 | import Chapter11.Query 14 | 15 | main :: IO () 16 | main = do runSqlite "example.db" $ do 17 | -- Create table structure 18 | runMigration migrateAll 19 | -- Insert initial data 20 | insertInitialData 21 | -- Run a query 22 | c1 <- getClientById 1 23 | liftIO $ print c1 24 | results1 <- getPeopleOver25FromSpainOrGermanyJoin 25 | mapM_ (\(Entity _ r) -> liftIO $ print r) results1 26 | results2 <- getMoneyByClient 27 | mapM_ (\(Entity _ r, Value l) -> liftIO $ print r >> print l) results2 28 | 29 | mainWithExplicitConnection :: IO () 30 | mainWithExplicitConnection = withSqliteConn ":memory:" $ \conn -> 31 | flip runSqlPersistM conn $ do 32 | runMigration migrateAll 33 | 34 | mainWithExplicitPool :: IO () 35 | mainWithExplicitPool = withSqlitePool ":memory:" 3 $ \pool -> 36 | flip runSqlPersistMPool pool $ do 37 | runMigration migrateAll 38 | 39 | insertInitialData :: PersistStore m => m () 40 | insertInitialData = do 41 | spain <- insert $ Country "Spain" True 42 | germany <- insert $ Country "Germany" True 43 | uk <- insert $ Country "United Kingdom" False 44 | _usa <- insert $ Country "United States of America" False 45 | 46 | client1 <- insert $ Client "Alejandro" "Serrano" "Home Town, 1" spain (Just Male) Nothing 47 | client2 <- insert $ Client "Werner" "Heisenberg" "A place in Wurzburg" germany (Just Male) (Just 50) 48 | _client3 <- insert $ Client "Doctor" "Who" "Police Box" uk Nothing Nothing 49 | 50 | let longDescription = "blah blah blah" 51 | product1 <- insert $ Product "Travel to the XIX Century" longDescription 12.3 3 52 | product2 <- insert $ Product "TM-223 Machine" longDescription 1245.0 10 53 | 54 | _ <- insert $ Purchase client1 product1 1 20.0 55 | _ <- insert $ Purchase client1 product2 5 1002.3 56 | _ <- insert $ Purchase client2 product1 3 58.0 57 | 58 | return () 59 | -------------------------------------------------------------------------------- /chapter12/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter12/chapter12.cabal: -------------------------------------------------------------------------------- 1 | name: chapter12 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable scotty-server 8 | build-depends: 9 | base >= 4, 10 | scotty, 11 | transformers, 12 | blaze-html, 13 | aeson, 14 | persistent, 15 | persistent-sqlite, 16 | persistent-template, 17 | http-types, 18 | text, 19 | hamlet, 20 | digestive-functors, 21 | digestive-functors-aeson, 22 | digestive-functors-blaze 23 | hs-source-dirs: src 24 | ghc-options: -Wall -rtsopts 25 | main-is: ScottyMain.hs 26 | other-modules: Chapter12.Database 27 | 28 | executable yesod-server 29 | build-depends: 30 | base >= 4, 31 | yesod, 32 | aeson, 33 | persistent, 34 | persistent-sqlite, 35 | persistent-template 36 | hs-source-dirs: src 37 | ghc-options: -Wall -rtsopts 38 | main-is: YesodMain.hs 39 | other-modules: Chapter12.Database 40 | -------------------------------------------------------------------------------- /chapter12/fay/Simple.hs: -------------------------------------------------------------------------------- 1 | module Simple where 2 | 3 | import Prelude 4 | import FFI 5 | 6 | main :: Fay () 7 | main = alert "Hello from Fay!" 8 | 9 | alert :: String -> Fay () 10 | alert = ffi "alert(%1)" 11 | -------------------------------------------------------------------------------- /chapter12/fay/Simple.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /chapter12/fay/ToScotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RebindableSyntax #-} 2 | 3 | module ToScotty where 4 | 5 | import Fay.Text 6 | import FFI 7 | import JQuery 8 | import Prelude hiding (concat) 9 | 10 | data Product = Product { name :: Text 11 | , description :: Text 12 | , price :: Double 13 | , inStock :: Int 14 | } 15 | 16 | main :: Fay () 17 | main = ready $ do 18 | productButton <- select "#productButton" 19 | onClick onProductButtonClick productButton 20 | return () 21 | 22 | onProductButtonClick :: Event -> Fay Bool 23 | onProductButtonClick _ = do 24 | productField <- select "#productId" 25 | productId <- getVal productField 26 | let url = concat ["http://localhost:3000/json/product/", productId] 27 | ajax url 28 | (\p -> alert $ name p) 29 | (\_ _ _ -> alert "Error in AJAX request") 30 | return True 31 | 32 | alert :: Text -> Fay () 33 | alert = ffi "alert(%1)" 34 | -------------------------------------------------------------------------------- /chapter12/fay/ToScotty.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /chapter12/src/Chapter12/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, 2 | TypeFamilies, EmptyDataDecls, 3 | FlexibleContexts, GADTs, 4 | OverloadedStrings #-} 5 | 6 | module Chapter12.Database where 7 | 8 | import Database.Persist.TH 9 | 10 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 11 | Country json 12 | name String 13 | canWeSend Bool default=False 14 | UniqueCountryName name 15 | deriving Show 16 | Client json 17 | firstName String 18 | lastName String 19 | address String 20 | country CountryId 21 | age Int Maybe 22 | UniqueClient firstName lastName address country 23 | deriving Show 24 | Product json 25 | name String 26 | description String 27 | price Double 28 | inStock Int 29 | deriving Show 30 | Purchase json 31 | client ClientId 32 | product ProductId 33 | number Int 34 | amount Double 35 | deriving Show 36 | |] 37 | -------------------------------------------------------------------------------- /chapter12/src/ScottyMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, RecordWildCards, 2 | QuasiQuotes, TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Prelude hiding (product) 7 | 8 | import Control.Monad.IO.Class (liftIO) 9 | import Data.Monoid (mconcat) 10 | import qualified Database.Persist.Sqlite as Db 11 | import Network.HTTP.Types 12 | import Data.Text.Lazy 13 | import Text.Hamlet 14 | import Web.Scotty 15 | 16 | import Control.Applicative ((<$>), (<*>)) 17 | import Text.Digestive 18 | import Text.Digestive.Blaze.Html5 19 | -- import Text.Digestive.Aeson 20 | import Text.Digestive.Util 21 | 22 | import qualified Text.Blaze.Html5 as H 23 | import qualified Text.Blaze.Html5.Attributes as A 24 | import Text.Blaze.Html.Renderer.Text (renderHtml) 25 | 26 | import Chapter12.Database 27 | 28 | main :: IO() 29 | main = do 30 | Db.runSqlite "example.db" $ Db.runMigration migrateAll 31 | -- liftIO $ Db.runSqlite "example.db" insertInitialData 32 | 33 | Db.withSqlitePool "example.db" 10 $ \pool -> 34 | scotty 3000 $ do 35 | get "/about" $ 36 | html $ mconcat [ "" 37 | , "

Hello Beginning Haskell!

" 38 | , "" ] 39 | 40 | get "/product/:productId" $ do 41 | (productId :: Integer) <- param "productId" 42 | product <- liftIO $ flip Db.runSqlPersistMPool pool $ 43 | Db.get $ Db.Key (Db.PersistInt64 $ fromIntegral productId) 44 | case product of 45 | Just (Product { .. }) -> html $ mconcat [ "" 46 | , "

" 47 | , pack productName 48 | , "

" 49 | , "

" 50 | , pack productDescription 51 | , "

" 52 | , "" ] 53 | Nothing -> status notFound404 54 | 55 | get "/product2/:productId" $ do 56 | (productId :: Integer) <- param "productId" 57 | product <- liftIO $ flip Db.runSqlPersistMPool pool $ 58 | Db.get $ Db.Key (Db.PersistInt64 $ fromIntegral productId) 59 | case product of 60 | Just (Product { .. }) -> html $ renderHtml $ 61 | H.html $ do 62 | H.head $ 63 | H.title "Time Machine Store" 64 | H.body $ do 65 | H.h1 $ H.toHtml productName 66 | H.p H.! A.id "descr" $ H.toHtml productDescription 67 | Nothing -> status notFound404 68 | 69 | get "/product3/:productId" $ do 70 | (productId :: Integer) <- param "productId" 71 | product <- liftIO $ flip Db.runSqlPersistMPool pool $ 72 | Db.get $ Db.Key (Db.PersistInt64 $ fromIntegral productId) 73 | case product of 74 | Just p -> html $ renderHtml [shamlet| 75 | 76 | 77 | Time Machine Store 78 | <body> 79 | <h1>#{productName p} 80 | <p id=descr>#{productDescription p} 81 | |] 82 | Nothing -> status notFound404 83 | 84 | get "/json/product/:productId" $ do 85 | (productId :: Integer) <- param "productId" 86 | (product :: Maybe Product) <- 87 | liftIO $ flip Db.runSqlPersistMPool pool $ 88 | Db.get $ Db.Key (Db.PersistInt64 $ fromIntegral productId) 89 | case product of 90 | Just p -> do setHeader "Access-Control-Allow-Origin" "*" 91 | json p 92 | Nothing -> status notFound404 93 | 94 | get "/products" $ do 95 | (products :: [Db.Entity Product]) <- 96 | liftIO $ flip Db.runSqlPersistMPool pool $ Db.selectList [] [] 97 | html $ renderHtml [shamlet| 98 | <html> 99 | <body> 100 | <h1>Products 101 | <table> 102 | <tr> 103 | <th>Name 104 | <th>Description 105 | $forall Db.Entity _ p <- products 106 | <tr> 107 | <td>#{productName p} 108 | <td>#{productDescription p} 109 | |] 110 | 111 | get "/new-product" $ do 112 | view <- getForm "product" productForm 113 | let view' = fmap H.toHtml view 114 | html $ renderHtml $ 115 | H.html $ do 116 | H.head $ H.title "Time Machine Store" 117 | H.body $ productView view' 118 | 119 | post "/new-product" $ do 120 | params' <- params 121 | (view,product) <- postForm "product" productForm (paramsToEnv params') 122 | case product of 123 | Just p -> do 124 | Db.Key (Db.PersistInt64 newId) <- liftIO $ flip Db.runSqlPersistMPool pool $ Db.insert p 125 | redirect $ mconcat ["/product/", pack $ show newId] 126 | Nothing -> do 127 | let view' = fmap H.toHtml view 128 | html $ renderHtml $ 129 | H.html $ do 130 | H.head $ H.title "Time Machine Store" 131 | H.body $ productView view' 132 | 133 | notFound $ do 134 | status notFound404 135 | html $ "<h1>Not found :(</h1>" 136 | 137 | countryForm :: Monad m => Form String m Country 138 | countryForm = Country <$> "name" .: string Nothing 139 | <*> "send" .: bool (Just True) 140 | 141 | productForm :: Monad m => Form String m Product 142 | productForm = Product <$> "name" .: string Nothing 143 | <*> "description" .: string Nothing 144 | <*> "price" .: validate isANumber (string Nothing) 145 | <*> "inStock" .: check "Must be >= 0" (>= 0) 146 | (validate isANumber (string Nothing)) 147 | 148 | productView :: View H.Html -> H.Html 149 | productView view = do 150 | form view "/new-product" $ do 151 | label "name" view "Name:" 152 | inputText "name" view 153 | H.br 154 | inputTextArea Nothing Nothing "description" view 155 | H.br 156 | label "price" view "Price:" 157 | inputText "price" view 158 | errorList "price" view 159 | label "inStock" view "# in Stock:" 160 | inputText "inStock" view 161 | errorList "inStock" view 162 | H.br 163 | inputSubmit "Submit" 164 | 165 | isANumber :: (Num a, Read a) => String -> Result String a 166 | isANumber = maybe (Error "Not a number") Success . readMaybe 167 | 168 | paramsToEnv :: Monad m => [Param] -> Text.Digestive.Env m 169 | paramsToEnv [] _ = fail "Parameter not found" 170 | paramsToEnv ((k,v):rest) t = if toStrict k == fromPath t 171 | then return [TextInput $ toStrict v] 172 | else paramsToEnv rest t 173 | 174 | insertInitialData :: Db.PersistStore m => m () 175 | insertInitialData = do 176 | spain <- Db.insert $ Country "Spain" True 177 | germany <- Db.insert $ Country "Germany" True 178 | uk <- Db.insert $ Country "United Kingdom" False 179 | _usa <- Db.insert $ Country "United States of America" False 180 | 181 | client1 <- Db.insert $ Client "Alejandro" "Serrano" "Home Town, 1" spain Nothing 182 | client2 <- Db.insert $ Client "Werner" "Heisenberg" "A place in Wurzburg" germany (Just 50) 183 | _client3 <- Db.insert $ Client "Doctor" "Who" "Police Box" uk Nothing 184 | 185 | let longDescription = "blah blah blah" 186 | product1 <- Db.insert $ Product "Travel to the XIX Century" longDescription 12.3 3 187 | product2 <- Db.insert $ Product "TM-223 Machine" longDescription 1245.0 10 188 | 189 | _ <- Db.insert $ Purchase client1 product1 1 20.0 190 | _ <- Db.insert $ Purchase client1 product2 5 1002.3 191 | _ <- Db.insert $ Purchase client2 product1 3 58.0 192 | 193 | return () 194 | -------------------------------------------------------------------------------- /chapter12/src/YesodMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, 2 | ScopedTypeVariables, OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Yesod 7 | import qualified Text.Blaze.Html5 as H 8 | 9 | import Database.Persist.Sqlite 10 | import Chapter12.Database 11 | 12 | data TimeMachineStore = TimeMachineStore ConnectionPool 13 | instance Yesod TimeMachineStore 14 | 15 | instance YesodPersist TimeMachineStore where 16 | type YesodPersistBackend TimeMachineStore = SqlPersistT 17 | 18 | runDB action = do TimeMachineStore pool <- getYesod 19 | runSqlPool action pool 20 | 21 | mkYesod "TimeMachineStore" [parseRoutes| 22 | /about AboutR GET 23 | /about1 About1R GET 24 | /about2 About2R GET 25 | /client/#ClientId ClientR GET 26 | /client2/#ClientId Client2R GET 27 | /is1984/#Integer Is1984R GET 28 | |] 29 | 30 | getAboutR :: Handler Html 31 | getAboutR = return $ H.html $ H.body $ 32 | H.p $ H.toHtml ("Hello Beginning Haskell!" :: String) 33 | 34 | getAbout1R :: Handler Html 35 | getAbout1R = return [shamlet| 36 | <html> 37 | <body> 38 | <p>Hello Beginning Haskell! 39 | |] 40 | 41 | getAbout2R :: Handler Html 42 | getAbout2R = defaultLayout [whamlet|Hello Beginning Haskell!|] 43 | 44 | getClientR :: ClientId -> Handler TypedContent 45 | getClientR clientId = do 46 | c <- runDB $ get404 clientId 47 | selectRep $ do 48 | provideRep $ defaultLayout [whamlet| 49 | <h1>#{clientFirstName c} #{clientLastName c} 50 | <p>#{clientAddress c} 51 | $maybe a <- clientAge c 52 | <p>#{a} years old 53 | $nothing 54 | <p>Unknown age 55 | |] 56 | provideRep $ returnJson $ c 57 | 58 | getClient2R :: ClientId -> Handler Html 59 | getClient2R clientId = do 60 | c <- runDB $ get404 clientId 61 | defaultLayout [whamlet| 62 | <h1>#{clientFirstName c} #{clientLastName c} 63 | <p>#{clientAddress c} 64 | $maybe a <- clientAge c 65 | <p>#{a} years old 66 | $nothing 67 | <p>Unknown age 68 | |] 69 | 70 | getIs1984R :: Integer -> Handler Html 71 | getIs1984R 1984 = defaultLayout [whamlet| 72 | <h1>Yes! 73 | <ul> 74 | <li><a href=@{AboutR}>About us 75 | <li><a href=@{Is1984R 1983}>Is is 1983? 76 | |] 77 | getIs1984R _ = defaultLayout [whamlet|<h1>No!|] 78 | 79 | -- main :: IO () 80 | -- main = warp 3000 TimeMachineStore 81 | 82 | main :: IO () 83 | main = withSqlitePool "example.db" 3 $ \pool -> 84 | warp 3000 $ TimeMachineStore pool 85 | -------------------------------------------------------------------------------- /chapter13/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter13/chapter13.cabal: -------------------------------------------------------------------------------- 1 | name: chapter13 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: base >= 4, singletons, persistent, persistent-template 10 | ghc-options: -Wall 11 | other-modules: 12 | Chapter13.GADTs, 13 | Chapter13.Initial, 14 | Chapter13.CheckPresentsFnDeps, 15 | Chapter13.CheckPresentsTyFams, 16 | Chapter13.CheckPresentsPromoted, 17 | Chapter13.VectorsLits, 18 | Chapter13.CheckRangesPromoted, 19 | Chapter13.Users, 20 | Chapter13.Numbers, 21 | Chapter13.CategoriesFnDeps, 22 | Chapter13.CategoriesTyFams, 23 | Chapter13.Database 24 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CategoriesFnDeps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 2 | 3 | module Chapter13.CategoriesFnDeps where 4 | 5 | data TimeMachine = TimeMachine { model :: String } deriving Show 6 | data Book = Book { title :: String, author :: String, rating :: Integer } deriving Show 7 | data Costume = Costume { place :: String, range :: (Integer, Integer)} deriving Show 8 | 9 | data TimeMachineOps = Travel Integer | Park deriving Show 10 | data BookOps = Read | Highlight | WriteCritique deriving Show 11 | data CostumeOps = PutOn | PutOff deriving Show 12 | 13 | class Product p op | p -> op where 14 | price :: p -> Float 15 | perform :: p -> op -> String 16 | testOperation :: p -> op 17 | 18 | instance Product TimeMachine TimeMachineOps where 19 | price _ = 1000.0 20 | perform (TimeMachine m) (Travel y) = "Travelling to " ++ show y ++ " with " ++ m 21 | perform (TimeMachine m) Park = "Parking time machine " ++ m 22 | testOperation _ = Travel 0 23 | 24 | {- 25 | instance Product TimeMachine BookOps where 26 | price _ = 500.0 27 | perform _ _ = "What?!" 28 | testOperation _ = Read -- ?? 29 | -} 30 | 31 | performTest :: Product p op => p -> String 32 | performTest p = perform p $ testOperation p 33 | 34 | totalAmount :: Product p op => [p] -> Float 35 | totalAmount = foldr (+) 0.0 . map price 36 | 37 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CategoriesTyFams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Chapter13.CategoriesTyFams where 4 | 5 | data TimeMachine = TimeMachine { model :: String } deriving Show 6 | data Book = Book { title :: String, author :: String, rating :: Integer } deriving Show 7 | data Costume = Costume { place :: String, range :: (Integer, Integer)} deriving Show 8 | 9 | data TimeMachineOps = Travel Integer | Park deriving Show 10 | data BookOps = Read | Highlight | WriteCritique deriving Show 11 | data CostumeOps = PutOn | PutOff deriving Show 12 | 13 | class Product p where 14 | type Operation p :: * 15 | price :: p -> Float 16 | perform :: p -> Operation p -> String 17 | testOperation :: p -> Operation p 18 | 19 | instance Product TimeMachine where 20 | type Operation TimeMachine = TimeMachineOps 21 | price _ = 1000.0 22 | perform (TimeMachine m) (Travel y) = "Travelling to " ++ show y ++ " with " ++ m 23 | perform (TimeMachine m) Park = "Parking time machine " ++ m 24 | testOperation _ = Travel 0 25 | 26 | instance Product Book where 27 | type Operation Book = BookOps 28 | price _ = 1.0 29 | perform (Book t _ _) _ = "Something on " ++ t 30 | testOperation _ = Read 31 | 32 | performTest :: Product p => p -> String 33 | performTest p = perform p $ testOperation p 34 | 35 | totalAmount :: Product p => [p] -> Float 36 | totalAmount = foldr (+) 0.0 . map price 37 | 38 | -- performTestFromOther :: Product p => p -> p -> String 39 | performTestFromOther :: (Product p, Product q, Operation p ~ Operation q) => p -> q -> String 40 | performTestFromOther p q = perform p $ testOperation q 41 | 42 | class Product2 p where 43 | data Operation2 p 44 | price2 :: p -> Float 45 | perform2 :: p -> Operation2 p -> String 46 | testOperation2 :: p -> Operation2 p 47 | 48 | instance Product2 TimeMachine where 49 | data Operation2 TimeMachine = Travel2 Integer | Park2 50 | price2 _ = 1000.0 51 | perform2 (TimeMachine m) (Travel2 y) = "Travelling to " ++ show y ++ " with " ++ m 52 | perform2 (TimeMachine m) Park2 = "Parking time machine " ++ m 53 | testOperation2 _ = Travel2 0 54 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CheckPresents.idr: -------------------------------------------------------------------------------- 1 | module Chapter13.CheckPresents 2 | 3 | data Expr : Type -> Type -> Type where 4 | AmountOf : a -> Expr a Nat 5 | PriceOf : a -> Expr a Float 6 | TotalNumberProducts : Expr a Nat 7 | TotalPrice : Expr a Float 8 | Val : Num n => n -> Expr a n 9 | (:+:) : Num n => Expr a n -> Expr a n -> Expr a n 10 | (:*:) : Num n => Expr a n -> Expr a n -> Expr a n 11 | (:<:) : Num n => Expr a n -> Expr a n -> Expr a Bool 12 | (:<=:) : Num n => Expr a n -> Expr a n -> Expr a Bool 13 | (:>:) : Num n => Expr a n -> Expr a n -> Expr a Bool 14 | (:>=:) : Num n => Expr a n -> Expr a n -> Expr a Bool 15 | (:&&:) : Expr a Bool -> Expr a Bool -> Expr a Bool 16 | (:||:) : Expr a Bool -> Expr a Bool -> Expr a Bool 17 | Not : Expr a Bool -> Expr a Bool 18 | 19 | data Offer : Type -> Nat -> Type where 20 | Present : a -> Offer a 1 21 | PercentDiscount : Float -> Offer a 0 22 | AbsoluteDiscount : Float -> Offer a 0 23 | Restrict : Vect (S n) a -> Offer a p -> Offer a (minimum (S n) p) 24 | From : Nat -> Offer a p -> Offer a p 25 | Until : Nat -> Offer a p -> Offer a p 26 | Extend : Nat -> Offer a p -> Offer a p 27 | Both : Offer a p -> Offer a q -> Offer a (p + q) 28 | BetterOf : Offer a p -> Offer a q -> Offer a (maximum p q) 29 | If : Expr a Bool -> Offer a p -> Offer a q -> Offer a (maximum p q) 30 | 31 | p : Offer Char 1 32 | p = Present 'a' 33 | 34 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CheckPresentsFnDeps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, 2 | FlexibleInstances, UndecidableInstances, GADTs, FlexibleContexts #-} 3 | 4 | module Chapter13.CheckPresentsFnDeps where 5 | 6 | data Zero 7 | data Succ n 8 | 9 | class Plus x y z | x y -> z 10 | instance Plus Zero x x 11 | instance Plus x y z => Plus (Succ x) y (Succ z) 12 | 13 | class Min x y z | x y -> z 14 | instance Min Zero y Zero 15 | instance Min (Succ x) Zero Zero 16 | instance Min x y z => Min (Succ x) (Succ y) (Succ z) 17 | 18 | class Max x y z | x y -> z 19 | instance Max Zero y y 20 | instance Max (Succ x) Zero (Succ x) 21 | instance Max x y z => Max (Succ x) (Succ y) (Succ z) 22 | 23 | data Expr a r where 24 | AmountOf :: a -> Expr a Integer 25 | PriceOf :: a -> Expr a Float 26 | TotalNumberProducts :: Expr a Integer 27 | TotalPrice :: Expr a Float 28 | Val :: Num n => n -> Expr a n 29 | (:+:) :: Num n => Expr a n -> Expr a n -> Expr a n 30 | (:*:) :: Num n => Expr a n -> Expr a n -> Expr a n 31 | (:<:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 32 | (:<=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 33 | (:>:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 34 | (:>=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 35 | (:&&:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 36 | (:||:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 37 | Not :: Expr a Bool -> Expr a Bool 38 | 39 | data Vect n a where 40 | VNil :: Vect Zero a 41 | VCons :: a -> Vect n a -> Vect (Succ n) a 42 | 43 | data Offer a p where 44 | Present :: a -> Offer a (Succ Zero) 45 | PercentDiscount :: Float -> Offer a Zero 46 | AbsoluteDiscount :: Float -> Offer a Zero 47 | Restrict :: Min (Succ n) p r => Vect (Succ n) a -> Offer a p -> Offer a r 48 | From :: Integer -> Offer a p -> Offer a p 49 | Until :: Integer -> Offer a p -> Offer a p 50 | Extend :: Integer -> Offer a p -> Offer a p 51 | Both :: Plus p q r => Offer a p -> Offer a q -> Offer a r 52 | BetterOf :: Max p q r => Offer a p -> Offer a q -> Offer a r 53 | If :: Max p q r => Expr a Bool -> Offer a p -> Offer a q -> Offer a r 54 | 55 | o = Both p (BetterOf p (Both p p)) where p = Present 'a' 56 | 57 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CheckPresentsPromoted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeFamilies, GADTs #-} 2 | 3 | module Chapter13.CheckPresentsPromoted where 4 | 5 | data Nat = Zero | Succ Nat 6 | 7 | type family Plus (x :: Nat) (y :: Nat) :: Nat 8 | -- type family Plus x y :: * -> * -> * -- (x :: *) (y :: *) :: * 9 | type instance Plus Zero x = x 10 | type instance Plus (Succ x) y = Succ (Plus x y) 11 | 12 | type family Min (x :: Nat) (y :: Nat) :: Nat 13 | type instance Min Zero y = Zero 14 | type instance Min (Succ x) Zero = Zero 15 | type instance Min (Succ x) (Succ y) = Succ (Min x y) 16 | 17 | type family Max (x :: Nat) (y :: Nat) :: Nat 18 | type instance Max Zero y = y 19 | type instance Max (Succ x) Zero = Succ x 20 | type instance Max (Succ x) (Succ y) = Succ (Max x y) 21 | 22 | data Expr a r where 23 | AmountOf :: a -> Expr a Integer 24 | PriceOf :: a -> Expr a Float 25 | TotalNumberProducts :: Expr a Integer 26 | TotalPrice :: Expr a Float 27 | Val :: Num n => n -> Expr a n 28 | (:+:) :: Num n => Expr a n -> Expr a n -> Expr a n 29 | (:*:) :: Num n => Expr a n -> Expr a n -> Expr a n 30 | (:<:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 31 | (:<=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 32 | (:>:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 33 | (:>=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 34 | (:&&:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 35 | (:||:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 36 | Not :: Expr a Bool -> Expr a Bool 37 | 38 | data Vect (n :: Nat) a where 39 | VNil :: Vect Zero a 40 | VCons :: a -> Vect n a -> Vect (Succ n) a 41 | 42 | {- 43 | incredibleVect :: Vect Int Char 44 | incredibleVect = undefined 45 | -} 46 | 47 | data Offer a (p :: Nat) where 48 | Present :: a -> Offer a (Succ Zero) 49 | PercentDiscount :: Float -> Offer a Zero 50 | AbsoluteDiscount :: Float -> Offer a Zero 51 | Restrict :: Vect (Succ n) a -> Offer a p -> Offer a (Min (Succ n) p) 52 | From :: Integer -> Offer a p -> Offer a p 53 | Until :: Integer -> Offer a p -> Offer a p 54 | Extend :: Integer -> Offer a p -> Offer a p 55 | Both :: Offer a p -> Offer a q -> Offer a (Plus p q) 56 | BetterOf :: Offer a p -> Offer a q -> Offer a (Max p q) 57 | If :: Expr a Bool -> Offer a p -> Offer a q -> Offer a (Max p q) 58 | 59 | o = Both p (BetterOf p (Both p p)) where p = Present 'a' 60 | 61 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CheckPresentsTyFams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} 2 | 3 | module Chapter13.CheckPresentsTyFams where 4 | 5 | data Zero 6 | data Succ n 7 | 8 | type family Plus x y 9 | type instance Plus Zero x = x 10 | type instance Plus (Succ x) y = Succ (Plus x y) 11 | 12 | type family Min x y 13 | type instance Min Zero y = Zero 14 | type instance Min (Succ x) Zero = Zero 15 | type instance Min (Succ x) (Succ y) = Succ (Min x y) 16 | 17 | type family Max x y 18 | type instance Max Zero y = y 19 | type instance Max (Succ x) Zero = Succ x 20 | type instance Max (Succ x) (Succ y) = Succ (Max x y) 21 | 22 | data Expr a r where 23 | AmountOf :: a -> Expr a Integer 24 | PriceOf :: a -> Expr a Float 25 | TotalNumberProducts :: Expr a Integer 26 | TotalPrice :: Expr a Float 27 | Val :: Num n => n -> Expr a n 28 | (:+:) :: Num n => Expr a n -> Expr a n -> Expr a n 29 | (:*:) :: Num n => Expr a n -> Expr a n -> Expr a n 30 | (:<:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 31 | (:<=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 32 | (:>:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 33 | (:>=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 34 | (:&&:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 35 | (:||:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 36 | Not :: Expr a Bool -> Expr a Bool 37 | 38 | data Vect n a where 39 | VNil :: Vect Zero a 40 | VCons :: a -> Vect n a -> Vect (Succ n) a 41 | 42 | data Offer a p where 43 | Present :: a -> Offer a (Succ Zero) 44 | PercentDiscount :: Float -> Offer a Zero 45 | AbsoluteDiscount :: Float -> Offer a Zero 46 | Restrict :: Vect (Succ n) a -> Offer a p -> Offer a (Min (Succ n) p) 47 | From :: Integer -> Offer a p -> Offer a p 48 | Until :: Integer -> Offer a p -> Offer a p 49 | Extend :: Integer -> Offer a p -> Offer a p 50 | Both :: Offer a p -> Offer a q -> Offer a (Plus p q) 51 | BetterOf :: Offer a p -> Offer a q -> Offer a (Max p q) 52 | If :: Expr a Bool -> Offer a p -> Offer a q -> Offer a (Max p q) 53 | 54 | o = Both p (BetterOf p (Both p p)) where p = Present 'a' 55 | 56 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/CheckRangesPromoted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeFamilies, GADTs, UndecidableInstances, TemplateHaskell, QuasiQuotes #-} 2 | 3 | module Chapter13.CheckRangesPromoted where 4 | 5 | import Data.Singletons 6 | 7 | $(singletons [d| 8 | data Nat = Zero | Succ Nat 9 | deriving (Show, Eq) 10 | |]) 11 | 12 | data BluNat (n :: Nat) where 13 | BluZero :: BluNat Zero 14 | BluSucc :: BluNat n -> BluNat (Succ n) 15 | 16 | $(promote [d| 17 | plus :: Nat -> Nat -> Nat 18 | plus Zero y = y 19 | plus (Succ x) y = Succ (plus x y) 20 | 21 | min :: Nat -> Nat -> Nat 22 | min Zero _ = Zero 23 | min _ Zero = Zero 24 | min (Succ x) (Succ y) = Succ (min x y) 25 | 26 | max :: Nat -> Nat -> Nat 27 | max Zero y = y 28 | max x Zero = x 29 | max (Succ x) (Succ y) = Succ (max x y) 30 | |]) 31 | 32 | $(promote [d| 33 | data Range = Empty | Open Nat | Closed Nat Nat 34 | 35 | infinite :: Range 36 | infinite = Open Zero 37 | |]) 38 | 39 | data Comparison = Less | Equal | Greater 40 | 41 | $(promote [d| 42 | compare :: Nat -> Nat -> Comparison 43 | compare Zero Zero = Equal 44 | compare Zero (Succ _) = Less 45 | compare (Succ _) Zero = Greater 46 | compare (Succ x) (Succ y) = compare x y 47 | 48 | restrictFrom :: Nat -> Range -> Range 49 | restrictFrom _ Empty = Empty 50 | restrictFrom n (Open f) = restrictFrom1 n f (compare n f) 51 | restrictFrom n (Closed f t) = restrictFrom2 n f t (compare n f) (compare n t) 52 | 53 | restrictFrom1 :: Nat -> Nat -> Comparison -> Range 54 | restrictFrom1 n _ Greater = Open n 55 | restrictFrom1 _ f Equal = Open f 56 | restrictFrom1 _ f Less = Open f 57 | 58 | restrictFrom2 :: Nat -> Nat -> Nat -> Comparison -> Comparison -> Range 59 | restrictFrom2 _ _ _ Greater Greater = Empty 60 | restrictFrom2 _ _ _ Greater Equal = Empty 61 | restrictFrom2 n _ t Greater Less = Closed n t 62 | restrictFrom2 _ f t Equal _ = Closed f t 63 | restrictFrom2 _ f t Less _ = Closed f t 64 | 65 | -- Exercise 66 | restrictUntil :: Nat -> Range -> Range 67 | restrictUntil _ Empty = Empty 68 | restrictUntil n (Open f) = restrictUntil1 n f (compare n f) 69 | restrictUntil n (Closed f t) = restrictUntil2 n f t (compare n f) (compare n t) 70 | 71 | restrictUntil1 :: Nat -> Nat -> Comparison -> Range 72 | restrictUntil1 n f Greater = Closed f n 73 | restrictUntil1 _ _ Equal = Empty 74 | restrictUntil1 _ _ Less = Empty 75 | 76 | restrictUntil2 :: Nat -> Nat -> Nat -> Comparison -> Comparison -> Range 77 | restrictUntil2 _ f t _ Greater = Closed f t 78 | restrictUntil2 _ f t _ Equal = Closed f t 79 | restrictUntil2 n f _ Greater Less = Closed f n 80 | restrictUntil2 _ _ _ Equal Less = Empty 81 | restrictUntil2 _ _ _ Less Less = Empty 82 | 83 | intersect :: Range -> Range -> Range 84 | intersect Empty _ = Empty 85 | intersect (Open f1) d2 = restrictFrom f1 d2 86 | intersect (Closed f1 t1) d2 = restrictFrom f1 (restrictUntil t1 d2) 87 | |]) 88 | 89 | data Expr a r where 90 | AmountOf :: a -> Expr a Integer 91 | PriceOf :: a -> Expr a Float 92 | TotalNumberProducts :: Expr a Integer 93 | TotalPrice :: Expr a Float 94 | Val :: Num n => n -> Expr a n 95 | (:+:) :: Num n => Expr a n -> Expr a n -> Expr a n 96 | (:*:) :: Num n => Expr a n -> Expr a n -> Expr a n 97 | (:<:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 98 | (:<=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 99 | (:>:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 100 | (:>=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 101 | (:&&:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 102 | (:||:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 103 | Not :: Expr a Bool -> Expr a Bool 104 | 105 | data Vect (n :: Nat) a where 106 | VNil :: Vect Zero a 107 | VCons :: a -> Vect n a -> Vect (Succ n) a 108 | 109 | data Offer a (r :: Range) where 110 | Present :: a -> Offer a Infinite 111 | PercentDiscount :: Float -> Offer a Infinite 112 | AbsoluteDiscount :: Float -> Offer a Infinite 113 | Restrict :: Vect (Succ n) a -> Offer a d -> Offer a d 114 | -- From :: (n :: Nat) -> Offer a d -> Offer a (RestrictFrom n d) 115 | -- Until :: (n :: Nat) -> Offer a d -> Offer a (RestrictUntil n d) 116 | From :: SNat n -> Offer a d -> Offer a (RestrictFrom n d) 117 | Until :: SNat n -> Offer a d -> Offer a (RestrictUntil n d) 118 | Both :: Offer a d1 -> Offer a d2 -> Offer a (Intersect d1 d2) 119 | BetterOf :: Offer a d1 -> Offer a d2 -> Offer a (Intersect d1 d2) 120 | If :: Expr a Bool -> Offer a d1 -> Offer a d2 -> Offer a (Intersect d1 d2) 121 | 122 | zero :: SNat Zero 123 | zero = sing 124 | one :: SNat (Succ Zero) 125 | one = sing 126 | two :: SNat (Succ (Succ Zero)) 127 | two = sing 128 | three :: SNat (Succ (Succ (Succ Zero))) 129 | three = sing 130 | four :: SNat (Succ (Succ (Succ (Succ Zero)))) 131 | four = sing 132 | five :: SNat (Succ (Succ (Succ (Succ (Succ Zero))))) 133 | five = sing 134 | 135 | o = Both (From one p) (BetterOf p (Until three p)) where p = Present 'a' 136 | 137 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, 2 | TypeFamilies, EmptyDataDecls, 3 | FlexibleContexts, GADTs, 4 | OverloadedStrings #-} 5 | 6 | module Chapter13.Database where 7 | 8 | import Database.Persist.TH 9 | 10 | mkPersist sqlSettings [persistLowerCase| 11 | Product 12 | name String 13 | description String 14 | price Double 15 | inStock Int 16 | deriving Show 17 | |] 18 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/DatabaseSpliced.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLiterals #-} 2 | module Chapter13.DatabaseSpliced where 3 | 4 | import qualified Data.Map as M 5 | import Database.Persist 6 | import Database.Persist.TH 7 | 8 | type Product = ProductGeneric SqlBackend 9 | data ProductGeneric backend = Product { productName :: !String 10 | , productDescription :: !String 11 | , productPrice :: !Double 12 | , productInStock :: !Int} 13 | deriving Show 14 | type ProductId = KeyBackend SqlBackend Product 15 | 16 | instance PersistEntity (ProductGeneric backend) where 17 | data instance Unique (ProductGeneric backend) 18 | data instance EntityField (ProductGeneric backend) typ where 19 | ProductId :: EntityField (ProductGeneric backend) ProductId 20 | ProductName :: EntityField (ProductGeneric backend) String 21 | ProductDescription :: EntityField (ProductGeneric backend) String 22 | ProductPrice :: EntityField (ProductGeneric backend) Double 23 | ProductInStock :: EntityField (ProductGeneric backend) Int 24 | type instance PersistEntityBackend (ProductGeneric backend) = backend 25 | 26 | entityDef _ = EntityDef (HaskellName "Product") (DBName "product") (DBName "id") [] 27 | [ FieldDef (HaskellName "name") (DBName "name") (FTTypeCon "String") SqlString [] True Nothing 28 | , FieldDef (HaskellName "description") (DBName "description") (FTTypeCon "String") SqlString [] True Nothing 29 | , FieldDef (HaskellName "price") (DBName "price") (FTTypeCon "Double") SqlReal [] True Nothing 30 | , FieldDef (HaskellName "inStock") (DBName "in_stock") (FTTypeCon "Int") SqlInt64 [] True Nothing ] 31 | [] ["Show"] (M.fromList []) False 32 | persistFieldDef ProductId = ... 33 | persistFieldDef ... 34 | toPersistFields (Product n d p i) = 35 | [SomePersistField n, SomePersistField d, SomePersistField p, SomePersistField i] 36 | fromPersistValues [n, d, p, i] = ... 37 | persistUniqueToFieldNames _ = ... 38 | persistUniqueToValues _ = ... 39 | persistUniqueKeys (Product n d p i) = [] 40 | persistIdField = ProductId 41 | fieldLens ProductId = ... 42 | fieldLens ... 43 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/GADTs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Chapter13.GADTs where 4 | 5 | data Offer a = Present a 6 | | PercentDiscount Float 7 | | AbsoluteDiscount Float 8 | | Restrict [a] (Offer a) 9 | | From Integer (Offer a) 10 | | Until Integer (Offer a) 11 | | Extend Integer (Offer a) 12 | | Both (Offer a) (Offer a) 13 | | BetterOf (Offer a) (Offer a) 14 | | If (Expr a Bool) (Offer a) (Offer a) 15 | 16 | data Expr a r where 17 | AmountOf :: a -> Expr a Integer 18 | PriceOf :: a -> Expr a Float 19 | TotalNumberProducts :: Expr a Integer 20 | TotalPrice :: Expr a Float 21 | {- -- Not overloaded versions of values 22 | IVal :: Integer -> Expr a Integer 23 | FVal :: Float -> Expr a Float 24 | -} 25 | Val :: Num n => n -> Expr a n 26 | {- -- Not overloaded versions of comparisons 27 | (:+:) :: Expr a Integer -> Expr a Integer -> Expr a Integer 28 | (:+.:) :: Expr a Float -> Expr a Float -> Expr a Float 29 | (:*:) :: Expr a Integer -> Expr a Integer -> Expr a Integer 30 | (:*.:) :: Expr a Float -> Expr a Float -> Expr a Float 31 | (:<:) :: Expr a Integer -> Expr a Integer -> Expr a Bool 32 | (:<.:) :: Expr a Float -> Expr a Float -> Expr a Bool 33 | (:<=:) :: Expr a Integer -> Expr a Integer -> Expr a Bool 34 | (:<=.:) :: Expr a Float -> Expr a Float -> Expr a Bool 35 | (:>:) :: Expr a Integer -> Expr a Integer -> Expr a Bool 36 | (:>.:) :: Expr a Float -> Expr a Float -> Expr a Bool 37 | (:>=:) :: Expr a Integer -> Expr a Integer -> Expr a Bool 38 | (:>=.:) :: Expr a Float -> Expr a Float -> Expr a Bool 39 | -} 40 | -- Overloaded versions of comparisons 41 | (:+:) :: Num n => Expr a n -> Expr a n -> Expr a n 42 | (:*:) :: Num n => Expr a n -> Expr a n -> Expr a n 43 | (:<:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 44 | (:<=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 45 | (:>:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 46 | (:>=:) :: Num n => Expr a n -> Expr a n -> Expr a Bool 47 | (:&&:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 48 | (:||:) :: Expr a Bool -> Expr a Bool -> Expr a Bool 49 | Not :: Expr a Bool -> Expr a Bool 50 | 51 | {- Does not compile 52 | incorrectExpression :: Expr Char Bool 53 | incorrectExpression = TotalPrice :||: (TotalNumberProducts :<: PriceOf 'a') 54 | -} 55 | 56 | interpretExpr :: Expr a t -> [(a,Float)] -> t 57 | interpretExpr (e1 :+: e2) list = interpretExpr e1 list + interpretExpr e2 list 58 | interpretExpr (e1 :||: e2) list = interpretExpr e1 list || interpretExpr e2 list 59 | 60 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Initial.hs: -------------------------------------------------------------------------------- 1 | module Chapter13.Initial where 2 | 3 | data Offer a = Present a 4 | | PercentDiscount Float 5 | | AbsoluteDiscount Float 6 | | Restrict [a] (Offer a) 7 | | From Integer (Offer a) 8 | | Until Integer (Offer a) 9 | | Extend Integer (Offer a) 10 | | Both (Offer a) (Offer a) 11 | | BetterOf (Offer a) (Offer a) 12 | | If (Expr a) (Offer a) (Offer a) 13 | 14 | data Expr a = AmountOf a 15 | | PriceOf a 16 | | TotalNumberProducts 17 | | TotalPrice 18 | | IVal Integer 19 | | FVal Float 20 | | (Expr a) :+: (Expr a) 21 | | (Expr a) :*: (Expr a) 22 | | (Expr a) :<: (Expr a) 23 | | (Expr a) :<=: (Expr a) 24 | | (Expr a) :>: (Expr a) 25 | | (Expr a) :>=: (Expr a) 26 | | (Expr a) :&&: (Expr a) 27 | | (Expr a) :||: (Expr a) 28 | | Not (Expr a) 29 | 30 | noOffer :: Offer a 31 | noOffer = AbsoluteDiscount 0 32 | 33 | v :: Offer String 34 | v = Until 30 $ BetterOf (AbsoluteDiscount 10.0) 35 | (Both (Present "ballon") 36 | (If (TotalPrice :>: IVal 100) (PercentDiscount 5.0) 37 | (AbsoluteDiscount 0))) 38 | 39 | incorrectExpression :: Expr Char 40 | incorrectExpression = TotalPrice :||: (TotalNumberProducts :<: PriceOf 'a') 41 | 42 | data ExprR = EInt Integer | EFloat Float | EBool Bool 43 | 44 | interpretExpr :: Expr a -> [(a,Float)] -> ExprR 45 | interpretExpr (e1 :||: e2) list = 46 | case (interpretExpr e1 list, interpretExpr e2 list) of 47 | (EBool b1, EBool b2) -> EBool (b1 || b2) 48 | _ -> error "type error" 49 | 50 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/ListL.idr: -------------------------------------------------------------------------------- 1 | module Chapter13.ListL 2 | 3 | data ListL : Nat -> Type -> Type where 4 | EmptyL : ListL Z a 5 | ConsL : a -> ListL n a -> ListL (S n) a 6 | 7 | duplicateEachElem : ListL n a -> ListL (n * 2) a 8 | duplicateEachElem EmptyL = EmptyL 9 | duplicateEachElem (ConsL x r) = ConsL x (ConsL x (duplicateEachElem r)) 10 | 11 | {- 12 | reverseAccum : ListL p a -> ListL q a -> ListL (q <+> p) a 13 | reverseAccum EmptyL acc = acc 14 | reverseAccum (ConsL x r) acc = reverseAccum r (ConsL x acc) 15 | 16 | reverseL : ListL n a -> ListL n a 17 | reverseL l = reverseAccum l EmptyL 18 | -} 19 | 20 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Numbers.hs: -------------------------------------------------------------------------------- 1 | module Chapter13.Numbers where 2 | 3 | data Number = Zero | Succ Number 4 | deriving Show 5 | 6 | one :: Number 7 | one = Succ Zero 8 | two :: Number 9 | two = Succ one 10 | three :: Number 11 | three = Succ two 12 | four :: Number 13 | four = Succ three 14 | five :: Number 15 | five = Succ four 16 | 17 | plus' :: Number -> Number -> Number 18 | plus' Zero y = y 19 | plus' (Succ x) y = Succ (plus' x y) 20 | 21 | max' :: Number -> Number -> Number 22 | max' Zero y = y 23 | max' x Zero = x 24 | max' (Succ x) (Succ y) = Succ (max' x y) 25 | 26 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Numbers.idr: -------------------------------------------------------------------------------- 1 | module Chapter13.Numbers 2 | 3 | data Number = Zero | Succ Number 4 | deriving Show 5 | 6 | one : Number 7 | one = Succ Zero 8 | two : Number 9 | two = Succ one 10 | three : Number 11 | three = Succ two 12 | four : Number 13 | four = Succ three 14 | five : Number 15 | five = Succ four 16 | 17 | plus : Number -> Number -> Number 18 | plus Zero y = y 19 | plus (Succ x) y = Succ (plus x y) 20 | 21 | max : Number -> Number -> Number 22 | max Zero y = y 23 | max x Zero = x 24 | max (Succ x) (Succ y) = Succ (max x y) 25 | 26 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Tree.idr: -------------------------------------------------------------------------------- 1 | module Chapter13.Tree 2 | 3 | data Tree : Nat -> Type -> Type where 4 | Leaf : a -> Tree 1 a 5 | Node : a -> Tree n a -> Tree m a -> Tree (1 + maximum n m) a 6 | 7 | t : Tree 3 Char 8 | t = Node 'a' (Leaf 'b') (Node 'c' (Leaf 'd') (Leaf 'e')) 9 | 10 | {- 11 | rotate : Tree n a -> Tree n a 12 | rotate (Leaf x) = Leaf x 13 | rotate (Node x r l) = Node x (rotate l) (rotate r) 14 | -} 15 | 16 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/Users.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls, GADTs #-} 2 | 3 | module Chapter13.Users where 4 | 5 | data AllowEverything 6 | data AllowProducts 7 | data AllowPurchases 8 | 9 | data Person = Person { firstName :: String, lastName :: String } 10 | 11 | data User r where 12 | Admin :: Person -> User AllowEverything 13 | StoreManager :: Person -> User AllowEverything 14 | StorePerson :: Person -> User AllowProducts 15 | Client :: Person -> User AllowPurchases 16 | -------------------------------------------------------------------------------- /chapter13/src/Chapter13/VectorsLits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs,DataKinds, TypeOperators #-} 2 | 3 | module Chapter13.VectorsLits where 4 | 5 | import GHC.TypeLits 6 | 7 | data Vect n a where 8 | VNil :: Vect 0 a 9 | VCons :: a -> Vect n a -> Vect (n + 1) a 10 | 11 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter14/chapter14.cabal: -------------------------------------------------------------------------------- 1 | name: chapter14 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Custom 5 | author: serras 6 | 7 | executable uuagc-examples 8 | hs-source-dirs: src 9 | build-depends: base >= 4, mtl, blaze-html >= 0.6 10 | ghc-options: -Wall 11 | other-modules: Chapter14.Expr, 12 | Chapter14.Expr2, 13 | Chapter14.ExprMonad, 14 | Chapter14.Presents, 15 | Chapter14.Simple, 16 | Chapter14.SimpleNoAG, 17 | Chapter14.Description, 18 | Chapter14.Origami 19 | extensions: ScopedTypeVariables 20 | main-is: Main.hs 21 | 22 | -------------------------------------------------------------------------------- /chapter14/offer-description.html: -------------------------------------------------------------------------------- 1 | <h1> 2 | Description of an offer 3 | </h1> 4 | <h2> 5 | Possible presents: 6 | </h2> 7 | <ul> 8 | <li> 9 | 'a' 10 | </li> 11 | <li> 12 | 'b' 13 | </li> 14 | </ul> 15 | <h2> 16 | Main offer 17 | </h2> 18 | <a href="#elt6"> 19 | BOTH 20 | </a> 21 | <ul> 22 | <li> 23 | <a href="#elt2"> 24 | PRESENT: 'a' 25 | </a> 26 | </li> 27 | <li> 28 | <a href="#elt5"> 29 | BETTER OF 30 | </a> 31 | </li> 32 | </ul> 33 | <h2> 34 | Complete offer 35 | </h2> 36 | <a name="elt6"> 37 | Both of 38 | </a> 39 | <ul> 40 | <li> 41 | <a name="elt2"> 42 | Give 'a' as a present 43 | </a> 44 | 45 | </li> 46 | <li> 47 | <a name="elt5"> 48 | Better of 49 | </a> 50 | <ul> 51 | <li> 52 | <a name="elt3"> 53 | Give 'b' as a present 54 | </a> 55 | 56 | </li> 57 | <li> 58 | <a name="elt4"> 59 | 30.0$ discount 60 | </a> 61 | 62 | </li> 63 | </ul> 64 | </li> 65 | </ul> 66 | 67 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Description.ag: -------------------------------------------------------------------------------- 1 | imports 2 | { 3 | import Data.List 4 | import Data.String 5 | import qualified Text.Blaze.Html5 as H 6 | import qualified Text.Blaze.Html5.Attributes as A 7 | } 8 | 9 | include "OfferType.ag" 10 | 11 | data HtmlRoot a 12 | | HtmlRoot root :: (Offer {a}) 13 | 14 | attr Offer 15 | chn counter :: Int 16 | syn title :: String 17 | syn subtitles :: {[(String,Int)]} 18 | syn presents use {++} {[]} :: {[a]} 19 | 20 | attr HtmlRoot Offer 21 | syn html :: {H.Html} 22 | 23 | sem Eq {a}, Show {a} => HtmlRoot 24 | | HtmlRoot root.counter = 1 25 | lhs.html = { do H.h1 $ H.toHtml "Description of an offer" 26 | H.h2 $ H.toHtml "Possible presents:" 27 | H.ul $ mapM_ (\e -> H.li $ H.toHtml (show e)) @root.presents 28 | H.h2 $ H.toHtml "Main offer" 29 | H.a H.! A.href (fromString ("#elt" ++ show @root.counter)) 30 | $ H.toHtml @root.title 31 | H.ul $ mapM_ (\(st, e) -> H.li $ H.a H.! A.href (fromString ("#elt" ++ show e)) 32 | $ H.toHtml st) 33 | @root.subtitles 34 | H.h2 $ H.toHtml "Complete offer" 35 | @root.html } 36 | 37 | sem Eq {a}, Show {a} => Offer 38 | | Present PercentDiscount AbsoluteDiscount 39 | loc.ident = @lhs.counter + 1 40 | lhs.counter = @loc.ident 41 | | Restrict From Until Extend 42 | inner.counter = @lhs.counter 43 | loc.ident = @inner.counter + 1 44 | lhs.counter = @loc.ident 45 | | Both BetterOf 46 | left.counter = @lhs.counter 47 | right.counter = @left.counter 48 | loc.ident = @right.counter + 1 49 | lhs.counter = @loc.ident 50 | | If 51 | then.counter = @lhs.counter 52 | else.counter = @then.counter 53 | loc.ident = @else.counter + 1 54 | lhs.counter = @loc.ident 55 | | Present PercentDiscount AbsoluteDiscount Restrict From Until Extend Both BetterOf If 56 | lhs.html = { do H.a H.! A.name (fromString ("elt" ++ show @loc.ident)) 57 | $ H.toHtml @loc.htmlText 58 | @loc.htmlChild } 59 | | Present 60 | lhs.title = { "PRESENT: " ++ show @present } 61 | lhs.subtitles = [] 62 | lhs.presents = [@present] 63 | loc.htmlText = "Give " ++ show @present ++ " as a present" 64 | loc.htmlChild = H.toHtml "" 65 | | PercentDiscount 66 | lhs.title = { "DISCOUNT: " ++ show @discount ++ "%" } 67 | lhs.subtitles = [] 68 | loc.htmlText = show @discount ++ "% discount" 69 | loc.htmlChild = H.toHtml "" 70 | | AbsoluteDiscount 71 | lhs.title = { "DISCOUNT: " ++ show @discount ++ "$" } 72 | lhs.subtitles = [] 73 | loc.htmlText = show @discount ++ "$ discount" 74 | loc.htmlChild = H.toHtml "" 75 | | From 76 | lhs.title = { "FROM: " ++ show @from } 77 | lhs.subtitles = [(@inner.title, @inner.counter)] 78 | loc.htmlText = "Only available from " ++ show @from ++ " days on" 79 | loc.htmlChild = H.ul $ H.li @inner.html 80 | | Until 81 | lhs.title = { "UNTIL: " ++ show @until } 82 | lhs.subtitles = [(@inner.title, @inner.counter)] 83 | loc.htmlText = "Only available until " ++ show @until ++ " days" 84 | loc.htmlChild = H.ul $ H.li @inner.html 85 | | Extend 86 | lhs.title = { "EXTEND: " ++ show @times ++ " times" } 87 | lhs.subtitles = [(@inner.title, @inner.counter)] 88 | loc.htmlText = "Available for " ++ show @times ++ " times more" 89 | loc.htmlChild = H.ul $ H.li @inner.html 90 | | Restrict 91 | lhs.title = { "RESTRICT PRODUCTS" } 92 | lhs.subtitles = [(@inner.title, @inner.counter)] 93 | lhs.presents = { @products `intersect` @inner.presents } 94 | loc.htmlText = "Restricting to products " ++ show @products 95 | loc.htmlChild = H.ul $ H.li @inner.html 96 | | Both 97 | lhs.title = { "BOTH" } 98 | lhs.subtitles = [(@left.title, @left.counter), (@right.title, @right.counter)] 99 | loc.htmlText = "Both of" 100 | loc.htmlChild = { H.ul $ do H.li @left.html 101 | H.li @right.html } 102 | | BetterOf 103 | lhs.title = { "BETTER OF" } 104 | lhs.subtitles = [(@left.title, @left.counter), (@right.title, @right.counter)] 105 | loc.htmlText = "Better of" 106 | loc.htmlChild = { H.ul $ do H.li @left.html 107 | H.li @right.html } 108 | | If 109 | lhs.title = { "CONDITIONAL OFFER" } 110 | lhs.subtitles = [(@then.title, @then.counter), (@else.title, @else.counter)] 111 | loc.htmlText = "If some condition is true" 112 | loc.htmlChild = { H.ul $ do H.li $ H.toHtml "Then" >> @then.html 113 | H.li $ H.toHtml "Else" >> @else.html } 114 | 115 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Expr.ag: -------------------------------------------------------------------------------- 1 | imports 2 | { 3 | import Control.Applicative 4 | } 5 | 6 | include "ExprType.ag" 7 | 8 | attr Root Expr 9 | inh products :: {[(a, Float)]} 10 | syn intValue :: {Maybe Int} 11 | syn fltValue :: {Maybe Float} 12 | syn boolValue :: {Maybe Bool} 13 | 14 | attr Expr 15 | inh numberOfProducts :: Int 16 | inh totalPrice :: Float 17 | 18 | sem Eq {a} => Root 19 | | Root expr.numberOfProducts = length @lhs.products 20 | expr.totalPrice = foldr (\(_,p) x -> p + x) 0.0 @lhs.products 21 | 22 | sem Eq {a} => Expr 23 | | AmountOf lhs.intValue = { Just (length $ filter (\(d,_) -> d == @product) @lhs.products) } 24 | lhs.fltValue = Nothing 25 | lhs.boolValue = Nothing 26 | | PriceOf lhs.intValue = Nothing 27 | lhs.fltValue = { Just (foldr (\(_,p) x -> p + x) 0.0 $ filter (\(d,_) -> d == @product) @lhs.products) } 28 | lhs.boolValue = Nothing 29 | | TotalNumberOfProducts lhs.intValue = Just @lhs.numberOfProducts 30 | lhs.fltValue = Nothing 31 | lhs.boolValue = Nothing 32 | | TotalPrice lhs.intValue = Nothing 33 | lhs.fltValue = Just @lhs.totalPrice 34 | lhs.boolValue = Nothing 35 | | IVal lhs.intValue = Just @val 36 | lhs.fltValue = Nothing 37 | lhs.boolValue = Nothing 38 | | FVal lhs.intValue = Nothing 39 | lhs.fltValue = Just @val 40 | lhs.boolValue = Nothing 41 | | Plus lhs.intValue = {(+) <$> @right.intValue <*> @left.intValue } 42 | lhs.fltValue = {(+) <$> @right.fltValue <*> @left.fltValue } 43 | lhs.boolValue = Nothing 44 | | Times lhs.intValue = {(*) <$> @right.intValue <*> @left.intValue } 45 | lhs.fltValue = {(*) <$> @right.fltValue <*> @left.fltValue } 46 | lhs.boolValue = Nothing 47 | | LessThan lhs.intValue = Nothing 48 | lhs.fltValue = Nothing 49 | lhs.boolValue = { (<=) <$> @right.intValue <*> @left.intValue 50 | <|> (<=) <$> @right.fltValue <*> @left.fltValue } 51 | | Or lhs.intValue = Nothing 52 | lhs.fltValue = Nothing 53 | lhs.boolValue = { (||) <$> @right.boolValue <*> @left.boolValue } 54 | | And lhs.intValue = Nothing 55 | lhs.fltValue = Nothing 56 | lhs.boolValue = { (||) <$> @right.boolValue <*> @left.boolValue } 57 | | Not lhs.intValue = Nothing 58 | lhs.fltValue = Nothing 59 | lhs.boolValue = { not <$> @inner.boolValue } 60 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Expr2.ag: -------------------------------------------------------------------------------- 1 | imports 2 | { 3 | import Control.Applicative 4 | } 5 | 6 | data Expr a 7 | | AmountOf product :: {a} 8 | | PriceOf product :: {a} 9 | | TotalNumberOfProducts 10 | | TotalPrice 11 | | IVal val :: Int 12 | | FVal val :: Float 13 | | Plus right :: (Expr {a}) left :: (Expr {a}) 14 | | Times right :: (Expr {a}) left :: (Expr {a}) 15 | | LessThan right :: (Expr {a}) left :: (Expr {a}) 16 | | Or right :: (Expr {a}) left :: (Expr {a}) 17 | | And right :: (Expr {a}) left :: (Expr {a}) 18 | | Not inner :: (Expr {a}) 19 | 20 | attr Expr 21 | inh products :: {[(a, Float)]} 22 | syn intValue :: {Maybe Int} 23 | syn fltValue :: {Maybe Float} 24 | syn boolValue :: {Maybe Bool} 25 | 26 | sem Eq {a} => Expr 27 | | AmountOf lhs.intValue = { Just (length $ filter (\(d,_) -> d == @product) @lhs.products) } 28 | lhs.fltValue = Nothing 29 | lhs.boolValue = Nothing 30 | | PriceOf lhs.intValue = Nothing 31 | lhs.fltValue = { Just (foldr (\(_,p) x -> p + x) 0.0 $ filter (\(d,_) -> d == @product) @lhs.products) } 32 | lhs.boolValue = Nothing 33 | | TotalNumberOfProducts lhs.intValue = Just $ length @lhs.products 34 | lhs.fltValue = Nothing 35 | lhs.boolValue = Nothing 36 | | TotalPrice lhs.intValue = Nothing 37 | lhs.fltValue = Just $ foldr (\(_,p) x -> p + x) 0.0 @lhs.products 38 | lhs.boolValue = Nothing 39 | | IVal lhs.intValue = Just @val 40 | lhs.fltValue = Nothing 41 | lhs.boolValue = Nothing 42 | | FVal lhs.intValue = Nothing 43 | lhs.fltValue = Just @val 44 | lhs.boolValue = Nothing 45 | | Plus lhs.intValue = {(+) <$> @right.intValue <*> @left.intValue } 46 | lhs.fltValue = {(+) <$> @right.fltValue <*> @left.fltValue } 47 | lhs.boolValue = Nothing 48 | right.products = @lhs.products 49 | left.products = @lhs.products 50 | | Times lhs.intValue = {(*) <$> @right.intValue <*> @left.intValue } 51 | lhs.fltValue = {(*) <$> @right.fltValue <*> @left.fltValue } 52 | lhs.boolValue = Nothing 53 | | LessThan lhs.intValue = Nothing 54 | lhs.fltValue = Nothing 55 | lhs.boolValue = { (<=) <$> @right.intValue <*> @left.intValue 56 | <|> (<=) <$> @right.fltValue <*> @left.fltValue } 57 | | Or lhs.intValue = Nothing 58 | lhs.fltValue = Nothing 59 | lhs.boolValue = { (||) <$> @right.boolValue <*> @left.boolValue } 60 | | And lhs.intValue = Nothing 61 | lhs.fltValue = Nothing 62 | lhs.boolValue = { (||) <$> @right.boolValue <*> @left.boolValue } 63 | | Not lhs.intValue = Nothing 64 | lhs.fltValue = Nothing 65 | lhs.boolValue = { not <$> @inner.boolValue } 66 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/ExprMonad.hs: -------------------------------------------------------------------------------- 1 | module Chapter14.ExprMonad where 2 | 3 | import Control.Applicative 4 | import Control.Monad.Reader 5 | import Control.Monad.Writer 6 | 7 | data Expr a = AmountOf a 8 | | PriceOf a 9 | | TotalNumberProducts 10 | | TotalPrice 11 | | IVal Int 12 | | FVal Float 13 | | (Expr a) :+: (Expr a) 14 | | (Expr a) :*: (Expr a) 15 | | (Expr a) :<: (Expr a) 16 | | (Expr a) :<=: (Expr a) 17 | | (Expr a) :>: (Expr a) 18 | | (Expr a) :>=: (Expr a) 19 | | (Expr a) :&&: (Expr a) 20 | | (Expr a) :||: (Expr a) 21 | | Not (Expr a) 22 | 23 | exprExample :: Expr Char 24 | exprExample = (AmountOf 'a' :<: IVal 2) :&&: (FVal 300.0 :<: TotalPrice) 25 | 26 | productsExample :: [(Char,Float)] 27 | productsExample = [('a',15.0), ('b',400.0)] 28 | 29 | executeExpr :: Eq a => Expr a -> [(a, Float)] -> Result 30 | executeExpr e p = execWriter (runReaderT (sem e) p) 31 | 32 | newtype Result = Result (Maybe Int, Maybe Float, Maybe Bool) deriving Show 33 | instance Monoid Result where 34 | _ `mappend` r2 = r2 35 | mempty = Result (Nothing, Nothing, Nothing) 36 | 37 | sem :: Eq a => Expr a -> ReaderT [(a,Float)] (Writer Result) () 38 | sem (AmountOf p) = do products <- ask 39 | tell $ Result (Just (length $ filter (\(d,_) -> d == p) products), Nothing, Nothing) 40 | sem (PriceOf p) = do products <- ask 41 | tell $ Result (Nothing, Just $ foldr (\(_,pr) x -> pr + x) 0.0 $ filter (\(d,_) -> d == p) products, Nothing) 42 | sem TotalNumberProducts = do products <- ask 43 | tell $ Result (Just (length products), Nothing, Nothing) 44 | sem TotalPrice = do products <- ask 45 | tell $ Result (Nothing, Just (foldr (\(_,p) x -> p + x) 0.0 products), Nothing) 46 | sem (IVal i) = tell $ Result (Just i, Nothing, Nothing) 47 | sem (FVal f) = tell $ Result (Nothing, Just f, Nothing) 48 | sem (e1 :+: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 49 | (_, Result (i2, f2, _)) <- listen (sem e2) 50 | tell $ Result ((+) <$> i1 <*> i2, (+) <$> f1 <*> f2, Nothing) 51 | sem (e1 :*: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 52 | (_, Result (i2, f2, _)) <- listen (sem e2) 53 | tell $ Result ((*) <$> i1 <*> i2, (*) <$> f1 <*> f2, Nothing) 54 | sem (e1 :<: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 55 | (_, Result (i2, f2, _)) <- listen (sem e2) 56 | tell $ Result (Nothing, Nothing, ((<) <$> i1 <*> i2) <|> ((<) <$> f1 <*> f2)) 57 | sem (e1 :<=: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 58 | (_, Result (i2, f2, _)) <- listen (sem e2) 59 | tell $ Result (Nothing, Nothing, ((<=) <$> i1 <*> i2) <|> ((<=) <$> f1 <*> f2)) 60 | sem (e1 :>: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 61 | (_, Result (i2, f2, _)) <- listen (sem e2) 62 | tell $ Result (Nothing, Nothing, ((>) <$> i1 <*> i2) <|> ((>) <$> f1 <*> f2)) 63 | sem (e1 :>=: e2) = do (_, Result (i1, f1, _)) <- listen (sem e1) 64 | (_, Result (i2, f2, _)) <- listen (sem e2) 65 | tell $ Result (Nothing, Nothing, ((>=) <$> i1 <*> i2) <|> ((>=) <$> f1 <*> f2)) 66 | sem (e1 :&&: e2) = do (_, Result (_,_,b1)) <- listen (sem e1) 67 | (_, Result (_,_,b2)) <- listen (sem e2) 68 | tell $ Result (Nothing, Nothing, (&&) <$> b1 <*> b2) 69 | sem (e1 :||: e2) = do (_, Result (_,_,b1)) <- listen (sem e1) 70 | (_, Result (_,_,b2)) <- listen (sem e2) 71 | tell $ Result (Nothing, Nothing, (||) <$> b1 <*> b2) 72 | sem (Not e) = do (_, Result (_,_,b)) <- listen (sem e) 73 | tell $ Result (Nothing, Nothing, not <$> b) 74 | 75 | 76 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/ExprType.ag: -------------------------------------------------------------------------------- 1 | data Root a 2 | | Root expr :: (Expr {a}) 3 | 4 | data Expr a 5 | | AmountOf product :: {a} 6 | | PriceOf product :: {a} 7 | | TotalNumberOfProducts 8 | | TotalPrice 9 | | IVal val :: Int 10 | | FVal val :: Float 11 | | Plus right :: (Expr {a}) left :: (Expr {a}) 12 | | Times right :: (Expr {a}) left :: (Expr {a}) 13 | | LessThan right :: (Expr {a}) left :: (Expr {a}) 14 | | Or right :: (Expr {a}) left :: (Expr {a}) 15 | | And right :: (Expr {a}) left :: (Expr {a}) 16 | | Not inner :: (Expr {a}) 17 | 18 | deriving Root Expr : Show 19 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/OfferType.ag: -------------------------------------------------------------------------------- 1 | include "ExprType.ag" 2 | 3 | data Offer a 4 | | Present present :: {a} 5 | | PercentDiscount discount :: Float 6 | | AbsoluteDiscount discount :: Float 7 | | Restrict products :: {[a]} inner :: (Offer {a}) 8 | | From from :: Int inner :: (Offer {a}) 9 | | Until until :: Int inner :: (Offer {a}) 10 | | Extend times :: Int inner :: (Offer {a}) 11 | | Both left :: (Offer {a}) right :: (Offer {a}) 12 | | BetterOf left :: (Offer {a}) right :: (Offer {a}) 13 | | If cond :: (Root {a}) then :: (Offer {a}) else :: (Offer {a}) 14 | 15 | deriving Offer : Show 16 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Origami.hs: -------------------------------------------------------------------------------- 1 | module Chapter14.Origami where 2 | 3 | data Expr a = Plus (Expr a) (Expr a) 4 | | Times (Expr a) (Expr a) 5 | | AmountOf a 6 | 7 | foldExpr :: (b -> b -> b) -> (b -> b -> b) -> (a -> b) -> Expr a -> b 8 | foldExpr plusFn timesFn amountFn e = 9 | let f = foldExpr plusFn timesFn amountFn 10 | in case e of 11 | Plus e1 e2 -> plusFn (f e1) (f e2) 12 | Times e1 e2 -> timesFn (f e1) (f e2) 13 | AmountOf x -> amountFn x 14 | 15 | performCount :: Eq a => [a] -> Expr a -> Int 16 | performCount s = foldExpr (+) (*) (\x -> length $ filter (==x) s) 17 | 18 | newtype ExprAlgebra a b = ExprAlgebra (b -> b -> b, b -> b -> b, a -> b) 19 | 20 | foldExpr' :: ExprAlgebra a b -> Expr a -> b 21 | foldExpr' a@(ExprAlgebra (plusFn,timesFn,amountFn)) e = 22 | case e of 23 | Plus e1 e2 -> plusFn (foldExpr' a e1) (foldExpr' a e2) 24 | Times e1 e2 -> timesFn (foldExpr' a e1) (foldExpr' a e2) 25 | AmountOf x -> amountFn x 26 | 27 | performCount' :: Eq a => [a] -> Expr a -> Int 28 | performCount' s = foldExpr' $ ExprAlgebra ((+),(*),\x -> length $ filter (==x) s) 29 | 30 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/Presents.ag: -------------------------------------------------------------------------------- 1 | imports 2 | { 3 | import Data.List 4 | } 5 | 6 | include "OfferType.ag" 7 | 8 | attr Offer 9 | syn presents use {++} {[]} :: {[a]} 10 | 11 | sem Eq {a} => Offer 12 | | Present lhs.presents = [@present] 13 | | Restrict lhs.presents = { @products `intersect` @inner.presents } 14 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter14/src/Chapter14/SimpleNoAG.hs: -------------------------------------------------------------------------------- 1 | module Chapter14.SimpleNoAG where 2 | 3 | data Expr = Plus Expr Expr 4 | | Times Expr Expr 5 | | AmountOf Char 6 | 7 | meaning :: Expr -> [Char] -> Int 8 | meaning (Plus l r) p = meaning l p + meaning r p 9 | meaning (Times l r) p = meaning l p * meaning r p 10 | meaning (AmountOf c) p = length $ filter (== c) p 11 | -------------------------------------------------------------------------------- /chapter14/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Chapter14.Simple as S 4 | import qualified Chapter14.Expr as E 5 | import qualified Chapter14.Expr2 as E2 6 | import qualified Chapter14.ExprMonad as E3 7 | import qualified Chapter14.Presents as P 8 | import qualified Chapter14.Description as D 9 | import qualified Chapter14.Origami as O 10 | 11 | import qualified Text.Blaze.Html5 as H 12 | import Text.Blaze.Html.Renderer.Pretty 13 | 14 | main :: IO () 15 | main = do 16 | print $ executeExpr (E.Root_Root $ E.Expr_FVal 4.0) productsExample 17 | print $ executeExpr exprExample productsExample 18 | print $ executeExpr2 expr2Example productsExample 19 | print $ E3.executeExpr E3.exprExample productsExample 20 | print $ executePresents offerExample 21 | putStrLn $ renderHtml $ describeOffer offerExample2 22 | 23 | executeExprSimple :: S.Expr -> String -> Int 24 | executeExprSimple e s = 25 | let syn = S.wrap_Expr (S.sem_Expr e) (S.Inh_Expr s) 26 | in S.result_Syn_Expr syn 27 | 28 | executeExpr :: Ord a => E.Root a -> [(a,Float)] -> (Maybe Int, Maybe Float, Maybe Bool) 29 | executeExpr e products = 30 | let syn = E.wrap_Root (E.sem_Root e) (E.Inh_Root products) 31 | in (E.intValue_Syn_Root syn, E.fltValue_Syn_Root syn, E.boolValue_Syn_Root syn) 32 | 33 | executeExpr2 :: Ord a => E2.Expr a -> [(a,Float)] -> (Maybe Int, Maybe Float, Maybe Bool) 34 | executeExpr2 e products = 35 | let syn = E2.wrap_Expr (E2.sem_Expr e) (E2.Inh_Expr products) 36 | in (E2.intValue_Syn_Expr syn, E2.fltValue_Syn_Expr syn, E2.boolValue_Syn_Expr syn) 37 | 38 | productsExample :: [(Char,Float)] 39 | productsExample = [('a',15.0), ('b',400.0)] 40 | 41 | exprExample :: E.Root Char 42 | exprExample = E.Root_Root $ 43 | E.Expr_And (E.Expr_AmountOf 'a' `E.Expr_LessThan` E.Expr_IVal 2) 44 | (E.Expr_FVal 300.0 `E.Expr_LessThan` E.Expr_TotalPrice) 45 | 46 | expr2Example :: E2.Expr Char 47 | expr2Example = 48 | E2.Expr_And (E2.Expr_AmountOf 'a' `E2.Expr_LessThan` E2.Expr_IVal 2) 49 | (E2.Expr_FVal 300.0 `E2.Expr_LessThan` E2.Expr_TotalPrice) 50 | 51 | executePresents :: Eq a => P.Offer a -> [a] 52 | executePresents o = P.presents_Syn_Offer $ P.wrap_Offer (P.sem_Offer o) P.Inh_Offer 53 | 54 | offerExample :: P.Offer Char 55 | offerExample = 56 | P.Offer_Both (P.Offer_Present 'a') 57 | (P.Offer_BetterOf (P.Offer_Present 'b') 58 | (P.Offer_AbsoluteDiscount 30.0)) 59 | 60 | describeOffer :: (Eq a, Show a) => D.Offer a -> H.Html 61 | describeOffer o = D.html_Syn_HtmlRoot $ D.wrap_HtmlRoot (D.sem_HtmlRoot $ D.HtmlRoot_HtmlRoot o) D.Inh_HtmlRoot 62 | 63 | offerExample2 :: D.Offer Char 64 | offerExample2 = 65 | D.Offer_Both (D.Offer_Present 'a') 66 | (D.Offer_BetterOf (D.Offer_Present 'b') 67 | (D.Offer_AbsoluteDiscount 30.0)) 68 | -------------------------------------------------------------------------------- /chapter14/uuagc_options: -------------------------------------------------------------------------------- 1 | file : "src/Chapter14/Simple.ag" 2 | options : data, semfuns, catas, pretty, wrappers, rename, module "Chapter14.Simple", haskellsyntax, signatures 3 | 4 | file : "src/Chapter14/Expr.ag" 5 | options : data, semfuns, catas, pretty, wrappers, rename, module "Chapter14.Expr", haskellsyntax, signatures 6 | 7 | file : "src/Chapter14/Expr2.ag" 8 | options : data, semfuns, catas, pretty, wrappers, rename, module "Chapter14.Expr2", haskellsyntax, signatures 9 | 10 | file : "src/Chapter14/Presents.ag" 11 | options : data, semfuns, catas, pretty, wrappers, rename, module "Chapter14.Presents", haskellsyntax, signatures 12 | 13 | file : "src/Chapter14/Description.ag" 14 | options : data, semfuns, catas, pretty, wrappers, rename, module "Chapter14.Description", haskellsyntax, signatures 15 | -------------------------------------------------------------------------------- /chapter15/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter15/chapter15.cabal: -------------------------------------------------------------------------------- 1 | name: chapter15 2 | version: 0.1 3 | cabal-version: >=1.8 4 | -- cabal: The field 'build-depends: chapter15' refers to a library which is 5 | -- defined within the same package. To use this feature the package must specify 6 | -- at least 'cabal-version: >= 1.8'. 7 | build-type: Simple 8 | author: serras 9 | 10 | library 11 | hs-source-dirs: src 12 | build-depends: 13 | base >= 4, 14 | QuickCheck 15 | ghc-options: -Wall 16 | exposed-modules: Chapter15.BinaryTree 17 | 18 | test-suite HSpec 19 | type: exitcode-stdio-1.0 20 | ghc-options: -Wall -rtsopts 21 | build-depends: 22 | base >= 4, 23 | hspec, 24 | hspec-smallcheck, 25 | HUnit, 26 | chapter15 27 | hs-source-dirs: test 28 | main-is: HSpec.hs 29 | 30 | test-suite Tasty 31 | type: exitcode-stdio-1.0 32 | ghc-options: -Wall -rtsopts 33 | build-depends: 34 | base >= 4, 35 | tasty >=0.4.0 && <0.5, 36 | tasty-hunit >=0.2 && <0.3, 37 | tasty-quickcheck >=0.3.1 && <0.4, 38 | tasty-smallcheck >=0.2 && <0.3, 39 | chapter15 40 | hs-source-dirs: test 41 | main-is: Tasty.hs 42 | 43 | -------------------------------------------------------------------------------- /chapter15/src/Chapter15/BinaryTree.hs: -------------------------------------------------------------------------------- 1 | -- | Simple implementation of binary trees 2 | module Chapter15.BinaryTree ( 3 | -- * The main data type 4 | BinaryTree(..), 5 | -- * Operations 6 | -- ** Insertion 7 | treeInsert, 8 | treeMerge, 9 | -- ** Lookup 10 | treeFind, 11 | treeFindMin, 12 | -- ** Removal 13 | treeDelete 14 | ) where 15 | 16 | import Test.QuickCheck 17 | 18 | -- | A typical binary tree 19 | data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) -- ^Inner nodes 20 | | Leaf -- ^Leaves 21 | deriving (Eq, Show) 22 | 23 | {-| 24 | Inserts an element into a 'BinaryTree' 25 | 26 | * If it finds a leaf, insert there 27 | 28 | * If smaller than the item in the node, insert in the left 29 | 30 | * If larger than the item in the node, insert in the right 31 | 32 | >>> treeInsert 1 Leaf 33 | Node 1 Leaf Leaf 34 | 35 | prop> size (treeInsert x t) = size t + 1 36 | -} 37 | treeInsert :: Ord a => a -> BinaryTree a -> BinaryTree a 38 | treeInsert x Leaf = Node x Leaf Leaf 39 | treeInsert x (Node y l r) | (x <= y) = Node y (treeInsert x l) r 40 | | otherwise = Node y l (treeInsert x r) 41 | 42 | treeFindMin :: BinaryTree a -> Maybe a 43 | treeFindMin Leaf = Nothing 44 | treeFindMin (Node x Leaf _) = Just x 45 | treeFindMin (Node _ l _) = treeFindMin l 46 | 47 | treeFind :: Ord a => a -> BinaryTree a -> Maybe a 48 | treeFind _ Leaf = Nothing 49 | treeFind x (Node y l r) | x < y = treeFind x l 50 | | x > y = treeFind x r 51 | | otherwise = Just y 52 | 53 | {-| 54 | Merges two trees by repeated insertion 55 | 56 | prop> treeMerge Leaf Leaf = Leaf 57 | -} 58 | treeMerge :: Ord a => BinaryTree a -> BinaryTree a -> BinaryTree a 59 | treeMerge t Leaf = t 60 | treeMerge t (Node x l r) = treeInsert x $ treeMerge (treeMerge t l) r 61 | 62 | treeDelete :: Ord a => a -> BinaryTree a -> BinaryTree a 63 | treeDelete _ Leaf = Leaf 64 | treeDelete x (Node y l r) 65 | | x < y = Node y (treeDelete x l) r 66 | | x > y = Node y l (treeDelete x r) 67 | | otherwise = case (l, r) of 68 | (Leaf, Leaf) -> Leaf 69 | (_, Leaf) -> l 70 | (Leaf, _ ) -> r 71 | (_, _ ) -> Node y l r' where 72 | Just m = treeFindMin r 73 | r' = treeDelete m r 74 | 75 | instance Arbitrary a => Arbitrary (BinaryTree a) where 76 | arbitrary = sized $ \n -> 77 | if (n == 0) 78 | then return Leaf 79 | else frequency [(1, return Leaf), 80 | (n, resize (n-1) arbitrary)] 81 | shrink Leaf = [] 82 | shrink (Node _ l r) = [l, r] 83 | 84 | -------------------------------------------------------------------------------- /chapter15/src/Chapter15/BinaryTreeFV.idr: -------------------------------------------------------------------------------- 1 | module Chapter15.BinaryTreeFV 2 | 3 | data BinaryTree : Type -> Nat -> Type where 4 | Leaf : BinaryTree a 0 5 | Node : a -> BinaryTree a l -> BinaryTree a r -> BinaryTree a (S (l + r)) 6 | 7 | treeInsert : Ord a => a -> BinaryTree a n -> BinaryTree a (S n) 8 | treeInsert x Leaf = Node x Leaf Leaf 9 | treeInsert x (Node y l r) with (x <= y) 10 | | True = let l' = treeInsert x l in Node y l' r 11 | | False ?= let r' = treeInsert x r in Node y l r' 12 | 13 | -- Do what has been done in Idris interactive mode 14 | Chapter15.BinaryTreeFV.treeInsert_lemma_1 = proof 15 | intros 16 | rewrite sym (plusSuccRightSucc l r) 17 | trivial 18 | 19 | treeMerge : Ord a => BinaryTree a n -> BinaryTree a m -> BinaryTree a (n + m) 20 | treeMerge t1 Leaf ?= t1 21 | treeMerge t1 (Node x2 l2 r2) ?= treeInsert x2 (treeMerge (treeMerge t1 l2) r2) 22 | 23 | Chapter15.BinaryTreeFV.treeMerge_lemma_1 = proof 24 | intros 25 | rewrite sym (plusZeroRightNeutral n) 26 | trivial 27 | 28 | {- 29 | Chapter15.BinaryTreeFV.treeMerge_lemma_2 = proof 30 | intros 31 | rewrite sym (plusCommutative n (S (plus l r))) 32 | rewrite sym (plusCommutative (plus l r) n) 33 | rewrite sym (plusAssociative n l r) 34 | trivial 35 | -} 36 | 37 | Chapter15.BinaryTreeFV.treeMerge_lemma_2 = proof 38 | intros 39 | rewrite (plusSuccRightSucc n (plus l r)) 40 | rewrite sym (plusAssociative n l r) 41 | trivial 42 | 43 | {- 44 | using (x : a, y : a, l : BinaryTree a ln, r : BinaryTree a rn) 45 | data In : a -> BinaryTree a n -> Type where 46 | AtNode : Ord a => In x (Node x l r) 47 | AtLeft : Ord a => In x l -> In x (Node y l r) 48 | AtRight : Ord a => In x r -> In x (Node y l r) 49 | 50 | insertIsThere : Ord a => (x : a) -> (t : BinaryTree a n) -> In x (treeInsert x t) 51 | insertIsThere x Leaf = AtNode 52 | insertIsThere x (Node y l r) with (x <= y, treeInsert x (Node y l r)) 53 | | (True, Node _ l' _) = AtLeft (insertIsThere x l ) 54 | | (False,Node _ _ r') = ?e2 -- $ insertIsThere x r 55 | -} 56 | -------------------------------------------------------------------------------- /chapter15/src/Chapter15/RevFV.idr: -------------------------------------------------------------------------------- 1 | module Chapter15.RevFV 2 | 3 | rev : List a -> List a 4 | rev [] = [] 5 | rev (x::xs) = rev xs ++ [x] 6 | 7 | appendLemma : (x : a) -> (xs : List a) -> (ys : List a) -> ((x::xs) ++ ys = x::(xs ++ ys)) 8 | appendLemma x [] ys = refl 9 | appendLemma x (z::zs) ys = refl 10 | 11 | revProp1 : (xs : List a) -> (ys : List a) -> (rev (xs ++ ys) = rev ys ++ rev xs) 12 | revProp1 [] ys = ?revProp1Empty 13 | revProp1 (x::xs) ys = ?revProp1Induction 14 | 15 | Chapter15.RevFV.revProp1Empty = proof 16 | intros 17 | rewrite sym (appendNilRightNeutral (rev ys)) 18 | trivial 19 | 20 | {- 21 | mutual 22 | lemmaIdempotent : (x : a) -> (xs : List a) -> (rev(xs ++ [x]) = x::rev xs) 23 | lemmaIdempotent x [] = refl 24 | lemmaIdempotent x (y::ys) = let i = revIdempotent (y::ys) in ?lemmaIdempotentStep 25 | 26 | revIdempotent : (lst : List a) -> (rev (rev lst) = lst) 27 | revIdempotent [] = refl 28 | revIdempotent (x::xs) = let i = lemmaIdempotent x xs in ?revIdempotentStep 29 | -} 30 | -------------------------------------------------------------------------------- /chapter15/test/HSpec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import Test.HUnit 5 | 6 | import Data.Maybe 7 | 8 | import Chapter15.BinaryTree 9 | 10 | main :: IO() 11 | main = hspec $ do 12 | describe "Insertion in binary tree" $ do 13 | it "Inserts correctly 1 in empty tree" $ 14 | treeInsert 1 Leaf @?= Node 1 Leaf Leaf 15 | it "Finds 1 after inserting it on a tree" $ 16 | isJust $ treeFind 1 $ treeInsert 1 (Node 2 Leaf Leaf) 17 | it "Gets the minimum correctly" $ 18 | pendingWith "Needs to be implemented" 19 | 20 | -------------------------------------------------------------------------------- /chapter15/test/Tasty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit as HU 7 | import Test.Tasty.SmallCheck as SC 8 | import Test.Tasty.QuickCheck as QC 9 | 10 | import Data.Maybe 11 | 12 | import Chapter15.BinaryTree 13 | 14 | main :: IO () 15 | main = defaultMain allTests 16 | 17 | allTests :: TestTree 18 | allTests = testGroup "Tasty Tests" [ 19 | testGroup "HUnit Tests" [ 20 | hunitTestInsertOnLeaf 21 | , hunitTestInsertFind 'b' Leaf 22 | , hunitTestInsertFind 'c' (Node 'd' Leaf Leaf) 23 | ] 24 | , reverseTests 25 | , quickCheckTests 26 | ] 27 | 28 | hunitTestInsertOnLeaf :: TestTree 29 | hunitTestInsertOnLeaf = HU.testCase "Insert 'a' on empty tree" $ 30 | HU.assertEqual "Insertion is wrong" (treeInsert 'a' Leaf) (Node 'a' Leaf Leaf) 31 | 32 | hunitTestInsertOnLeaf' = HU.testCase "Insert 'a' on empty tree" $ 33 | treeInsert 'a' Leaf HU.@?= Node 'a' Leaf Leaf 34 | 35 | hunitTestInsertFind :: Ord a => a -> BinaryTree a -> TestTree 36 | hunitTestInsertFind e t = HU.testCase "Insert can be found" $ 37 | assertBool "Cannot find element" (isJust $ treeFind e $ treeInsert e t) 38 | 39 | hunitTestInsertFind' :: Ord a => a -> BinaryTree a -> TestTree 40 | hunitTestInsertFind' e t = HU.testCase "Insert can be found" $ 41 | (isJust $ treeFind e $ treeInsert e t) HU.@? "Cannot find element" 42 | 43 | reverseTests :: TestTree 44 | reverseTests = testGroup "Tests over reverse" 45 | [ QC.testProperty "reverse respects length" $ 46 | \(lst :: [Integer]) -> length (reverse' lst) == length lst ] 47 | 48 | quickCheckTests :: TestTree 49 | quickCheckTests = testGroup "QuickCheck Tests" 50 | [ QC.testProperty "insert => you will find it" $ 51 | \(n :: Int) t -> treeFind n (treeInsert n t) == Just n 52 | , QC.testProperty "delete => not find it" $ 53 | \(n :: Int) t -> (treeFind n t == Nothing) QC.==> (treeFind n $ treeDelete n $ treeInsert n t) == Nothing ] 54 | 55 | reverse' :: [a] -> [a] 56 | reverse' [] = [] 57 | reverse' [x] = [x, x] 58 | reverse' (x:xs) = reverse' xs ++ [x] 59 | -------------------------------------------------------------------------------- /chapter16/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter16/chapter16.cabal: -------------------------------------------------------------------------------- 1 | name: chapter16 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: base >= 4, free 10 | ghc-options: -Wall 11 | exposed-modules: Chapter16.FreeMonads 12 | 13 | -------------------------------------------------------------------------------- /chapter16/src/Chapter16/FreeMonads.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module Chapter16.FreeMonads where 4 | 5 | import Control.Monad.Free 6 | import Data.Char 7 | import Data.List 8 | 9 | newtype ClientId = ClientId Integer deriving Show 10 | data Client = Client { clientName :: String } deriving Show 11 | 12 | data AdminOp r = GetClient ClientId (Client -> r) 13 | | SaveClient ClientId Client r 14 | | NewClient Client (ClientId -> r) 15 | deriving Functor 16 | 17 | type Admin = Free AdminOp 18 | 19 | getClient :: ClientId -> Admin Client 20 | getClient i = liftF $ GetClient i id 21 | 22 | saveClient :: ClientId -> Client -> Admin () 23 | saveClient i c = liftF $ SaveClient i c () 24 | 25 | newClient :: Client -> Admin ClientId 26 | newClient c = liftF $ NewClient c id 27 | 28 | exampleAdmin :: String -> Admin String 29 | exampleAdmin s = do i <- newClient $ Client s 30 | n <- fmap clientName $ getClient i 31 | return $ map toUpper n 32 | 33 | runAdmin :: Admin a -> ([(Integer,Client)],a) 34 | runAdmin m = runAdmin' m [] 35 | where runAdmin' (Free (GetClient (ClientId i) n)) l = 36 | let Just c = lookup i l in runAdmin' (n c) l 37 | runAdmin' (Free (SaveClient (ClientId i) c n)) l = 38 | let l' = deleteBy (\(j,_) (k,_) -> j == k) (i, c) l 39 | in runAdmin' n $ (i,c):l' 40 | runAdmin' (Free (NewClient c n)) [] = 41 | runAdmin' (n $ ClientId 1) [(1,c)] 42 | runAdmin' (Free (NewClient c n)) l = 43 | let (i',_) = maximumBy (\(j,_) (k,_) -> compare j k) l 44 | in runAdmin' (n $ ClientId (i' + 1)) $ (i' + 1,c):l 45 | runAdmin' (Pure c) l = (l, c) 46 | -------------------------------------------------------------------------------- /chapter2/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter2/chapter2.cabal: -------------------------------------------------------------------------------- 1 | name: chapter2 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: Alejandro Serrano 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: base >= 4 10 | ghc-options: -Wall 11 | exposed-modules: 12 | Chapter2.Section2.Example, 13 | Chapter2.SimpleFunctions 14 | other-modules: 15 | Chapter2.DataTypes, 16 | Chapter2.DefaultValues 17 | 18 | -------------------------------------------------------------------------------- /chapter2/src/Chapter2/DataTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, NamedFieldPuns, RecordWildCards #-} 2 | 3 | module Chapter2.DataTypes where 4 | 5 | import Data.Char 6 | 7 | data Client = GovOrg String 8 | | Company String Integer Person String 9 | | Individual Person Bool 10 | deriving Show 11 | 12 | data Person = Person String String Gender 13 | deriving Show 14 | 15 | data Gender = Male | Female | Unknown 16 | deriving Show 17 | 18 | clientName :: Client -> String 19 | -- LONG VERSION 20 | -- clientName client = case client of 21 | -- GovOrg name -> name 22 | -- Company name _ _ _ -> name 23 | -- Individual (Person fName lName _) _ -> fName ++ " " ++ lName 24 | -- SHORT VERSION 25 | clientName (GovOrg name) = name 26 | clientName (Company name _ _ _) = name 27 | clientName (Individual (Person fName lName _) _) = fName ++ " " ++ lName 28 | 29 | responsibility :: Client -> String 30 | responsibility (Company _ _ _ r) = r 31 | responsibility _ = "Unknown" 32 | 33 | specialClient :: Client -> Bool 34 | specialClient (clientName -> "Mr. Alejandro") = True 35 | specialClient (responsibility -> "Director") = True 36 | specialClient _ = False 37 | 38 | companyName :: Client -> Maybe String 39 | companyName client = case client of 40 | Company name _ _ _ -> Just name 41 | _ -> Nothing 42 | 43 | fibonacci :: Integer -> Integer 44 | -- LONG VERSION 45 | -- fibonacci n = case n of 46 | -- 0 -> 0 47 | -- 1 -> 1 48 | -- _ -> fibonacci (n-1) + fibonacci (n-2) 49 | -- SHORT VERSION 50 | fibonacci 0 = 0 51 | fibonacci 1 = 1 52 | fibonacci n = fibonacci (n-1) + fibonacci (n-2) 53 | 54 | f :: Client -> String 55 | f client = case client of 56 | Company _ _ (Person name _ _) "Boss" -> name ++ " is the boss" 57 | _ -> "There is no boss" 58 | 59 | g :: Client -> String 60 | g client = case client of 61 | Company _ _ (Person name _ _) pos -> 62 | case pos of "Boss" -> name ++ " is the boss" 63 | _ -> "There is no boss" 64 | 65 | (+++) :: [a] -> [a] -> [a] 66 | [] +++ list2 = list2 67 | (x:xs) +++ list2 = x:(xs +++ list2) 68 | {-list1 +++ list2 = case list1 of 69 | [] -> list2 70 | x:xs -> x:(xs +++ list2)-} 71 | 72 | sorted :: [Integer] -> Bool 73 | sorted [] = True 74 | sorted [_] = True 75 | sorted (x : r@(y:_)) = x < y && sorted r 76 | 77 | maxmin [x] = (x,x) 78 | maxmin (x:xs) = ( if x > xs_max then x else xs_max 79 | , if x < xs_min then x else xs_min 80 | ) where (xs_max, xs_min) = maxmin xs 81 | 82 | ifibonacci :: Integer -> Maybe Integer 83 | ifibonacci n | n < 0 = Nothing 84 | ifibonacci 0 = Just 0 85 | ifibonacci 1 = Just 1 86 | ifibonacci n | otherwise = let (Just f1, Just f2) = (ifibonacci (n-1), ifibonacci (n-2)) 87 | in Just (f1 + f2) 88 | {-ifibonacci n = case n of 89 | n' | n' < 0 -> Nothing 90 | 0 -> Just 0 91 | 1 -> Just 1 92 | _ | otherwise -> let Just f1 = ifibonacci (n-1) 93 | Just f2 = ifibonacci (n-2) 94 | in Just (f1 + f2)-} 95 | {- ifibonacci n = if n < 0 96 | then Nothing 97 | else case n of 98 | 0 -> Just 0 99 | 1 -> Just 1 100 | n -> let Just f1 = ifibonacci (n-1) 101 | Just f2 = ifibonacci (n-2) 102 | in Just (f1 + f2) -} 103 | 104 | binom :: Integer -> Integer -> Integer 105 | binom _ 0 = 1 106 | binom x y | x == y = 1 107 | binom n k = (binom (n-1) (k-1)) + (binom (n-1) k) 108 | 109 | multipleOf :: Integer -> Integer -> Bool 110 | multipleOf x y = (mod x y) == 0 111 | 112 | specialMultiples :: Integer -> String 113 | specialMultiples n 114 | | multipleOf n 2 = show n ++ " is multiple of 2" 115 | | multipleOf n 3 = show n ++ " is multiple of 3" 116 | | multipleOf n 5 = show n ++ " is multiple of 5" 117 | | otherwise = show n ++ " is a beautiful number" 118 | {- 119 | specialMultiples n | multipleOf n 2 = show n ++ " is multiple of 2" 120 | specialMultiples n | multipleOf n 3 = show n ++ " is multiple of 3" 121 | specialMultiples n | multipleOf n 5 = show n ++ " is multiple of 5" 122 | specialMultiples n | otherwise = show n ++ " is a beautiful number" 123 | -} 124 | 125 | data ClientR = GovOrgR { clientRName :: String } 126 | | CompanyR { clientRName :: String 127 | , companyId :: Integer 128 | , person :: PersonR 129 | , duty :: String } 130 | | IndividualR { person :: PersonR } 131 | deriving Show 132 | 133 | data PersonR = PersonR { firstName :: String 134 | , lastName :: String 135 | } deriving Show 136 | 137 | greet :: ClientR -> String 138 | greet IndividualR { person = PersonR { .. } } = "Hi, " ++ firstName 139 | greet CompanyR { .. } = "Hello, " ++ clientRName 140 | greet GovOrgR { } = "Welcome" 141 | 142 | nameInCapitals :: PersonR -> PersonR 143 | nameInCapitals p@(PersonR { firstName = initial:rest }) = 144 | let newName = (toUpper initial):rest 145 | in p { firstName = newName } 146 | nameInCapitals p@(PersonR { firstName = "" }) = p -------------------------------------------------------------------------------- /chapter2/src/Chapter2/DefaultValues.hs: -------------------------------------------------------------------------------- 1 | module Chapter2.DefaultValues where 2 | 3 | -- Information for a connection 4 | -- * URL to connect to 5 | -- * Connection type: TCP or UDP 6 | -- * Connection speed 7 | -- * Whether to use a proxy 8 | -- * Whether to use caching 9 | -- * Whether to use keep-alive 10 | -- * Time out 11 | data ConnType = TCP | UDP 12 | data UseProxy = NoProxy | Proxy String 13 | data TimeOut = NoTimeOut | TimeOut Integer 14 | 15 | data Connection = Connection -- Just a placeholder 16 | deriving Show 17 | 18 | connect :: String -> ConnType -> Integer -> UseProxy -> Bool -> Bool -> TimeOut -> Connection 19 | connect _ _ _ _ _ _ _ = undefined 20 | 21 | connectUrl :: String -> Connection 22 | connectUrl u = connect u TCP 0 NoProxy False False NoTimeOut 23 | 24 | data ConnOptions = ConnOptions { connType :: ConnType 25 | , connSpeed :: Integer 26 | , connProxy :: UseProxy 27 | , connCaching :: Bool 28 | , connKeepAlive :: Bool 29 | , connTimeOut :: TimeOut 30 | } 31 | 32 | connect' :: String -> ConnOptions -> Connection 33 | connect' _ _ = undefined 34 | 35 | connDefault :: ConnOptions 36 | connDefault = ConnOptions TCP 0 NoProxy False False NoTimeOut -------------------------------------------------------------------------------- /chapter2/src/Chapter2/Section2/Example.hs: -------------------------------------------------------------------------------- 1 | module Chapter2.Section2.Example where 2 | 3 | -------------------------------------------------------------------------------- /chapter2/src/Chapter2/SimpleFunctions.hs: -------------------------------------------------------------------------------- 1 | module Chapter2.SimpleFunctions where 2 | 3 | firstOrEmpty :: [[Char]] -> [Char] 4 | firstOrEmpty lst = if not (null lst) then head lst else "empty" 5 | 6 | (+++) :: [a] -> [a] -> [a] 7 | lst1 +++ lst2 = if null lst1 {- check emptyness -} 8 | then lst2 -- base case 9 | else (head lst1) : (tail lst1 +++ lst2) 10 | 11 | reverse2 :: [a] -> [a] 12 | reverse2 list = if null list 13 | then [] 14 | else reverse2 (tail list) +++ [head list] 15 | 16 | {- 17 | maxmin list = if null (tail list) 18 | then (head list, head list) 19 | else ( if (head list) > fst (maxmin (tail list)) 20 | then head list 21 | else fst (maxmin (tail list)) 22 | , if (head list) < snd (maxmin (tail list)) 23 | then head list 24 | else snd (maxmin (tail list)) 25 | ) 26 | -} 27 | 28 | maxmin list = let h = head list 29 | in if null (tail list) 30 | then (h, h) 31 | else ( if h > t_max then h else t_max 32 | , if h < t_min then h else t_min ) 33 | where t = maxmin (tail list) 34 | t_max = fst t 35 | t_min = snd t 36 | 37 | -------------------------------------------------------------------------------- /chapter3/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter3/chapter3.cabal: -------------------------------------------------------------------------------- 1 | name: chapter3 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: base >= 4 10 | ghc-options: -Wall 11 | exposed-modules: Chapter3.ParamPoly 12 | other-modules: 13 | Chapter3.FnsParams, 14 | Chapter3.MoreModules, 15 | Chapter3.Lists, 16 | Chapter3.Comprehensions, 17 | Chapter3.Origami 18 | 19 | -------------------------------------------------------------------------------- /chapter3/src/Chapter3/Comprehensions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TransformListComp, RecordWildCards, ParallelListComp #-} 2 | 3 | module Chapter3.Comprehensions where 4 | 5 | import Chapter3.ParamPoly 6 | import Chapter3.Lists 7 | 8 | import Data.List 9 | import Data.Char 10 | 11 | import GHC.Exts 12 | 13 | companyAnalytics :: [Client a] -> [(String, [(Person, String)])] 14 | companyAnalytics clients = [ (the clientName, zip person duty) 15 | | client@(Company { .. }) <- clients 16 | , then sortWith by duty 17 | , then group by clientName using groupWith 18 | , then sortWith by length client 19 | ] -------------------------------------------------------------------------------- /chapter3/src/Chapter3/FnsParams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Chapter3.FnsParams where 4 | 5 | map' :: (a -> b) -> [a] -> [b] 6 | map' _ [] = [] 7 | map' f (x:xs) = (f x) : (map f xs) 8 | 9 | apply3f2 :: (Integer -> Integer) -> Integer -> Integer 10 | apply3f2 f x = 3 * f (x + 2) 11 | 12 | equalTuples :: [(Integer,Integer)] -> [Bool] 13 | equalTuples t = map (\(x,y) -> x == y) t 14 | 15 | sayHello :: [String] -> [String] 16 | sayHello names = map (\name -> case name of 17 | "Alejandro" -> "Hello, writer" 18 | _ -> "Welcome, " ++ name 19 | ) names 20 | 21 | sayHello' :: [String] -> [String] 22 | sayHello' names = map (\case "Alejandro" -> "Hello, writer" 23 | name -> "Welcome, " ++ name 24 | ) names 25 | 26 | multiplyByN :: Integer -> (Integer -> Integer) 27 | multiplyByN n = \x -> n*x 28 | 29 | duplicateOdds :: [Integer] -> [Integer] 30 | duplicateOdds list = map (*2) $ filter odd list 31 | 32 | duplicateOdds' :: [Integer] -> [Integer] 33 | duplicateOdds' = map (*2) . filter odd 34 | 35 | --uncurry :: (a -> b -> c) -> (a,b) -> c 36 | --uncurry f = \(x,y) -> f x y 37 | 38 | --curry :: ((a,b) -> c) -> a -> b -> c 39 | --curry f = \x y -> f (x,y) 40 | 41 | (***) :: (a -> b) -> (c -> d) -> ((a,c) -> (b,d)) 42 | f *** g = \(x,y) -> (f x, g y) 43 | 44 | duplicate :: a -> (a,a) 45 | duplicate x = (x,x) 46 | 47 | formula1 :: Integer -> Integer 48 | formula1 = uncurry (+) . ( ((*7) . (+2)) *** (*3) ) . duplicate 49 | 50 | maximum' :: [Integer] -> Integer 51 | maximum' = foldr1 max 52 | -------------------------------------------------------------------------------- /chapter3/src/Chapter3/Lists.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} 2 | 3 | module Chapter3.Lists where 4 | 5 | import Data.Function (on) 6 | import Data.List 7 | import Data.Ord 8 | import Chapter3.ParamPoly 9 | 10 | data InfNumber a = MinusInfinity 11 | | Number a 12 | | PlusInfinity 13 | deriving Show 14 | 15 | infMax MinusInfinity x = x 16 | infMax x MinusInfinity = x 17 | infMax PlusInfinity _ = PlusInfinity 18 | infMax _ PlusInfinity = PlusInfinity 19 | infMax (Number a) (Number b) = Number (max a b) 20 | 21 | maximum' :: Ord t => [t] -> InfNumber t 22 | maximum' = foldr (\x y -> infMax (Number x) y) MinusInfinity 23 | 24 | maximum'' :: Ord t => [t] -> t 25 | maximum'' = foldr1 max 26 | 27 | bothFilters :: (a -> Bool) -> [a] -> ([a],[a]) 28 | bothFilters p list = (filter p list, filter (not . p) list) 29 | 30 | skipUntilGov :: [Client a] -> [Client a] 31 | skipUntilGov = dropWhile (\case { GovOrg {} -> False ; _ -> True }) 32 | 33 | isIndividual :: Client a -> Bool 34 | isIndividual (Individual {}) = True 35 | isIndividual _ = False 36 | 37 | checkIndividualAnalytics :: [Client a] -> (Bool, Bool) 38 | checkIndividualAnalytics cs = (any isIndividual cs, not $ all isIndividual cs) 39 | 40 | compareClient :: Client a -> Client a -> Ordering 41 | compareClient (Individual{person = p1}) (Individual{person = p2}) 42 | = compare (firstName p1) (firstName p2) 43 | compareClient (Individual {}) _ = GT 44 | compareClient _ (Individual {}) = LT 45 | compareClient c1 c2 = compare (clientName c1) (clientName c2) 46 | 47 | listOfClients :: [Client Int] 48 | -- listOfClients = [ Individual 2 (Person "James" "Joyce") 49 | -- , GovOrg 3 "NATO" 50 | -- , Company 4 "My Inc." (Person "Frank" "Kakfa") "Boss" 51 | -- , Individual 5 (Person "Albert" "Einstein") 52 | -- ] 53 | listOfClients = [ Individual 2 (Person "H. G." "Wells") 54 | , GovOrg 3 "NTTF" -- National Time Travel Foundation 55 | , Company 4 "Wormhole Inc." (Person "Karl" "Schwarzschild") "Physicist" 56 | , Individual 5 (Person "Doctor" "") 57 | , Individual 6 (Person "Sarah" "Jane") 58 | ] 59 | 60 | enum :: Int -> Int -> [Int] 61 | enum a b | a > b = [] 62 | enum a b = a : enum (a+1) b 63 | 64 | withPositions :: [a] -> [(Int,a)] 65 | withPositions list = zip (enum 1 $ length list) list 66 | 67 | companyDutiesAnalytics :: [Client a] -> [String] 68 | companyDutiesAnalytics = map (duty . head) . 69 | sortBy (flip (compare `on` length)) . 70 | groupBy ((==) `on` duty) . 71 | filter isCompany 72 | where isCompany (Company {}) = True 73 | isCompany _ = False -------------------------------------------------------------------------------- /chapter3/src/Chapter3/MoreModules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Chapter3.MoreModules(Range(),range,r,prettyRange) where 4 | 5 | import qualified Data.List as L 6 | 7 | filterAndReverse :: (a -> Bool) -> [a] -> [a] 8 | filterAndReverse f = L.reverse . L.filter f 9 | 10 | permutationsStartingWith :: Char -> String -> [String] 11 | permutationsStartingWith letter = L.filter (\l -> head l == letter) . L.permutations 12 | 13 | data Range = Range Integer Integer deriving Show 14 | 15 | range :: Integer -> Integer -> Range 16 | range a b = if a <= b then Range a b else error "a must be <= b" 17 | 18 | data RangeObs = R Integer Integer deriving Show 19 | 20 | r :: Range -> RangeObs 21 | r (Range a b) = R a b 22 | 23 | prettyRange :: Range -> String 24 | prettyRange rng = case rng of 25 | (r -> R a b) -> "[" ++ show a ++ "," ++ show b ++ "]" -------------------------------------------------------------------------------- /chapter3/src/Chapter3/Origami.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Chapter3.Origami where 4 | 5 | import Data.List 6 | 7 | filterAsFold :: (a -> Bool) -> [a] -> [a] 8 | filterAsFold p = foldr (\x l -> if p x then x : l else l) [] 9 | 10 | mapAsFold :: (a -> b) -> [a] -> [b] 11 | mapAsFold f = foldr (\x l -> f x : l) [] 12 | 13 | enumUnfold :: Int -> Int -> [Int] 14 | enumUnfold n m = unfoldr (\x -> if x > m then Nothing else Just (x, x+1)) n 15 | 16 | minSort :: Ord a => [a] -> [a] 17 | minSort = unfoldr (\case [] -> Nothing 18 | xs -> Just (m, delete m xs) where m = minimum xs) 19 | 20 | foldr2 :: (Maybe (a,b) -> b) -> [a] -> b 21 | foldr2 f [] = f Nothing 22 | foldr2 f (x:xs) = f $ Just (x, foldr2 f xs) 23 | 24 | mapAsFold2 :: (a -> b) -> [a] -> [b] 25 | mapAsFold2 f = foldr2 (\case Nothing -> [] 26 | Just (x,xs) -> f x : xs) -------------------------------------------------------------------------------- /chapter3/src/Chapter3/ParamPoly.hs: -------------------------------------------------------------------------------- 1 | module Chapter3.ParamPoly where 2 | 3 | maybeString :: Maybe t -> String 4 | maybeString (Just _) = "Just" 5 | maybeString Nothing = "Nothing" 6 | 7 | swapTriple (x,y,z) = (y,z,x) 8 | 9 | duplicate x = (x,x) 10 | 11 | nothing _ = Nothing 12 | 13 | index [] = [] 14 | index [x] = [(0,x)] 15 | index (x:xs) = let indexed@((n,_):_) = index xs 16 | in (n+1,x):indexed 17 | 18 | maybeA [] = 'a' 19 | 20 | data Client i = GovOrg { clientId :: i, clientName :: String } 21 | | Company { clientId :: i, clientName :: String 22 | , person :: Person, duty :: String } 23 | | Individual { clientId :: i, person :: Person } 24 | deriving Show 25 | 26 | data Person = Person { firstName :: String, lastName :: String } 27 | deriving Show 28 | 29 | data Triple a b c = Triple a b c 30 | 31 | data SamePair a = SamePair a a -------------------------------------------------------------------------------- /chapter4/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter4/chapter4.cabal: -------------------------------------------------------------------------------- 1 | name: chapter4 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: Alejandro Serrano 6 | synopsis: Package for chapter 4 7 | maintainer: Alejandro Serrano <my@email.com> 8 | homepage: http://haskell.great.is 9 | 10 | library 11 | hs-source-dirs: src 12 | build-depends: 13 | base >= 4, 14 | containers >= 0.5 && < 0.6 15 | ghc-options: -Wall 16 | exposed-modules: Chapter4.Containers 17 | other-modules: 18 | Chapter4.TypeClasses, 19 | Chapter4.MinimumPrice, 20 | Chapter4.FunctorsFoldables 21 | 22 | -------------------------------------------------------------------------------- /chapter4/src/Chapter4/Containers.hs: -------------------------------------------------------------------------------- 1 | module Chapter4.Containers where 2 | 3 | import qualified Data.Map as M 4 | import qualified Data.Set as S 5 | import Data.Tree 6 | import qualified Data.Foldable hiding (concat) 7 | import Data.Graph 8 | 9 | set1 :: S.Set String 10 | set1 = S.insert "welcome" $ S.singleton "hello" 11 | 12 | set2 :: S.Set String 13 | set2 = S.fromList ["hello","bye"] 14 | 15 | setOps :: (S.Set String, Bool, S.Set Int) 16 | setOps = ( set1 `S.intersection` set2 17 | , "welcome" `S.member` set1 18 | , S.map length set2 ) 19 | 20 | preOrder :: (a -> b) -> Tree a -> [b] 21 | preOrder f (Node v subtrees) = 22 | let subtreesTraversed = concat $ map (preOrder f) subtrees 23 | in f v : subtreesTraversed 24 | 25 | pictureTree :: Tree Int 26 | pictureTree = Node 1 [ Node 2 [ Node 3 [] 27 | , Node 4 [] 28 | , Node 5 [] ] 29 | , Node 6 [] ] 30 | 31 | 32 | timeMachineGraph :: [(String, String, [String])] 33 | timeMachineGraph = 34 | [("wood","wood",["walls"]), ("plastic","plastic",["walls","wheels"]) 35 | ,("aluminum","aluminum",["wheels","door"]),("walls","walls",["done"]) 36 | ,("wheels","wheels",["done"]),("door","door",["done"]),("done","done",[])] 37 | 38 | timeMachinePrecedence :: (Graph, Vertex -> (String,String,[String]), String -> Maybe Vertex) 39 | timeMachinePrecedence = graphFromEdges timeMachineGraph 40 | 41 | timeMachineTravel :: Graph 42 | timeMachineTravel = buildG (103,2013) 43 | [(1302,1614),(1614,1302),(1302,2013),(2013,1302),(1614,2013) 44 | ,(2013,1408),(1408,1993),(1408,917),(1993,917),(907,103),(103,917)] -------------------------------------------------------------------------------- /chapter4/src/Chapter4/FunctorsFoldables.hs: -------------------------------------------------------------------------------- 1 | module Chapter4.FunctorsFoldables where 2 | 3 | import Chapter4.MinimumPrice 4 | 5 | import qualified Data.Map as M 6 | import qualified Data.Tree as T 7 | 8 | modifyTravelGuidePrice :: Double -> [TravelGuide] -> [TravelGuide] 9 | modifyTravelGuidePrice m = map (\tg -> tg { price = m * price tg }) 10 | 11 | modifyTravelGuidePriceMap :: Double -> M.Map a TravelGuide -> M.Map a TravelGuide 12 | modifyTravelGuidePriceMap m = M.map (\tg -> tg { price = m * price tg }) 13 | 14 | modifyTravelGuidePriceTree :: Double -> T.Tree TravelGuide -> T.Tree TravelGuide 15 | modifyTravelGuidePriceTree m = fmap (\tg -> tg { price = m * price tg }) 16 | 17 | modifyTravelGuidePrice' :: Functor f => Double -> f TravelGuide -> f TravelGuide 18 | modifyTravelGuidePrice' m = fmap (\tg -> tg { price = m * price tg }) 19 | 20 | {- 21 | instance Functor ((->) r) where 22 | fmap f g = f . g 23 | -} -------------------------------------------------------------------------------- /chapter4/src/Chapter4/MinimumPrice.hs: -------------------------------------------------------------------------------- 1 | module Chapter4.MinimumPrice where 2 | 3 | import Data.Monoid (Monoid, (<>), mempty, mappend) 4 | 5 | data TravelGuide = TravelGuide { title :: String, authors :: [String], price :: Double } 6 | deriving (Show, Eq, Ord) 7 | 8 | -- instance Ord TravelGuide where 9 | -- (TravelGuide t1 a1 p1) <= (TravelGuide t2 a2 p2) = 10 | -- p1 < p2 || (p1 == p2 && (t1 < t2 || (t1 == t2 && a1 <= a2))) 11 | 12 | data BinaryTree = Node TravelGuide BinaryTree BinaryTree 13 | | Leaf 14 | deriving Show 15 | 16 | treeFind :: TravelGuide -> BinaryTree -> Maybe TravelGuide 17 | treeFind t (Node v l r) = case compare t v of 18 | EQ -> Just v 19 | LT -> treeFind t l 20 | GT -> treeFind t r 21 | treeFind _ Leaf = Nothing 22 | 23 | treeEmpty :: BinaryTree 24 | treeEmpty = Leaf 25 | 26 | treeInsert :: TravelGuide -> BinaryTree -> BinaryTree 27 | treeInsert t n@(Node v l r) = case compare t v of 28 | EQ -> n 29 | LT -> Node v (treeInsert t l) r 30 | GT -> Node v l (treeInsert t r) 31 | treeInsert t Leaf = Node t Leaf Leaf 32 | 33 | data BinaryTree2 a = Node2 a (BinaryTree2 a) (BinaryTree2 a) 34 | | Leaf2 35 | deriving Show 36 | 37 | treeFind2 :: Ord a => a -> BinaryTree2 a -> Maybe a 38 | treeFind2 t (Node2 v l r) = case compare t v of 39 | EQ -> Just v 40 | LT -> treeFind2 t l 41 | GT -> treeFind2 t r 42 | treeFind2 _ Leaf2 = Nothing 43 | 44 | -- data TravelGuidePrice = TravelGuidePrice TravelGuide 45 | 46 | newtype TravelGuidePrice = TravelGuidePrice TravelGuide 47 | deriving Eq 48 | 49 | instance Ord TravelGuidePrice where 50 | (TravelGuidePrice (TravelGuide t1 a1 p1)) <= (TravelGuidePrice (TravelGuide t2 a2 p2)) = 51 | p1 < p2 || (p1 == p2 && (t1 < t2 || (t1 == t2 && a1 <= a2))) 52 | 53 | data BinaryTree3 v c = Node3 v c (BinaryTree3 v c) (BinaryTree3 v c) 54 | | Leaf3 55 | deriving (Show, Eq, Ord) 56 | 57 | treeInsert3 :: (Ord v, Ord c) => v -> c -> BinaryTree3 v c -> BinaryTree3 v c 58 | treeInsert3 v c (Node3 v2 c2 l r) = case compare v v2 of 59 | EQ -> Node3 v2 c2 l r 60 | LT -> Node3 v2 (min c c2) (treeInsert3 v c l) r 61 | GT -> Node3 v2 (min c c2) l (treeInsert3 v c r) 62 | treeInsert3 v c Leaf3 = Node3 v c Leaf3 Leaf3 63 | 64 | treeInsert4 :: (Ord v, Monoid c) => v -> c -> BinaryTree3 v c -> BinaryTree3 v c 65 | treeInsert4 v c (Node3 v2 c2 l r) = case compare v v2 of 66 | EQ -> Node3 v2 c2 l r 67 | LT -> let newLeft = (treeInsert4 v c l) 68 | newCache = c2 <> cached newLeft <> cached r 69 | in Node3 v2 newCache newLeft r 70 | GT -> let newRight = (treeInsert4 v c r) 71 | newCache = c2 <> cached l <> cached newRight 72 | in Node3 v2 newCache l newRight 73 | treeInsert4 v c Leaf3 = Node3 v c Leaf3 Leaf3 74 | 75 | cached :: Monoid c => BinaryTree3 v c -> c 76 | cached (Node3 _ c _ _) = c 77 | cached Leaf3 = mempty 78 | 79 | newtype Min = Min Double deriving Show 80 | 81 | instance Monoid Min where 82 | mempty = Min infinity where infinity = 1/0 83 | mappend (Min x) (Min y) = Min $ min x y -------------------------------------------------------------------------------- /chapter4/src/Chapter4/TypeClasses.hs: -------------------------------------------------------------------------------- 1 | module Chapter4.TypeClasses where 2 | 3 | class Nameable n where 4 | name :: n -> String 5 | 6 | initial :: Nameable n => n -> Char 7 | initial n = head (name n) 8 | 9 | data Client i = GovOrg { clientId :: i, clientName :: String } 10 | | Company { clientId :: i, clientName :: String 11 | , person :: Person, duty :: String } 12 | | Individual { clientId :: i, person :: Person } 13 | deriving Show 14 | 15 | data Person = Person { firstName :: String, lastName :: String } 16 | deriving (Show, Read) 17 | 18 | instance Nameable (Client i) where 19 | name Individual { person = Person { firstName = f, lastName = n } } 20 | = f ++ " " ++ n 21 | name c = clientName c 22 | 23 | data Complex = C Double Double deriving (Show, Eq) 24 | 25 | instance Num Complex where 26 | (C a1 b1) + (C a2 b2) = C (a1 + a2) (b1 + b2) 27 | (C a1 b1) - (C a2 b2) = C (a1 - a2) (b1 - b2) 28 | (C a1 b1) * (C a2 b2) = C (a1*a2-b1*b2) (a1*b2+b1*a2) 29 | negate (C a b) = C (negate a) (negate b) 30 | fromInteger n = C (fromInteger n) 0 31 | abs (C a b) = C (sqrt $ a*a+b*b) 0 32 | signum c@(C a b) = let C n _ = abs c in C (a / n) (b / n) -------------------------------------------------------------------------------- /chapter5/.gitignore: -------------------------------------------------------------------------------- 1 | /profiling-example.aux 2 | /profiling-example.eps 3 | /profiling-example.pdf 4 | /profiling-example.prof 5 | /profiling-example.ps 6 | -------------------------------------------------------------------------------- /chapter5/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter5/chapter5.cabal: -------------------------------------------------------------------------------- 1 | name: chapter5 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: 10 | base >= 4, 11 | deepseq 12 | ghc-options: -Wall 13 | exposed-modules: Chapter5.Infinite 14 | other-modules: 15 | Chapter5.Problems, 16 | Chapter5.Annotations 17 | 18 | executable profiling-example 19 | build-depends: base >= 4 20 | hs-source-dirs: src 21 | ghc-options: -Wall -prof -fprof-auto -rtsopts 22 | main-is: Main.hs 23 | other-modules: Chapter5.Annotations 24 | 25 | -------------------------------------------------------------------------------- /chapter5/src/Chapter5/Annotations.hs: -------------------------------------------------------------------------------- 1 | module Chapter5.Annotations where 2 | 3 | import Control.DeepSeq 4 | 5 | data Client = GovOrg {-# UNPACK #-} !Int String 6 | | Company {-# UNPACK #-} !Int String Person String 7 | | Individual {-# UNPACK #-} !Int Person 8 | deriving Show 9 | 10 | instance NFData Client where 11 | rnf (GovOrg i n) = i `deepseq` n `deepseq` () 12 | rnf (Company i n (Person f l) r) = i `deepseq` n `deepseq` f `deepseq` l 13 | `deepseq` r `deepseq` () 14 | rnf (Individual i (Person f l)) = i `deepseq` f `deepseq` l `deepseq` () 15 | 16 | data Person = Person { firstName :: String, lastName :: String } 17 | deriving Show -------------------------------------------------------------------------------- /chapter5/src/Chapter5/Infinite.hs: -------------------------------------------------------------------------------- 1 | module Chapter5.Infinite where 2 | 3 | -- import Data.List 4 | 5 | data TimeMachine = TM { manufacturer :: String, year :: Integer } deriving (Eq, Show) 6 | 7 | timeMachinesFrom :: String -> Integer -> [TimeMachine] 8 | timeMachinesFrom mf y = TM mf y : timeMachinesFrom mf (y+1) 9 | 10 | timelyIncMachines :: [TimeMachine] 11 | timelyIncMachines = timeMachinesFrom "Timely Inc." 100 12 | 13 | allNumbers :: [Integer] 14 | allNumbers = allNumbersFrom 1 15 | where allNumbersFrom n = n : allNumbersFrom (n+1) 16 | 17 | fibonacci :: [Integer] 18 | fibonacci = 0 : 1 : zipWith (+) fibonacci (tail fibonacci) 19 | 20 | infinite2020Machines :: [TimeMachine] 21 | infinite2020Machines = TM "Timely Inc." 2020 : infinite2020Machines 22 | 23 | specialOffer :: [TimeMachine] 24 | specialOffer = cycle [TM m 2005, TM m 1994, TM m 908] 25 | where m = "Timely Inc." -------------------------------------------------------------------------------- /chapter5/src/Chapter5/Problems.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Chapter5.Problems where 4 | 5 | import Chapter5.Infinite 6 | 7 | sumForce :: [Integer] -> Integer 8 | sumForce xs = sumForce' xs 0 9 | where sumForce' [] z = z 10 | sumForce' (y:ys) z = sumForce' ys $! (z+y) 11 | 12 | sumYears :: [TimeMachine] -> Integer 13 | sumYears xs = sumYears' xs 0 14 | where sumYears' [] z = z 15 | sumYears' (TM _ !y :ys) z = let !s = z + y in sumYears' ys s -------------------------------------------------------------------------------- /chapter5/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | 5 | main :: IO () 6 | main = putStrLn $ show result 7 | 8 | result :: Integer 9 | result = foldl' (*) 1 [1 .. 100000] -------------------------------------------------------------------------------- /chapter6/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter6/chapter6.cabal: -------------------------------------------------------------------------------- 1 | name: chapter6 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | library 8 | hs-source-dirs: src 9 | build-depends: 10 | base >= 4, 11 | data-default, 12 | containers, 13 | lens, 14 | mtl 15 | ghc-options: -Wall 16 | exposed-modules: 17 | Chapter6.CombinatorsState, 18 | Chapter6.IncompleteData, 19 | Chapter6.KMeans, 20 | Chapter6.KMeansLens, 21 | Chapter6.KMeansRWS, 22 | Chapter6.KMeansState, 23 | Chapter6.KMeansStateLens, 24 | Chapter6.Lens, 25 | Chapter6.Lens2, 26 | Chapter6.StateLenses, 27 | Chapter6.Vector 28 | other-modules: 29 | Chapter6.ReaderWriter, 30 | Chapter6.STRef 31 | 32 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/CombinatorsState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, LiberalTypeSynonyms #-} 2 | 3 | module Chapter6.CombinatorsState where 4 | 5 | import Chapter6.Vector 6 | 7 | import Data.Default 8 | import Data.List 9 | import qualified Data.Map as M 10 | 11 | type State s a = s -> (a, s) 12 | 13 | thenDo :: State s a -> (a -> State s b) -> State s b 14 | -- thenDo :: (s -> (a,s)) -> (a -> s -> (b,s)) -> s -> (b,s) 15 | --thenDo f g s = let (resultOfF, stateAfterF) = f s 16 | -- in g resultOfF stateAfterF 17 | thenDo f g = uncurry g . f 18 | 19 | data KMeansState v = KMeansState { centroids :: [v] 20 | , threshold :: Double 21 | , steps :: Int } 22 | 23 | newCentroids :: (Vector v, Vectorizable e v) => M.Map v [e] -> [v] 24 | newCentroids = M.elems . fmap (centroid . map toVector) 25 | 26 | clusterAssignments :: (Vector v, Vectorizable e v) => [v] -> [e] -> M.Map v [e] 27 | clusterAssignments centrs points = 28 | let initialMap = M.fromList $ zip centrs (repeat []) 29 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 30 | (distance y $ toVector p)) 31 | centrs 32 | in M.adjust (p:) chosenCentroid m) 33 | initialMap points 34 | 35 | kMeans' :: (Vector v, Vectorizable e v) => [e] -> State (KMeansState v) [v] 36 | kMeans' points = 37 | (\s -> (centroids s,s)) `thenDo` (\prevCentrs -> 38 | (\s -> (clusterAssignments prevCentrs points, s)) `thenDo` (\assignments -> 39 | (\s -> (newCentroids assignments, s)) `thenDo` (\newCentrs -> 40 | (\s -> ((), s { centroids = newCentrs })) `thenDo` (\_ -> 41 | (\s -> ((), s { steps = steps s + 1 })) `thenDo` (\_ -> 42 | (\s -> (threshold s, s)) `thenDo` (\t -> 43 | (\s -> (sum $ zipWith distance prevCentrs newCentrs, s)) `thenDo` (\err -> 44 | if err < t then (\s -> (newCentrs, s)) else (kMeans' points) ))))))) 45 | 46 | initialState :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> KMeansState v 47 | initialState i k pts t = KMeansState (i k pts) t 0 48 | 49 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 50 | kMeans i k pts t = fst $ kMeans' pts (initialState i k pts t) 51 | 52 | remain :: a -> (s -> (a,s)) 53 | remain x = \s -> (x,s) 54 | 55 | access :: (s -> a) -> (s -> (a,s)) 56 | access f = \s -> (f s, s) 57 | 58 | modify :: (s -> s) -> (s -> ((), s)) 59 | modify f = \s -> ((), f s) 60 | 61 | kMeans2 :: (Vector v, Vectorizable e v) => [e] -> State (KMeansState v) [v] 62 | kMeans2 points = 63 | access centroids `thenDo` (\prevCentrs -> 64 | remain (clusterAssignments prevCentrs points) `thenDo` (\assignments -> 65 | remain (newCentroids assignments) `thenDo` (\newCentrs -> 66 | modify (\s -> s { centroids = newCentrs }) `thenDo` (\_ -> 67 | modify (\s -> s { steps = steps s + 1 }) `thenDo` (\_ -> 68 | access threshold `thenDo` (\t -> 69 | remain (sum $ zipWith distance prevCentrs newCentrs) `thenDo` (\err -> 70 | if err < t then remain newCentrs else kMeans2 points ))))))) 71 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/IncompleteData.hs: -------------------------------------------------------------------------------- 1 | module Chapter6.IncompleteData where 2 | 3 | import Data.Maybe 4 | 5 | meanPurchase :: Integer -- the client identifier 6 | -> Double -- the mean purchase 7 | meanPurchase clientId = let p = purchasesByClientId clientId 8 | in foldr (+) 0.0 $ catMaybes $ map purchaseValue p 9 | 10 | thenDo :: Maybe a -> (a -> Maybe b) -> Maybe b 11 | thenDo Nothing _ = Nothing 12 | thenDo (Just x) f = f x 13 | 14 | {- 15 | purchaseValue :: Integer -> Maybe Double 16 | purchaseValue purchaseId = 17 | case numberItemsByPurchaseId purchaseId of 18 | Nothing -> Nothing 19 | Just n -> case productIdByPurchaseId purchaseId of 20 | Nothing -> Nothing 21 | Just productId -> case priceByProductId productId of 22 | Nothing -> Nothing 23 | Just price -> Just $ (fromInteger n) * price 24 | -} 25 | 26 | purchaseValue :: Integer -> Maybe Double 27 | purchaseValue purchaseId = 28 | numberItemsByPurchaseId purchaseId `thenDo` (\n -> 29 | productIdByPurchaseId purchaseId `thenDo` (\productId -> 30 | priceByProductId productId `thenDo` (\price -> 31 | Just $ fromInteger n * price ))) 32 | 33 | 34 | purchasesByClientId :: Integer -> [Integer] 35 | purchasesByClientId = error "Unimplemented" 36 | 37 | numberItemsByPurchaseId :: Integer -> Maybe Integer 38 | numberItemsByPurchaseId = error "Unimplemented" 39 | 40 | productIdByPurchaseId :: Integer -> Maybe Integer 41 | productIdByPurchaseId = error "Unimplemented" 42 | 43 | priceByProductId :: Integer -> Maybe Double 44 | priceByProductId = error "Unimplemented" 45 | 46 | purchaseValueWithDo :: Integer -> Maybe Double 47 | purchaseValueWithDo purchaseId = do n <- numberItemsByPurchaseId purchaseId 48 | productId <- productIdByPurchaseId purchaseId 49 | price <- priceByProductId productId 50 | return $ fromInteger n * price 51 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/KMeans.hs: -------------------------------------------------------------------------------- 1 | module Chapter6.KMeans where 2 | 3 | import Chapter6.Vector 4 | 5 | import Data.List 6 | import qualified Data.Map as M 7 | 8 | clusterAssignmentPhase :: (Vector v, Vectorizable e v) => [v] -> [e] -> M.Map v [e] 9 | clusterAssignmentPhase centroids points = 10 | let initialMap = M.fromList $ zip centroids (repeat []) 11 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 12 | (distance y $ toVector p)) 13 | centroids 14 | in M.adjust (p:) chosenCentroid m) 15 | initialMap points 16 | 17 | newCentroidPhase :: (Vector v, Vectorizable e v) => M.Map v [e] -> [(v,v)] 18 | newCentroidPhase = M.toList . fmap (centroid . map toVector) 19 | 20 | shouldStop :: (Vector v) => [(v,v)] -> Double -> Bool 21 | shouldStop centroids threshold = foldr (\(x,y) s -> s + distance x y) 0.0 centroids < threshold 22 | 23 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -- initialization function 24 | -> Int -- number of centroids 25 | -> [e] -- the information 26 | -> Double -- threshold 27 | -> [v] -- final centroids 28 | kMeans i k points = kMeans' (i k points) points 29 | 30 | kMeans' :: (Vector v, Vectorizable e v) => [v] -> [e] -> Double -> [v] 31 | kMeans' centroids points threshold = 32 | let assignments = clusterAssignmentPhase centroids points 33 | oldNewCentroids = newCentroidPhase assignments 34 | newCentroids = map snd oldNewCentroids 35 | in if shouldStop oldNewCentroids threshold 36 | then newCentroids 37 | else kMeans' newCentroids points threshold 38 | 39 | initializeSimple :: Int -> [e] -> [(Double,Double)] 40 | initializeSimple 0 _ = [] 41 | initializeSimple n v = (fromIntegral n, fromIntegral n) : initializeSimple (n-1) v 42 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/KMeansLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter6.KMeansLens (kMeans) where 4 | 5 | import Chapter6.Vector 6 | 7 | import Control.Lens 8 | 9 | import Data.List 10 | import qualified Data.Map as M 11 | 12 | data KMeansState e v = KMeansState { _centroids :: [v], _points :: [e] 13 | , _err :: Double, _threshold :: Double 14 | , _steps :: Int } 15 | 16 | makeLenses ''KMeansState 17 | 18 | initializeState :: (Int -> [e] -> [v]) -> Int -> [e] -> Double -> KMeansState e v 19 | initializeState i n pts t = KMeansState (i n pts) pts (1.0/0.0) t 0 20 | 21 | clusterAssignments :: (Vector v, Vectorizable e v) => KMeansState e v -> M.Map v [e] 22 | clusterAssignments state = 23 | let initialMap = M.fromList $ zip (state^.centroids) (repeat []) 24 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 25 | (distance y $ toVector p)) 26 | (state^.centroids) 27 | in M.adjust (p:) chosenCentroid m) 28 | initialMap (state^.points) 29 | 30 | 31 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 32 | kMeans i n pts t = view centroids $ kMeans' (initializeState i n pts t) 33 | 34 | kMeans' :: (Vector v, Vectorizable e v) => KMeansState e v -> KMeansState e v 35 | kMeans' state = let assignments = clusterAssignments state 36 | state1 = state & centroids.traversed 37 | %~ (\c -> centroid $ fmap toVector $ M.findWithDefault [] c assignments) 38 | state2 = state1 & err .~ sum (zipWith distance (state^.centroids) (state1^.centroids)) 39 | state3 = state2 & steps +~ 1 40 | in if state3^.err < state3^.threshold then state3 else kMeans' state3 41 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/KMeansRWS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Chapter6.KMeansRWS (kMeans) where 4 | 5 | import Chapter6.Vector 6 | 7 | import Control.Monad.RWS 8 | -- import Control.Monad.RWS.Class 9 | 10 | import Data.List 11 | import qualified Data.Map as M 12 | 13 | 14 | newCentroids :: (Vector v, Vectorizable e v) => M.Map v [e] -> [v] 15 | newCentroids = M.elems . fmap (centroid . map toVector) 16 | 17 | clusterAssignments :: (Vector v, Vectorizable e v) => [v] -> [e] -> M.Map v [e] 18 | clusterAssignments centrs points = 19 | let initialMap = M.fromList $ zip centrs (repeat []) 20 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 21 | (distance y $ toVector p)) 22 | centrs 23 | in M.adjust (p:) chosenCentroid m) 24 | initialMap points 25 | 26 | kMeans' :: (Vector v, Vectorizable e v) => [e] -> RWS Double (Sum Int) [v] () 27 | kMeans' points = do prevCentrs <- get 28 | let assignments = clusterAssignments prevCentrs points 29 | newCentrs = newCentroids assignments 30 | put newCentrs 31 | tell (Sum 1) 32 | t <- ask 33 | let err = sum $ zipWith distance prevCentrs newCentrs 34 | unless (err < t) $ kMeans' points 35 | 36 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> ([v], Sum Int) 37 | kMeans i n pts t = execRWS (kMeans' pts) t (i n pts) 38 | 39 | newtype MyWriter m a = MyWriter (a,m) 40 | 41 | instance Monoid m => Monad (MyWriter m) where 42 | return x = MyWriter (x,mempty) 43 | (MyWriter (a,x)) >>= f = let MyWriter (b,y) = f a 44 | in MyWriter (b,x `mappend` y) 45 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/KMeansState.hs: -------------------------------------------------------------------------------- 1 | module Chapter6.KMeansState (kMeans) where 2 | 3 | import Chapter6.Vector 4 | 5 | import Control.Monad.State 6 | 7 | import Data.List 8 | import qualified Data.Map as M 9 | 10 | data KMeansState v = KMeansState { centroids :: [v] 11 | , threshold :: Double 12 | , steps :: Int } 13 | 14 | initializeState :: (Int -> [e] -> [v]) -> Int -> [e] -> Double -> KMeansState v 15 | initializeState i n pts t = KMeansState (i n pts) t 0 16 | 17 | newCentroids :: (Vector v, Vectorizable e v) => M.Map v [e] -> [v] 18 | newCentroids = M.elems . fmap (centroid . map toVector) 19 | 20 | clusterAssignments :: (Vector v, Vectorizable e v) => [v] -> [e] -> M.Map v [e] 21 | clusterAssignments centrs points = 22 | let initialMap = M.fromList $ zip centrs (repeat []) 23 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 24 | (distance y $ toVector p)) 25 | centrs 26 | in M.adjust (p:) chosenCentroid m) 27 | initialMap points 28 | 29 | kMeans' :: (Vector v, Vectorizable e v) => [e] -> State (KMeansState v) [v] 30 | kMeans' points = do prevCentrs <- fmap centroids get 31 | let assignments = clusterAssignments prevCentrs points 32 | newCentrs = newCentroids assignments 33 | modify (\s -> s { centroids = newCentrs }) 34 | modify (\s -> s { steps = steps s + 1 }) 35 | t <- fmap threshold get 36 | let err = sum $ zipWith distance prevCentrs newCentrs 37 | if err < t then return newCentrs else kMeans' points 38 | 39 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 40 | kMeans i n pts t = evalState (kMeans' pts) (initializeState i n pts t) 41 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/KMeansStateLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter6.KMeansStateLens (kMeans, initializeSimple) where 4 | 5 | import Chapter6.Vector 6 | 7 | import Control.Monad.State 8 | 9 | import Control.Lens 10 | 11 | import Data.List 12 | import qualified Data.Map as M 13 | 14 | data KMeansState v = KMeansState { _centroids :: [v] 15 | , _threshold :: Double 16 | , _steps :: Int } 17 | 18 | makeLenses ''KMeansState 19 | 20 | initializeState :: (Int -> [e] -> [v]) -> Int -> [e] -> Double -> KMeansState v 21 | initializeState i n pts t = KMeansState (i n pts) t 0 22 | 23 | newCentroids :: (Vector v, Vectorizable e v) => M.Map v [e] -> [v] 24 | newCentroids = M.elems . fmap (centroid . map toVector) 25 | 26 | clusterAssignments :: (Vector v, Vectorizable e v) => [v] -> [e] -> M.Map v [e] 27 | clusterAssignments centrs points = 28 | let initialMap = M.fromList $ zip centrs (repeat []) 29 | in foldr (\p m -> let chosenCentroid = minimumBy (\x y -> compare (distance x $ toVector p) 30 | (distance y $ toVector p)) 31 | centrs 32 | in M.adjust (p:) chosenCentroid m) 33 | initialMap points 34 | 35 | kMeans' :: (Vector v, Vectorizable e v) => [e] -> State (KMeansState v) [v] 36 | kMeans' points = do prevCentrs <- use centroids 37 | let assignments = clusterAssignments prevCentrs points 38 | newCentrs = newCentroids assignments 39 | centroids .= newCentrs 40 | steps += 1 41 | let err = sum $ zipWith distance prevCentrs newCentrs 42 | t <- use threshold 43 | if err < t then return newCentrs else kMeans' points 44 | 45 | kMeans :: (Vector v, Vectorizable e v) => (Int -> [e] -> [v]) -> Int -> [e] -> Double -> [v] 46 | kMeans i n pts t = evalState (kMeans' pts) (initializeState i n pts t) 47 | 48 | initializeSimple :: Int -> [e] -> [(Double,Double)] 49 | initializeSimple 0 _ = [] 50 | initializeSimple n v = (fromIntegral n, fromIntegral n) : initializeSimple (n-1) v 51 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Chapter6.Lens where 4 | 5 | import Control.Lens 6 | 7 | data Client i = GovOrg i String 8 | | Company i String Person String 9 | | Individual i Person 10 | deriving Show 11 | 12 | data Person = Person String String 13 | deriving Show 14 | 15 | firstName :: Simple Lens Person String 16 | firstName = lens (\(Person f _) -> f) 17 | (\(Person _ l) newF -> Person newF l) 18 | 19 | lastName :: Simple Lens Person String 20 | lastName = lens (\(Person _ l) -> l) 21 | (\(Person f _) newL -> Person f newL) 22 | 23 | identifier :: Lens (Client i) (Client j) i j 24 | identifier = lens (\case (GovOrg i _) -> i 25 | (Company i _ _ _) -> i 26 | (Individual i _) -> i) 27 | (\client newId -> case client of 28 | GovOrg _ n -> GovOrg newId n 29 | Company _ n p r -> Company newId n p r 30 | Individual _ p -> Individual newId p) 31 | 32 | fullName' :: Simple Lens Person String 33 | fullName' = lens (\(Person f l) -> f ++ " " ++ l) 34 | (\_ newFullName -> case words newFullName of 35 | f:l:_ -> Person f l 36 | _ -> error "Incorrect name") -------------------------------------------------------------------------------- /chapter6/src/Chapter6/Lens2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter6.Lens2 where 4 | 5 | import Control.Lens 6 | -- import Control.Lens.Cons 7 | 8 | -- import Data.Char 9 | 10 | data Client i = GovOrg { _identifier :: i, _name :: String } 11 | | Company { _identifier :: i, _name :: String 12 | , _person :: Person, _duty :: String } 13 | | Individual { _identifier :: i, _person :: Person } 14 | deriving Show 15 | 16 | data Person = Person { _firstName :: String, _lastName :: String } 17 | deriving Show 18 | 19 | makeLenses ''Client 20 | makeLenses ''Person 21 | 22 | fullName :: Simple Lens Person String 23 | fullName = lens (\(Person f l) -> f ++ " " ++ l) 24 | (\_ newFullName -> case words newFullName of 25 | f:l:_ -> Person f l 26 | _ -> error "Incorrect name") -------------------------------------------------------------------------------- /chapter6/src/Chapter6/ReaderWriter.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter6.ReaderWriter where 4 | 5 | import Control.Monad.Reader 6 | import Control.Monad.Writer 7 | -- import Control.Lens 8 | 9 | import Data.Char 10 | 11 | import Chapter6.Lens2 12 | import Chapter6.Vector 13 | import Chapter6.KMeans 14 | 15 | data Settings e v = Settings { i :: Int -> [e] -> [v], k :: Int, th :: Double, user :: Person } 16 | 17 | kMeansMain :: (Vector v, Vectorizable e v) => [e] -> Reader (Settings e v) [v] 18 | kMeansMain points = do i' <- asks i 19 | k' <- asks k 20 | t' <- asks th 21 | return $ kMeans i' k' points t' 22 | 23 | saveKMeans :: Vector v => [v] -> Reader (Settings e v) () 24 | saveKMeans centroids = 25 | do u <- asks user 26 | printString $ "Saving for user: " ++ show u 27 | local (\s -> let Person f l = user s 28 | in s { user = Person (map toUpper f) l }) $ 29 | do u' <- asks user 30 | saveDatabase centroids u' 31 | return () 32 | 33 | compareClusters :: (Vector v, Vectorizable e v) => [e] -> Reader (Settings e v) ([v], [v]) 34 | compareClusters points = do c1 <- kMeansMain points 35 | c2 <- local (\s -> s { k = k s + 1 }) 36 | (kMeansMain points) 37 | return (c1, c2) 38 | 39 | printString :: String -> Reader (Settings e v) () 40 | printString _ = return () 41 | 42 | saveDatabase :: Vector v => [v] -> Person -> Reader (Settings e v) () 43 | saveDatabase _ _ = return () 44 | 45 | readInformation :: Writer String [String] 46 | readInformation = return [] 47 | 48 | computeValue :: [String] -> Writer String () 49 | computeValue _ = return () 50 | 51 | accessDatabase :: Writer String () 52 | accessDatabase = do tell "Start database access" 53 | info <- readInformation 54 | computeValue info 55 | tell "Finish database access" 56 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/STRef.hs: -------------------------------------------------------------------------------- 1 | module Chapter6.STRef where 2 | 3 | import Control.Monad.ST 4 | import Data.STRef 5 | 6 | listLength :: [a] -> Integer 7 | listLength list = runST $ do l <- newSTRef 0 8 | traverseList list l 9 | readSTRef l 10 | where traverseList [] _ = return () 11 | traverseList (_:xs) l = do modifySTRef' l (+1) 12 | traverseList xs l 13 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/StateLenses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Chapter6.StateLenses where 4 | 5 | import Chapter6.Lens2 6 | 7 | import Control.Lens 8 | import Control.Monad.State 9 | import Data.Char 10 | 11 | data ExampleState = ExampleState { _increment :: Int, _clients :: [Client Int] } 12 | deriving Show 13 | makeLenses ''ExampleState 14 | 15 | zoomExample :: State ExampleState () 16 | zoomExample = do n <- use increment 17 | zoom (clients.traversed) $ do 18 | identifier += n 19 | person.fullName %= map toUpper 20 | -------------------------------------------------------------------------------- /chapter6/src/Chapter6/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module Chapter6.Vector where 4 | 5 | import Data.Default 6 | 7 | 8 | class (Default v, Ord v) => Vector v where 9 | distance :: v -> v -> Double 10 | centroid :: [v] -> v 11 | 12 | instance Vector (Double, Double) where 13 | distance (a,b) (c,d) = sqrt $ (c-a)*(c-a) + (d-b)*(d-b) 14 | centroid lst = let (u,v) = foldr (\(a,b) (c,d) -> (a+c,b+d)) (0.0,0.0) lst 15 | n = fromIntegral $ length lst 16 | in (u / n, v / n) 17 | 18 | class Vector v => Vectorizable e v where 19 | toVector :: e -> v 20 | 21 | instance Vectorizable (Double,Double) (Double,Double) where 22 | toVector = id 23 | -------------------------------------------------------------------------------- /chapter7/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter7/chapter7.cabal: -------------------------------------------------------------------------------- 1 | name: chapter7 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable chapter7 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | build-depends: 11 | base >= 4, 12 | containers, 13 | logict, 14 | mtl, 15 | transformers 16 | ghc-options: -Wall 17 | other-modules: 18 | Chapter7.APriori.FirstImpl, 19 | Chapter7.APriori.WithMonads, 20 | Chapter7.APriori.Types, 21 | Chapter7.MoreThanOneValue, 22 | Chapter7.MonadPlus, 23 | Chapter7.Graph, 24 | Chapter7.UnderAMonad, 25 | Chapter7.CombiningMonads 26 | 27 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/APriori/FirstImpl.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.APriori.FirstImpl (apriori) where 2 | 3 | -- import Data.Set (Set) 4 | import qualified Data.Set as S 5 | 6 | import Chapter7.APriori.Types 7 | 8 | apriori :: Double -> [Transaction] -> [FrequentSet] 9 | apriori minSupport transactions = 10 | let c1 = noDups $ concatMap (\(Transaction t) -> map (FrequentSet . S.singleton) $ S.toList t) transactions 11 | l1 = filter (\fs -> setSupport transactions fs > minSupport) c1 12 | in concat $ l1 : generateMoreCs minSupport transactions l1 13 | 14 | generateMoreCs :: Double -> [Transaction] -> [FrequentSet] -> [[FrequentSet]] 15 | generateMoreCs _ _ [] = [] 16 | generateMoreCs minSupport transactions lk = 17 | let ck1 = noDups $ zipWith (\(FrequentSet a) (FrequentSet b) -> FrequentSet $ a `S.union` b) lk lk 18 | lk1 = filter (\fs -> setSupport transactions fs > minSupport) ck1 19 | in lk1 : generateMoreCs minSupport transactions lk1 20 | 21 | noDups :: Ord a => [a] -> [a] 22 | noDups = S.toList . S.fromList 23 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/APriori/Types.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.APriori.Types where 2 | 3 | import Data.Set (Set) 4 | import qualified Data.Set as S 5 | 6 | data Client = GovOrg { clientName :: String } 7 | | Company { clientName :: String, person :: Person, duty :: String } 8 | | Individual { person :: Person } 9 | deriving (Show, Eq, Ord) 10 | 11 | data ClientKind = KindGovOrg | KindCompany | KindIndividual 12 | deriving (Show, Eq, Ord) 13 | 14 | data Person = Person { firstName :: String, lastName :: String, gender :: Gender } 15 | deriving (Show, Eq, Ord) 16 | 17 | data Gender = Male | Female | UnknownGender 18 | deriving (Show, Eq, Ord) 19 | 20 | data Product = Product { productId :: Integer, productType :: ProductType } 21 | deriving (Show, Eq, Ord) 22 | 23 | data ProductType = TimeMachine | TravelGuide | Tool | Trip 24 | deriving (Show, Eq, Ord) 25 | 26 | data Purchase = Purchase { client :: Client, products :: [Product] } 27 | deriving (Show, Eq, Ord) 28 | 29 | data PurchaseInfo = InfoClientKind ClientKind 30 | | InfoClientDuty String 31 | | InfoClientGender Gender 32 | | InfoPurchasedProduct Integer 33 | | InfoPurchasedProductType ProductType 34 | deriving (Show, Eq, Ord) 35 | 36 | clientToPurchaseInfo :: Client -> Set PurchaseInfo 37 | clientToPurchaseInfo GovOrg { } = 38 | S.singleton $ InfoClientKind KindGovOrg 39 | clientToPurchaseInfo Company { duty = d } = 40 | S.fromList [ InfoClientKind KindCompany, InfoClientDuty d ] 41 | clientToPurchaseInfo Individual { person = Person { gender = UnknownGender } } = 42 | S.singleton $ InfoClientKind KindIndividual 43 | clientToPurchaseInfo Individual { person = Person { gender = g } } = 44 | S.fromList [ InfoClientKind KindIndividual, InfoClientGender g ] 45 | 46 | productsToPurchaseInfo :: [Product] -> Set PurchaseInfo 47 | productsToPurchaseInfo = foldr 48 | (\(Product i t) pinfos -> S.insert (InfoPurchasedProduct i) $ 49 | S.insert (InfoPurchasedProductType t) pinfos) 50 | S.empty 51 | 52 | purchaseToTransaction :: Purchase -> Transaction 53 | purchaseToTransaction (Purchase c p) = 54 | Transaction $ clientToPurchaseInfo c `S.union` productsToPurchaseInfo p 55 | 56 | newtype Transaction = Transaction (Set PurchaseInfo) deriving (Eq, Ord) 57 | newtype FrequentSet = FrequentSet (Set PurchaseInfo) deriving (Eq, Ord) 58 | data AssocRule = AssocRule (Set PurchaseInfo) (Set PurchaseInfo) deriving (Eq, Ord) 59 | 60 | instance Show AssocRule where 61 | show (AssocRule a b) = show a ++ " => " ++ show b 62 | 63 | setSupport :: [Transaction] -> FrequentSet -> Double 64 | setSupport transactions (FrequentSet sElts) = 65 | let total = length transactions 66 | supp = length (filter (\(Transaction tElts) -> sElts `S.isSubsetOf` tElts) transactions) 67 | in fromIntegral supp / fromIntegral total 68 | 69 | ruleConfidence :: [Transaction] -> AssocRule -> Double 70 | ruleConfidence transactions (AssocRule a b) = 71 | setSupport transactions (FrequentSet $ a `S.union` b) / setSupport transactions (FrequentSet a) 72 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/APriori/WithMonads.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.APriori.WithMonads where 2 | 3 | import Control.Monad (guard) 4 | -- import Data.Set (Set) 5 | import qualified Data.Set as S 6 | import Data.List (unfoldr) 7 | 8 | import Chapter7.APriori.Types 9 | 10 | apriori2 :: Double -> Double -> [Transaction] -> [AssocRule] 11 | -- apriori2 minSupport minConfidence transactions = 12 | -- let l1 = generateL1 minSupport transactions 13 | -- allL = concat $ unfoldr (generateNextLk minSupport transactions) (1, l1) 14 | -- in generateAssocRules minConfidence transactions allL 15 | apriori2 minSupport minConfidence transactions = 16 | generateAssocRules minConfidence transactions 17 | $ concat $ unfoldr (generateNextLk minSupport transactions) 18 | (1, generateL1 minSupport transactions) 19 | 20 | generateL1 :: Double -> [Transaction] -> [FrequentSet] 21 | generateL1 minSupport transactions = 22 | noDups $ do Transaction t <- transactions 23 | e <- S.toList t 24 | let fs = FrequentSet $ S.singleton e 25 | guard $ setSupport transactions fs > minSupport 26 | return fs 27 | 28 | generateNextLk :: Double -> [Transaction] -> (Int, [FrequentSet]) -> Maybe ([FrequentSet], (Int, [FrequentSet])) 29 | generateNextLk _ _ (_, []) = Nothing 30 | generateNextLk minSupport transactions (k, lk) = 31 | let lk1 = noDups $ do FrequentSet a <- lk 32 | FrequentSet b <- lk 33 | guard $ S.size (a `S.intersection` b) == k - 1 34 | let fs = FrequentSet $ a `S.union` b 35 | guard $ setSupport transactions fs > minSupport 36 | return fs 37 | in Just (lk1, (k+1, lk1)) 38 | 39 | 40 | generateAssocRules :: Double -> [Transaction] -> [FrequentSet] -> [AssocRule] 41 | generateAssocRules minConfidence transactions sets = 42 | do FrequentSet fs <- sets 43 | subset@(_:_) <- powerset $ S.toList fs 44 | let ssubset = S.fromList subset 45 | rule = AssocRule ssubset (fs `S.difference` ssubset) 46 | guard $ ruleConfidence transactions rule > minConfidence 47 | return rule 48 | 49 | noDups :: Ord a => [a] -> [a] 50 | noDups = S.toList . S.fromList 51 | 52 | powerset :: [a] -> [[a]] 53 | powerset [] = [[]] 54 | powerset (x:xs) = powerset xs ++ map (x:) (powerset xs) 55 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/CombiningMonads.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Chapter7.CombiningMonads where 4 | 5 | import Control.Monad 6 | import Control.Monad.Reader 7 | import Control.Monad.Writer 8 | import Control.Monad.State 9 | import Control.Monad.RWS 10 | 11 | pathsWriter :: [(Int,Int)] -> Int -> Int -> [[Int]] 12 | pathsWriter edges start end = map execWriter (pathsWriter' edges start end) 13 | 14 | pathsWriter' :: [(Int,Int)] -> Int -> Int -> [Writer [Int] ()] 15 | pathsWriter' edges start end = 16 | let e_paths = do (e_start, e_end) <- edges 17 | guard $ e_start == start 18 | subpath <- pathsWriter' edges e_end end 19 | return $ do tell [start] 20 | subpath 21 | in if start == end then tell [start] : e_paths else e_paths 22 | 23 | graph1 :: [(Int, Int)] 24 | graph1 = [(2013,501),(2013,1004),(501,2558),(1004,2558)] 25 | 26 | pathsWriterT :: [(Int,Int)] -> Int -> Int -> [[Int]] 27 | pathsWriterT edges start end = execWriterT (pathsWriterT' edges start end) 28 | 29 | pathsWriterT' :: [(Int,Int)] -> Int -> Int -> WriterT [Int] [] () 30 | pathsWriterT' edges start end = 31 | let e_paths = do (e_start, e_end) <- lift edges 32 | guard $ e_start == start 33 | tell [start] 34 | pathsWriterT' edges e_end end 35 | in if start == end then tell [start] `mplus` e_paths else e_paths 36 | 37 | readerWriterExample :: ReaderT Int (Writer String) Int 38 | readerWriterExample = do x <- ask 39 | lift . tell $ show x 40 | return $ x + 1 41 | 42 | readerWriterExampleG :: (MonadReader Int m, MonadWriter String m) => m Int 43 | readerWriterExampleG = do x <- ask 44 | tell $ show x 45 | return $ x + 1 46 | 47 | factorial' :: StateT Integer (State Integer) Integer 48 | factorial' = do n <- get 49 | if n == 0 50 | then lift get 51 | else do lift . modify $ (*n) 52 | modify $ \x -> x - 1 53 | factorial' 54 | 55 | factorial :: Integer -> Integer 56 | factorial x = execState (execStateT factorial' x) 1 57 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/Graph.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.Graph where 2 | 3 | import Control.Monad 4 | import Control.Monad.Logic 5 | 6 | paths :: [(Int,Int)] -> Int -> Int -> [[Int]] 7 | paths edges start end = 8 | let e_paths = do (e_start, e_end) <- edges 9 | guard $ e_start == start 10 | subpath <- paths edges e_end end 11 | return $ start:subpath 12 | in if start == end 13 | then return [end] `mplus` e_paths 14 | else e_paths 15 | 16 | graph1 :: [(Int, Int)] 17 | graph1 = [(2013,501),(2013,1004),(501,2558),(1004,2558)] 18 | 19 | graph2 :: [(Int, Int)] 20 | graph2 = [(2013,501),(501,2558),(501,1004),(1004,501),(2013,2558)] 21 | 22 | pathsL :: [(Int,Int)] -> Int -> Int -> Logic [Int] 23 | pathsL edges start end = 24 | let e_paths = do (e_start, e_end) <- choices edges 25 | guard $ e_start == start 26 | subpath <- pathsL edges e_end end 27 | return $ start:subpath 28 | in if start == end then return [end] `mplus` e_paths else e_paths 29 | 30 | choices :: [a] -> Logic a 31 | choices = msum . map return 32 | 33 | pathsLFair :: [(Int,Int)] -> Int -> Int -> Logic [Int] 34 | pathsLFair edges start end = 35 | let e_paths = choices edges >>- \(e_start, e_end) -> 36 | guard (e_start == start) >> 37 | pathsLFair edges e_end end >>- \subpath -> 38 | return $ start:subpath 39 | in if start == end 40 | then return [end] `interleave` e_paths 41 | else e_paths 42 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/MonadPlus.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.MonadPlus where 2 | 3 | import Control.Monad 4 | 5 | broken1 :: Integer -> [Integer] 6 | broken1 n = [n-1, n+1] 7 | 8 | broken2 :: Integer -> [Integer] 9 | broken2 n = [1024, n+2] 10 | 11 | find_ :: (a -> Bool) -> [a] -> Maybe a 12 | find_ f = msum . map (\x -> if f x then Just x else Nothing) -------------------------------------------------------------------------------- /chapter7/src/Chapter7/MoreThanOneValue.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.MoreThanOneValue where 2 | 3 | brokenJump :: Integer -> [Integer] 4 | brokenJump y = [y-1, y+3, y+5] 5 | 6 | brokenThreeJumps :: Integer -> [Integer] 7 | brokenThreeJumps y = do firstJ <- brokenJump y 8 | secondJ <- brokenJump firstJ 9 | brokenJump secondJ 10 | 11 | brokenJumps :: Integer -> Integer -> [Integer] 12 | brokenJumps n year = brokenJumps' n [year] 13 | where brokenJumps' 0 years = years 14 | brokenJumps' i years = years >>= brokenJumps' (i-1) . brokenJump 15 | -------------------------------------------------------------------------------- /chapter7/src/Chapter7/UnderAMonad.hs: -------------------------------------------------------------------------------- 1 | module Chapter7.UnderAMonad where 2 | 3 | import Control.Monad 4 | import Control.Monad.Reader 5 | import Control.Monad.Writer 6 | 7 | addPrefix :: String -> Reader String String 8 | addPrefix s = ask >>= \p -> return $ p ++ s 9 | -- ask >>= return . (++ s) 10 | 11 | addPrefixL :: [String] -> Reader String [String] 12 | addPrefixL = mapM addPrefix 13 | 14 | logInformation :: [String] -> Writer String () 15 | logInformation = mapM_ (\s -> tell (s ++ "\n")) 16 | 17 | logInformation2 :: [String] -> Writer String () 18 | logInformation2 infos = forM_ infos $ \s -> 19 | tell (s ++ "\n") 20 | 21 | factorialSteps :: Integer -> Writer (Sum Integer) Integer 22 | factorialSteps n = foldM (\f x -> tell (Sum 1) >> return (f*x)) 1 [1 .. n] 23 | -------------------------------------------------------------------------------- /chapter7/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | 5 | main::IO() 6 | main = undefined -------------------------------------------------------------------------------- /chapter8/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter8/chapter8.cabal: -------------------------------------------------------------------------------- 1 | name: chapter8 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable par 8 | hs-source-dirs: src 9 | main-is: Par.hs 10 | build-depends: base >= 4, monad-par, containers, deepseq 11 | ghc-options: -Wall -threaded 12 | other-modules: Chapter8.APriori.Par, Chapter8.APriori.Par2 13 | 14 | executable stm 15 | hs-source-dirs: src 16 | main-is: Stm.hs 17 | build-depends: base >= 4, stm, random 18 | ghc-options: -Wall -threaded 19 | 20 | executable distr 21 | hs-source-dirs: src 22 | main-is: Distr.hs 23 | build-depends: base >= 4, binary >= 0.6.3.0 && < 0.7, distributed-process, distributed-process-simplelocalnet, random 24 | ghc-options: -Wall -threaded 25 | 26 | -------------------------------------------------------------------------------- /chapter8/src/Chapter8/APriori/Par.hs: -------------------------------------------------------------------------------- 1 | module Chapter8.APriori.Par (apriori) where 2 | 3 | import Control.Monad.Par 4 | -- import Data.Set (Set) 5 | import qualified Data.Set as S 6 | 7 | import Chapter8.APriori.Types 8 | 9 | {- 10 | -- No parallelism 11 | apriori :: Double -> [Transaction] -> [FrequentSet] 12 | apriori minSupport transactions = 13 | let c1 = noDups $ concatMap (\(Transaction t) -> map (FrequentSet . S.singleton) $ S.toList t) transactions 14 | l1 = filter (\fs -> setSupport transactions fs > minSupport) c1 15 | in concat $ l1 : generateMoreCs minSupport transactions l1 16 | 17 | generateMoreCs :: Double -> [Transaction] -> [FrequentSet] -> [[FrequentSet]] 18 | generateMoreCs _ _ [] = [] 19 | generateMoreCs minSupport transactions lk = 20 | let ck1 = noDups $ zipWith (\(FrequentSet a) (FrequentSet b) -> FrequentSet $ a `S.union` b) lk lk 21 | lk1 = filter (\fs -> setSupport transactions fs > minSupport) ck1 22 | in lk1 : generateMoreCs minSupport transactions lk1 23 | -} 24 | 25 | noDups :: Ord a => [a] -> [a] 26 | noDups = S.toList . S.fromList 27 | 28 | -- With parMapM 29 | apriori :: Double -> [Transaction] -> [FrequentSet] 30 | apriori minSupport transactions = runPar $ do 31 | let c1 = noDups $ concatMap (\(Transaction t) -> map (FrequentSet . S.singleton) $ S.toList t) transactions 32 | l1NotFiltered <- parMap (\fs -> (fs, setSupport transactions fs > minSupport)) c1 33 | let l1 = concatMap (\(fs,b) -> if b then [fs] else []) l1NotFiltered 34 | return $ concat (l1 : generateMoreCs minSupport transactions l1) 35 | 36 | generateMoreCs :: Double -> [Transaction] -> [FrequentSet] -> [[FrequentSet]] 37 | generateMoreCs _ _ [] = [] 38 | generateMoreCs minSupport transactions lk = 39 | let ck1 = noDups $ zipWith (\(FrequentSet a) (FrequentSet b) -> FrequentSet $ a `S.union` b) lk lk 40 | lk1 = runPar $ filterLk minSupport transactions ck1 41 | in lk1 : generateMoreCs minSupport transactions lk1 42 | 43 | -- Splitting in halves 44 | filterLk :: Double -> [Transaction] -> [FrequentSet] -> Par [FrequentSet] 45 | filterLk minSupport transactions ck = 46 | let lengthCk = length ck 47 | in if lengthCk <= 5 48 | then return $ filter (\fs -> setSupport transactions fs > minSupport) ck 49 | else let (l,r) = splitAt (lengthCk `div` 2) ck 50 | in do lVar <- spawn $ filterLk minSupport transactions l 51 | lFiltered <- get lVar 52 | rVar <- spawn $ filterLk minSupport transactions r 53 | rFiltered <- get rVar 54 | return $ lFiltered ++ rFiltered 55 | 56 | {- 57 | -- With skeleton 58 | filterLk :: Double -> [Transaction] -> [FrequentSet] -> [FrequentSet] 59 | filterLk minSupport transactions = 60 | divConq (\p -> length p <= 5) 61 | (\p -> let (l, r) = splitAt (length p `div` 2) p in [l, r]) 62 | (\[l,r] -> l ++ r) 63 | (filter (\fs -> setSupport transactions fs > minSupport)) 64 | -} 65 | 66 | divConq :: NFData sol 67 | => (prob -> Bool) -- indivisible? 68 | -> (prob -> [prob]) -- split into subproblems 69 | -> ([sol] -> sol) -- join solutions 70 | -> (prob -> sol) -- solve a subproblem 71 | -> (prob -> sol) 72 | divConq indiv split join f prob = runPar $ go prob 73 | where go prob | indiv prob = return (f prob) 74 | | otherwise = do sols <- parMapM go (split prob) 75 | return (join sols) 76 | 77 | -------------------------------------------------------------------------------- /chapter8/src/Chapter8/APriori/Par2.hs: -------------------------------------------------------------------------------- 1 | module Chapter8.APriori.Par2 where 2 | 3 | import Control.Monad (guard) 4 | import Control.Monad.Par 5 | -- import Data.Set (Set) 6 | import qualified Data.Set as S 7 | import Data.List (unfoldr) 8 | 9 | import Chapter8.APriori.Types 10 | 11 | apriori2 :: Double -> Double -> [Transaction] -> [AssocRule] 12 | -- apriori2 minSupport minConfidence transactions = 13 | -- let l1 = generateL1 minSupport transactions 14 | -- allL = concat $ unfoldr (generateNextLk minSupport transactions) (1, l1) 15 | -- in generateAssocRules minConfidence transactions allL 16 | apriori2 minSupport minConfidence transactions = 17 | generateAssocRules minConfidence transactions 18 | $ concat $ unfoldr (generateNextLk minSupport transactions) 19 | (1, generateL1 minSupport transactions) 20 | 21 | generateL1 :: Double -> [Transaction] -> [FrequentSet] 22 | generateL1 minSupport transactions = runPar $ do 23 | let c1 = noDups $ concatMap (\(Transaction t) -> map (FrequentSet . S.singleton) $ S.toList t) transactions 24 | l1NotFiltered <- parMap (\fs -> (fs, setSupport transactions fs > minSupport)) c1 25 | return $ concatMap (\(fs,b) -> if b then [fs] else []) l1NotFiltered 26 | {- 27 | let c1 = noDups $ concatMap (\(Transaction t) -> map (FrequentSet . S.singleton) $ S.toList t) transactions 28 | l1NotFiltered = map (\fs -> (fs, setSupport transactions fs > minSupport)) c1 29 | in concatMap (\(fs,b) -> if b then [fs] else []) l1NotFiltered 30 | -} 31 | {- 32 | noDups $ do Transaction t <- transactions 33 | e <- S.toList t 34 | let fs = FrequentSet $ S.singleton e 35 | guard $ setSupport transactions fs > minSupport 36 | return fs 37 | -} 38 | 39 | generateNextLk :: Double -> [Transaction] -> (Int, [FrequentSet]) -> Maybe ([FrequentSet], (Int, [FrequentSet])) 40 | generateNextLk _ _ (_, []) = Nothing 41 | generateNextLk minSupport transactions (k, lk) = 42 | let ck1 = noDups $ [ FrequentSet $ a `S.union` b | FrequentSet a <- lk, FrequentSet b <- lk 43 | , S.size (a `S.intersection` b) == k - 1 ] 44 | lk1 = runPar $ filterLk minSupport transactions ck1 45 | in Just (lk1, (k+1, lk1)) 46 | 47 | filterLk :: Double -> [Transaction] -> [FrequentSet] -> Par [FrequentSet] 48 | filterLk minSupport transactions ck = 49 | let lengthCk = length ck 50 | in if lengthCk <= 5 51 | then return $ filter (\fs -> setSupport transactions fs > minSupport) ck 52 | else let (l,r) = splitAt (lengthCk `div` 2) ck 53 | in do lVar <- spawn $ filterLk minSupport transactions l 54 | lFiltered <- get lVar 55 | rVar <- spawn $ filterLk minSupport transactions r 56 | rFiltered <- get rVar 57 | return $ lFiltered ++ rFiltered 58 | 59 | generateAssocRules :: Double -> [Transaction] -> [FrequentSet] -> [AssocRule] 60 | generateAssocRules minConfidence transactions sets = 61 | do FrequentSet fs <- sets 62 | subset@(_:_) <- powerset $ S.toList fs 63 | let ssubset = S.fromList subset 64 | rule = AssocRule ssubset (fs `S.difference` ssubset) 65 | guard $ ruleConfidence transactions rule > minConfidence 66 | return rule 67 | 68 | noDups :: Ord a => [a] -> [a] 69 | noDups = S.toList . S.fromList 70 | 71 | powerset :: [a] -> [[a]] 72 | powerset [] = [[]] 73 | powerset (x:xs) = powerset xs ++ map (x:) (powerset xs) -------------------------------------------------------------------------------- /chapter8/src/Chapter8/APriori/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Chapter8.APriori.Types where 4 | 5 | import Data.Set (Set) 6 | import qualified Data.Set as S 7 | 8 | import Control.DeepSeq 9 | import GHC.Generics 10 | 11 | data Client = GovOrg { clientName :: String } 12 | | Company { clientName :: String, person :: Person, duty :: String } 13 | | Individual { person :: Person } 14 | deriving (Show, Eq, Ord, Generic) 15 | 16 | data ClientKind = KindGovOrg | KindCompany | KindIndividual 17 | deriving (Show, Eq, Ord, Generic) 18 | 19 | data Person = Person { firstName :: String, lastName :: String, gender :: Gender } 20 | deriving (Show, Eq, Ord, Generic) 21 | 22 | data Gender = Male | Female | UnknownGender 23 | deriving (Show, Eq, Ord, Generic) 24 | 25 | data Product = Product { productId :: Integer, productType :: ProductType } 26 | deriving (Show, Eq, Ord, Generic) 27 | 28 | data ProductType = TimeMachine | TravelGuide | Tool | Trip 29 | deriving (Show, Eq, Ord, Generic) 30 | 31 | data Purchase = Purchase { client :: Client, products :: [Product] } 32 | deriving (Show, Eq, Ord, Generic) 33 | 34 | data PurchaseInfo = InfoClientKind ClientKind 35 | | InfoClientDuty String 36 | | InfoClientGender Gender 37 | | InfoPurchasedProduct Integer 38 | | InfoPurchasedProductType ProductType 39 | deriving (Show, Eq, Ord, Generic) 40 | 41 | instance NFData Client 42 | instance NFData ClientKind 43 | instance NFData Person 44 | instance NFData Gender 45 | instance NFData Product 46 | instance NFData ProductType 47 | instance NFData Purchase 48 | instance NFData PurchaseInfo 49 | 50 | clientToPurchaseInfo :: Client -> Set PurchaseInfo 51 | clientToPurchaseInfo GovOrg { } = 52 | S.singleton $ InfoClientKind KindGovOrg 53 | clientToPurchaseInfo Company { duty = d } = 54 | S.fromList [ InfoClientKind KindCompany, InfoClientDuty d ] 55 | clientToPurchaseInfo Individual { person = Person { gender = UnknownGender } } = 56 | S.singleton $ InfoClientKind KindIndividual 57 | clientToPurchaseInfo Individual { person = Person { gender = g } } = 58 | S.fromList [ InfoClientKind KindIndividual, InfoClientGender g ] 59 | 60 | productsToPurchaseInfo :: [Product] -> Set PurchaseInfo 61 | productsToPurchaseInfo = foldr 62 | (\(Product i t) pinfos -> S.insert (InfoPurchasedProduct i) $ 63 | S.insert (InfoPurchasedProductType t) pinfos) 64 | S.empty 65 | 66 | purchaseToTransaction :: Purchase -> Transaction 67 | purchaseToTransaction (Purchase c p) = 68 | Transaction $ clientToPurchaseInfo c `S.union` productsToPurchaseInfo p 69 | 70 | newtype Transaction = Transaction (Set PurchaseInfo) deriving (Eq, Ord, Generic) 71 | newtype FrequentSet = FrequentSet (Set PurchaseInfo) deriving (Eq, Ord, Generic) 72 | data AssocRule = AssocRule (Set PurchaseInfo) (Set PurchaseInfo) deriving (Eq, Ord, Generic) 73 | 74 | instance NFData Transaction 75 | instance NFData FrequentSet 76 | instance NFData AssocRule 77 | 78 | instance Show AssocRule where 79 | show (AssocRule a b) = show a ++ " => " ++ show b 80 | 81 | setSupport :: [Transaction] -> FrequentSet -> Double 82 | setSupport transactions (FrequentSet sElts) = 83 | let total = length transactions 84 | supp = length (filter (\(Transaction tElts) -> sElts `S.isSubsetOf` tElts) transactions) 85 | in fromIntegral supp / fromIntegral total 86 | 87 | ruleConfidence :: [Transaction] -> AssocRule -> Double 88 | ruleConfidence transactions (AssocRule a b) = 89 | setSupport transactions (FrequentSet $ a `S.union` b) / setSupport transactions (FrequentSet a) 90 | -------------------------------------------------------------------------------- /chapter8/src/Distr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, DoAndIfThenElse #-} 2 | 3 | module Main where 4 | 5 | import Control.Concurrent 6 | import Control.Distributed.Process 7 | import Control.Distributed.Process.Node (initRemoteTable) 8 | import Control.Distributed.Process.Closure 9 | import Control.Distributed.Process.Backend.SimpleLocalnet 10 | import Control.Monad 11 | import System.Environment 12 | import System.Random 13 | 14 | -- For deriving Serializable 15 | import Data.Binary (Binary) 16 | import Data.Typeable (Typeable) 17 | import GHC.Generics (Generic) 18 | 19 | data GalaxyMessage = LookForGalaxy ProcessId 20 | -- data GalaxyMessage = LookForGalaxy (SendPort GalaxyMessage) 21 | | GalaxyFound String 22 | deriving (Typeable, Generic) 23 | instance Binary GalaxyMessage 24 | 25 | data WormHoleMessage = LostInWormHole 26 | deriving (Typeable, Generic) 27 | instance Binary WormHoleMessage 28 | 29 | -- Version 1: one message 30 | {- 31 | traveller :: Process () 32 | traveller = do LookForGalaxy m <- expect 33 | say "Looking for galaxy" 34 | r <- liftIO $ randomRIO (3, 15) 35 | liftIO $ threadDelay (r * 1000000) 36 | say "Found!" 37 | send m (GalaxyFound "Andromeda") 38 | 39 | remotable ['traveller] 40 | 41 | master :: [NodeId] -> Process () 42 | master nodes = 43 | do myPid <- getSelfPid 44 | mapM_ (\node -> do say $ "Sending to " ++ show node 45 | pid <- spawn node $(mkStaticClosure 'traveller) 46 | send pid (LookForGalaxy myPid)) 47 | nodes 48 | forever $ do GalaxyFound g <- expect 49 | say $ "Found galaxy: " ++ g 50 | -} 51 | 52 | -- Version 2: several kinds of message 53 | 54 | traveller :: Process () 55 | traveller = do LookForGalaxy m <- expect 56 | say "Looking for galaxy" 57 | b <- liftIO $ randomIO 58 | if b 59 | then do say "Found!" 60 | send m (GalaxyFound "Andromeda") 61 | else do say "Lost in wormhole!" 62 | send m LostInWormHole 63 | 64 | remotable ['traveller] 65 | 66 | master :: [NodeId] -> Process () 67 | master nodes = 68 | do myPid <- getSelfPid 69 | mapM_ (\node -> do say $ "Sending to " ++ show node 70 | pid <- spawn node $(mkStaticClosure 'traveller) 71 | send pid (LookForGalaxy myPid)) 72 | nodes 73 | forever $ do receiveWait 74 | [ match $ \(GalaxyFound g) -> say $ "Found galaxy: " ++ g 75 | , match $ \LostInWormHole -> say "Lost in wormhole" 76 | ] 77 | 78 | 79 | -- Version 3: using channels 80 | {- 81 | traveller :: Process () 82 | traveller = do LookForGalaxy sendPort <- expect 83 | say "Looking for galaxy" 84 | say "Found!" 85 | sendChan sendPort (GalaxyFound "Andromeda") 86 | 87 | remotable ['traveller] 88 | 89 | master :: [NodeId] -> Process () 90 | master = 91 | mapM_ $ \node -> do say $ "Creating channel with " ++ show node 92 | pid <- spawn node $(mkStaticClosure 'traveller) 93 | (sendPort, rcvPort) <- newChan 94 | send pid (LookForGalaxy sendPort) -- init conversation 95 | GalaxyFound g <- receiveChan rcvPort -- it could be more fruitful 96 | say $ "Found galaxy: " ++ g 97 | -} 98 | main :: IO () 99 | main = do args <- getArgs 100 | case args of 101 | ["master", host, port] -> do 102 | backend <- initializeBackend host port (Main.__remoteTable initRemoteTable) 103 | putStrLn "Starting master..." 104 | startMaster backend master 105 | ["traveller", host, port] -> do 106 | backend <- initializeBackend host port (Main.__remoteTable initRemoteTable) 107 | putStrLn "Starting traveller..." 108 | startSlave backend 109 | _ -> do putStrLn "Unknown parameters" 110 | 111 | 112 | 113 | -- Speak about http://www.well-typed.com/blog/71 114 | -------------------------------------------------------------------------------- /chapter8/src/Par.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Par 4 | import System.Environment 5 | import Control.DeepSeq 6 | 7 | import Chapter8.APriori.Par 8 | import Chapter8.APriori.Par2 9 | 10 | main :: IO () 11 | main = do n <- fmap (read . head) getArgs 12 | print $ findTwoFactors n (n + 1) 13 | 14 | 15 | {- 16 | -- Version 1: no parallelism 17 | findTwoFactors :: Integer -> Integer -> ([Integer],[Integer]) 18 | findTwoFactors x y = (findFactors x, findFactors y) 19 | -} 20 | 21 | -- Version 2: with futures 22 | findTwoFactors :: Integer -> Integer -> ([Integer],[Integer]) 23 | findTwoFactors x y = runPar $ do 24 | factorsXVar <- spawnP $ findFactors x 25 | -- factorsYVar <- spawnP $ findFactors y 26 | -- factorsX <- get factorsXVar 27 | -- factorsY <- get factorsYVar 28 | let factorsY = findFactors y 29 | _ = rnf factorsY 30 | factorsX <- get factorsXVar 31 | return (factorsX, factorsY) 32 | 33 | findFactors :: Integer -> [Integer] 34 | findFactors 1 = [1] 35 | findFactors n = let oneFactor = findFactor n 2 36 | in oneFactor : (findFactors $ n `div` oneFactor) 37 | 38 | findFactor :: Integer -> Integer -> Integer 39 | findFactor n m | n == m = n 40 | | n `mod` m == 0 = m 41 | | otherwise = findFactor n (m + 1) 42 | 43 | {- 44 | main :: IO () 45 | main = putStrLn $ printTicket 1 1 [(1,"A"),(2,"B")] [(1,"Machine"),(2,"Book")] 46 | -} 47 | 48 | printTicket :: Int -> Int -> [(Int,String)] -> [(Int,String)] -> String 49 | printTicket idC idP clients products = runPar $ do 50 | clientV <- new 51 | productV <- new 52 | fork $ lookupPar clientV idC clients 53 | fork $ lookupPar productV idP products 54 | envV <- new 55 | letterV <- new 56 | fork $ printEnvelope clientV envV 57 | fork $ printLetter clientV productV letterV 58 | envS <- get envV 59 | letterS <- get letterV 60 | return $ envS ++ "\n\n" ++ letterS 61 | 62 | lookupPar :: (Eq a, NFData b) => IVar (Maybe b) -> a -> [(a,b)] -> Par () 63 | lookupPar i _ [] = put i Nothing 64 | lookupPar i x ((k,v):r) | x == k = put i $ Just v 65 | | otherwise = lookupPar i x r 66 | 67 | printEnvelope :: IVar (Maybe String) -> IVar String -> Par () 68 | printEnvelope clientV envV = do 69 | clientName <- get clientV 70 | case clientName of 71 | Nothing -> put envV "Unknown" 72 | Just n -> put envV $ "To: " ++ n 73 | 74 | printLetter :: IVar (Maybe String) -> IVar (Maybe String) -> IVar String -> Par () 75 | printLetter clientV productV letterV = do 76 | clientName <- get clientV 77 | productName <- get productV 78 | case (clientName, productName) of 79 | (Nothing, Nothing) -> put letterV "Unknown" 80 | (Just n, Nothing) -> put letterV $ n ++ " bought something" 81 | (Nothing, Just p) -> put letterV $ "Someone bought " ++ p 82 | (Just n, Just p) -> put letterV $ n ++ " bought " ++ p 83 | 84 | -------------------------------------------------------------------------------- /chapter8/src/Stm.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | import Control.Concurrent.STM 5 | import Control.Concurrent.STM.TQueue 6 | import Control.Monad 7 | import System.Random 8 | 9 | -- Basic combinators 10 | forkN :: Int -> IO () -> IO () 11 | -- forkN 0 _ = return () 12 | -- forkN n f = forkIO f >> forkN (n - 1) f 13 | forkN n f = replicateM_ n (forkIO f) 14 | 15 | forkDelay :: Int -> IO () -> IO () 16 | forkDelay n f = replicateM_ n $ forkIO (randomDelay >> f) 17 | 18 | randomDelay :: IO () 19 | randomDelay = do r <- randomRIO (3, 15) 20 | threadDelay (r * 1000000) 21 | 22 | -- Example 1 23 | {- 24 | main :: IO () 25 | main = do v <- newMVar 10000 26 | forkDelay 5 $ updateMoney v 27 | forkDelay 5 $ readMoney v 28 | _ <- getLine -- to wait for completion 29 | return () 30 | -} 31 | 32 | updateMoney :: MVar Integer -> IO () 33 | updateMoney v = do r <- randomRIO (0, 3000) 34 | m <- takeMVar v 35 | putStrLn $ "Updating value, which is " ++ show m 36 | putMVar v (m + r) 37 | 38 | readMoney :: MVar Integer -> IO () 39 | readMoney v = do m <- readMVar v -- equivalent to take and put 40 | putStrLn $ "The current value is " ++ show m 41 | 42 | 43 | -- Example 2 44 | {- 45 | main :: IO () 46 | main = do v <- newMVar 10000 47 | s <- newMVar [("a",7)] 48 | forkDelay 5 $ updateMoneyAndStock "a" 1000 v s 49 | forkDelay 5 $ printMoneyAndStock v s 50 | _ <- getLine -- to wait for completion 51 | return () 52 | -} 53 | 54 | updateMoneyAndStock :: Eq a => a -> Integer -> MVar Integer -> MVar [(a,Integer)] -> IO () 55 | updateMoneyAndStock product price money stock = 56 | do s <- takeMVar stock 57 | let Just productNo = lookup product s 58 | if productNo > 0 59 | then do m <- takeMVar money -- Problem of deadlocking 60 | let newS = map (\(k,v) -> if k == product then (k,v-1) else (k,v)) s 61 | putMVar money (m + price) >> putMVar stock newS -- Problem of deadlocking 62 | else putMVar stock s 63 | 64 | printMoneyAndStock :: Show a => MVar Integer -> MVar [(a,Integer)] -> IO () 65 | printMoneyAndStock money stock = do m <- readMVar money -- Problem of deadlocking 66 | s <- readMVar stock 67 | putStrLn $ show m ++ "\n" ++ show s 68 | 69 | -- Example 3 70 | {- 71 | main :: IO () 72 | main = do v <- newTVarIO 10000 73 | s <- newTVarIO [("a",7)] 74 | forkDelay 5 $ atomically $ updateMoneyAndStockStm "a" 1000 v s 75 | _ <- getLine -- to wait for completion 76 | return () 77 | -} 78 | 79 | updateMoneyAndStockStm :: Eq a => a -> Integer -> TVar Integer -> TVar [(a,Integer)] -> STM () 80 | updateMoneyAndStockStm product price money stock = 81 | do s <- readTVar stock 82 | let Just productNo = lookup product s 83 | if productNo > 0 84 | then do m <- readTVar money 85 | let newS = map (\(k,v) -> if k == product then (k,v-1) else (k,v)) s 86 | writeTVar money (m + price) >> writeTVar stock newS 87 | else return () 88 | 89 | payByCard :: Eq a => a -> Integer -> TVar Integer -> TVar [(a,Integer)] -> STM () 90 | payByCard product price money stock = 91 | do working <- isCardSystemWorking 92 | if not working 93 | then retry -- shows retry 94 | else updateMoneyAndStockStm product price money stock -- shows compositionality 95 | 96 | isCardSystemWorking :: STM Bool 97 | isCardSystemWorking = undefined 98 | 99 | -- Merging if retry 100 | pay :: Eq a => a -> Integer -> TVar Integer -> TVar [(a,Integer)] -> STM () 101 | pay product price money stock = payByCard product price money stock `orElse` 102 | payByCash product price money stock 103 | 104 | payByCash :: Eq a => a -> Integer -> TVar Integer -> TVar [(a,Integer)] -> STM () 105 | payByCash = undefined 106 | 107 | --Use a queue 108 | 109 | main :: IO () 110 | main = do q <- newTQueueIO 111 | forkIO $ backend q 112 | forkN 10 $ frontend q 113 | _ <- getLine 114 | return () 115 | 116 | 117 | backend :: TQueue (String,Integer) -> IO () 118 | backend q = do 119 | m <- newTVarIO 10000 120 | s <- newTVarIO [("a",7)] 121 | forever $ atomically $ do (product,price) <- readTQueue q 122 | pay product price m s 123 | 124 | frontend :: TQueue (String,Integer) -> IO () 125 | frontend q = do (product,price) <- askClient 126 | atomically $ writeTQueue q (product,price) 127 | 128 | askClient :: IO (String,Integer) 129 | askClient = undefined 130 | -------------------------------------------------------------------------------- /chapter9/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter9/chapter9.cabal: -------------------------------------------------------------------------------- 1 | name: chapter9 2 | version: 0.1 3 | cabal-version: >=1.2 4 | build-type: Simple 5 | author: serras 6 | 7 | executable chapter9 8 | hs-source-dirs: src 9 | main-is: Basic.hs 10 | build-depends: base >= 4, haskeline, monad-loops, random, mtl, binary 11 | ghc-options: -Wall 12 | other-modules: Chapter9.Types 13 | 14 | executable chapter9-exn 15 | hs-source-dirs: src 16 | main-is: Exceptions.hs 17 | build-depends: base >= 4, random, mtl, cereal 18 | ghc-options: -Wall 19 | other-modules: Chapter9.Types 20 | 21 | executable chapter9-stream 22 | hs-source-dirs: src 23 | main-is: Streams.hs 24 | build-depends: base >= 4, random, mtl, conduit, deepseq, random, bytestring, binary, binary-conduit 25 | ghc-options: -Wall 26 | other-modules: Chapter9.Types 27 | 28 | executable chapter9-server 29 | hs-source-dirs: src 30 | main-is: Server.hs 31 | build-depends: base >= 4, mtl, random, network-conduit, conduit, binary, network 32 | ghc-options: -Wall 33 | other-modules: Chapter9.Types 34 | 35 | executable chapter9-client 36 | hs-source-dirs: src 37 | main-is: Client.hs 38 | build-depends: base >= 4, mtl, random, network-conduit, conduit, binary, network 39 | ghc-options: -Wall 40 | other-modules: Chapter9.Types 41 | 42 | -------------------------------------------------------------------------------- /chapter9/src/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Chapter9.Types 6 | import System.Console.Haskeline 7 | import Data.Maybe 8 | import Control.Monad 9 | import Control.Monad.Loops 10 | import System.Random 11 | import Data.List 12 | import Data.String 13 | import System.Environment 14 | import System.IO 15 | 16 | -- Different examples 17 | main :: IO () 18 | 19 | main = putStrLn "Hello Beginning Haskell!" 20 | 21 | {- 22 | main = do putStrLn "Where do you want to travel?" 23 | place <- getLine 24 | let year = (length place) * 10 25 | putStrLn $ "You should travel to year " ++ show year 26 | -} 27 | 28 | {- 29 | main = do putStrLn "First name?" 30 | fName <- getLine 31 | putStrLn "Last name?" 32 | lName <- getLine 33 | putChar '>' >> putChar ' ' 34 | print $ Person fName lName 35 | -} 36 | 37 | {- 38 | main = runInputT defaultSettings $ do 39 | fName <- getInputLine "First name? " 40 | lName <- getInputLine "Last name? " 41 | case (fName, lName) of 42 | (Just f, Just l) -> outputStrLn $ show (Person f l) 43 | (_ , _ ) -> outputStrLn "I cannot identify you" 44 | -} 45 | 46 | createVIPList :: Show a => [Client a] -> IO [Client a] 47 | createVIPList = foldM (\lst c -> do 48 | putStr "\nShould " 49 | putStr $ show c 50 | putStrLn " be included in the VIP list? " 51 | answer <- getLine 52 | case answer of 53 | 'Y':_ -> return $ c:lst 54 | _ -> return lst) [] 55 | 56 | {- 57 | main = do actionName <- getLine 58 | case lookup actionName listOfActions of 59 | Just action -> action 60 | Nothing -> putStrLn "Unknown action" 61 | -} 62 | 63 | listOfActions :: [(String, IO ())] 64 | listOfActions = [ 65 | ("greet", do name <- getLine 66 | putStrLn $ "Hello " ++ name), 67 | ("sum" , do putStrLn "First number:" 68 | n1 <- fmap read getLine 69 | putStrLn "Second number:" 70 | n2 <- fmap read getLine 71 | putStrLn $ show n1 ++ "+" ++ show n2 ++ "=" ++ show (n1+n2))] 72 | 73 | {- 74 | main = do (initial :: Int) <- fmap read getLine 75 | jumps <- unfoldrM (\_ -> do next <- randomRIO (0, 3000) 76 | if next == initial 77 | then return Nothing 78 | else return $ Just (next, next)) 79 | initial 80 | print $ take 10 jumps 81 | -} 82 | 83 | {- 84 | main = do (initial :: Int) <- fmap read getLine 85 | gen <- getStdGen 86 | print $ take 10 $ getJumps gen initial 87 | -} 88 | 89 | getJumps :: StdGen -> Int -> [Int] 90 | getJumps gen initial = unfoldr (\g -> let (next, nextG) = randomR (0, 3000) g in 91 | if next == initial 92 | then Nothing 93 | else Just (next, nextG)) 94 | gen 95 | 96 | {- 97 | main = do clients <- fmap lines $ readFile "clients.db" 98 | clientsAndWinners <- mapM (\c -> do (winner :: Bool) <- randomIO 99 | (year :: Int ) <- randomRIO (0, 3000) 100 | return (c, winner, year)) 101 | clients 102 | writeFile "clientsWinners.db" $ concatMap show clientsAndWinners 103 | -} 104 | 105 | {- 106 | main = do (inFile:outFile:_) <- getArgs 107 | inHandle <- openFile inFile ReadMode 108 | outHandle <- openFile outFile WriteMode 109 | loop inHandle outHandle 110 | hClose inHandle 111 | hClose outHandle 112 | where loop inHandle outHandle = do 113 | isEof <- hIsEOF inHandle 114 | if not isEof 115 | then do client <- hGetLine inHandle 116 | (winner :: Bool) <- randomIO 117 | (year :: Int ) <- randomRIO (0, 3000) 118 | hPutStrLn outHandle $ show (client, winner, year) 119 | loop inHandle outHandle 120 | -} 121 | 122 | {- 123 | main = do (inFile:outFile:_) <- getArgs 124 | withFile inFile ReadMode $ \inHandle -> 125 | withFile outFile WriteMode $ \outHandle -> 126 | loop inHandle outHandle 127 | where loop inHandle outHandle = do 128 | isEof <- hIsEOF inHandle 129 | if not isEof 130 | then do client <- hGetLine inHandle 131 | (winner :: Bool) <- randomIO 132 | (year :: Int ) <- randomRIO (0, 3000) 133 | hPutStrLn outHandle $ show (client, winner, year) 134 | loop inHandle outHandle 135 | else return () 136 | -} 137 | 138 | 139 | -------------------------------------------------------------------------------- /chapter9/src/Chapter9/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, DeriveGeneric #-} 2 | 3 | module Chapter9.Types where 4 | 5 | import Control.Monad.Error 6 | import Data.Binary 7 | import GHC.Generics 8 | 9 | data Client i = GovOrg { clientId :: i, clientName :: String } 10 | | Company { clientId :: i, clientName :: String 11 | , person :: Person, duty :: String } 12 | | Individual { clientId :: i, person :: Person } 13 | deriving Show 14 | 15 | data Person = Person { firstName :: String, lastName :: String } 16 | deriving (Show, Read, Generic) 17 | 18 | instance Binary Person 19 | 20 | data CompanyNameError = GovOrgArgument | IndividualArgument 21 | 22 | companyName :: MonadError CompanyNameError m => Client i -> m String 23 | companyName Company { clientName = n } = return n 24 | companyName GovOrg { } = throwError GovOrgArgument 25 | companyName Individual { } = throwError IndividualArgument 26 | 27 | companyNameDef :: MonadError CompanyNameError m => Client i -> m String 28 | companyNameDef c = companyName c `catchError` (\_ -> return "") 29 | -------------------------------------------------------------------------------- /chapter9/src/Client.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Trans 4 | import qualified Data.ByteString.Char8 as BS 5 | import Data.Conduit 6 | import Data.Conduit.Network 7 | import System.Environment 8 | import Network 9 | 10 | main :: IO () 11 | main = withSocketsDo $ do 12 | (name:_) <- getArgs 13 | runTCPClient (clientSettings 8900 (BS.pack "127.0.0.1")) (clientApp name) 14 | 15 | clientApp :: String -> Application IO 16 | clientApp name d = do (yield $ BS.pack name) $$ appSink d 17 | appSource d $$ (do Just w <- await 18 | lift $ BS.putStrLn w) 19 | -------------------------------------------------------------------------------- /chapter9/src/Exceptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} 2 | 3 | module Main where 4 | 5 | import Control.Exception 6 | import System.Random 7 | -- import System.IO.Error 8 | import System.IO 9 | import System.Environment 10 | import Data.Typeable 11 | 12 | main :: IO () 13 | 14 | {- 15 | main = do clients <- fmap lines $ readFile "clients.db" 16 | clientsAndWinners <- mapM (\c -> do (winner :: Bool) <- randomIO 17 | (year :: Int ) <- randomRIO (0, 3000) 18 | return (c, winner, year)) 19 | clients 20 | writeFile "clientsWinners.db" $ concatMap show clientsAndWinners 21 | `catch` (\(e :: IOException) -> if isDoesNotExistError e 22 | then putStrLn "File does not exist" 23 | else putStrLn $ "Other error: " ++ show e) 24 | -} 25 | 26 | {- 27 | main = do (n1 :: Int) <- fmap read getLine 28 | (n2 :: Int) <- fmap read getLine 29 | putStrLn $ show n1 ++ " / " ++ show n2 ++ " = " ++ show (n1 `div` n2) 30 | `catch` (\(_ :: ErrorCall) -> putStrLn "Error reading number") 31 | `catch` (\(e :: ArithException) -> case e of 32 | DivideByZero -> putStrLn "Division by zero" 33 | _ -> putStrLn $ "Other arithmetic error: " ++ show e) 34 | -} 35 | 36 | {- 37 | main = do (n1 :: Int) <- fmap read getLine 38 | (n2 :: Int) <- fmap read getLine 39 | putStrLn $ show n1 ++ " / " ++ show n2 ++ " = " ++ show (n1 `div` n2) 40 | `catches` [ Handler (\(_ :: ErrorCall) -> putStrLn "Error reading number") 41 | , Handler (\(e :: ArithException) -> case e of 42 | DivideByZero -> putStrLn "Division by zero" 43 | _ -> putStrLn $ "Other arithmetic error: " ++ show e)] 44 | -} 45 | 46 | {- 47 | main = handle (\(_ :: ErrorCall) -> putStrLn "Error reading number") $ 48 | handle (\(e :: ArithException) -> putStrLn $ show e) $ 49 | do (n1 :: Int) <- fmap read getLine 50 | (n2 :: Int) <- fmap read getLine 51 | putStrLn $ show n1 ++ " / " ++ show n2 ++ " = " ++ show (n1 `div` n2) 52 | -} 53 | 54 | {- 55 | main = do r <- try (do (n1 :: Int) <- fmap read getLine 56 | (n2 :: Int) <- fmap read getLine 57 | return $ (n1, n2, n1 `div` n2) ) 58 | case r of 59 | Right (n1, n2, q) -> putStrLn $ show n1 ++ " / " ++ show n2 ++ " = " ++ show q 60 | Left (_ :: SomeException) -> putStrLn $ "Error in quotient" 61 | -} 62 | 63 | {- 64 | main = catchJust (\e -> if e == DivideByZero then Just e else Nothing) 65 | (do (n1 :: Int) <- fmap read getLine 66 | (n2 :: Int) <- fmap read getLine 67 | putStrLn $ show n1 ++ " / " ++ show n2 ++ " = " ++ show (n1 `div` n2) 68 | `catch` (\(_ :: ErrorCall) -> putStrLn "Error reading number") ) 69 | (\_ -> putStrLn "Division by zero") 70 | -} 71 | 72 | {- 73 | main = do (inFile:outFile:_) <- getArgs 74 | inHandle <- openFile inFile ReadMode 75 | outHandle <- openFile outFile WriteMode 76 | ( loop inHandle outHandle 77 | `finally` (do hClose inHandle 78 | hClose outHandle) ) 79 | -} 80 | 81 | {- 82 | main = do (inFile:outFile:_) <- getArgs 83 | bracket (openFile inFile ReadMode) 84 | hClose 85 | (\inHandle -> bracket (openFile outFile WriteMode) 86 | hClose 87 | (\outHandle -> loop inHandle outHandle)) 88 | where loop inHandle outHandle = undefined 89 | -} 90 | 91 | {- 92 | main = do throw $ NoMethodError "I don't know what to do" 93 | `catch` (\(e :: SomeException) -> do putStr "An exception was thrown: " 94 | putStrLn $ show e) 95 | -} 96 | 97 | data AuthenticationException = UnknownUserName String 98 | | PasswordMismatch String 99 | | NotEnoughRights String 100 | deriving (Show, Typeable) 101 | 102 | instance Exception AuthenticationException 103 | 104 | main = do throw $ UnknownUserName "Alejandro" 105 | `catch` (\(e :: AuthenticationException) -> do putStr "An exception was thrown: " 106 | putStrLn $ show e) 107 | -------------------------------------------------------------------------------- /chapter9/src/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.Trans 6 | import qualified Data.ByteString.Char8 as BS 7 | import Data.Conduit 8 | import Data.Conduit.Network 9 | import Data.Monoid 10 | import System.Random 11 | import Network 12 | 13 | main :: IO () 14 | main = withSocketsDo $ runTCPServer (serverSettings 8900 HostAny) serverApp 15 | 16 | serverApp :: Application IO 17 | serverApp d = do appSource d $$ isWinner =$ appSink d 18 | 19 | isWinner :: Conduit BS.ByteString IO BS.ByteString 20 | isWinner = do client <- await 21 | case client of 22 | Nothing -> return () 23 | Just c -> do lift $ BS.putStrLn c 24 | (w :: Bool) <- liftIO $ randomIO 25 | (y :: Int ) <- liftIO $ randomRIO (0, 3000) 26 | yield $ c <> BS.pack (" " ++ show w ++ " " ++ show y) 27 | isWinner 28 | -------------------------------------------------------------------------------- /chapter9/src/Streams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} 2 | 3 | module Main where 4 | 5 | import System.IO 6 | import Control.DeepSeq 7 | import Data.Conduit 8 | import qualified Data.Conduit.List as L 9 | import Chapter9.Types 10 | import System.Random 11 | import Control.Monad.Trans 12 | import Control.Monad.State 13 | import qualified Data.ByteString.Char8 as BS 14 | import Data.Monoid 15 | import qualified Data.Conduit.Binary as B 16 | -- import qualified Data.Binary as S 17 | import qualified Data.Conduit.Serialization.Binary as S 18 | 19 | main :: IO () 20 | 21 | {- 22 | main = do h <- openFile "/home/serras/comandos" ReadMode 23 | s <- hGetContents h 24 | s `deepseq` hClose h 25 | print s 26 | -} 27 | 28 | {- 29 | main = do p <- L.sourceList [ GovOrg 1 "Zas", Individual 2 (Person "Alejandro" "Serrano")] $$ people =$ L.consume 30 | print p 31 | -} 32 | 33 | {- 34 | main = let clients = [ GovOrg 1 "Zas", Individual 2 (Person "Alejandro" "Serrano")] 35 | conduitGovOrgs = L.sourceList clients $$ countGovOrgs 36 | in print $ execState conduitGovOrgs 0 37 | -} 38 | 39 | {- 40 | main = runResourceT $ 41 | B.sourceFile "clients.db" $$ B.lines =$= winnersFile =$ B.sinkFile "clientsWinners.db" 42 | -} 43 | 44 | {- 45 | main = runResourceT $ L.sourceList clients $$ S.conduitEncode =$ B.sinkFile "people.db" 46 | where clients = [ Person "Alejandro" "Serrano", Person "The Doctor" "Who?" ] 47 | -} 48 | 49 | 50 | main = runResourceT $ 51 | B.sourceFile "people.db" $$ S.conduitDecode 52 | =$ L.mapM_ (\(p :: Person) -> lift $ putStrLn $ show p) 53 | 54 | 55 | people :: Monad m => Conduit (Client i) m Person 56 | people = do client <- await 57 | case client of 58 | Nothing -> return () 59 | Just c -> do case c of 60 | Company { person = p } -> yield p 61 | Individual { person = p } -> yield p 62 | _ -> return () 63 | people 64 | 65 | winners :: Conduit (Client i) IO (Client i, Bool, Int) 66 | winners = do client <- await 67 | case client of 68 | Nothing -> return () 69 | Just c -> do (w :: Bool) <- lift $ randomIO 70 | (y :: Int ) <- lift $ randomRIO (0, 3000) 71 | yield (c, w, y) 72 | winners 73 | 74 | countGovOrgs :: MonadState Int m => Sink (Client i) m Int 75 | countGovOrgs = do client <- await 76 | case client of 77 | Nothing -> do n <- lift $ get 78 | return n 79 | Just c -> do case c of 80 | GovOrg { } -> lift $ modify (+1) 81 | _ -> return () 82 | countGovOrgs 83 | 84 | winnersFile :: (Monad m, MonadIO m) => Conduit BS.ByteString m BS.ByteString 85 | winnersFile = do client <- await 86 | case client of 87 | Nothing -> return () 88 | Just c -> do (w :: Bool) <- liftIO $ randomIO 89 | (y :: Int ) <- liftIO $ randomRIO (0, 3000) 90 | yield $ c <> BS.pack (" " ++ show w ++ " " ++ show y) 91 | winnersFile 92 | 93 | -------------------------------------------------------------------------------- /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! --------------------------------------------------------------------------------