├── .gitignore ├── README.md ├── _config.yml ├── afp.html ├── cabal.project ├── css └── metropolis.css ├── hie.yaml ├── img ├── attack.png ├── attack1.png ├── attack2.png ├── attack3.png ├── attack4.png ├── attack5.png ├── diceroll.jpg ├── eeveecard.png ├── energy │ ├── colorless.webp │ ├── darkness.webp │ ├── dragon.webp │ ├── fighting.webp │ ├── fire.png │ ├── grass.webp │ ├── lightning.webp │ ├── metal.webp │ ├── psychic.webp │ └── water.webp ├── goomycard.png ├── grookeycard.png ├── haskell-rainbow.gif ├── libs.png ├── monads.png ├── pikachu.png ├── pikachucard.png ├── random_number.png ├── rps.png ├── session1.png ├── session2.png └── zurihac.svg ├── infofp.html ├── infofp ├── Monadic.hs ├── Task1.hs ├── Task2.hs ├── Task3.hs └── infofp.cabal ├── session1.html ├── session1 ├── Monadic.hs ├── Operational1.hs ├── Operational2.hs ├── Task1.hs ├── Task2.hs ├── Task3.hs └── session1.cabal ├── session2.html └── session2 ├── CloudyRolly.hs ├── DiceRoll.hs ├── DiceRollIncrement.hs ├── DiceRollSolution.hs └── session2.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist*/ -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [ZuriHac 2022](https://zfoh.ch/zurihac2022/) Workshop 2 | 3 | ## [Get the code!](https://github.com/serras/zurihac-workshop/releases) 4 | 5 | ## Slides 6 | 7 | [![The Legend of DSLs](img/session1.png)](http://serras.github.io/zurihac-workshop/session1) [![Adventures in IO](img/session2.png)](http://serras.github.io/zurihac-workshop/session2) -------------------------------------------------------------------------------- /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-tactile 2 | title: ZuriHac 2022 Workshop 3 | author: Alejandro Serrano 4 | social-network-links: 5 | github: serras 6 | twitter: trupill -------------------------------------------------------------------------------- /afp.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Haskell - The Legend of DSLs 5 | 6 | 12 | 13 | 14 | 865 | 867 | 870 | 871 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: session1/*.cabal session2/*.cabal -------------------------------------------------------------------------------- /css/metropolis.css: -------------------------------------------------------------------------------- 1 | @import url(https://fonts.googleapis.com/css?family=Fira+Sans:300,300i,400,400i,500,500i,700,700i); 2 | @import url(https://cdn.rawgit.com/tonsky/FiraCode/1.204/distr/fira_code.css); 3 | 4 | body { 5 | font-family: 'Fira Sans','Droid Serif', 'Palatino Linotype', 'Book Antiqua', Palatino, 'Microsoft YaHei', 'Songti SC', serif; 6 | } 7 | 8 | .remark-code, .remark-inline-code { 9 | font-family: 'Fira Code', 'Lucida Console', Monaco, monospace; 10 | font-size: 80%; 11 | } 12 | 13 | .remark-code-zoom { 14 | font-family: 'Fira Code', 'Lucida Console', Monaco, monospace; 15 | font-size: 100%; 16 | } 17 | 18 | .remark-slide-content { 19 | background-color: #FAFAFA; 20 | border-top: 90px solid #23373B; 21 | font-size: 36px; 22 | font-weight: 300; 23 | line-height: 1.5; 24 | padding: 1em 2em 1em 2em 25 | } 26 | 27 | .title-slide .inverse .remark-slide-content { 28 | background-color: #FAFAFA; 29 | } 30 | 31 | .inverse { 32 | background-color: #23373B; 33 | text-shadow: none; 34 | } 35 | 36 | .remark-slide-content > h1 { 37 | font-family: 'Fira Sans'; 38 | font-weight: normal; 39 | font-size: 45px; 40 | margin-top: -100px; 41 | margin-left: -00px; 42 | padding-bottom: 10px; 43 | color: #FAFAFA; 44 | line-height: 1; 45 | } 46 | 47 | .remark-slide-content > h1 > .remark-inline-code { 48 | background: none; 49 | } 50 | 51 | .remark-slide-content > ul { 52 | margin-top: -20px; 53 | } 54 | 55 | .remark-slide-content > inverse { 56 | width: 112px; 57 | height: 47px; 58 | border-bottom: 1px solid black; 59 | position: absolute; 60 | } 61 | 62 | /* Removes colored bar from top of the slide resulting in a clear slide */ 63 | .clear{ 64 | border-top: 0px solid #FAFAFA; 65 | } 66 | 67 | .remark-slide-content > h2, h3, h4 { 68 | padding-top: -15px; 69 | padding-bottom: 00px; 70 | color: #1A292C; 71 | text-shadow: none; 72 | font-weight: 400; 73 | text-align: left; 74 | margin-left: 00px; 75 | margin-bottom: -10px; 76 | } 77 | 78 | .remark-slide-content > h2, .pull-left > h2, .pull-right > h2 { 79 | font-size: 40px; 80 | } 81 | 82 | .remark-slide-content > h3, .remark-slide-content > h4, 83 | .pull-left > h3, .pull-left > h4, .pull-right > h3, .pull-right > h4 { 84 | font-size: 36px; 85 | } 86 | 87 | .remark-slide-content > blockquote { 88 | font-style: italic; 89 | color: grey; 90 | } 91 | 92 | .remark-slide-content .font80 > blockquote { 93 | font-style: italic; 94 | color: grey; 95 | } 96 | 97 | .blue { 98 | color: blue; 99 | } 100 | 101 | .margin-top { 102 | margin-top: 20px; 103 | } 104 | 105 | .little-margin-top { 106 | margin-top: -30px; 107 | margin-bottom: -15px; 108 | } 109 | 110 | .very-little-margin-top { 111 | margin-top: -45px; 112 | margin-bottom: -15px; 113 | } 114 | 115 | .less-line-height { 116 | line-height: 1; 117 | } 118 | 119 | .more-line-height { 120 | line-height: 1.2; 121 | } 122 | 123 | .grey { 124 | color: grey; 125 | } 126 | 127 | .smaller { 128 | font-size: 80%; 129 | } 130 | 131 | .title-slide { 132 | background-color: #FAFAFA; 133 | border-top: 80px solid #FAFAFA; 134 | } 135 | 136 | .title-slide > h1 { 137 | color: #1A292C; 138 | font-size: 50px; 139 | text-shadow: none; 140 | font-weight: 400; 141 | text-align: left; 142 | margin-left: 15px; 143 | padding-top: 80px; 144 | } 145 | .title-slide > h2 { 146 | margin-top: -25px; 147 | padding-bottom: -20px; 148 | color: #1A292C; 149 | text-shadow: none; 150 | font-weight: 300; 151 | font-size: 40px; 152 | text-align: left; 153 | margin-left: 15px; 154 | } 155 | .title-slide > h3 { 156 | color: #1A292C; 157 | text-shadow: none; 158 | font-weight: 300; 159 | font-size: 25px; 160 | text-align: left; 161 | margin-left: 15px; 162 | margin-bottom: -30px; 163 | } 164 | 165 | .align-left { 166 | text-align: left; 167 | } 168 | 169 | .remark-slide-number { 170 | font-size: 13pt; 171 | font-family: 'Fira Sans'; 172 | color: #272822; 173 | opacity: 1; 174 | } 175 | .inverse .remark-slide-number { 176 | font-size: 13pt; 177 | font-family: 'Fira Sans'; 178 | color: #FAFAFA; 179 | opacity: 1; 180 | } 181 | 182 | /* turns off slide numbers for title page: https://github.com/gnab/remark/issues/298 */ 183 | .title-slide .remark-slide-number { 184 | display: none; 185 | } 186 | 187 | .remark-inline-code { 188 | /* background: #F5F5F5; /* lighter */ 189 | background: #e7e8e2; /* darker */ 190 | border-radius: 3px; 191 | padding: 4px; 192 | } 193 | 194 | .code10 .remark-code { 195 | font-size: 10%; 196 | } 197 | 198 | .code20 .remark-code { 199 | font-size: 20%; 200 | } 201 | 202 | .code30 .remark-code { 203 | font-size: 30%; 204 | } 205 | 206 | .code40 .remark-code { 207 | font-size: 40%; 208 | } 209 | 210 | .code50 .remark-code { 211 | font-size: 50%; 212 | } 213 | 214 | .code60 .remark-code { 215 | font-size: 60%; 216 | } 217 | 218 | .code70 .remark-code { 219 | font-size: 70%; 220 | } 221 | 222 | .code80 .remark-code { 223 | font-size: 80%; 224 | } 225 | 226 | .code90 .remark-code { 227 | font-size: 90%; 228 | } 229 | 230 | .code100 .remark-code { 231 | font-size: 100%; 232 | } 233 | 234 | .font10 { 235 | font-size: 10%; 236 | } 237 | 238 | .font20 { 239 | font-size: 20%; 240 | } 241 | 242 | .font30 { 243 | font-size: 30%; 244 | } 245 | 246 | .font40 { 247 | font-size: 40%; 248 | } 249 | 250 | .font50 { 251 | font-size: 50%; 252 | } 253 | 254 | .font60 { 255 | font-size: 60%; 256 | } 257 | 258 | .font70 { 259 | font-size: 70%; 260 | } 261 | 262 | .font80 { 263 | font-size: 80%; 264 | } 265 | 266 | .font90 { 267 | font-size: 90%; 268 | } 269 | 270 | .font100 { 271 | font-size: 100%; 272 | } 273 | 274 | .font110 { 275 | font-size: 110%; 276 | } 277 | 278 | .font120 { 279 | font-size: 120%; 280 | } 281 | 282 | .font130 { 283 | font-size: 130%; 284 | } 285 | 286 | .font140 { 287 | font-size: 140%; 288 | } 289 | 290 | .font150 { 291 | font-size: 150%; 292 | } 293 | 294 | .font160 { 295 | font-size: 160%; 296 | } 297 | .font170 { 298 | font-size: 170%; 299 | } 300 | .font180 { 301 | font-size: 180%; 302 | } 303 | .font190 { 304 | font-size: 190%; 305 | } 306 | .font200 { 307 | font-size: 200%; 308 | } 309 | 310 | .strike { 311 | text-decoration: line-through; 312 | } -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "session1" 4 | component: "session1" 5 | - path: "session2" 6 | component: "session2" -------------------------------------------------------------------------------- /img/attack.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack.png -------------------------------------------------------------------------------- /img/attack1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack1.png -------------------------------------------------------------------------------- /img/attack2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack2.png -------------------------------------------------------------------------------- /img/attack3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack3.png -------------------------------------------------------------------------------- /img/attack4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack4.png -------------------------------------------------------------------------------- /img/attack5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/attack5.png -------------------------------------------------------------------------------- /img/diceroll.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/diceroll.jpg -------------------------------------------------------------------------------- /img/eeveecard.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/eeveecard.png -------------------------------------------------------------------------------- /img/energy/colorless.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/colorless.webp -------------------------------------------------------------------------------- /img/energy/darkness.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/darkness.webp -------------------------------------------------------------------------------- /img/energy/dragon.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/dragon.webp -------------------------------------------------------------------------------- /img/energy/fighting.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/fighting.webp -------------------------------------------------------------------------------- /img/energy/fire.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/fire.png -------------------------------------------------------------------------------- /img/energy/grass.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/grass.webp -------------------------------------------------------------------------------- /img/energy/lightning.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/lightning.webp -------------------------------------------------------------------------------- /img/energy/metal.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/metal.webp -------------------------------------------------------------------------------- /img/energy/psychic.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/psychic.webp -------------------------------------------------------------------------------- /img/energy/water.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/energy/water.webp -------------------------------------------------------------------------------- /img/goomycard.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/goomycard.png -------------------------------------------------------------------------------- /img/grookeycard.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/grookeycard.png -------------------------------------------------------------------------------- /img/haskell-rainbow.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/haskell-rainbow.gif -------------------------------------------------------------------------------- /img/libs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/libs.png -------------------------------------------------------------------------------- /img/monads.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/monads.png -------------------------------------------------------------------------------- /img/pikachu.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/pikachu.png -------------------------------------------------------------------------------- /img/pikachucard.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/pikachucard.png -------------------------------------------------------------------------------- /img/random_number.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/random_number.png -------------------------------------------------------------------------------- /img/rps.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/rps.png -------------------------------------------------------------------------------- /img/session1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/session1.png -------------------------------------------------------------------------------- /img/session2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serras/zurihac-workshop/cb6d87a650ea6590f7efa79990992adfb6c9c8ec/img/session2.png -------------------------------------------------------------------------------- /infofp.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Haskell - The Legend of DSLs 5 | 6 | 12 | 13 | 14 | 1043 | 1045 | 1048 | 1049 | -------------------------------------------------------------------------------- /infofp/Monadic.hs: -------------------------------------------------------------------------------- 1 | module Monadic where 2 | 3 | import Control.Monad (ap, liftM) 4 | import Control.Monad.Loops 5 | import GHC.Natural 6 | 7 | data FlipOutcome 8 | = Heads | Tails 9 | deriving (Eq) 10 | 11 | data Action a 12 | = FlipCoin (FlipOutcome -> Action a) 13 | | Return a 14 | 15 | instance Monad Action where 16 | return = _ 17 | x >>= f = _ 18 | 19 | instance Applicative Action where 20 | pure = Return 21 | (<*>) = ap 22 | 23 | instance Functor Action where 24 | fmap = liftM 25 | 26 | flipCoin :: Action FlipOutcome 27 | flipCoin = FlipCoin Return 28 | 29 | while :: Monad m => (a -> Bool) -> m a -> m [a] 30 | while = unfoldWhileM 31 | 32 | -- | Define Pikachu's "Iron Tail" attack 33 | -- 34 | -- > Flip a coin until you get tails. 35 | -- > This attack does 30 damage for each heads. 36 | ironTailAction :: Action Int 37 | ironTailAction = do 38 | heads <- while (/= Tails) flipCoin 39 | return (30 * length heads) -------------------------------------------------------------------------------- /infofp/Task1.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | module Task1 where 3 | 4 | import Data.Text 5 | import GHC.Natural 6 | 7 | data Energy = Colorless 8 | | Grass | Fire | Water 9 | | Lightning | Fighting | Psychic 10 | | Darkness | Metal | Dragon 11 | 12 | data Card = PokemonCard { name :: Text 13 | , typ :: Energy 14 | , hp :: Natural 15 | , attacks :: [Attack] } 16 | | EnergyCard { typ :: Energy } 17 | 18 | data Attack = Attack { attackName :: Text 19 | , cost :: [Energy] 20 | , damage :: Natural } 21 | 22 | 23 | -- Define values for the following cards 24 | 25 | -- | https://pokemoncard.io/card/?search=swsh1-11 26 | grookey :: Card 27 | grookey = _ 28 | 29 | -- | https://pokemoncard.io/card/?search=swsh8-195 30 | goomy :: Card 31 | goomy = _ 32 | 33 | -- | https://pokemoncard.io/card/?search=swsh4-130 34 | eevee :: Card 35 | eevee = _ 36 | 37 | 38 | -- | Check whether some energy cards are enough to 39 | -- "pay" for the cost of an attack 40 | enoughEnergy :: [Energy] -> [Card] -> Bool 41 | enoughEnergy cost attached = _ 42 | 43 | -- Then, refine it to return the missing energy 44 | missingEnergy :: [Energy] -> [Card] -> Maybe [Energy] 45 | missingEnergy cost attached = _ -------------------------------------------------------------------------------- /infofp/Task2.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language DeriveGeneric, DeriveAnyClass #-} 3 | module Task2 where 4 | 5 | import GHC.Natural 6 | import GHC.Generics 7 | import System.Random 8 | import System.Random.Stateful 9 | 10 | data FlipOutcome 11 | = Heads | Tails 12 | deriving (Generic, Finite, Uniform) 13 | 14 | data Action 15 | = FlipCoin (FlipOutcome -> Action) 16 | | Damage Natural 17 | 18 | surpriseAttackAction :: Action 19 | surpriseAttackAction 20 | = FlipCoin $ \case Heads -> Damage 30 21 | Tails -> Damage 0 22 | 23 | -- | Define Pikachu's "Iron Tail" attack 24 | -- 25 | -- > Flip a coin until you get tails. 26 | -- > This attack does 30 damage for each heads. 27 | ironTailAction :: Action 28 | ironTailAction = _ 29 | 30 | -- | Define the randomness interpretation of 'Action' 31 | interpretRandom :: Action -> IO Natural 32 | interpretRandom _ = _ 33 | where 34 | flipCoin :: IO FlipOutcome 35 | flipCoin = uniformM globalStdGen 36 | 37 | interpretPure :: [FlipOutcome] -> Action -> Natural 38 | interpretPure (result : future) (FlipCoin next) = 39 | interpretPure future (next result) 40 | interpretPure _future (Damage n) = n -------------------------------------------------------------------------------- /infofp/Task3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Task3 where 3 | 4 | import Data.Text ( Text ) 5 | import GHC.Natural ( Natural ) 6 | 7 | data Energy = Colorless 8 | | Grass | Fire | Water 9 | | Lightning | Fighting | Psychic 10 | | Darkness | Metal | Dragon 11 | 12 | data Card = PokemonCard { name :: Text 13 | , typ :: Energy 14 | , hp :: Natural 15 | , attacks :: [Attack] } 16 | | EnergyCard { typ :: Energy } 17 | 18 | data Attack = Attack { attackName :: Text 19 | , cost :: [Energy] 20 | , damage :: Natural } 21 | 22 | data FlipOutcome 23 | = Heads | Tails 24 | 25 | data Action 26 | = FlipCoin (FlipOutcome -> Action) 27 | | DrawCard (Maybe Card -> Action) 28 | | QueryAttached ([Card] -> Action) 29 | | Damage Natural 30 | 31 | drawN :: Natural -> ([Card] -> Action) -> Action 32 | drawN n next = _ 33 | where 34 | go n acc = _ -------------------------------------------------------------------------------- /infofp/infofp.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: infofp 3 | version: 0.1.0.0 4 | synopsis: The Legend of DSLs 5 | homepage: 6 | license: NONE 7 | author: Alejandro Serrano 8 | maintainer: trupill@gmail.com 9 | extra-source-files: 10 | README.md 11 | 12 | library 13 | exposed-modules: 14 | Task1 15 | Task2 16 | Task3 17 | Monadic 18 | Operational1 19 | Operational2 20 | -- other-modules: 21 | build-depends: base >= 4.14, text, random >= 1.2, monad-loops, mtl, tasty, tasty-quickcheck, generic-arbitrary 22 | default-language: Haskell2010 23 | ghc-options: -fdefer-typed-holes 24 | -------------------------------------------------------------------------------- /session1.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Haskell - The Legend of DSLs 5 | 6 | 12 | 13 | 14 | 874 | 876 | 879 | 880 | -------------------------------------------------------------------------------- /session1/Monadic.hs: -------------------------------------------------------------------------------- 1 | module Monadic where 2 | 3 | import Control.Monad (ap, liftM) 4 | import Control.Monad.Loops 5 | import GHC.Natural 6 | 7 | data FlipOutcome 8 | = Heads | Tails 9 | deriving (Eq) 10 | 11 | data Action a 12 | = FlipCoin (FlipOutcome -> Action a) 13 | | Return a 14 | 15 | instance Monad Action where 16 | return = _ 17 | x >>= f = _ 18 | 19 | instance Applicative Action where 20 | pure = Return 21 | (<*>) = ap 22 | 23 | instance Functor Action where 24 | fmap = liftM 25 | 26 | flipCoin :: Action FlipOutcome 27 | flipCoin = FlipCoin Return 28 | 29 | while :: Monad m => (a -> Bool) -> m a -> m [a] 30 | while = unfoldWhileM 31 | 32 | -- | Define Pikachu's "Iron Tail" attack 33 | -- 34 | -- > Flip a coin until you get tails. 35 | -- > This attack does 30 damage for each heads. 36 | ironTailAction :: Action Int 37 | ironTailAction = do 38 | heads <- while (/= Tails) flipCoin 39 | return (30 * length heads) -------------------------------------------------------------------------------- /session1/Operational1.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language RankNTypes #-} 3 | {-# language LambdaCase #-} 4 | {-# language DeriveGeneric, DeriveAnyClass #-} 5 | module Operational1 where 6 | 7 | import Control.Monad 8 | import Control.Monad.Loops 9 | import Data.List (genericLength) 10 | import Data.Text (Text) 11 | import GHC.Natural 12 | import GHC.Generics 13 | import System.Random 14 | import System.Random.Stateful 15 | 16 | data Energy = Colorless 17 | | Grass | Fire | Water 18 | | Lightning | Fighting | Psychic 19 | | Darkness | Metal | Dragon 20 | 21 | data Card = PokemonCard { name :: Text 22 | , typ :: Energy 23 | , hp :: Natural 24 | , attacks :: [Attack] } 25 | | EnergyCard { typ :: Energy } 26 | 27 | data Attack = Attack { attackName :: Text 28 | , cost :: [Energy] 29 | , damage :: Natural } 30 | 31 | data FlipOutcome 32 | = Heads | Tails 33 | deriving (Eq, Generic, Finite, Uniform) 34 | 35 | data Program instr a where 36 | Done :: a -> Program instr a 37 | (:>>=) :: instr a 38 | -> (a -> Program instr b) 39 | -> Program instr b 40 | 41 | data Action a where 42 | FlipCoin :: Action FlipOutcome 43 | DrawCard :: Action (Maybe Card) 44 | QueryAttached :: Action [Card] 45 | 46 | perform :: instr a -> Program instr a 47 | perform action = action :>>= Done 48 | 49 | instance Monad (Program instr) where 50 | return = Done 51 | Done x >>= k = k x 52 | (x :>>= k1) >>= k2 = x :>>= (\next -> k1 next >>= k2) 53 | 54 | instance Applicative (Program instr) where 55 | pure = Done 56 | (<*>) = ap 57 | 58 | instance Functor (Program instr) where 59 | fmap = liftM 60 | 61 | interpret :: Monad m 62 | => (forall x. instr x -> m x) 63 | -> Program instr a -> m a 64 | interpret f = go 65 | where 66 | go (Done x) = return x 67 | go (action :>>= k) = do 68 | x <- f action 69 | go (k x) 70 | -- f action >>= go . k 71 | 72 | interpretRandom :: Program Action a -> IO a 73 | interpretRandom = interpret $ \case 74 | FlipCoin -> uniformM globalStdGen 75 | _ -> undefined 76 | 77 | -- | Define Pikachu's "Iron Tail" attack 78 | -- 79 | -- > Flip a coin until you get tails. 80 | -- > This attack does 30 damage for each heads. 81 | ironTailAction :: Program Action Natural 82 | ironTailAction = do 83 | outcome <- perform FlipCoin 84 | case outcome of 85 | Tails -> pure 0 86 | Heads -> (30 +) <$> ironTailAction 87 | 88 | ironTailAction2 :: Program Action Natural 89 | ironTailAction2 = do 90 | heads <- unfoldWhileM (== Heads) (perform FlipCoin) 91 | pure $ 30 * genericLength heads 92 | 93 | -- | Draw 'n' cards. 94 | -- 95 | -- The resulting list may have fewer cards 96 | -- than requested, if there were not enough. 97 | drawN :: Natural -> Program Action [Card] 98 | drawN n = _ 99 | 100 | -- | Define "Ice Bonus" attacj 101 | -- 102 | -- > Discard a Water Energy card from your hand. 103 | -- > If you do, draw 3 cards. 104 | iceBonusAction :: Program Action Natural 105 | iceBonusAction = _ -------------------------------------------------------------------------------- /session1/Operational2.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language RankNTypes #-} 3 | {-# language LambdaCase #-} 4 | {-# language DeriveGeneric, DeriveAnyClass #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language DerivingVia #-} 7 | module Operational2 where 8 | 9 | import Control.Monad 10 | import Control.Monad.Loops 11 | import Control.Monad.State 12 | import Data.List (genericLength) 13 | import Data.Text (Text) 14 | import GHC.Natural 15 | import GHC.Generics 16 | import System.Random 17 | import System.Random.Stateful 18 | 19 | import Test.Tasty 20 | import Test.Tasty.QuickCheck 21 | import Test.QuickCheck.Arbitrary.Generic 22 | 23 | data FlipOutcome 24 | = Heads | Tails 25 | deriving (Show, Eq, Generic, Finite, Uniform) 26 | deriving (Arbitrary) via GenericArbitrary FlipOutcome 27 | 28 | data Program instr a where 29 | Done :: a -> Program instr a 30 | (:>>=) :: instr a 31 | -> (a -> Program instr b) 32 | -> Program instr b 33 | 34 | data Action a where 35 | FlipCoin :: Action FlipOutcome 36 | 37 | perform :: instr a -> Program instr a 38 | perform action = action :>>= Done 39 | 40 | instance Monad (Program instr) where 41 | return = Done 42 | Done x >>= k = k x 43 | (x :>>= k1) >>= k2 = x :>>= (\next -> k1 next >>= k2) 44 | 45 | instance Applicative (Program instr) where 46 | pure = Done 47 | (<*>) = ap 48 | 49 | instance Functor (Program instr) where 50 | fmap = liftM 51 | 52 | interpret :: Monad m 53 | => (forall x. instr x -> m x) 54 | -> Program instr a -> m a 55 | interpret f = go 56 | where 57 | go (Done x) = return x 58 | go (action :>>= k) = do 59 | x <- f action 60 | go (k x) 61 | -- f action >>= go . k 62 | 63 | interpretRandom :: Program Action a -> IO a 64 | interpretRandom = interpret $ \case 65 | FlipCoin -> uniformM globalStdGen 66 | 67 | interpretPure :: [FlipOutcome] -> Program Action a -> a 68 | interpretPure outcomes = 69 | flip evalState (cycle outcomes) . interpret f 70 | where f :: Action x -> State [FlipOutcome] x 71 | f FlipCoin = do 72 | ~(result : nexts) <- get 73 | put nexts 74 | return result 75 | 76 | interpretPure2 :: [FlipOutcome] -> Program Action a -> a 77 | interpretPure2 outcomes = go (cycle outcomes) 78 | where go :: [FlipOutcome] -> Program Action x -> x 79 | go _ (Done x) = x 80 | go ~(result : nexts) (FlipCoin :>>= k) = 81 | go nexts (k result) 82 | 83 | --- >>> interpretPure [Heads, Heads, Tails] ironTailAction 84 | -- 60 85 | ironTailAction :: Program Action Natural 86 | ironTailAction = do 87 | outcome <- perform FlipCoin 88 | case outcome of 89 | Tails -> pure 0 90 | Heads -> (30 +) <$> ironTailAction 91 | 92 | ironTailAction2 :: Program Action Natural 93 | ironTailAction2 = do 94 | heads <- unfoldWhileM (== Heads) (perform FlipCoin) 95 | pure $ 30 * genericLength heads 96 | 97 | tests :: TestTree 98 | tests = 99 | testGroup "Iron Tail" 100 | [ testProperty "non-negative" $ \outcomes -> 101 | interpretPure (outcomes ++ [Tails]) ironTailAction >= 0 102 | , testProperty "30 times # of heads" $ \(noOfHeads :: Int) -> 103 | noOfHeads > 0 ==> 104 | interpretPure (replicate noOfHeads Heads ++ [Tails]) ironTailAction 105 | == fromIntegral (noOfHeads * 30) 106 | -- write a property for implementations to coincide 107 | ] 108 | -------------------------------------------------------------------------------- /session1/Task1.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | module Task1 where 3 | 4 | import Data.Text 5 | import GHC.Natural 6 | 7 | data Energy = Colorless 8 | | Grass | Fire | Water 9 | | Lightning | Fighting | Psychic 10 | | Darkness | Metal | Dragon 11 | 12 | data Card = PokemonCard { name :: Text 13 | , typ :: Energy 14 | , hp :: Natural 15 | , attacks :: [Attack] } 16 | | EnergyCard { typ :: Energy } 17 | 18 | data Attack = Attack { attackName :: Text 19 | , cost :: [Energy] 20 | , damage :: Natural } 21 | 22 | 23 | -- Define values for the following cards 24 | 25 | -- | https://pokemoncard.io/card/?search=swsh1-11 26 | grookey :: Card 27 | grookey = _ 28 | 29 | -- | https://pokemoncard.io/card/?search=swsh8-195 30 | goomy :: Card 31 | goomy = _ 32 | 33 | -- | https://pokemoncard.io/card/?search=swsh4-130 34 | eevee :: Card 35 | eevee = _ 36 | 37 | 38 | -- | Check whether some energy cards are enough to 39 | -- "pay" for the cost of an attack 40 | enoughEnergy :: [Energy] -> [Card] -> Bool 41 | enoughEnergy cost attached = _ 42 | 43 | -- Then, refine it to return the missing energy 44 | missingEnergy :: [Energy] -> [Card] -> Maybe [Energy] 45 | missingEnergy cost attached = _ -------------------------------------------------------------------------------- /session1/Task2.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language DeriveGeneric, DeriveAnyClass #-} 3 | module Task2 where 4 | 5 | import GHC.Natural 6 | import GHC.Generics 7 | import System.Random 8 | import System.Random.Stateful 9 | 10 | data FlipOutcome 11 | = Heads | Tails 12 | deriving (Generic, Finite, Uniform) 13 | 14 | data Action 15 | = FlipCoin (FlipOutcome -> Action) 16 | | Damage Natural 17 | 18 | surpriseAttackAction :: Action 19 | surpriseAttackAction 20 | = FlipCoin $ \case Heads -> Damage 30 21 | Tails -> Damage 0 22 | 23 | -- | Define Pikachu's "Iron Tail" attack 24 | -- 25 | -- > Flip a coin until you get tails. 26 | -- > This attack does 30 damage for each heads. 27 | ironTailAction :: Action 28 | ironTailAction = _ 29 | 30 | -- | Define the randomness interpretation of 'Action' 31 | interpretRandom :: Action -> IO Natural 32 | interpretRandom _ = _ 33 | where 34 | flipCoin :: IO FlipOutcome 35 | flipCoin = uniformM globalStdGen 36 | 37 | interpretPure :: [FlipOutcome] -> Action -> Natural 38 | interpretPure (result : future) (FlipCoin next) = 39 | interpretPure future (next result) 40 | interpretPure _future (Damage n) = n -------------------------------------------------------------------------------- /session1/Task3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Task3 where 3 | 4 | import Data.Text ( Text ) 5 | import GHC.Natural ( Natural ) 6 | 7 | data Energy = Colorless 8 | | Grass | Fire | Water 9 | | Lightning | Fighting | Psychic 10 | | Darkness | Metal | Dragon 11 | 12 | data Card = PokemonCard { name :: Text 13 | , typ :: Energy 14 | , hp :: Natural 15 | , attacks :: [Attack] } 16 | | EnergyCard { typ :: Energy } 17 | 18 | data Attack = Attack { attackName :: Text 19 | , cost :: [Energy] 20 | , damage :: Natural } 21 | 22 | data FlipOutcome 23 | = Heads | Tails 24 | 25 | data Action 26 | = FlipCoin (FlipOutcome -> Action) 27 | | DrawCard (Maybe Card -> Action) 28 | | QueryAttached ([Card] -> Action) 29 | | Damage Natural 30 | 31 | drawN :: Natural -> ([Card] -> Action) -> Action 32 | drawN n next = _ 33 | where 34 | go n acc = _ -------------------------------------------------------------------------------- /session1/session1.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: session1 3 | version: 0.1.0.0 4 | synopsis: The Legend of DSLs - Workshop presented at ZuriHac 2022 5 | homepage: 6 | license: NONE 7 | author: Alejandro Serrano 8 | maintainer: trupill@gmail.com 9 | extra-source-files: 10 | README.md 11 | 12 | library 13 | exposed-modules: 14 | Task1 15 | Task2 16 | Task3 17 | Monadic 18 | Operational1 19 | Operational2 20 | -- other-modules: 21 | build-depends: base >= 4.14, text, random >= 1.2, monad-loops, mtl, tasty, tasty-quickcheck, generic-arbitrary 22 | default-language: Haskell2010 23 | ghc-options: -fdefer-typed-holes 24 | -------------------------------------------------------------------------------- /session2.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Haskell - Adventures in IO 5 | 6 | 12 | 13 | 14 | 828 | 830 | 833 | 834 | -------------------------------------------------------------------------------- /session2/CloudyRolly.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language ScopedTypeVariables #-} 3 | {-# language TypeApplications #-} 4 | {-# language DeriveGeneric, DeriveAnyClass #-} 5 | module CloudyRolly where 6 | 7 | import Control.Concurrent.STM 8 | import Control.Monad (replicateM) 9 | import Control.Monad.IO.Class 10 | import Data.Aeson 11 | import Data.ByteString (ByteString) 12 | import qualified Data.ByteString.Lazy as LBS 13 | import Data.HashMap.Strict (HashMap) 14 | import qualified Data.HashMap.Strict as Map 15 | import Data.Text (Text) 16 | import qualified Data.Text 17 | import GHC.Generics 18 | import Network.Simple.TCP 19 | import System.Random 20 | 21 | type GameCode = Text 22 | 23 | data Request 24 | = NewGame 25 | | JoinGame GameCode 26 | deriving (Eq, Show, Generic, FromJSON, ToJSON) 27 | 28 | data Response 29 | = GameCode GameCode 30 | | GameNotFound 31 | | GameStarts 32 | deriving (Eq, Show, Generic, FromJSON, ToJSON) 33 | 34 | type State = HashMap GameCode [Socket] 35 | 36 | crServer :: IO () 37 | crServer = do 38 | state <- newTVarIO @State Map.empty 39 | serve "127.0.0.1" "8080" $ \(skt, _) -> 40 | crServerWorker state skt 41 | 42 | crServerWorker :: TVar State -> Socket -> IO () 43 | crServerWorker state skt = start 44 | where 45 | start = do 46 | Just req <- recvJson skt 47 | case req of 48 | NewGame -> newGame 49 | JoinGame code -> joinGame code 50 | 51 | newGame = do 52 | code <- randomCode 53 | atomically $ 54 | modifyTVar state (Map.insert code [skt]) 55 | sendJson skt (GameCode code) 56 | atomically $ do 57 | Just skts <- Map.lookup code <$> readTVar state 58 | check (length skts > 1) 59 | sendJson skt GameStarts 60 | play 61 | 62 | joinGame code = do 63 | found <- atomically $ do 64 | result <- Map.lookup code <$> readTVar state 65 | case result of 66 | Nothing -> pure False 67 | Just skts -> do 68 | modifyTVar state (Map.insertWith (<>) code [skt]) 69 | pure True 70 | if found 71 | then sendJson skt GameStarts >> play 72 | else sendJson skt GameNotFound 73 | 74 | play = putStrLn "play!" 75 | 76 | player1Client :: IO () 77 | player1Client = connect "127.0.0.1" "8080" $ \(skt, _) -> do 78 | sendJson skt NewGame 79 | Just (GameCode code) <- recvJson skt 80 | putStrLn $ "code: " <> Data.Text.unpack code 81 | Just GameStarts <- recvJson skt 82 | putStrLn "game starts!" 83 | 84 | player2Client :: GameCode -> IO () 85 | player2Client code = connect "127.0.0.1" "8080" $ \(skt, _) -> do 86 | sendJson skt (JoinGame code) 87 | Just GameStarts <- recvJson skt 88 | putStrLn "game starts!" 89 | 90 | -- UTILITIES 91 | -- ========= 92 | 93 | instance MonadFail STM where 94 | fail _ = retry 95 | 96 | randomCode :: (MonadIO m) => m Text 97 | randomCode = liftIO $ 98 | Data.Text.pack <$> replicateM 4 (randomRIO ('A', 'Z')) 99 | 100 | recvJson :: (MonadIO m, FromJSON a) => Socket -> m (Maybe a) 101 | recvJson skt = do 102 | line <- recvLine skt 103 | case line of 104 | Nothing -> pure Nothing 105 | Just l -> pure $ decodeStrict l 106 | 107 | sendJson :: (MonadIO m, ToJSON a) => Socket -> a -> m () 108 | sendJson skt x = send skt (LBS.toStrict $ encode x) >> send skt "\n" 109 | 110 | -- | Receive until we obtain @\n@ 111 | recvLine :: MonadIO m => Socket -> m (Maybe ByteString) 112 | recvLine skt = do 113 | mayFirst <- recv skt 1 114 | case mayFirst of 115 | Nothing -> pure Nothing 116 | Just "\n" -> pure $ Just "" 117 | Just first -> Just . (first <>) <$> go 118 | where 119 | go = do 120 | more <- recv skt 1 121 | case more of 122 | Nothing -> pure mempty 123 | Just "\n" -> pure mempty 124 | Just c -> (c <>) <$> go -------------------------------------------------------------------------------- /session2/DiceRoll.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language TypeApplications #-} 3 | module DiceRoll where 4 | 5 | import Control.Monad.IO.Class 6 | import Data.ByteString 7 | import Data.Serialize 8 | import Data.Word 9 | import Network.Simple.TCP 10 | import System.Random 11 | 12 | diceServer :: IO () 13 | diceServer = serve "127.0.0.1" "8080" $ \(skt, adr) -> go skt 14 | where 15 | go :: Socket -> IO () 16 | go skt = do 17 | -- read and parse request 18 | mayBytes <- recv skt 8 19 | case mayBytes of 20 | Nothing -> pure () 21 | Just bytes -> do 22 | let Right max = decode @Word64 bytes 23 | response <- encode <$> randomRIO (1, max) 24 | -- send a response 25 | send skt response 26 | go skt 27 | 28 | diceClient :: Word64 -> IO Word64 29 | diceClient n = _ 30 | -------------------------------------------------------------------------------- /session2/DiceRollIncrement.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language TypeApplications #-} 3 | {-# language DeriveGeneric, DeriveAnyClass #-} 4 | module DiceRollIncrement where 5 | 6 | import Control.Monad.IO.Class 7 | import Data.ByteString 8 | import Data.Serialize 9 | import Data.Word 10 | import GHC.Generics 11 | import Network.Simple.TCP 12 | import System.Random 13 | 14 | data Request 15 | = DiceRoll { max :: Word64 } 16 | | Increment { number :: Word64 } 17 | deriving (Generic, Serialize) 18 | 19 | type Response = Word64 20 | 21 | diceServer :: IO () 22 | diceServer = serve "127.0.0.1" "8080" $ \(skt, adr) -> go skt 23 | where 24 | go :: Socket -> IO () 25 | go skt = do 26 | -- read and parse request 27 | mayBytes <- recv skt 9 -- 1 + 8 info 28 | case mayBytes of 29 | Nothing -> pure () 30 | Just bytes -> do 31 | let Right req = decode @Request bytes 32 | response <- case req of 33 | DiceRoll max -> randomRIO (1, max) 34 | Increment n -> pure (n + 1) 35 | -- send a response 36 | send skt (encode response) 37 | go skt 38 | 39 | diceClient :: Word64 -> IO Word64 40 | diceClient n = connect "127.0.0.1" "8080" $ \(skt, _) -> do 41 | send skt (encode $ DiceRoll n) 42 | Just bytes <- recv skt 8 43 | let Right result = decode @Word64 bytes 44 | pure result 45 | 46 | incrementClient :: Word64 -> IO Word64 47 | incrementClient n = connect "127.0.0.1" "8080" $ \(skt, _) -> do 48 | send skt (encode $ Increment n) 49 | Just bytes <- recv skt 8 50 | let Right result = decode @Word64 bytes 51 | pure result 52 | -------------------------------------------------------------------------------- /session2/DiceRollSolution.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language TypeApplications #-} 3 | {-# language ScopedTypeVariables #-} 4 | module DiceRollSolution where 5 | 6 | import Control.Exception.Safe 7 | import Control.Monad.IO.Class 8 | import Data.ByteString 9 | import Data.Serialize 10 | import Data.Word 11 | import Network.Simple.TCP 12 | import System.Random 13 | 14 | diceServer :: IO () 15 | diceServer = serve "127.0.0.1" "8080" $ \(skt, adr) -> go skt 16 | where 17 | go :: Socket -> IO () 18 | go skt = do 19 | -- read and parse request 20 | mayBytes <- recv skt 8 21 | case mayBytes of 22 | Nothing -> pure () 23 | Just bytes -> do 24 | let Right max = decode @Word64 bytes 25 | response <- encode <$> randomRIO (1, max) 26 | -- send a response 27 | send skt response 28 | go skt 29 | 30 | diceClient :: Word64 -> IO Word64 31 | diceClient n = connect "127.0.0.1" "8080" $ \(skt, _) -> do 32 | send skt (encode n) 33 | Just bytes <- recv skt 8 34 | let Right result = decode @Word64 bytes 35 | pure result 36 | 37 | diceClientExn :: Word64 -> IO (Maybe Word64) 38 | diceClientExn n = connect "127.0.0.1" "8080" (\(skt, _) -> do 39 | send skt (encode n) 40 | Just bytes <- recv skt 8 41 | let Right result = decode @Word64 bytes 42 | pure $ Just result) 43 | `catch` 44 | (\(e :: IOException) -> pure Nothing) 45 | -------------------------------------------------------------------------------- /session2/session2.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: session2 3 | version: 0.1.0.0 4 | synopsis: Adventures in IO - Workshop presented at ZuriHac 2022 5 | homepage: 6 | license: NONE 7 | author: Alejandro Serrano 8 | maintainer: trupill@gmail.com 9 | extra-source-files: 10 | README.md 11 | 12 | library 13 | exposed-modules: DiceRoll, DiceRollSolution, DiceRollIncrement, CloudyRolly 14 | -- other-modules: 15 | build-depends: base >= 4.14, network-simple, bytestring, cereal, random, aeson, text, safe-exceptions, stm, unordered-containers 16 | default-language: Haskell2010 17 | ghc-options: -fdefer-typed-holes 18 | --------------------------------------------------------------------------------