├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── css ├── layout.css └── style.css ├── deploy.sh ├── errata.md ├── extensions.csv ├── extensions.html ├── img ├── .gitignore ├── Haskell-Logo.ps ├── Makefile ├── class.dot ├── class.png ├── cover.ps ├── criterion.png ├── diagram1.png ├── diagram1.svg ├── ekg.png ├── ghc.dot ├── ghc.png ├── graph1.dot ├── graph1.png ├── graph2.dot ├── graph2.png ├── graphviz.png ├── haskell_logo.svg ├── lambda.png ├── matrix.svg ├── numerics.dot ├── numerics.png ├── par.dot ├── par.png ├── threadscope.png ├── title.png ├── transformer_unroll.png ├── transformer_unroll.svg ├── tree.dot └── tree.png ├── includes.hs ├── js └── nav.js ├── resources ├── back.tex ├── copyright.html ├── copyright.md ├── copyright.tex ├── cover.tex ├── dtrt.sty ├── haskell.sty ├── template.epub ├── template.html ├── template.tex └── unicodemapping.tex ├── shell.nix ├── src ├── .gitignore ├── 01-basics │ ├── bottoms.hs │ ├── ci │ ├── defer.hs │ ├── errors.hs │ ├── fail.hs │ ├── ghci.conf │ ├── mylibrary.cabal │ ├── stack.yaml │ ├── stacktrace.hs │ ├── trace.hs │ └── typedhole.hs ├── 02-monads │ ├── ci │ ├── example.cabal │ ├── list.hs │ ├── list_impl.hs │ ├── maybe.hs │ ├── maybe_impl.hs │ ├── reader.hs │ ├── reader_impl.hs │ ├── stack.yaml │ ├── state.hs │ ├── state_impl.hs │ ├── writer.hs │ └── writer_impl.hs ├── 03-monad-transformers │ ├── cabal.project │ ├── ci │ ├── duplicate_fields.hs │ ├── example.cabal │ ├── mini-fused │ │ ├── Main.hs │ │ ├── example.cabal │ │ └── stack.yaml │ ├── newtype.hs │ ├── newtype_deriving.hs │ ├── overloaded_labels.hs │ ├── polysemy.hs │ ├── stack.yaml │ └── transformer.hs ├── 04-extensions │ ├── application.hs │ ├── ci │ ├── derive_any.hs │ ├── derive_functor.hs │ ├── derive_traversable.hs │ ├── derive_via.hs │ ├── example.cabal │ ├── flexcontexts.hs │ ├── flexinstances.hs │ ├── folding.hs │ ├── incoherent.hs │ ├── incoherent_anno.hs │ ├── lambdacase.hs │ ├── monomorphism.hs │ ├── overlapping.hs │ ├── overlapping_anno.hs │ ├── partial_type_signatures.hs │ ├── patterns.hs │ ├── safe.hs │ ├── stack.yaml │ ├── synonym.hs │ ├── views.hs │ ├── wildcards.hs │ └── wildcards_update.hs ├── 05-laziness │ ├── ci │ ├── diverge.ml │ ├── lazy_patterns.hs │ └── nodiverge.hs ├── 06-prelude │ ├── ci │ ├── example.cabal │ ├── foldable_traversable.hs │ ├── split.hs │ └── stack.yaml ├── 07-text-bytestring │ ├── builder.hs │ ├── bytestring.hs │ ├── ci │ ├── convert.hs │ ├── example.cabal │ ├── overloadedlist.hs │ ├── printf.hs │ ├── regex.hs │ ├── stack.yaml │ └── text.hs ├── 08-applicatives │ ├── applicative.hs │ ├── ci │ └── variadic.hs ├── 09-errors │ ├── ci │ ├── either.hs │ ├── either_impl.hs │ ├── errors.hs │ ├── example.cabal │ ├── exceptions.hs │ ├── exceptt.hs │ ├── ioexception.hs │ ├── spoon.hs │ └── stack.yaml ├── 10-advanced-monads │ ├── base.hs │ ├── ci │ ├── cont.hs │ ├── cont_impl.hs │ ├── example.cabal │ ├── free_dsl.hs │ ├── free_impl.hs │ ├── function.hs │ ├── indexed.hs │ ├── logict.hs │ ├── mmorph.hs │ ├── monadfix.hs │ ├── monadplus.hs │ ├── partiality.hs │ ├── rws.hs │ ├── st.hs │ └── stack.yaml ├── 11-quantification │ ├── ci │ ├── example.cabal │ ├── existential.hs │ ├── impredicative.hs │ ├── rankn.hs │ ├── scopedtvars.hs │ ├── skolem_capture.hs │ ├── stack.yaml │ └── universal.hs ├── 12-gadts │ ├── ci │ ├── equal.hs │ ├── example.cabal │ ├── gadt.hs │ ├── kindsignatures.hs │ ├── phantom.hs │ ├── phantom_example.hs │ ├── propositional_equal.hs │ └── stack.yaml ├── 13-lambda-calculus │ ├── church_encoding.hs │ ├── church_list.hs │ ├── ci │ ├── debruijn.hs │ ├── example.cabal │ ├── hoas.hs │ ├── phoas.hs │ └── stack.yaml ├── 14-interpreters │ ├── catamorphism.hs │ ├── ci │ ├── example.cabal │ ├── factorial.hs │ ├── fext.hs │ ├── final.hs │ ├── initial.hs │ ├── initial_interpreter.hs │ ├── recursion_schemes.hs │ └── stack.yaml ├── 15-testing │ ├── arbitrary.hs │ ├── ci │ ├── criterion.hs │ ├── example.cabal │ ├── qcheck.hs │ ├── quickspec.hs │ ├── silently.hs │ ├── smallcheck.hs │ ├── smallcheck_series.hs │ ├── smallcheck_tree.hs │ ├── stack.yaml │ └── tasty.hs ├── 16-type-families │ ├── ci │ ├── constraintkinds.hs │ ├── datafamily.hs │ ├── dict.hs │ ├── example.cabal │ ├── family_nat_operators.hs │ ├── family_type.hs │ ├── fundeps.hs │ ├── mparam.hs │ ├── mparam_fun.hs │ ├── noempty.hs │ ├── proof.hs │ ├── role_infer.hs │ ├── roles.hs │ └── stack.yaml ├── 17-promotion │ ├── Vector.agda │ ├── ci │ ├── closed_typefamily.hs │ ├── constraint_list.hs │ ├── countargs.hs │ ├── datakinds.hs │ ├── errors.hs │ ├── errors_dsl.hs │ ├── example.cabal │ ├── hasfield.hs │ ├── hlist.hs │ ├── kindpoly.hs │ ├── nonempty.hs │ ├── reverse.hs │ ├── reverse_nat.hs │ ├── singleton.hs │ ├── singleton_class.hs │ ├── stack.yaml │ ├── type_equality.hs │ ├── typefamily.hs │ ├── typelevel_fields.hs │ ├── typelevel_strings.hs │ ├── typemap.hs │ ├── typenat.hs │ └── typenat_cmp.hs ├── 18-generics │ ├── biplate.hs │ ├── cereal.hs │ ├── ci │ ├── data.hs │ ├── derive_aeson.hs │ ├── dynamic.hs │ ├── example.cabal │ ├── generic_impl.hs │ ├── generics.hs │ ├── hashable.hs │ ├── stack.yaml │ ├── typeable.hs │ └── uniplate.hs ├── 19-numbers │ ├── arithmoi.hs │ ├── ci │ ├── creal.hs │ ├── diffeq │ │ ├── Main.hs │ │ ├── example.cabal │ │ └── stack.yaml │ ├── example.cabal │ ├── polynomial.hs │ ├── puzzle.hs │ ├── scientific.hs │ ├── stack.yaml │ └── stats.hs ├── 20-data-structures │ ├── ci │ ├── dlist.hs │ ├── example.cabal │ ├── graph.hs │ ├── hashtables.hs │ ├── hblas.hs │ ├── map.hs │ ├── sequence.hs │ ├── set.hs │ ├── stack.yaml │ ├── tree.hs │ ├── unordered.hs │ ├── vector.hs │ └── vector_mutable.hs ├── 21-ffi │ ├── ci │ ├── example.cabal │ ├── ffi.hs │ ├── mini-hsc │ │ ├── Example.hs │ │ ├── Example.hsc │ │ └── msghdr.c │ ├── pointer.c │ ├── pointer_use.hs │ ├── qsort.c │ ├── simple.c │ ├── simple_ffi.hs │ └── stack.yaml ├── 22-concurrency │ ├── async.hs │ ├── ci │ ├── example.cabal │ ├── par.hs │ ├── spark.hs │ ├── sparks.hs │ ├── stack.yaml │ ├── stm.hs │ ├── strategies.hs │ └── strategies_param.hs ├── 23-graphics │ └── diagrams.hs ├── 24-parsing │ ├── attoparsec.hs │ ├── attoparsec_lang.hs │ ├── ci │ ├── configurator.hs │ ├── example.cabal │ ├── example.config │ ├── generics.hs │ ├── happy │ │ ├── Eval.hs │ │ ├── Lexer.x │ │ ├── Main.hs │ │ ├── Parser.y │ │ ├── Syntax.hs │ │ ├── example.cabal │ │ ├── input.test │ │ └── stack.yaml │ ├── lexer_text.hs │ ├── megaparsec.hs │ ├── optparse_applicative.hs │ ├── optparse_generic.hs │ ├── parsec_applicative.hs │ ├── parsec_operators.hs │ ├── parser.hs │ ├── recursive-generics.hs │ ├── simple.ml │ ├── simple_parser.hs │ └── stack.yaml ├── 25-streaming │ ├── ci │ ├── conduit.hs │ ├── example.cabal │ ├── foo.txt │ ├── lazyio.hs │ ├── pipes.hs │ ├── pipes_file.hs │ ├── pipes_io.hs │ ├── pipes_safe.hs │ └── stack.yaml ├── 26-data-formats │ ├── aeson_custom.hs │ ├── aeson_derive.hs │ ├── aeson_structured.hs │ ├── aeson_unstructured.hs │ ├── cassava_structured.hs │ ├── cassava_unstructured.hs │ ├── ci │ ├── crew.json │ ├── example.cabal │ ├── example.json │ ├── example.yaml │ ├── iris.csv │ ├── stack.yaml │ └── yaml.hs ├── 27-web │ ├── blaze.hs │ ├── blaze_instance.hs │ ├── ci │ ├── example.cabal │ ├── hastache.hs │ ├── hastache_generic.hs │ ├── http.hs │ ├── lucid.hs │ ├── mini-servant │ │ ├── Main.hs │ │ ├── example.cabal │ │ └── stack.yaml │ ├── req.hs │ ├── scotty.hs │ ├── stack.yaml │ └── warp.hs ├── 28-databases │ ├── acid.hs │ ├── books.db │ ├── booktown.sql │ ├── ci │ ├── example.cabal │ ├── hedis.hs │ ├── hedis_pubsub.hs │ ├── mini-selda │ │ ├── Main.hs │ │ ├── company.sqlite │ │ ├── example.cabal │ │ └── stack.yaml │ ├── postgres.hs │ ├── postgres_custom.hs │ ├── postgres_qq.hs │ ├── selda.hs │ ├── sqlite.hs │ └── stack.yaml ├── 29-ghc │ ├── artifacts │ │ ├── example.dump-asm │ │ ├── example.dump-cmm │ │ ├── example.dump-parsed │ │ ├── example.dump-simpl │ │ └── example.dump-stg │ ├── ci │ ├── closure_size.hs │ ├── cmm │ │ ├── Main.hs │ │ ├── example.cabal │ │ ├── example.cmm │ │ └── stack.yaml │ ├── cmm_include.hs │ ├── dictionaries.hs │ ├── ekg.hs │ ├── example.cabal │ ├── example.hs │ ├── factorial.cmm │ ├── heapview.hs │ ├── hie.hs │ ├── io_impl.hs │ ├── monad_prim.hs │ ├── prim.hs │ ├── profile.hs │ ├── simd │ │ ├── example.cabal │ │ ├── simd.hs │ │ └── stack.yaml │ ├── specialize.hs │ └── stack.yaml ├── 30-languages │ ├── README.md │ ├── ci │ ├── example.cabal │ ├── haskelline.hs │ ├── llvm-hs.hs │ ├── llvm-irbuilder.hs │ ├── pretty.hs │ ├── prettysimple.hs │ ├── repline.hs │ ├── stack.yaml │ ├── unbound-generics.hs │ └── unbound.hs ├── 31-template-haskell │ ├── Antiquote.hs │ ├── Class.hs │ ├── EnumFamily.hs │ ├── Insert.hs │ ├── Multiline.hs │ ├── Quasiquote.hs │ ├── README.md │ ├── Singleton.hs │ ├── Splice.hs │ ├── ci │ ├── cquote.hs │ ├── derive.hs │ ├── enum_family_splice.hs │ ├── example.cabal │ ├── multiline_example.hs │ ├── quasiquote_use.hs │ ├── singleton_lib.hs │ ├── singleton_promote.hs │ ├── splice_class.hs │ ├── splice_singleton.hs │ ├── stack.yaml │ ├── template_info.hs │ └── use_antiquote.hs ├── 32-cryptography │ ├── AES.hs │ ├── Argon.hs │ ├── Blake2.hs │ ├── Curve25519.hs │ ├── ECC.hs │ ├── Ed25519.hs │ ├── Galois.hs │ ├── Keccak.hs │ ├── Pairing.hs │ ├── SHA.hs │ ├── Secp256k1.hs │ ├── ci │ ├── example.cabal │ └── stack.yaml ├── 33-categories │ ├── README.md │ ├── categories.hs │ ├── ci │ ├── dual.hs │ ├── example.cabal │ ├── functors.hs │ ├── iso.hs │ ├── kleisli.hs │ ├── monoidal.hs │ ├── natural.hs │ └── stack.yaml ├── 34-time │ ├── Strings.hs │ ├── Time.hs │ ├── ci │ ├── example.cabal │ └── stack.yaml └── ci ├── stack.yaml ├── stack.yaml.lock ├── tutorial.md └── wiwinwlh.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[pon] 2 | *.o 3 | *.so 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | dist/ 7 | *.hi 8 | *.o 9 | includes 10 | *.html 11 | *.epub 12 | *.pdf 13 | *.mobi 14 | *.docx 15 | tutorial.tex 16 | .stack-work 17 | dist-newstyle 18 | resources/*.eps 19 | errata.* 20 | .brokdb 21 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | addons: 4 | apt: 5 | packages: 6 | - libgmp-dev 7 | env: 8 | - ARGS="" 9 | before_install: 10 | - mkdir -p ~/.local/bin 11 | - export PATH=$HOME/.local/bin:$PATH 12 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 13 | script: 14 | - sudo apt-get install texlive texlive-xetex 15 | - stack $ARGS --no-terminal --install-ghc build 16 | - stack $ARGS --no-terminal --install-ghc ghc includes.hs -- -o includes 17 | - stack $ARGS --no-terminal --install-ghc exec make html 18 | # Run the example test suite 19 | - sudo apt-get install libblas-dev liblapack-dev 20 | - cd src && bash ./ci 21 | cache: 22 | directories: 23 | - $HOME/.stack 24 | - .stack-work 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2009-2020 Stephen Diehl 2 | 3 | This code included in the text is dedicated to the public domain. You can copy, 4 | modify, distribute and perform the code, even for commercial purposes, all 5 | without asking permission. 6 | 7 | You may distribute this text in its full form freely, but may not reauthor or 8 | sublicense this work. Any reproductions of major portions of the text must 9 | include attribution. 10 | 11 | The software is provided "as is", without warranty of any kind, express or 12 | implied, including But not limited to the warranties of merchantability, fitness 13 | for a particular purpose and noninfringement. In no event shall the authors or 14 | copyright holders be liable for any claim, damages or other liability, whether 15 | in an action of contract, tort or otherwise, Arising from, out of or in 16 | connection with the software or the use or other dealings in the software. 17 | -------------------------------------------------------------------------------- /deploy.sh: -------------------------------------------------------------------------------- 1 | #rsync css/style.css ec2:~ 2 | #ssh ec2 'sudo mv style.css /srv/http/hask/css/style.css' 3 | # 4 | #rsync css/layout.css ec2:~ 5 | #ssh ec2 'sudo mv layout.css /srv/http/hask/css/layout.css' 6 | # 7 | #rsync js/nav.js ec2:~ 8 | #ssh ec2 'sudo mv nav.js /srv/http/hask/nav.js' 9 | 10 | rsync --progress tutorial.html ec2:~ 11 | rsync --progress tutorial.pdf ec2:~ 12 | rsync --progress tutorial_print.pdf ec2:~ 13 | ssh ec2 'sudo mv tutorial.html /srv/http/hask/index.html' 14 | ssh ec2 'sudo mv tutorial_print.pdf /srv/http/hask/' 15 | ssh ec2 'sudo mv tutorial.pdf /srv/http/hask/' 16 | -------------------------------------------------------------------------------- /errata.md: -------------------------------------------------------------------------------- 1 | Errata 2 | ====== 3 | -------------------------------------------------------------------------------- /img/.gitignore: -------------------------------------------------------------------------------- 1 | *.eps 2 | *.ps 3 | -------------------------------------------------------------------------------- /img/Makefile: -------------------------------------------------------------------------------- 1 | SRC=$(wildcard *.dot) 2 | OUT=$(SRC:.dot=.png) 3 | 4 | %.png : %.dot 5 | dot -Tpng -Gdpi=300 $< -o $@ 6 | 7 | all: $(OUT) 8 | 9 | clean: 10 | rm -f $(OUT) 11 | -------------------------------------------------------------------------------- /img/class.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | Semigroup -> Monoid; 3 | Functor -> Applicative; 4 | Applicative -> Monad; 5 | Applicative -> Alternative; 6 | Functor -> Traversable; 7 | Foldable -> Traversable; 8 | } 9 | -------------------------------------------------------------------------------- /img/class.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/class.png -------------------------------------------------------------------------------- /img/criterion.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/criterion.png -------------------------------------------------------------------------------- /img/diagram1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/diagram1.png -------------------------------------------------------------------------------- /img/ekg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/ekg.png -------------------------------------------------------------------------------- /img/ghc.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | rankdir=TD 3 | node [shape=box] 4 | Parse -> Rename -> Typecheck -> Desugar -> Simplify -> Stg -> Codegen -> Cmm -> "Native Code" 5 | } 6 | 7 | -------------------------------------------------------------------------------- /img/ghc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/ghc.png -------------------------------------------------------------------------------- /img/graph1.dot: -------------------------------------------------------------------------------- 1 | digraph graphname { 2 | a -> b; 3 | b -> c; 4 | c -> a; 5 | } 6 | -------------------------------------------------------------------------------- /img/graph1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/graph1.png -------------------------------------------------------------------------------- /img/graph2.dot: -------------------------------------------------------------------------------- 1 | digraph ex2 { 2 | a -> b; 3 | b -> c; 4 | c -> a; 5 | 6 | d -> e; 7 | e -> f; 8 | e -> e; 9 | f -> d; 10 | f -> e; 11 | } 12 | -------------------------------------------------------------------------------- /img/graph2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/graph2.png -------------------------------------------------------------------------------- /img/graphviz.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/graphviz.png -------------------------------------------------------------------------------- /img/lambda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/lambda.png -------------------------------------------------------------------------------- /img/numerics.dot: -------------------------------------------------------------------------------- 1 | digraph graphname { 2 | Num -> Real 3 | Ord -> Real 4 | 5 | Num -> Fractional; 6 | 7 | Real -> Integral; 8 | Enum -> Integral; 9 | 10 | Real -> RealFrac; 11 | Fractional -> RealFrac; 12 | 13 | Fractional -> Floating; 14 | 15 | RealFrac -> RealFloat; 16 | Floating -> RealFloat; 17 | } 18 | -------------------------------------------------------------------------------- /img/numerics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/numerics.png -------------------------------------------------------------------------------- /img/par.dot: -------------------------------------------------------------------------------- 1 | digraph graphname { 2 | "f x" -> "a + b"; 3 | "g x" -> "a + b"; 4 | "a + b" -> "f (a + b)"; 5 | "a + b" -> "g (a + b)"; 6 | "f (a + b)" -> "(d, e)"; 7 | "g (a + b)" -> "(d, e)"; 8 | } 9 | -------------------------------------------------------------------------------- /img/par.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/par.png -------------------------------------------------------------------------------- /img/threadscope.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/threadscope.png -------------------------------------------------------------------------------- /img/title.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/title.png -------------------------------------------------------------------------------- /img/transformer_unroll.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/transformer_unroll.png -------------------------------------------------------------------------------- /img/tree.dot: -------------------------------------------------------------------------------- 1 | digraph graphname { 2 | A -> B; 3 | A -> C; 4 | C -> D; 5 | C -> E; 6 | } 7 | -------------------------------------------------------------------------------- /img/tree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/img/tree.png -------------------------------------------------------------------------------- /js/nav.js: -------------------------------------------------------------------------------- 1 | $(function () { 2 | 3 | // NAV 4 | 5 | var $sidebar = $('#sidebar-wrapper'); 6 | var $toggle = $('#toggle-sidebar'); 7 | 8 | $toggle.click(function () { 9 | $sidebar.toggleClass('expanded'); 10 | }); 11 | 12 | $sidebar.find('.sidebar-nav a').click(function () { 13 | $sidebar.removeClass('expanded'); 14 | }); 15 | 16 | // TABLES 17 | $('#main table').each(function () { 18 | var $table = $(this).wrap('
'); 19 | }); 20 | 21 | }); 22 | -------------------------------------------------------------------------------- /resources/cover.tex: -------------------------------------------------------------------------------- 1 | \begin{titlepage} 2 | \definecolor{titlepagecolor}{HTML}{FDF6E3} 3 | \definecolor{namecolor}{cmyk}{1,.50,0,.10} 4 | %\pagecolor{titlepagecolor} 5 | %\pagecolor{white} 6 | 7 | \color{black} 8 | \begin{flushright} 9 | \Huge\textbf{What I Wish I Knew When Learning Haskell} 10 | \line(1,0){450} \\ 11 | \Large{Stephen Diehl} 12 | \end{flushright} 13 | 14 | \tikz[remember picture, overlay] 15 | \node[opacity=1,inner sep=0pt,shift={(0 cm,8cm)}] at (current page.south) 16 | {\includegraphics[width=\paperwidth,height=\paperheight]{resources/cover2.png}}; 17 | 18 | \end{titlepage} 19 | \pagecolor{white} 20 | -------------------------------------------------------------------------------- /resources/template.epub: -------------------------------------------------------------------------------- 1 | % What I Wish I Knew When Learning Haskell (Version 2.5) 2 | % Stephen Diehl 3 | % January 2020 4 | -------------------------------------------------------------------------------- /resources/unicodemapping.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\sbullet}{% 2 | \texorpdfstring{\textsbullet}{\textbullet}% 3 | } 4 | \DeclareRobustCommand{\textsbullet}{% 5 | \unskip~\,\begin{picture}(1,1)(0,-3)\circle*{3}\end{picture}\ % 6 | } 7 | \usepackage{newunicodechar} 8 | \newunicodechar{⊥}{\ensuremath{\bot}} 9 | \newunicodechar{⊤}{\ensuremath{\top}} 10 | \newunicodechar{∨}{\ensuremath{\vee}} 11 | \newunicodechar{∧}{\ensuremath{\wedge}} 12 | \newunicodechar{⇒}{\ensuremath{\Rightarrow}} 13 | \newunicodechar{•}{\ensuremath{\sbullet}} 14 | \newunicodechar{λ}{\ensuremath{\lambda}} 15 | \newunicodechar{Λ}{\ensuremath{\Lambda}} 16 | \newunicodechar{∎}{\ensuremath{\blacksquare}} 17 | \newunicodechar{μ}{\ensuremath{\mu}} 18 | \newunicodechar{ℕ}{\ensuremath{\mathbb{N}}} 19 | \newunicodechar{✓}{\ensuremath{\checkmark}} 20 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {}, compiler ? "ghc843" }: with pkgs; 2 | let 3 | ghcWithDeps = pkgs.haskell.packages.${compiler}.ghcWithPackages 4 | ( ps: with ps; [ base pandoc containers ] ); 5 | tex = with pkgs; texlive.combine { 6 | inherit (texlive) 7 | scheme-small 8 | xetex 9 | newunicodechar 10 | ; 11 | }; 12 | fontsConf = makeFontsConf { 13 | fontDirectories = [ dejavu_fonts ]; 14 | }; 15 | in 16 | pkgs.stdenv.mkDerivation { 17 | name = "wiwinwlh-env"; 18 | buildInputs = [ ghcWithDeps tex ]; 19 | FONTCONFIG_FILE = fontsConf; 20 | shellHook = '' 21 | export LANG=en_US.UTF-8 22 | eval $(egrep ^export ${ghcWithDeps}/bin/ghc) 23 | ''; 24 | } 25 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | stack.yaml.lock 2 | -------------------------------------------------------------------------------- /src/01-basics/bottoms.hs: -------------------------------------------------------------------------------- 1 | import GHC.Err 2 | import Prelude hiding (head, (!!), undefined) 3 | 4 | -- degenerate functions 5 | 6 | undefined :: a 7 | undefined = error "Prelude.undefined" 8 | 9 | head :: [a] -> a 10 | head (x:_) = x 11 | head [] = error "Prelude.head: empty list" 12 | 13 | (!!) :: [a] -> Int -> a 14 | xs !! n | n < 0 = error "Prelude.!!: negative index" 15 | [] !! _ = error "Prelude.!!: index too large" 16 | (x:_) !! 0 = x 17 | (_:xs) !! n = xs !! (n-1) 18 | 19 | -------------------------------------------------------------------------------- /src/01-basics/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive defer.hs -Wno-deferred-type-errors 5 | stack exec ghc -- -e ":q" --interactive bottoms.hs 6 | stack exec ghc -- -e ":q" --interactive errors.hs 7 | stack exec ghc -- -e ":q" --interactive fail.hs 8 | stack exec ghc -- -e ":q" --interactive stacktrace.hs 9 | stack exec ghc -- -e ":q" --interactive trace.hs 10 | #stack exec ghc -- -e ":q" --interactive typedhole.hs 11 | -------------------------------------------------------------------------------- /src/01-basics/defer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fdefer-type-errors #-} -- Enable deferred type 2 | -- errors at module level 3 | 4 | x :: () 5 | x = print 3 6 | 7 | y :: Char 8 | y = 0 9 | 10 | z :: Int 11 | z = 0 + "foo" 12 | 13 | main :: IO () 14 | main = do 15 | print x 16 | -------------------------------------------------------------------------------- /src/01-basics/errors.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Annotated code that features use of the error function. 3 | 4 | divByY:: (Num a, Eq a, Fractional a) => a -> a -> a 5 | divByY _ 0 = error "Divide by zero error" -- Dividing by 0 causes an error 6 | divByY dividend divisor = dividend / divisor -- Handles defined division 7 | 8 | 9 | -------------------------------------------------------------------------------- /src/01-basics/fail.hs: -------------------------------------------------------------------------------- 1 | import GHC.Base 2 | 3 | foo :: a 4 | foo = undefined 5 | -- *** Exception: Prelude.undefined 6 | 7 | bar :: a 8 | bar = assert False undefined 9 | -- *** Exception: src/fail.hs:8:7-12: Assertion failed 10 | -------------------------------------------------------------------------------- /src/01-basics/ghci.conf: -------------------------------------------------------------------------------- 1 | :set prompt "λ: " 2 | 3 | :def hlint const . return $ ":! hlint \"src\"" 4 | :def hoogle \s -> return $ ":! hoogle --count=15 \"" ++ s ++ "\"" 5 | -------------------------------------------------------------------------------- /src/01-basics/mylibrary.cabal: -------------------------------------------------------------------------------- 1 | name: mylibrary 2 | version: 0.1 3 | cabal-version: >= 1.10 4 | author: Paul Atreides 5 | license: MIT 6 | license-file: LICENSE 7 | synopsis: The code must flow. 8 | category: Math 9 | tested-with: GHC 10 | build-type: Simple 11 | 12 | library 13 | exposed-modules: 14 | Library.ExampleModule1 15 | Library.ExampleModule2 16 | 17 | build-depends: 18 | base >= 4 && < 5 19 | 20 | default-language: Haskell2010 21 | 22 | ghc-options: -O2 -Wall -fwarn-tabs 23 | 24 | executable "example" 25 | build-depends: 26 | base >= 4 && < 5, 27 | mylibrary == 0.1 28 | default-language: Haskell2010 29 | main-is: Main.hs 30 | 31 | Test-Suite test 32 | type: exitcode-stdio-1.0 33 | main-is: Test.hs 34 | default-language: Haskell2010 35 | build-depends: 36 | base >= 4 && < 5, 37 | mylibrary == 0.1 38 | -------------------------------------------------------------------------------- /src/01-basics/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/01-basics/stacktrace.hs: -------------------------------------------------------------------------------- 1 | import Control.Exception 2 | 3 | f x = g x 4 | 5 | g x = error (show x) 6 | 7 | main = try (evaluate (f ())) :: IO (Either SomeException ()) 8 | -------------------------------------------------------------------------------- /src/01-basics/trace.hs: -------------------------------------------------------------------------------- 1 | import Debug.Trace 2 | 3 | example1 :: Int 4 | example1 = trace "impure print" 1 5 | 6 | example2 :: Int 7 | example2 = traceShow "tracing" 2 8 | 9 | example3 :: [Int] 10 | example3 = [trace "will not be called" 3] 11 | 12 | main :: IO () 13 | main = do 14 | print example1 15 | print example2 16 | print $ length example3 17 | -- impure print 18 | -- 1 19 | -- "tracing" 20 | -- 2 21 | -- 1 22 | -------------------------------------------------------------------------------- /src/01-basics/typedhole.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XPartialTypeSignatures #-} 2 | 3 | head' = head _ 4 | 5 | const' :: _ 6 | const' x y = x 7 | 8 | foo :: _a -> _a 9 | foo _ = False 10 | 11 | succ' :: _ => a -> a 12 | succ' x = x + 1 13 | 14 | main = undefined 15 | -------------------------------------------------------------------------------- /src/02-monads/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive list.hs 5 | stack exec ghc -- -e ":q" --interactive maybe.hs 6 | stack exec ghc -- -e ":q" --interactive reader.hs 7 | stack exec ghc -- -e ":q" --interactive state.hs 8 | stack exec ghc -- -e ":q" --interactive writer.hs 9 | -------------------------------------------------------------------------------- /src/02-monads/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2016 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | tested-with: GHC ==7.6.3 8 | category: Documentation 9 | build-type: Simple 10 | 11 | library 12 | default-language: Haskell2010 13 | build-depends: base >=4.6 && <4.14 14 | -------------------------------------------------------------------------------- /src/02-monads/list.hs: -------------------------------------------------------------------------------- 1 | example :: [(Int, Int, Int)] 2 | example = do 3 | a <- [1,2] 4 | b <- [10,20] 5 | c <- [100,200] 6 | return (a,b,c) 7 | -- [(1,10,100),(1,10,200),(1,20,100),(1,20,200),(2,10,100),(2,10,200),(2,20,100),(2,20,200)] 8 | 9 | desugared :: [(Int, Int, Int)] 10 | desugared = [1, 2] >>= \a -> 11 | [10, 20] >>= \b -> 12 | [100, 200] >>= \c -> 13 | return (a, b, c) 14 | -- [(1,10,100),(1,10,200),(1,20,100),(1,20,200),(2,10,100),(2,10,200),(2,20,100),(2,20,200)] 15 | -------------------------------------------------------------------------------- /src/02-monads/list_impl.hs: -------------------------------------------------------------------------------- 1 | instance Monad [] where 2 | m >>= f = concat (map f m) 3 | return x = [x] 4 | -------------------------------------------------------------------------------- /src/02-monads/maybe_impl.hs: -------------------------------------------------------------------------------- 1 | data Maybe a = Just a | Nothing 2 | 3 | instance Monad Maybe where 4 | (Just x) >>= k = k x 5 | Nothing >>= k = Nothing 6 | 7 | return = Just 8 | -------------------------------------------------------------------------------- /src/02-monads/reader.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Reader 2 | 3 | data MyContext = MyContext 4 | { foo :: String 5 | , bar :: Int 6 | } deriving (Show) 7 | 8 | computation :: Reader MyContext (Maybe String) 9 | computation = do 10 | n <- asks bar 11 | x <- asks foo 12 | if n > 0 13 | then return (Just x) 14 | else return Nothing 15 | 16 | ex1 :: Maybe String 17 | ex1 = runReader computation $ MyContext "hello" 1 18 | 19 | ex2 :: Maybe String 20 | ex2 = runReader computation $ MyContext "haskell" 0 21 | -------------------------------------------------------------------------------- /src/02-monads/reader_impl.hs: -------------------------------------------------------------------------------- 1 | newtype Reader r a = Reader { runReader :: r -> a } 2 | 3 | instance Monad (Reader r) where 4 | return a = Reader $ \_ -> a 5 | m >>= k = Reader $ \r -> runReader (k (runReader m r)) r 6 | 7 | ask :: Reader a a 8 | ask = Reader id 9 | 10 | asks :: (r -> a) -> Reader r a 11 | asks f = Reader f 12 | 13 | local :: (r -> r) -> Reader r a -> Reader r a 14 | local f m = Reader $ runReader m . f 15 | -------------------------------------------------------------------------------- /src/02-monads/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/02-monads/state.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | 3 | test :: State Int Int 4 | test = do 5 | put 3 6 | modify (+1) 7 | get 8 | 9 | main :: IO () 10 | main = print $ execState test 0 11 | -------------------------------------------------------------------------------- /src/02-monads/state_impl.hs: -------------------------------------------------------------------------------- 1 | newtype State s a = State { runState :: s -> (a,s) } 2 | 3 | instance Monad (State s) where 4 | return a = State $ \s -> (a, s) 5 | 6 | State act >>= k = State $ \s -> 7 | let (a, s') = act s 8 | in runState (k a) s' 9 | 10 | get :: State s s 11 | get = State $ \s -> (s, s) 12 | 13 | put :: s -> State s () 14 | put s = State $ \_ -> ((), s) 15 | 16 | modify :: (s -> s) -> State s () 17 | modify f = get >>= \x -> put (f x) 18 | 19 | evalState :: State s a -> s -> a 20 | evalState act = fst . runState act 21 | 22 | execState :: State s a -> s -> s 23 | execState act = snd . runState act 24 | -------------------------------------------------------------------------------- /src/02-monads/writer.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Writer 2 | 3 | type MyWriter = Writer [Int] String 4 | 5 | example :: MyWriter 6 | example = do 7 | tell [1..3] 8 | tell [3..5] 9 | return "foo" 10 | 11 | output :: (String, [Int]) 12 | output = runWriter example 13 | -- ("foo", [1, 2, 3, 3, 4, 5]) 14 | -------------------------------------------------------------------------------- /src/02-monads/writer_impl.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | newtype Writer w a = Writer { runWriter :: (a, w) } 4 | 5 | instance Monoid w => Monad (Writer w) where 6 | return a = Writer (a, mempty) 7 | m >>= k = Writer $ let 8 | (a, w) = runWriter m 9 | (b, w') = runWriter (k a) 10 | in (b, w `mappend` w') 11 | 12 | execWriter :: Writer w a -> w 13 | execWriter m = snd (runWriter m) 14 | 15 | tell :: w -> Writer w () 16 | tell w = Writer ((), w) 17 | -------------------------------------------------------------------------------- /src/03-monad-transformers/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /src/03-monad-transformers/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive duplicate_fields.hs 5 | #stack exec ghc -- -e ":q" --interactive newtype.hs 6 | stack exec ghc -- -e ":q" --interactive newtype_deriving.hs 7 | stack exec ghc -- -e ":q" --interactive overloaded_labels.hs 8 | stack exec ghc -- -e ":q" --interactive transformer.hs 9 | -------------------------------------------------------------------------------- /src/03-monad-transformers/duplicate_fields.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | data Person = Person { id :: Int } 4 | data Animal = Animal { id :: Int } 5 | data Vegetable = Vegetable { id :: Int } 6 | 7 | test :: (Person, Animal, Vegetable) 8 | test = (Person {id = 1}, Animal {id = 2}, Vegetable {id = 3}) 9 | -------------------------------------------------------------------------------- /src/03-monad-transformers/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.10 && <4.14, 15 | mtl >= 2.2 && <2.3, 16 | polysemy >= 1.2 && <1.3, 17 | polysemy-plugin >= 0.2 && <0.3, 18 | transformers >= 0.5 && <0.6, 19 | fused-effects >= 1.0 && <1.1, 20 | eff >= 0.0 && <1.0 21 | 22 | default-language: Haskell2010 23 | -------------------------------------------------------------------------------- /src/03-monad-transformers/mini-fused/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | build-type: Simple 5 | 6 | executable example 7 | main-is: Main.hs 8 | default-language: Haskell2010 9 | build-depends: 10 | base >=4.6 && <4.14 11 | , fused-effects >=1.0 && <1.1 12 | -------------------------------------------------------------------------------- /src/03-monad-transformers/mini-fused/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - fused-effects-1.0.0.0 4 | -------------------------------------------------------------------------------- /src/03-monad-transformers/newtype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | newtype Quantity v a = Quantity a 4 | deriving (Eq, Ord, Num, Show) 5 | 6 | data Haskeller 7 | type Haskellers = Quantity Haskeller Int 8 | 9 | a = Quantity 2 :: Haskellers 10 | b = Quantity 6 :: Haskellers 11 | 12 | totalHaskellers :: Haskellers 13 | totalHaskellers = a + b 14 | 15 | newtype Velocity = Velocity { unVelocity :: Double } 16 | deriving (Eq, Ord) 17 | 18 | v :: Velocity 19 | v = Velocity 2.718 20 | 21 | x :: Double 22 | x = 2.718 23 | 24 | -- Type error is caught at compile time even though 25 | -- they are the same value at runtime! 26 | err = v + x 27 | -------------------------------------------------------------------------------- /src/03-monad-transformers/overloaded_labels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE DuplicateRecordFields #-} 7 | {-# LANGUAGE ExistentialQuantification #-} 8 | 9 | import GHC.Records (HasField(..)) 10 | import GHC.OverloadedLabels (IsLabel(..)) 11 | 12 | data S = MkS { foo :: Int } 13 | data T x y z = forall b . MkT { foo :: y, bar :: b } 14 | 15 | instance HasField x r a => IsLabel x (r -> a) where 16 | fromLabel = getField @x 17 | 18 | main :: IO () 19 | main = do 20 | print (#foo (MkS 42)) 21 | print (#foo (MkT True False)) 22 | -------------------------------------------------------------------------------- /src/03-monad-transformers/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: 3 | - fused-effects-1.0.0.0 4 | - polysemy-1.2.3.0 5 | -------------------------------------------------------------------------------- /src/03-monad-transformers/transformer.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Reader 2 | 3 | type Env = [(String, Int)] 4 | type Eval a = ReaderT Env Maybe a 5 | 6 | data Expr 7 | = Val Int 8 | | Add Expr Expr 9 | | Var String 10 | deriving (Show) 11 | 12 | eval :: Expr -> Eval Int 13 | eval ex = case ex of 14 | 15 | Val n -> return n 16 | 17 | Add x y -> do 18 | a <- eval x 19 | b <- eval y 20 | return (a+b) 21 | 22 | Var x -> do 23 | env <- ask 24 | val <- lift (lookup x env) 25 | return val 26 | 27 | env :: Env 28 | env = [("x", 2), ("y", 5)] 29 | 30 | ex1 :: Eval Int 31 | ex1 = eval (Add (Val 2) (Add (Val 1) (Var "x"))) 32 | 33 | example1, example2 :: Maybe Int 34 | example1 = runReaderT ex1 env 35 | example2 = runReaderT ex1 [] 36 | -------------------------------------------------------------------------------- /src/04-extensions/application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | import Data.Proxy 4 | 5 | a :: Proxy Int 6 | a = Proxy @Int 7 | 8 | b :: String 9 | b = show (read @Int "42") 10 | -------------------------------------------------------------------------------- /src/04-extensions/ci: -------------------------------------------------------------------------------- 1 | set +e 2 | for f in *.hs; do 3 | echo $f 4 | stack exec ghc -- -e ":q" --interactive $f 5 | done 6 | -------------------------------------------------------------------------------- /src/04-extensions/derive_any.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | class MinimalClass a where 5 | const1 :: a -> Int 6 | default const1 :: a -> Int 7 | const1 _ = 1 8 | 9 | const2 :: a -> Int 10 | default const2 :: a -> Int 11 | const2 _ = 2 12 | 13 | data Example = Example 14 | deriving (MinimalClass) 15 | 16 | main :: IO () 17 | main = do 18 | print (const1 Example) 19 | print (const2 Example) 20 | -------------------------------------------------------------------------------- /src/04-extensions/derive_functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | data Tree a = Node a [Tree a] 4 | deriving (Show, Functor) 5 | 6 | tree :: Tree Int 7 | tree = fmap (+1) (Node 1 [Node 2 [], Node 3 []]) 8 | -------------------------------------------------------------------------------- /src/04-extensions/derive_traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE PartialTypeSignatures #-} 3 | 4 | 5 | data Tree a = Node a [Tree a] 6 | deriving (Show, Functor, Foldable, Traversable) 7 | 8 | tree :: Maybe [Int] 9 | tree = foldMap go (Node [1] [Node [2] [], Node [3,4] []]) 10 | where 11 | go [] = Nothing 12 | go xs = Just xs 13 | -------------------------------------------------------------------------------- /src/04-extensions/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.10 15 | 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /src/04-extensions/flexcontexts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | class MyClass a 4 | 5 | -- Without flexible contexts, all contexts must be type variable. The 6 | -- following would be legal. 7 | instance (MyClass a) => MyClass (Either a b) 8 | 9 | -- With flexible contexts, typeclass contexts can be arbitrary nested types. The 10 | -- following would be forbidden without it. 11 | instance (MyClass (Maybe a)) => MyClass (Either a b) 12 | -------------------------------------------------------------------------------- /src/04-extensions/flexinstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | class MyClass a 4 | 5 | -- Without flexible instances, all instance heads must be type variable. The 6 | -- following would be legal. 7 | instance MyClass (Maybe a) 8 | 9 | -- With flexible instances, typeclass heads can be arbitrary nested types. The 10 | -- following would be forbidden without it. 11 | instance MyClass (Maybe Int) 12 | -------------------------------------------------------------------------------- /src/04-extensions/folding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | 3 | data RoseTree a 4 | = RoseTree a [RoseTree a] 5 | deriving (Foldable) 6 | 7 | data Tree a 8 | = Leaf a 9 | | Branch (Tree a) (Tree a) 10 | deriving (Foldable) 11 | -------------------------------------------------------------------------------- /src/04-extensions/incoherent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE IncoherentInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | class MyClass a b where 6 | fn :: (a,b) 7 | 8 | instance MyClass Int b where 9 | fn = error "a" 10 | 11 | instance MyClass a Int where 12 | fn = error "b" 13 | 14 | example :: (Int, Int) 15 | example = fn 16 | -------------------------------------------------------------------------------- /src/04-extensions/incoherent_anno.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | class MyClass a b where 5 | fn :: (a,b) 6 | 7 | instance {-# INCOHERENT #-} MyClass a Int where 8 | fn = error "general" 9 | 10 | instance {-# INCOHERENT #-} MyClass Int Int where 11 | fn = error "specific" 12 | 13 | example :: (Int, Int) 14 | example = fn 15 | -------------------------------------------------------------------------------- /src/04-extensions/lambdacase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | data Exp a 4 | = Lam a (Exp a) 5 | | Var a 6 | | App (Exp a) (Exp a) 7 | 8 | example :: Exp a -> a 9 | example = \case 10 | Lam a b -> a 11 | Var a -> a 12 | App a b -> example a 13 | -------------------------------------------------------------------------------- /src/04-extensions/monomorphism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module Monomorphism (foo,bar) where 4 | 5 | -- + extension: Num a => a -> a -> a 6 | -- - extension: Num a => a -> a -> a 7 | foo x y = x + y 8 | 9 | -- + extension: Num a => a -> a 10 | -- - extension: Integer -> Integer 11 | bar = foo 1 12 | 13 | 14 | -- Now if this module is loaded without the extension, 15 | -- then the call `bar 1.0` fails, since 1.0 is not a valid 16 | -- Integer. If, however, `bar 1.0` was called somewhere within 17 | -- this module, then there would be enough information to 18 | -- correctly infer the type. 19 | -------------------------------------------------------------------------------- /src/04-extensions/overlapping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverlappingInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | class MyClass a b where 6 | fn :: (a,b) 7 | 8 | instance MyClass Int b where 9 | fn = error "b" 10 | 11 | instance MyClass a Int where 12 | fn = error "a" 13 | 14 | instance MyClass Int Int where 15 | fn = error "c" 16 | 17 | example :: (Int, Int) 18 | example = fn 19 | -------------------------------------------------------------------------------- /src/04-extensions/overlapping_anno.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | class MyClass a b where 5 | fn :: (a,b) 6 | 7 | instance {-# OVERLAPPING #-} MyClass Int b where 8 | fn = error "b" 9 | 10 | instance {-# OVERLAPPING #-} MyClass a Int where 11 | fn = error "a" 12 | 13 | instance {-# OVERLAPPING #-} MyClass Int Int where 14 | fn = error "c" 15 | 16 | example :: (Int, Int) 17 | example = fn 18 | -------------------------------------------------------------------------------- /src/04-extensions/partial_type_signatures.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XPartialTypeSignatures #-} 2 | 3 | triple :: Int -> _ 4 | triple i = (i,i,i) 5 | 6 | main = undefined 7 | -------------------------------------------------------------------------------- /src/04-extensions/patterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | import Data.List (foldl1') 4 | 5 | type Name = String 6 | type TVar = String 7 | type TyCon = String 8 | 9 | data Type 10 | = TVar TVar 11 | | TCon TyCon 12 | | TApp Type Type 13 | deriving (Show, Eq, Ord) 14 | 15 | 16 | pattern TArr t1 t2 = TApp (TApp (TCon "(->)") t1) t2 17 | 18 | tapp :: TyCon -> [Type] -> Type 19 | tapp tcon args = foldl TApp (TCon tcon) args 20 | 21 | arr :: [Type] -> Type 22 | arr ts = foldl1' (\t1 t2 -> tapp "(->)" [t1, t2]) ts 23 | 24 | elimTArr :: Type -> [Type] 25 | elimTArr (TArr (TArr t1 t2) t3) = t1 : t2 : elimTArr t3 26 | elimTArr (TArr t1 t2) = t1 : elimTArr t2 27 | elimTArr t = [t] 28 | 29 | -- (->) a ((->) b a) 30 | -- a -> b -> a 31 | to :: Type 32 | to = arr [TVar "a", TVar "b", TVar "a"] 33 | 34 | from :: [Type] 35 | from = elimTArr to 36 | -------------------------------------------------------------------------------- /src/04-extensions/safe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | import Unsafe.Coerce 4 | import System.IO.Unsafe 5 | 6 | bad1 :: String 7 | bad1 = unsafePerformIO getLine 8 | 9 | bad2 :: a 10 | bad2 = unsafeCoerce 3.14 () 11 | -------------------------------------------------------------------------------- /src/04-extensions/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/04-extensions/synonym.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | type IntList = [Int] 5 | 6 | class MyClass a 7 | 8 | -- Without type synonym instances, we're forced to manually expand out type 9 | -- synonyms in the typeclass head. 10 | instance MyClass [Int] 11 | 12 | -- With it GHC will do this for us automatically. Type synonyms still need to 13 | -- be fully applied. 14 | instance MyClass IntList 15 | -------------------------------------------------------------------------------- /src/04-extensions/views.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | 4 | import Safe 5 | 6 | lookupDefault :: Eq a => a -> b -> [(a,b)] -> b 7 | lookupDefault k _ (lookup k -> Just s) = s 8 | lookupDefault _ d _ = d 9 | 10 | headTup :: (a, [t]) -> [t] 11 | headTup (headMay . snd -> Just n) = [n] 12 | headTup _ = [] 13 | 14 | headNil :: [a] -> [a] 15 | headNil (headMay -> Just x) = [x] 16 | headNil _ = [] 17 | -------------------------------------------------------------------------------- /src/04-extensions/wildcards.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | data T = T { a :: Int , b :: Int } 4 | 5 | f :: T -> Int 6 | f (T {..} ) = a + b 7 | -------------------------------------------------------------------------------- /src/04-extensions/wildcards_update.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Text 5 | 6 | data Example = Example 7 | { e1 :: Int 8 | , e2 :: Text 9 | , e3 :: Text 10 | } deriving (Show) 11 | 12 | -- Extracting from a record using wildcards. 13 | scope :: Example -> (Int, Text, Text) 14 | scope Example {..} = (e1, e2, e3) 15 | 16 | -- Assign to a record using wildcards. 17 | assign :: Example 18 | assign = Example {..} 19 | where 20 | (e1, e2, e3) = (1, "Kirk", "Picard") 21 | -------------------------------------------------------------------------------- /src/05-laziness/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive lazy_patterns.hs 5 | stack exec ghc -- -e ":q" --interactive nodiverge.hs 6 | -------------------------------------------------------------------------------- /src/05-laziness/diverge.ml: -------------------------------------------------------------------------------- 1 | let ignore x = 0;; 2 | let rec loop a = loop a;; 3 | 4 | print_int (ignore (loop ())); 5 | -------------------------------------------------------------------------------- /src/05-laziness/lazy_patterns.hs: -------------------------------------------------------------------------------- 1 | f :: (a, b) -> Int 2 | f (a,b) = const 1 a 3 | 4 | g :: (a, b) -> Int 5 | g ~(a,b) = const 1 a 6 | 7 | -- λ: f undefined 8 | -- *** Exception: Prelude.undefined 9 | -- λ: g undefined 10 | -- 1 11 | 12 | j :: Maybe t -> t 13 | j ~(Just x) = x 14 | 15 | k :: Maybe t -> t 16 | k (Just x) = x 17 | 18 | -- λ: j Nothing 19 | -- *** Exception: src/05-laziness/lazy_patterns.hs:15:1-15: Irrefutable pattern failed for pattern (Just x) 20 | -- 21 | -- λ: k Nothing 22 | -- *** Exception: src/05-laziness/lazy_patterns.hs:18:1-14: Non-exhaustive patterns in function k 23 | -------------------------------------------------------------------------------- /src/05-laziness/nodiverge.hs: -------------------------------------------------------------------------------- 1 | ignore :: a -> Int 2 | ignore x = 0 3 | 4 | loop :: a 5 | loop = loop 6 | 7 | main :: IO () 8 | main = print $ ignore loop 9 | -------------------------------------------------------------------------------- /src/06-prelude/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive foldable_traversable.hs 6 | stack exec ghc -- -e ":q" --interactive split.hs 7 | -------------------------------------------------------------------------------- /src/06-prelude/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.6 && <4.14 14 | , split >=0.2.3.3 && <0.3 15 | , transformers >=0.5 && <0.6 16 | -------------------------------------------------------------------------------- /src/06-prelude/split.hs: -------------------------------------------------------------------------------- 1 | import Data.List.Split 2 | 3 | example1 :: [String] 4 | example1 = splitOn "." "foo.bar.baz" 5 | -- ["foo","bar","baz"] 6 | 7 | example2 :: [String] 8 | example2 = chunksOf 10 "To be or not to be that is the question." 9 | -- ["To be or n","ot to be t","hat is the"," question."] 10 | -------------------------------------------------------------------------------- /src/06-prelude/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - split-0.2.3.3 4 | -------------------------------------------------------------------------------- /src/07-text-bytestring/builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Monoid (mconcat, (<>)) 4 | 5 | import Data.Text.Lazy.Builder (Builder, toLazyText) 6 | import Data.Text.Lazy.Builder.Int (decimal) 7 | import qualified Data.Text.Lazy.IO as L 8 | 9 | beer :: Int -> Builder 10 | beer n = decimal n <> " bottles of beer on the wall.\n" 11 | 12 | wall :: Builder 13 | wall = mconcat $ fmap beer [1..1000] 14 | 15 | main :: IO () 16 | main = L.putStrLn $ toLazyText wall 17 | -------------------------------------------------------------------------------- /src/07-text-bytestring/bytestring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.ByteString as S 4 | import qualified Data.ByteString.Char8 as S8 5 | 6 | -- From pack 7 | bstr1 :: S.ByteString 8 | bstr1 = S.pack [102, 111, 111] -- ascii encoding of foo as [Word8] 9 | 10 | -- From overloaded string literal. 11 | bstr2 :: S.ByteString 12 | bstr2 = "bar" 13 | -------------------------------------------------------------------------------- /src/07-text-bytestring/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive builder.hs 6 | stack exec ghc -- -e ":q" --interactive bytestring.hs 7 | #stack exec ghc -- -e ":q" --interactive overloadedlist.hs 8 | stack exec ghc -- -e ":q" --interactive printf.hs 9 | stack exec ghc -- -e ":q" --interactive regex.hs 10 | stack exec ghc -- -e ":q" --interactive text.hs 11 | -------------------------------------------------------------------------------- /src/07-text-bytestring/convert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.String.Conv 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.Text.Lazy.IO as TL 7 | 8 | import qualified Data.ByteString as B 9 | import qualified Data.ByteString.Lazy as BL 10 | 11 | import Data.Monoid 12 | 13 | a :: String 14 | a = "Gödel" 15 | 16 | b :: BL.ByteString 17 | b = "Einstein" 18 | 19 | c :: T.Text 20 | c = "Feynmann" 21 | 22 | d :: B.ByteString 23 | d = "Schrödinger" 24 | 25 | -- Compare unlike strings 26 | (==~) :: (Eq a, StringConv b a) => a -> b -> Bool 27 | (==~) a b = a == toS b 28 | 29 | -- Concat unlike strings 30 | (<>~) :: (Monoid a, StringConv b a) => a -> b -> a 31 | (<>~) a b = a <> toS b 32 | 33 | main :: IO () 34 | main = do 35 | putStrLn (toS a) 36 | TL.putStrLn (toS b) 37 | print (a ==~ b) 38 | print (c ==~ d) 39 | print (c ==~ c) 40 | print (b <>~ c) 41 | -------------------------------------------------------------------------------- /src/07-text-bytestring/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && < 4.14, 15 | string-conv >= 0.1 && < 0.2, 16 | text >= 1.2 && < 1.3, 17 | bytestring >= 0.10 && < 0.11, 18 | regex-tdfa >= 1.3, 19 | regex-base >= 0.94 20 | 21 | default-language: Haskell2010 22 | -------------------------------------------------------------------------------- /src/07-text-bytestring/overloadedlist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | import qualified Data.Map as Map 5 | import GHC.Exts (IsList (..)) 6 | 7 | instance (Ord k) => IsList (Map.Map k v) where 8 | type Item (Map.Map k v) = (k, v) 9 | fromList = Map.fromList 10 | toList = Map.toList 11 | 12 | example1 :: Map.Map String Int 13 | example1 = [("a", 1), ("b", 2)] 14 | -------------------------------------------------------------------------------- /src/07-text-bytestring/printf.hs: -------------------------------------------------------------------------------- 1 | import Data.Text 2 | import Text.Printf 3 | 4 | a :: Int 5 | a = 3 6 | 7 | b :: Double 8 | b = 3.14159 9 | 10 | c :: String 11 | c = "haskell" 12 | 13 | example :: String 14 | example = printf "(%i, %f, %s)" a b c 15 | -- "(3, 3.14159, haskell)" 16 | -------------------------------------------------------------------------------- /src/07-text-bytestring/regex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Text 4 | import Text.Regex.TDFA 5 | 6 | -- | Verify url address 7 | url :: Text -> Bool 8 | url input = input =~ urlRegex 9 | where 10 | urlRegex :: Text 11 | urlRegex = "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)" 12 | 13 | -- | Verify email address 14 | email :: Text -> Bool 15 | email input = input =~ emailRegex 16 | where 17 | emailRegex :: Text 18 | emailRegex = "[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+" 19 | -------------------------------------------------------------------------------- /src/07-text-bytestring/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - string-conv-0.1 6 | - regex-base-0.94.0.0 7 | - regex-tdfa-1.3.1.0 8 | flags: {} 9 | extra-package-dbs: [] 10 | -------------------------------------------------------------------------------- /src/07-text-bytestring/text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.Text as T 4 | 5 | -- From pack 6 | myTStr1 :: T.Text 7 | myTStr1 = T.pack ("foo" :: String) 8 | 9 | -- From overloaded string literal. 10 | myTStr2 :: T.Text 11 | myTStr2 = "bar" 12 | -------------------------------------------------------------------------------- /src/08-applicatives/applicative.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative ((<$>), (<*>)) 2 | import Network.HTTP 3 | 4 | example1 :: Maybe Integer 5 | example1 = (+) <$> m1 <*> m2 6 | where 7 | m1 = Just 3 8 | m2 = Nothing 9 | 10 | -- Nothing 11 | 12 | example2 :: [(Int, Int, Int)] 13 | example2 = (,,) <$> m1 <*> m2 <*> m3 14 | where 15 | m1 = [1, 2] 16 | m2 = [10, 20] 17 | m3 = [100, 200] 18 | 19 | -- [(1,10,100),(1,10,200),(1,20,100),(1,20,200),(2,10,100),(2,10,200),(2,20,100),(2,20,200)] 20 | 21 | example3 :: IO String 22 | example3 = (++) <$> fetch1 <*> fetch2 23 | where 24 | fetch1 = simpleHTTP (getRequest "http://www.python.org/") >>= getResponseBody 25 | fetch2 = simpleHTTP (getRequest "http://www.haskell.org/") >>= getResponseBody 26 | -------------------------------------------------------------------------------- /src/08-applicatives/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive applicative.hs 5 | stack exec ghc -- -e ":q" --interactive variadic.hs 6 | -------------------------------------------------------------------------------- /src/08-applicatives/variadic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | class Arg a where 4 | collect' :: [String] -> a 5 | 6 | -- extract to IO 7 | instance Arg (IO ()) where 8 | collect' acc = mapM_ putStrLn acc 9 | 10 | -- extract to [String] 11 | instance Arg [String] where 12 | collect' acc = acc 13 | 14 | instance (Show a, Arg r) => Arg (a -> r) where 15 | collect' acc = \x -> collect' (acc ++ [show x]) 16 | 17 | collect :: Arg t => t 18 | collect = collect' [] 19 | 20 | example1 :: [String] 21 | example1 = collect 'a' 2 3.0 22 | 23 | example2 :: IO () 24 | example2 = collect () "foo" [1,2,3] 25 | -------------------------------------------------------------------------------- /src/09-errors/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive either.hs 6 | #stack exec ghc -- -e ":q" --interactive either_impl.hs 7 | stack exec ghc -- -e ":q" --interactive errors.hs 8 | stack exec ghc -- -e ":q" --interactive exceptions.hs 9 | stack exec ghc -- -e ":q" --interactive exceptt.hs 10 | stack exec ghc -- -e ":q" --interactive ioexception.hs 11 | stack exec ghc -- -e ":q" --interactive spoon.hs 12 | -------------------------------------------------------------------------------- /src/09-errors/either.hs: -------------------------------------------------------------------------------- 1 | sdiv :: Double -> Double -> Either String Double 2 | sdiv _ 0 = throwError "divide by zero" 3 | sdiv i j = return $ i / j 4 | 5 | example :: Double -> Double -> Either String Double 6 | example n m = do 7 | a <- sdiv n m 8 | b <- sdiv 2 a 9 | c <- sdiv 2 b 10 | return c 11 | 12 | throwError :: String -> Either String b 13 | throwError a = Left a 14 | 15 | main :: IO () 16 | main = do 17 | print $ example 1 5 18 | print $ example 1 0 19 | -------------------------------------------------------------------------------- /src/09-errors/either_impl.hs: -------------------------------------------------------------------------------- 1 | instance Monad (Either e) where 2 | return = Right 3 | 4 | (Left x) >>= f = Left x 5 | (Right x) >>= f = f x 6 | -------------------------------------------------------------------------------- /src/09-errors/errors.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Except 2 | import Control.Monad.Identity 3 | 4 | data Exception 5 | = Failure String 6 | | GenericFailure 7 | deriving (Show) 8 | 9 | type ErrMonad a = ExceptT Exception Identity a 10 | 11 | example :: Int -> Int -> ErrMonad Int 12 | example x y = do 13 | case y of 14 | 0 -> throwError $ Failure "division by zero" 15 | x -> return $ x `div` y 16 | 17 | runFail :: ErrMonad a -> Either Exception a 18 | runFail = runIdentity . runExceptT 19 | 20 | example1 :: Either Exception Int 21 | example1 = runFail $ example 2 3 22 | 23 | example2 :: Either Exception Int 24 | example2 = runFail $ example 2 0 25 | -------------------------------------------------------------------------------- /src/09-errors/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14, 15 | spoon >= 0.3 && <0.4, 16 | errors >= 2.3 && <2.4, 17 | either >= 4.4 && <5.1, 18 | transformers >= 0.5 && <0.6, 19 | mtl >= 2.2 && <2.3 20 | 21 | default-language: Haskell2010 22 | -------------------------------------------------------------------------------- /src/09-errors/exceptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Data.Typeable 4 | import Control.Monad.Catch 5 | import Control.Monad.Identity 6 | 7 | data MyException = MyException 8 | deriving (Show, Typeable) 9 | 10 | instance Exception MyException 11 | 12 | example :: MonadCatch m => Int -> Int -> m Int 13 | example x y | y == 0 = throwM MyException 14 | | otherwise = return $ x `div` y 15 | 16 | pure :: MonadCatch m => m (Either MyException Int) 17 | pure = do 18 | a <- try (example 1 2) 19 | b <- try (example 1 0) 20 | return (a >> b) 21 | -------------------------------------------------------------------------------- /src/09-errors/exceptt.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Except 2 | 3 | data Failure 4 | = NonPositive Int 5 | | ReadError String 6 | deriving Show 7 | 8 | example :: Int -> Int -> Except Failure Int 9 | example a b = do 10 | if b == 0 11 | then throwError (NonPositive b) 12 | else return (a `div` b) 13 | 14 | runExample :: IO () 15 | runExample = do 16 | print ((runExcept (example 1 2)) :: Either Failure Int) 17 | print ((runExcept (example 1 0)) :: Either Failure Int) 18 | -------------------------------------------------------------------------------- /src/09-errors/ioexception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Data.Typeable 4 | import Control.Exception 5 | 6 | data MyException = MyException 7 | deriving (Show, Typeable) 8 | 9 | instance Exception MyException 10 | 11 | evil :: [Int] 12 | evil = [throw MyException] 13 | 14 | example1 :: Int 15 | example1 = head evil 16 | 17 | example2 :: Int 18 | example2 = length evil 19 | 20 | main :: IO () 21 | main = do 22 | a <- try (evaluate example1) :: IO (Either MyException Int) 23 | print a 24 | 25 | b <- try (return example2) :: IO (Either MyException Int) 26 | print b 27 | -------------------------------------------------------------------------------- /src/09-errors/spoon.hs: -------------------------------------------------------------------------------- 1 | import Control.Spoon 2 | 3 | goBoom :: Int -> Int -> Int 4 | goBoom x y = x `div` y 5 | 6 | -- evaluate to normal form 7 | test1 :: Maybe [Int] 8 | test1 = spoon [1, 2, undefined] 9 | 10 | -- evaluate to weak head normal form 11 | test2 :: Maybe [Int] 12 | test2 = teaspoon [1, 2, undefined] 13 | 14 | main :: IO () 15 | main = do 16 | maybe (putStrLn "Nothing") (print . length) test1 17 | maybe (putStrLn "Nothing") (print . length) test2 18 | -------------------------------------------------------------------------------- /src/09-errors/stack.yaml: -------------------------------------------------------------------------------- 1 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 2 | resolver: lts-14.20 3 | packages: 4 | - '.' 5 | extra-deps: [] 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /src/10-advanced-monads/base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | import Control.Monad.Base 6 | import Control.Monad.State 7 | import Control.Monad.ST 8 | import Control.Monad.Trans.Control 9 | 10 | newtype CounterT m a = CounterT {unCounterT :: StateT Int m a} 11 | deriving (Functor, Applicative, Monad, MonadTrans) 12 | 13 | instance MonadTransControl CounterT where 14 | type StT CounterT a = StT (StateT Int) a 15 | liftWith = defaultLiftWith CounterT unCounterT 16 | restoreT = defaultRestoreT CounterT 17 | -------------------------------------------------------------------------------- /src/10-advanced-monads/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive base.hs 6 | stack exec ghc -- -e ":q" --interactive cont.hs 7 | #stack exec ghc -- -e ":q" --interactive cont_impl.hs 8 | stack exec ghc -- -e ":q" --interactive free_dsl.hs 9 | stack exec ghc -- -e ":q" --interactive free_impl.hs 10 | stack exec ghc -- -e ":q" --interactive function.hs 11 | #stack exec ghc -- -e ":q" --interactive indexed.hs 12 | stack exec ghc -- -e ":q" --interactive logict.hs 13 | stack exec ghc -- -e ":q" --interactive mmorph.hs 14 | stack exec ghc -- -e ":q" --interactive monadfix.hs 15 | stack exec ghc -- -e ":q" --interactive monadplus.hs 16 | stack exec ghc -- -e ":q" --interactive partiality.hs 17 | stack exec ghc -- -e ":q" --interactive rws.hs 18 | stack exec ghc -- -e ":q" --interactive st.hs 19 | -------------------------------------------------------------------------------- /src/10-advanced-monads/cont.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.Cont 3 | 4 | add :: Int -> Int -> Cont k Int 5 | add x y = return $ x + y 6 | 7 | mult :: Int -> Int -> Cont k Int 8 | mult x y = return $ x * y 9 | 10 | contt :: ContT () IO () 11 | contt = do 12 | k <- do 13 | callCC $ \exit -> do 14 | lift $ putStrLn "Entry" 15 | exit $ \_ -> do 16 | putStrLn "Exit" 17 | lift $ putStrLn "Inside" 18 | lift $ k () 19 | 20 | callcc :: Cont String Integer 21 | callcc = do 22 | a <- return 1 23 | b <- callCC (\k -> k 2) 24 | return $ a+b 25 | 26 | ex1 :: IO () 27 | ex1 = print $ runCont (f >>= g) id 28 | where 29 | f = add 1 2 30 | g = mult 3 31 | -- 9 32 | 33 | ex2 :: IO () 34 | ex2 = print $ runCont callcc show 35 | -- "3" 36 | 37 | ex3 :: IO () 38 | ex3 = runContT contt print 39 | -- Entry 40 | -- Inside 41 | -- Exit 42 | 43 | main :: IO () 44 | main = do 45 | ex1 46 | ex2 47 | ex3 48 | -------------------------------------------------------------------------------- /src/10-advanced-monads/cont_impl.hs: -------------------------------------------------------------------------------- 1 | newtype Cont r a = Cont { runCont :: ((a -> r) -> r) } 2 | 3 | instance Monad (Cont r) where 4 | return a = Cont $ \k -> k a 5 | (Cont c) >>= f = Cont $ \k -> c (\a -> runCont (f a) k) 6 | 7 | class (Monad m) => MonadCont m where 8 | callCC :: ((a -> m b) -> m a) -> m a 9 | 10 | instance MonadCont (Cont r) where 11 | callCC f = Cont $ \k -> runCont (f (\a -> Cont $ \_ -> k a)) k 12 | -------------------------------------------------------------------------------- /src/10-advanced-monads/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14, 15 | safe >= 0.3 && <0.4, 16 | mmorph >= 1.0 && <1.5, 17 | mtl >= 2.2 && <2.3, 18 | transformers-base >= 0.4 && <0.5, 19 | monad-control >= 1.0 && <1.1, 20 | lifted-base >= 0.2 && <0.3, 21 | free >= 5.1 && <5.2 22 | 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /src/10-advanced-monads/function.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | id' :: (->) a a 4 | id' = id 5 | 6 | const' :: (->) a ((->) b a) 7 | const' = const 8 | 9 | -- Monad m => a -> m a 10 | fret :: a -> b -> a 11 | fret = return 12 | 13 | -- Monad m => m a -> (a -> m b) -> m b 14 | fbind :: (r -> a) -> (a -> (r -> b)) -> (r -> b) 15 | fbind f k = f >>= k 16 | 17 | -- Monad m => m (m a) -> m a 18 | fjoin :: (r -> (r -> a)) -> (r -> a) 19 | fjoin = join 20 | 21 | fid :: a -> a 22 | fid = const >>= id 23 | 24 | -- Functor f => (a -> b) -> f a -> f b 25 | fcompose :: (a -> b) -> (r -> a) -> (r -> b) 26 | fcompose = (.) 27 | -------------------------------------------------------------------------------- /src/10-advanced-monads/logict.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | range :: MonadPlus m => [a] -> m a 4 | range [] = mzero 5 | range (x:xs) = range xs `mplus` return x 6 | 7 | pyth :: Integer -> [(Integer,Integer,Integer)] 8 | pyth n = do 9 | x <- range [1..n] 10 | y <- range [1..n] 11 | z <- range [1..n] 12 | if x*x + y*y == z*z then return (x,y,z) else mzero 13 | 14 | main :: IO () 15 | main = print $ pyth 15 16 | {- 17 | [ ( 12 , 9 , 15 ) 18 | , ( 12 , 5 , 13 ) 19 | , ( 9 , 12 , 15 ) 20 | , ( 8 , 6 , 10 ) 21 | , ( 6 , 8 , 10 ) 22 | , ( 5 , 12 , 13 ) 23 | , ( 4 , 3 , 5 ) 24 | , ( 3 , 4 , 5 ) 25 | ] 26 | -} 27 | -------------------------------------------------------------------------------- /src/10-advanced-monads/mmorph.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | import Control.Monad.Morph 3 | 4 | type Eval a = State [Int] a 5 | 6 | runEval :: [Int] -> Eval a -> a 7 | runEval = flip evalState 8 | 9 | pop :: Eval Int 10 | pop = do 11 | top <- gets head 12 | modify tail 13 | return top 14 | 15 | push :: Int -> Eval () 16 | push x = modify (x:) 17 | 18 | ev1 :: Eval Int 19 | ev1 = do 20 | push 3 21 | push 4 22 | pop 23 | pop 24 | 25 | ev2 :: StateT [Int] IO () 26 | ev2 = do 27 | result <- hoist generalize ev1 28 | liftIO $ putStrLn $ "Result: " ++ show result 29 | -------------------------------------------------------------------------------- /src/10-advanced-monads/monadfix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | 3 | import Control.Applicative 4 | import Control.Monad.Fix 5 | 6 | stream1 :: Maybe [Int] 7 | stream1 = do 8 | rec xs <- Just (1:xs) 9 | return (map negate xs) 10 | 11 | stream2 :: Maybe [Int] 12 | stream2 = mfix $ \xs -> do 13 | xs' <- Just (1:xs) 14 | return (map negate xs') 15 | -------------------------------------------------------------------------------- /src/10-advanced-monads/monadplus.hs: -------------------------------------------------------------------------------- 1 | import Safe 2 | import Control.Monad 3 | 4 | list1 :: [(Int,Int)] 5 | list1 = [(a,b) | a <- [1..25], b <- [1..25], a < b] 6 | 7 | list2 :: [(Int,Int)] 8 | list2 = do 9 | a <- [1..25] 10 | b <- [1..25] 11 | guard (a < b) 12 | return $ (a,b) 13 | 14 | maybe1 :: String -> String -> Maybe Double 15 | maybe1 a b = do 16 | a' <- readMay a 17 | b' <- readMay b 18 | guard (b' /= 0.0) 19 | return $ a'/b' 20 | 21 | maybe2 :: Maybe Int 22 | maybe2 = msum [Nothing, Nothing, Just 3, Just 4] 23 | -------------------------------------------------------------------------------- /src/10-advanced-monads/partiality.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Fix 2 | import Control.Monad.Free 3 | 4 | type Partiality a = Free Maybe a 5 | 6 | -- Non-termination. 7 | never :: Partiality a 8 | never = fix (Free . Just) 9 | 10 | fromMaybe :: Maybe a -> Partiality a 11 | fromMaybe (Just x) = Pure x 12 | fromMaybe Nothing = Free Nothing 13 | 14 | runPartiality :: Int -> Partiality a -> Maybe a 15 | runPartiality 0 _ = Nothing 16 | runPartiality _ (Pure a) = Just a 17 | runPartiality _ (Free Nothing) = Nothing 18 | runPartiality n (Free (Just a)) = runPartiality (n-1) a 19 | 20 | ack :: Int -> Int -> Partiality Int 21 | ack 0 n = Pure $ n + 1 22 | ack m 0 = Free $ Just $ ack (m-1) 1 23 | ack m n = Free $ Just $ ack m (n-1) >>= ack (m-1) 24 | 25 | main :: IO () 26 | main = do 27 | let diverge = never :: Partiality () 28 | print $ runPartiality 1000 diverge 29 | print $ runPartiality 1000 (ack 3 4) 30 | print $ runPartiality 5500 (ack 3 4) 31 | -------------------------------------------------------------------------------- /src/10-advanced-monads/rws.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.RWS 2 | 3 | type R = Int 4 | type W = [Int] 5 | type S = Int 6 | 7 | computation :: RWS R W S () 8 | computation = do 9 | e <- ask 10 | a <- get 11 | let b = a + e 12 | put b 13 | tell [b] 14 | 15 | example = runRWS computation 2 3 16 | -------------------------------------------------------------------------------- /src/10-advanced-monads/st.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Control.Monad.ST 3 | import Control.Monad.State.Strict 4 | import Data.STRef 5 | 6 | example1 :: Int 7 | example1 = runST $ do 8 | x <- newSTRef 0 9 | forM_ [1 .. 1000] $ \j -> do 10 | writeSTRef x j 11 | readSTRef x 12 | 13 | example2 :: Int 14 | example2 = runST $ do 15 | count <- newSTRef 0 16 | replicateM_ (10 ^ 6) $ modifySTRef' count (+ 1) 17 | readSTRef count 18 | 19 | example3 :: Int 20 | example3 = flip evalState 0 $ do 21 | replicateM_ (10 ^ 6) $ modify' (+ 1) 22 | get 23 | -------------------------------------------------------------------------------- /src/10-advanced-monads/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/11-quantification/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive existential.hs 6 | stack exec ghc -- -e ":q" --interactive impredicative.hs 7 | #stack exec ghc -- -e ":q" --interactive rankn.hs 8 | #stack exec ghc -- -e ":q" --interactive scopedtvars.hs 9 | #stack exec ghc -- -e ":q" --interactive skolem_capture.hs 10 | stack exec ghc -- -e ":q" --interactive universal.hs 11 | -------------------------------------------------------------------------------- /src/11-quantification/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14 15 | 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /src/11-quantification/existential.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | -- ∃ t. (t, t → t, t → String) 5 | data Box = forall a. Box 6 | { value :: a 7 | , update :: a -> a 8 | , print :: a -> String 9 | } 10 | 11 | boxa :: Box 12 | boxa = Box 1 negate show 13 | 14 | boxb :: Box 15 | boxb = Box "foo" reverse show 16 | 17 | apply :: Box -> String 18 | apply (Box x f p) = p (f x) 19 | 20 | -- ∃ t. Show t => t 21 | data SBox = forall a. Show a => SBox a 22 | 23 | boxes :: [SBox] 24 | boxes = [SBox (), SBox 2, SBox "foo"] 25 | 26 | showBox :: SBox -> String 27 | showBox (SBox a) = show a 28 | 29 | main :: IO () 30 | main = mapM_ (putStrLn . showBox) boxes 31 | -- () 32 | -- 2 33 | -- "foo" 34 | -------------------------------------------------------------------------------- /src/11-quantification/impredicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImpredicativeTypes #-} 2 | 3 | -- Uses higher-ranked polymorphism. 4 | f :: (forall a. [a] -> a) -> (Int, Char) 5 | f get = (get [1,2], get ['a', 'b', 'c']) 6 | 7 | -- Uses impredicative polymorphism. 8 | g :: Maybe (forall a. [a] -> a) -> (Int, Char) 9 | g Nothing = (0, '0') 10 | g (Just get) = (get [1,2], get ['a','b','c']) 11 | -------------------------------------------------------------------------------- /src/11-quantification/rankn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | -- Can't unify ( Bool ~ Char ) 4 | rank1 :: forall a. (a -> a) -> (Bool, Char) 5 | rank1 f = (f True, f 'a') 6 | 7 | rank2 :: (forall a. a -> a) -> (Bool, Char) 8 | rank2 f = (f True, f 'a') 9 | 10 | auto :: (forall a. a -> a) -> (forall b. b -> b) 11 | auto x = x 12 | 13 | xauto :: forall a. (forall b. b -> b) -> a -> a 14 | xauto f = f 15 | -------------------------------------------------------------------------------- /src/11-quantification/scopedtvars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | poly :: forall a b c. a -> b -> c -> (a, a) 5 | poly x y z = (f x y, f x z) 6 | where 7 | -- second argument is universally quantified from inference 8 | -- f :: forall t0 t1. t0 -> t1 -> t0 9 | f x' _ = x' 10 | 11 | mono :: forall a b c. a -> b -> c -> (a, a) 12 | mono x y z = (f x y, f x z) 13 | where 14 | -- b is not implicitly universally quantified because it is in scope 15 | f :: a -> b -> a 16 | f x' _ = x' 17 | 18 | example :: IO () 19 | example = do 20 | x :: [Int] <- readLn 21 | print x 22 | -------------------------------------------------------------------------------- /src/11-quantification/skolem_capture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | escape :: (forall a. a -> a) -> Int 4 | escape f = f 0 5 | 6 | g x = escape (\a -> x) 7 | -------------------------------------------------------------------------------- /src/11-quantification/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/11-quantification/universal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | 3 | -- ∀a. [a] 4 | example1 :: forall a. [a] 5 | example1 = [] 6 | 7 | -- ∀a. [a] 8 | example2 :: forall a. [a] 9 | example2 = [undefined] 10 | 11 | -- ∀a. ∀b. (a → b) → [a] → [b] 12 | map' :: forall a. forall b. (a -> b) -> [a] -> [b] 13 | map' f = foldr ((:) . f) [] 14 | 15 | -- ∀a. [a] → [a] 16 | reverse' :: forall a. [a] -> [a] 17 | reverse' = foldl (flip (:)) [] 18 | -------------------------------------------------------------------------------- /src/12-gadts/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive equal.hs 5 | stack exec ghc -- -e ":q" --interactive gadt.hs 6 | stack exec ghc -- -e ":q" --interactive kindsignatures.hs 7 | #stack exec ghc -- -e ":q" --interactive phantom.hs 8 | stack exec ghc -- -e ":q" --interactive phantom_example.hs 9 | #stack exec ghc -- -e ":q" --interactive propositional_equal.hs 10 | -------------------------------------------------------------------------------- /src/12-gadts/equal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | 4 | -- a ≡ b 5 | data Eql a b where 6 | Refl :: Eql a a 7 | 8 | -- Congruence 9 | -- (f : A → B) {x y} → x ≡ y → f x ≡ f y 10 | cong :: Eql a b -> Eql (f a) (f b) 11 | cong Refl = Refl 12 | 13 | -- Symmetry 14 | -- {a b : A} → a ≡ b → a ≡ b 15 | sym :: Eql a b -> Eql b a 16 | sym Refl = Refl 17 | 18 | -- Transitivity 19 | -- {a b c : A} → a ≡ b → b ≡ c → a ≡ c 20 | trans :: Eql a b -> Eql b c -> Eql a c 21 | trans Refl Refl = Refl 22 | 23 | -- Coerce one type to another given a proof of their equality. 24 | -- {a b : A} → a ≡ b → a → b 25 | castWith :: Eql a b -> a -> b 26 | castWith Refl = id 27 | 28 | -- Trivial cases 29 | a :: forall n. Eql n n 30 | a = Refl 31 | 32 | b :: forall. Eql () () 33 | b = Refl 34 | -------------------------------------------------------------------------------- /src/12-gadts/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14 15 | 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /src/12-gadts/gadt.hs: -------------------------------------------------------------------------------- 1 | {-# Language GADTs #-} 2 | 3 | data Term a where 4 | Lit :: a -> Term a 5 | Succ :: Term Int -> Term Int 6 | IsZero :: Term Int -> Term Bool 7 | If :: Term Bool -> Term a -> Term a -> Term a 8 | 9 | eval :: Term a -> a 10 | eval (Lit i) = i -- Term a 11 | eval (Succ t) = 1 + eval t -- Term (a ~ Int) 12 | eval (IsZero i) = eval i == 0 -- Term (a ~ Int) 13 | eval (If b e1 e2) = if eval b then eval e1 else eval e2 -- Term (a ~ Bool) 14 | 15 | example :: Int 16 | example = eval (Succ (Succ (Lit 3))) 17 | -------------------------------------------------------------------------------- /src/12-gadts/kindsignatures.hs: -------------------------------------------------------------------------------- 1 | {-# Language GADTs #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | data Term a :: * where 5 | Lit :: a -> Term a 6 | Succ :: Term Int -> Term Int 7 | IsZero :: Term Int -> Term Bool 8 | If :: Term Bool -> Term a -> Term a -> Term a 9 | 10 | data Vec :: * -> * -> * where 11 | Nil :: Vec n a 12 | Cons :: a -> Vec n a -> Vec n a 13 | 14 | data Fix :: (* -> *) -> * where 15 | In :: f (Fix f) -> Fix f 16 | -------------------------------------------------------------------------------- /src/12-gadts/phantom.hs: -------------------------------------------------------------------------------- 1 | import Data.Void 2 | 3 | data Foo tag a = Foo a 4 | 5 | combine :: Num a => Foo tag a -> Foo tag a -> Foo tag a 6 | combine (Foo a) (Foo b) = Foo (a+b) 7 | 8 | -- All identical at the value level, but differ at the type level. 9 | a :: Foo () Int 10 | a = Foo 1 11 | 12 | b :: Foo t Int 13 | b = Foo 1 14 | 15 | c :: Foo Void Int 16 | c = Foo 1 17 | 18 | -- () ~ () 19 | example1 :: Foo () Int 20 | example1 = combine a a 21 | 22 | -- t ~ () 23 | example2 :: Foo () Int 24 | example2 = combine a b 25 | 26 | -- t0 ~ t1 27 | example3 :: Foo t Int 28 | example3 = combine b b 29 | 30 | -- Couldn't match type `t' with `Void' 31 | example4 :: Foo t Int 32 | example4 = combine b c 33 | -------------------------------------------------------------------------------- /src/12-gadts/phantom_example.hs: -------------------------------------------------------------------------------- 1 | import Data.Text 2 | 3 | data Cryptotext 4 | data Plaintext 5 | 6 | data Msg a = Msg Text 7 | 8 | encrypt :: Msg Plaintext -> Msg Cryptotext 9 | encrypt = undefined 10 | 11 | decrypt :: Msg Cryptotext -> Msg Plaintext 12 | decrypt = undefined 13 | -------------------------------------------------------------------------------- /src/12-gadts/propositional_equal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -- a ≡ b 8 | data a :~: b where 9 | Refl :: a :~: a 10 | 11 | -- (f : A → B) {x y} → x ≡ y → f x ≡ f y 12 | cong :: a :~: b -> (f a) :~: (f b) 13 | cong Refl = Refl 14 | 15 | -- {a b : A} → a ≡ b → a ≡ b 16 | sym :: a :~: b -> b :~: a 17 | sym Refl = Refl 18 | 19 | -- {a b c : A} → a ≡ b → b ≡ c → a ≡ c 20 | trans :: a :~: b -> b :~: c -> a :~: c 21 | trans Refl Refl = Refl 22 | 23 | -- {a b : A} → a ≡ b → a → b 24 | cast :: a :~: b -> a -> b 25 | cast Refl = id 26 | 27 | a :: forall n. n :~: n 28 | a = Refl 29 | 30 | b :: forall n. (Maybe n) :~: (Maybe n) 31 | b = Refl 32 | 33 | c :: forall. Eql () :~: () 34 | c = Refl 35 | -------------------------------------------------------------------------------- /src/12-gadts/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/13-lambda-calculus/church_list.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | newtype List a = List (forall b. (a -> b -> b) -> b -> b) 4 | 5 | fromList :: [a] -> List a 6 | fromList xs = List (\n c -> foldr n c xs) 7 | 8 | toList :: List a -> [a] 9 | toList xs = unList xs (:) [] 10 | 11 | unList :: List a 12 | -> (a -> b -> b) -- Cons 13 | -> b -- Nil 14 | -> b 15 | unList (List l) = l 16 | 17 | nil :: List a 18 | nil = List (\n c -> c) 19 | 20 | cons :: a -> List a -> List a 21 | cons x xs = List (\n c -> n x (unList xs n c)) 22 | 23 | append :: List a -> List a -> List a 24 | append xs ys = List (\n c -> unList xs n (unList ys n c)) 25 | 26 | singleton :: a -> List a 27 | singleton x = List (\n c -> n x c) 28 | 29 | length :: List a -> Integer 30 | length (List l) = l (\_ n -> n + 1) 0 31 | 32 | test :: [Integer] 33 | test = toList (fromList [1,2,3] `append` fromList [4,5,6]) 34 | -------------------------------------------------------------------------------- /src/13-lambda-calculus/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack exec ghc -- -e ":q" --interactive church_encoding.hs 5 | stack exec ghc -- -e ":q" --interactive church_list.hs 6 | stack exec ghc -- -e ":q" --interactive debruijn.hs 7 | stack exec ghc -- -e ":q" --interactive hoas.hs 8 | stack exec ghc -- -e ":q" --interactive phoas.hs 9 | -------------------------------------------------------------------------------- /src/13-lambda-calculus/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14 15 | 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /src/13-lambda-calculus/hoas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | data Expr a where 4 | Con :: a -> Expr a 5 | Lam :: (Expr a -> Expr b) -> Expr (a -> b) 6 | App :: Expr (a -> b) -> Expr a -> Expr b 7 | 8 | i :: Expr (a -> a) 9 | i = Lam (\x -> x) 10 | 11 | k :: Expr (a -> b -> a) 12 | k = Lam (\x -> Lam (\y -> x)) 13 | 14 | s :: Expr ((a -> b -> c) -> (a -> b) -> (a -> c)) 15 | s = Lam (\x -> Lam (\y -> Lam (\z -> App (App x z) (App y z)))) 16 | 17 | eval :: Expr a -> a 18 | eval (Con v) = v 19 | eval (Lam f) = \x -> eval (f (Con x)) 20 | eval (App e1 e2) = (eval e1) (eval e2) 21 | 22 | 23 | skk :: Expr (a -> a) 24 | skk = App (App s k) k 25 | 26 | example :: Integer 27 | example = eval skk 1 28 | -- 1 29 | -------------------------------------------------------------------------------- /src/13-lambda-calculus/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/14-interpreters/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive catamorphism.hs 6 | stack exec ghc -- -e ":q" --interactive factorial.hs 7 | stack exec ghc -- -e ":q" --interactive fext.hs 8 | stack exec ghc -- -e ":q" --interactive final.hs 9 | stack exec ghc -- -e ":q" --interactive initial.hs 10 | stack exec ghc -- -e ":q" --interactive initial_interpreter.hs 11 | stack exec ghc -- -e ":q" --interactive recursion_schemes.hs 12 | -------------------------------------------------------------------------------- /src/14-interpreters/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.10 && <4.14 14 | , containers >=0.6.0.1 && <0.7 15 | , recursion-schemes >=5.1.3 && <5.2 16 | -------------------------------------------------------------------------------- /src/14-interpreters/factorial.hs: -------------------------------------------------------------------------------- 1 | import Data.Functor.Foldable 2 | 3 | factorial :: Int -> Int 4 | factorial = hylo alg coalg 5 | where 6 | coalg :: Int -> ListF Int Int 7 | coalg m 8 | | m <= 1 = Nil 9 | | otherwise = Cons m (m - 1) 10 | alg :: ListF Int Int -> Int 11 | alg Nil = 1 12 | alg (Cons a x) = a * x 13 | -------------------------------------------------------------------------------- /src/14-interpreters/final.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (id) 2 | 3 | class Expr rep where 4 | lam :: (rep a -> rep b) -> rep (a -> b) 5 | app :: rep (a -> b) -> (rep a -> rep b) 6 | lit :: a -> rep a 7 | 8 | newtype Interpret a = R { reify :: a } 9 | 10 | instance Expr Interpret where 11 | lam f = R $ reify . f . R 12 | app f a = R $ reify f $ reify a 13 | lit = R 14 | 15 | eval :: Interpret a -> a 16 | eval e = reify e 17 | 18 | e1 :: Expr rep => rep Int 19 | e1 = app (lam (\x -> x)) (lit 3) 20 | 21 | e2 :: Expr rep => rep Int 22 | e2 = app (lam (\x -> lit 4)) (lam $ \x -> lam $ \y -> y) 23 | 24 | example1 :: Int 25 | example1 = eval e1 26 | -- 3 27 | 28 | example2 :: Int 29 | example2 = eval e2 30 | -- 4 31 | -------------------------------------------------------------------------------- /src/14-interpreters/recursion_schemes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | import Data.Functor.Foldable 5 | 6 | type Var = String 7 | 8 | data Exp 9 | = Var Var 10 | | App Exp Exp 11 | | Lam [Var] Exp 12 | deriving (Show) 13 | 14 | data ExpF a 15 | = VarF Var 16 | | AppF a a 17 | | LamF [Var] a 18 | deriving (Functor) 19 | 20 | type instance Base Exp = ExpF 21 | 22 | instance Recursive Exp where 23 | project (Var a) = VarF a 24 | project (App a b) = AppF a b 25 | project (Lam a b) = LamF a b 26 | 27 | instance Corecursive Exp where 28 | embed (VarF a) = Var a 29 | embed (AppF a b) = App a b 30 | embed (LamF a b) = Lam a b 31 | 32 | fvs :: Exp -> [Var] 33 | fvs = cata phi 34 | where 35 | phi (VarF a) = [a] 36 | phi (AppF a b) = a ++ b 37 | phi (LamF a b) = foldr (filter . (/=)) a b 38 | -------------------------------------------------------------------------------- /src/14-interpreters/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/15-testing/arbitrary.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | data Color = Red | Green | Blue deriving Show 4 | 5 | instance Arbitrary Color where 6 | arbitrary = do 7 | n <- choose (0,2) :: Gen Int 8 | return $ case n of 9 | 0 -> Red 10 | 1 -> Green 11 | 2 -> Blue 12 | 13 | example1 :: IO [Color] 14 | example1 = sample' arbitrary 15 | -- [Red,Green,Red,Blue,Red,Red,Red,Blue,Green,Red,Red] 16 | -------------------------------------------------------------------------------- /src/15-testing/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive arbitrary.hs 6 | stack exec ghc -- -e ":q" --interactive criterion.hs 7 | stack exec ghc -- -e ":q" --interactive qcheck.hs 8 | #stack exec ghc -- -e ":q" --interactive quickspec.hs 9 | stack exec ghc -- -e ":q" --interactive silently.hs 10 | stack exec ghc -- -e ":q" --interactive smallcheck.hs 11 | stack exec ghc -- -e ":q" --interactive smallcheck_series.hs 12 | stack exec ghc -- -e ":q" --interactive smallcheck_tree.hs 13 | stack exec ghc -- -e ":q" --interactive tasty.hs 14 | -------------------------------------------------------------------------------- /src/15-testing/criterion.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | 3 | -- Naive recursion for fibonacci numbers. 4 | fib1 :: Int -> Int 5 | fib1 0 = 0 6 | fib1 1 = 1 7 | fib1 n = fib1 (n -1) + fib1 (n -2) 8 | 9 | -- Use the De Moivre closed form for fibonacci numbers. 10 | fib2 :: Int -> Int 11 | fib2 x = truncate $ (1 / sqrt 5) * (phi ^ x - psi ^ x) 12 | where 13 | phi = (1 + sqrt 5) / 2 14 | psi = (1 - sqrt 5) / 2 15 | 16 | suite :: [Benchmark] 17 | suite = 18 | [ bgroup 19 | "naive" 20 | [ bench "fib 10" $ whnf fib1 5, 21 | bench "fib 20" $ whnf fib1 10 22 | ], 23 | bgroup 24 | "de moivre" 25 | [ bench "fib 10" $ whnf fib2 5, 26 | bench "fib 20" $ whnf fib2 10 27 | ] 28 | ] 29 | 30 | main :: IO () 31 | main = defaultMain suite 32 | -------------------------------------------------------------------------------- /src/15-testing/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC ==7.6.3 10 | 11 | library 12 | build-depends: 13 | base >=4.6 && <4.14 14 | , criterion >=1.2 && <1.6 15 | , quickspec >=2.1 && <2.2 16 | , silently >=1.2 && <1.3 17 | , smallcheck >=1.1 && <1.2 18 | , tasty >=1.2 && <1.3 19 | , tasty-hunit >=0.9 && <0.11 20 | , tasty-quickcheck >=0.10 && <0.11 21 | , tasty-smallcheck >=0.8 && <0.9 22 | 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /src/15-testing/qcheck.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | qsort :: [Int] -> [Int] 4 | qsort [] = [] 5 | qsort (x:xs) = qsort lhs ++ [x] ++ qsort rhs 6 | where lhs = filter (< x) xs 7 | rhs = filter (>= x) xs 8 | 9 | prop_maximum :: [Int] -> Property 10 | prop_maximum xs = not (null xs) ==> 11 | last (qsort xs) == maximum xs 12 | 13 | main :: IO () 14 | main = quickCheck prop_maximum 15 | -------------------------------------------------------------------------------- /src/15-testing/silently.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Test.Tasty.HUnit 3 | import System.IO.Silently 4 | 5 | test :: Int -> IO () 6 | test n = print (n * n) 7 | 8 | testCapture n = do 9 | (stdout, result) <- capture (test n) 10 | assert (stdout == show (n*n) ++ "\n") 11 | 12 | suite :: TestTree 13 | suite = testGroup "Test Suite" [ 14 | testGroup "Units" 15 | [ testCase "Equality" $ testCapture 10 16 | ] 17 | ] 18 | 19 | main :: IO () 20 | main = defaultMain suite 21 | -------------------------------------------------------------------------------- /src/15-testing/smallcheck.hs: -------------------------------------------------------------------------------- 1 | import Test.SmallCheck 2 | 3 | distrib :: Int -> Int -> Int -> Bool 4 | distrib a b c = a * (b + c) == a * b + a * c 5 | 6 | cauchy :: [Double] -> [Double] -> Bool 7 | cauchy xs ys = (abs (dot xs ys))^2 <= (dot xs xs) * (dot ys ys) 8 | 9 | failure :: [Double] -> [Double] -> Bool 10 | failure xs ys = abs (dot xs ys) <= (dot xs xs) * (dot ys ys) 11 | 12 | dot :: Num a => [a] -> [a] -> a 13 | dot xs ys = sum (zipWith (*) xs ys) 14 | 15 | main :: IO () 16 | main = do 17 | putStrLn "Testing distributivity..." 18 | smallCheck 25 distrib 19 | 20 | putStrLn "Testing Cauchy-Schwarz..." 21 | smallCheck 4 cauchy 22 | 23 | putStrLn "Testing invalid Cauchy-Schwarz..." 24 | smallCheck 4 failure 25 | -------------------------------------------------------------------------------- /src/15-testing/smallcheck_series.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | import Test.SmallCheck 5 | import Test.SmallCheck.Series 6 | import Control.Applicative 7 | 8 | import qualified Data.Vector as V 9 | 10 | dot :: Num a => V.Vector a -> V.Vector a -> a 11 | dot xs ys = V.sum (V.zipWith (*) xs ys) 12 | 13 | cauchy :: V.Vector Double -> V.Vector Double -> Bool 14 | cauchy xs ys = (abs (dot xs ys))^2 <= (dot xs xs) * (dot ys ys) 15 | 16 | instance (Serial m a, Monad m) => Serial m (V.Vector a) where 17 | series = V.fromList <$> series 18 | 19 | main :: IO () 20 | main = smallCheck 4 cauchy 21 | -------------------------------------------------------------------------------- /src/15-testing/smallcheck_tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | import GHC.Generics 6 | import Test.SmallCheck.Series 7 | 8 | data Tree a = Null | Fork (Tree a) a (Tree a) 9 | deriving (Show, Generic) 10 | 11 | instance Serial m a => Serial m (Tree a) 12 | 13 | example :: [Tree ()] 14 | example = list 3 series 15 | 16 | main = print example 17 | -------------------------------------------------------------------------------- /src/15-testing/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - quickspec-2.1.2 6 | - twee-lib-2.2 7 | flags: {} 8 | extra-package-dbs: [] 9 | -------------------------------------------------------------------------------- /src/15-testing/tasty.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Test.Tasty.HUnit 3 | import Test.Tasty.QuickCheck 4 | import qualified Test.Tasty.SmallCheck as SC 5 | 6 | arith :: Integer -> Integer -> Property 7 | arith x y = (x > 0) && (y > 0) ==> (x+y)^2 > x^2 + y^2 8 | 9 | negation :: Integer -> Bool 10 | negation x = abs (x^2) >= x 11 | 12 | suite :: TestTree 13 | suite = testGroup "Test Suite" [ 14 | testGroup "Units" 15 | [ testCase "Equality" $ True @=? True 16 | , testCase "Assertion" $ assert $ (length [1,2,3]) == 3 17 | ], 18 | 19 | testGroup "QuickCheck tests" 20 | [ testProperty "Quickcheck test" arith 21 | ], 22 | 23 | testGroup "SmallCheck tests" 24 | [ SC.testProperty "Negation" negation 25 | ] 26 | ] 27 | 28 | main :: IO () 29 | main = defaultMain suite 30 | -------------------------------------------------------------------------------- /src/16-type-families/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive constraintkinds.hs 6 | stack exec ghc -- -e ":q" --interactive datafamily.hs 7 | stack exec ghc -- -e ":q" --interactive dict.hs 8 | stack exec ghc -- -e ":q" --interactive family_nat_operators.hs 9 | stack exec ghc -- -e ":q" --interactive family_type.hs 10 | stack exec ghc -- -e ":q" --interactive fundeps.hs 11 | stack exec ghc -- -e ":q" --interactive mparam.hs 12 | stack exec ghc -- -e ":q" --interactive mparam_fun.hs 13 | stack exec ghc -- -e ":q" --interactive noempty.hs 14 | stack exec ghc -- -e ":q" --interactive proof.hs 15 | stack exec ghc -- -e ":q" --interactive role_infer.hs 16 | #stack exec ghc -- -e ":q" --interactive roles.hs 17 | -------------------------------------------------------------------------------- /src/16-type-families/constraintkinds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstrainedClassMethods #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Data.HashSet 6 | import Data.Hashable 7 | import GHC.Exts (Constraint) 8 | 9 | type family Con a :: Constraint 10 | 11 | type instance Con [a] = (Ord a, Eq a) 12 | 13 | type instance Con (HashSet a) = (Hashable a) 14 | 15 | class Sized a where 16 | gsize :: Con a => a -> Int 17 | 18 | instance Sized [a] where 19 | gsize = length 20 | 21 | instance Sized (HashSet a) where 22 | gsize = size 23 | -------------------------------------------------------------------------------- /src/16-type-families/datafamily.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | import qualified Data.Vector.Unboxed as V 4 | 5 | data family Array a 6 | data instance Array Int = IArray (V.Vector Int) 7 | data instance Array Bool = BArray (V.Vector Bool) 8 | data instance Array (a,b) = PArray (Array a) (Array b) 9 | data instance Array (Maybe a) = MArray (V.Vector Bool) (Array a) 10 | 11 | class IArray a where 12 | index :: Array a -> Int -> a 13 | 14 | instance IArray Int where 15 | index (IArray xs) i = xs V.! i 16 | 17 | instance IArray Bool where 18 | index (BArray xs) i = xs V.! i 19 | 20 | -- Vector of pairs 21 | instance (IArray a, IArray b) => IArray (a, b) where 22 | index (PArray xs ys) i = (index xs i, index ys i) 23 | 24 | -- Vector of missing values 25 | instance (IArray a) => IArray (Maybe a) where 26 | index (MArray bm xs) i = 27 | case bm V.! i of 28 | True -> Nothing 29 | False -> Just $ index xs i 30 | -------------------------------------------------------------------------------- /src/16-type-families/dict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | import GHC.Exts (Constraint) 6 | 7 | data Dict :: Constraint -> * where 8 | Dict :: (c) => Dict c 9 | 10 | dShow :: Dict (Show a) -> a -> String 11 | dShow Dict x = show x 12 | 13 | dEqNum :: Dict (Eq a, Num a) -> a -> Bool 14 | dEqNum Dict x = x == 0 15 | 16 | 17 | fShow :: String 18 | fShow = dShow Dict 10 19 | 20 | fEqual :: Bool 21 | fEqual = dEqNum Dict 0 22 | -------------------------------------------------------------------------------- /src/16-type-families/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.6 && <4.14 14 | , hashable >=1.2.0.0 && <1.4 15 | , unordered-containers >=0.2.10.0 && <0.3 16 | , vector >=0.11.0.0 && <0.13 17 | -------------------------------------------------------------------------------- /src/16-type-families/family_type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | import Data.Char 4 | 5 | type family Rep a :: * 6 | type instance Rep Int = Char 7 | type instance Rep Char = Int 8 | 9 | class Convertible a where 10 | convert :: a -> Rep a 11 | 12 | instance Convertible Int where 13 | convert = chr 14 | 15 | instance Convertible Char where 16 | convert = ord 17 | -------------------------------------------------------------------------------- /src/16-type-families/mparam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | import Data.Char 4 | 5 | class Convertible a b where 6 | convert :: a -> b 7 | 8 | instance Convertible Int Integer where 9 | convert = toInteger 10 | 11 | instance Convertible Int Char where 12 | convert = chr 13 | 14 | instance Convertible Char Int where 15 | convert = ord 16 | -------------------------------------------------------------------------------- /src/16-type-families/mparam_fun.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | 4 | 5 | import Data.Char 6 | 7 | class Convertible a b | a -> b where 8 | convert :: a -> b 9 | 10 | instance Convertible Int Char where 11 | convert = chr 12 | 13 | instance Convertible Char Int where 14 | convert = ord 15 | -------------------------------------------------------------------------------- /src/16-type-families/noempty.hs: -------------------------------------------------------------------------------- 1 | import Data.List.NonEmpty 2 | import Prelude hiding (head, tail, foldl1) 3 | import Data.Foldable (foldl1) 4 | 5 | a :: NonEmpty Integer 6 | a = fromList [1,2,3] 7 | -- 1 :| [2,3] 8 | 9 | b :: NonEmpty Integer 10 | b = 1 :| [2,3] 11 | -- 1 :| [2,3] 12 | 13 | c :: NonEmpty Integer 14 | c = fromList [] 15 | -- *** Exception: NonEmpty.fromList: empty list 16 | 17 | d :: Integer 18 | d = foldl1 (+) $ fromList [1..100] 19 | -- 5050 20 | -------------------------------------------------------------------------------- /src/16-type-families/proof.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | data Z 7 | data S n 8 | 9 | data SNat n where 10 | Zero :: SNat Z 11 | Succ :: SNat n -> SNat (S n) 12 | 13 | data Eql a b where 14 | Refl :: Eql a a 15 | 16 | type family Add m n 17 | type instance Add Z n = n 18 | type instance Add (S m) n = S (Add m n) 19 | 20 | add :: SNat n -> SNat m -> SNat (Add n m) 21 | add Zero m = m 22 | add (Succ n) m = Succ (add n m) 23 | 24 | cong :: Eql a b -> Eql (f a) (f b) 25 | cong Refl = Refl 26 | 27 | -- ∀n. 0 + suc n = suc n 28 | plus_suc :: forall n. SNat n 29 | -> Eql (Add Z (S n)) (S n) 30 | plus_suc Zero = Refl 31 | plus_suc (Succ n) = cong (plus_suc n) 32 | 33 | -- ∀n. 0 + n = n 34 | plus_zero :: forall n. SNat n 35 | -> Eql (Add Z n) n 36 | plus_zero Zero = Refl 37 | plus_zero (Succ n) = cong (plus_zero n) 38 | -------------------------------------------------------------------------------- /src/16-type-families/role_infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE RoleAnnotations #-} 6 | 7 | data Nat = Zero | Suc Nat 8 | 9 | type role Vec nominal representational 10 | data Vec :: Nat -> * -> * where 11 | Nil :: Vec Zero a 12 | (:*) :: a -> Vec n a -> Vec (Suc n) a 13 | 14 | type role App representational nominal 15 | data App (f :: k -> *) (a :: k) = App (f a) 16 | 17 | type role Mu nominal nominal 18 | data Mu (f :: (k -> *) -> k -> *) (a :: k) = Roll (f (Mu f) a) 19 | 20 | type role Proxy phantom 21 | data Proxy (a :: k) = Proxy 22 | -------------------------------------------------------------------------------- /src/16-type-families/roles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | newtype Age = MkAge {unAge :: Int} 6 | 7 | type family Inspect x 8 | 9 | type instance Inspect Age = Int 10 | 11 | type instance Inspect Int = Bool 12 | 13 | class Boom a where 14 | boom :: a -> Inspect a 15 | 16 | instance Boom Int where 17 | boom = (== 0) 18 | 19 | deriving instance Boom Age 20 | 21 | -- GHC 7.6.3 exhibits undefined behavior 22 | failure = boom (MkAge 3) 23 | -- -6341068275333450897 24 | -------------------------------------------------------------------------------- /src/16-type-families/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/17-promotion/countargs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | import Data.Proxy 7 | import GHC.TypeLits 8 | 9 | type family Count (f :: *) :: Nat where 10 | Count (a -> b) = 1 + (Count b) 11 | Count x = 1 12 | 13 | type Fn1 = Int -> Int 14 | type Fn2 = Int -> Int -> Int -> Int 15 | 16 | fn1 :: Integer 17 | fn1 = natVal (Proxy :: Proxy (Count Fn1)) 18 | -- 2 19 | 20 | fn2 :: Integer 21 | fn2 = natVal (Proxy :: Proxy (Count Fn2)) 22 | -- 4 23 | -------------------------------------------------------------------------------- /src/17-promotion/errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | import GHC.TypeLits 6 | 7 | instance-- Error Message 8 | 9 | TypeError 10 | ( Text "Equality is not defined for functions" 11 | :$$: (ShowType a :<>: Text " -> " :<>: ShowType b) 12 | ) => 13 | -- Instance head 14 | Eq (a -> b) 15 | where 16 | (==) = undefined 17 | 18 | -- Fail when we try to equate two functions 19 | example = id == id 20 | -------------------------------------------------------------------------------- /src/17-promotion/errors_dsl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | import GHC.TypeLits 8 | 9 | type family Coerce a b where 10 | Coerce Int Int = Int 11 | Coerce Float Float = Float 12 | Coerce Int Float = Float 13 | Coerce Float Int = TypeError (Text "Cannot cast to smaller type") 14 | 15 | data Expr a where 16 | EInt :: Int -> Expr Int 17 | EFloat :: Float -> Expr Float 18 | ECoerce :: Expr b -> Expr c -> Expr (Coerce b c) 19 | 20 | foo :: Expr Int 21 | foo = ECoerce (EFloat 3) (EInt 4) 22 | -------------------------------------------------------------------------------- /src/17-promotion/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2020 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >= 4.6 && <4.14 14 | -------------------------------------------------------------------------------- /src/17-promotion/hlist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | 6 | infixr 5 ::: 7 | 8 | data HList (ts :: [ * ]) where 9 | Nil :: HList '[] 10 | (:::) :: t -> HList ts -> HList (t ': ts) 11 | 12 | -- Take the head of a non-empty list with the first value as Bool type. 13 | headBool :: HList (Bool ': xs) -> Bool 14 | headBool hlist = case hlist of 15 | (a ::: _) -> a 16 | 17 | hlength :: HList x -> Int 18 | hlength Nil = 0 19 | hlength (_ ::: b) = 1 + (hlength b) 20 | 21 | 22 | tuple :: (Bool, (String, (Double, ()))) 23 | tuple = (True, ("foo", (3.14, ()))) 24 | 25 | hlist :: HList '[Bool, String , Double , ()] 26 | hlist = True ::: "foo" ::: 3.14 ::: () ::: Nil 27 | -------------------------------------------------------------------------------- /src/17-promotion/kindpoly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | data Proxy a = Proxy 6 | data Rep = Rep 7 | 8 | class PolyClass a where 9 | foo :: Proxy a -> Rep 10 | foo = const Rep 11 | 12 | -- () :: * 13 | -- [] :: * -> * 14 | -- Either :: * -> * -> * 15 | 16 | instance PolyClass () 17 | instance PolyClass [] 18 | instance PolyClass Either 19 | -------------------------------------------------------------------------------- /src/17-promotion/nonempty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | 7 | data Size = Empty | NonEmpty 8 | 9 | data List a b where 10 | Nil :: List Empty a 11 | Cons :: a -> List b a -> List NonEmpty a 12 | 13 | head' :: List NonEmpty a -> a 14 | head' (Cons x _) = x 15 | 16 | example1 :: Int 17 | example1 = head' (1 `Cons` (2 `Cons` Nil)) 18 | 19 | -- Cannot match type Empty with NonEmpty 20 | example2 :: Int 21 | example2 = head' Nil 22 | -------------------------------------------------------------------------------- /src/17-promotion/singleton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Data.Proxy 6 | import GHC.TypeLits 7 | 8 | a :: Integer 9 | a = natVal (Proxy :: Proxy 1) 10 | -- 1 11 | 12 | b :: String 13 | b = symbolVal (Proxy :: Proxy "foo") 14 | -- "foo" 15 | 16 | c :: Integer 17 | c = natVal (Proxy :: Proxy (2 + 3)) 18 | -- 5 19 | -------------------------------------------------------------------------------- /src/17-promotion/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/17-promotion/type_equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | 6 | import GHC.TypeLits 7 | import Data.Type.Equality 8 | 9 | type Not a b = ((b == a) ~ False) 10 | 11 | restrictUnit :: Not () a => a -> a 12 | restrictUnit = id 13 | 14 | restrictChar :: Not Char a => a -> a 15 | restrictChar = id 16 | -------------------------------------------------------------------------------- /src/17-promotion/typefamily.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | 4 | import Prelude hiding (Bool(..)) 5 | 6 | data Bool = False | True 7 | 8 | type family Not (a :: Bool) :: Bool 9 | 10 | type instance Not True = False 11 | type instance Not False = True 12 | 13 | false :: Not True ~ False => a 14 | false = undefined 15 | 16 | true :: Not False ~ True => a 17 | true = undefined 18 | 19 | -- Fails at compile time. 20 | -- Couldn't match type 'False with 'True 21 | invalid :: Not True ~ True => a 22 | invalid = undefined 23 | -------------------------------------------------------------------------------- /src/17-promotion/typelevel_strings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | import GHC.TypeLits 7 | 8 | data Tagged (l :: Symbol) a = Tag a 9 | deriving (Show) 10 | 11 | m :: Tagged "m" Double 12 | m = Tag 10.0 13 | 14 | s :: Tagged "s" Double 15 | s = Tag 20.0 16 | 17 | divUnits :: 18 | Fractional a => 19 | Tagged u1 a -> 20 | Tagged u2 a -> 21 | Tagged (u1 `AppendSymbol` u2) a 22 | divUnits (Tag x) (Tag y) = Tag (x / y) 23 | 24 | addUnits :: 25 | (Num a, u1 `CmpSymbol` u2 ~ 'EQ) => 26 | Tagged u1 a -> 27 | Tagged u2 a -> 28 | Tagged u1 a 29 | addUnits (Tag x) (Tag y) = Tag (x + y) 30 | -------------------------------------------------------------------------------- /src/17-promotion/typemap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | import GHC.TypeLits 12 | import Data.Proxy 13 | import Data.Type.Equality 14 | 15 | type family If (p :: Bool) (a :: k) (b :: k) :: k where 16 | If True a b = a 17 | If False a b = b 18 | 19 | type family Lookup (k :: a) (ls :: [(a, b)]) :: Maybe b where 20 | Lookup k '[] = 'Nothing 21 | Lookup k ('(a, b) ': xs) = If (a == k) ('Just b) (Lookup k xs) 22 | 23 | type M = [ 24 | '("a", 1) 25 | , '("b", 2) 26 | , '("c", 3) 27 | , '("d", 4) 28 | ] 29 | 30 | type K = "a" 31 | type (!!) m (k :: Symbol) a = (Lookup k m) ~ Just a 32 | 33 | value :: Integer 34 | value = natVal ( Proxy :: (M !! "a") a => Proxy a ) 35 | -------------------------------------------------------------------------------- /src/17-promotion/typenat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | import GHC.TypeLits 7 | 8 | data Vec :: Nat -> * -> * where 9 | Nil :: Vec 0 a 10 | Cons :: a -> Vec n a -> Vec (1 + n) a 11 | 12 | -- GHC 7.6 will not reduce 13 | -- vec3 :: Vec (1 + (1 + (1 + 0))) Int 14 | 15 | vec3 :: Vec 3 Int 16 | vec3 = 0 `Cons` (1 `Cons` (2 `Cons` Nil)) 17 | -------------------------------------------------------------------------------- /src/17-promotion/typenat_cmp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | 7 | import GHC.TypeLits 8 | import Data.Type.Equality 9 | 10 | data Foo :: Nat -> * where 11 | Small :: (n <= 2) => Foo n 12 | Big :: (3 <= n) => Foo n 13 | 14 | Empty :: ((n == 0) ~ True) => Foo n 15 | NonEmpty :: ((n == 0) ~ False) => Foo n 16 | 17 | big :: Foo 10 18 | big = Big 19 | 20 | small :: Foo 2 21 | small = Small 22 | 23 | empty :: Foo 0 24 | empty = Empty 25 | 26 | nonempty :: Foo 3 27 | nonempty = NonEmpty 28 | -------------------------------------------------------------------------------- /src/18-generics/cereal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | import Data.Word 4 | import Data.ByteString 5 | import Data.Serialize 6 | 7 | import GHC.Generics 8 | 9 | data Val = A [Val] | B [(Val, Val)] | C 10 | deriving (Generic, Show) 11 | 12 | instance Serialize Val where 13 | 14 | encoded :: ByteString 15 | encoded = encode (A [B [(C, C)]]) 16 | -- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\STX\STX" 17 | 18 | bytes :: [Word8] 19 | bytes = unpack encoded 20 | -- [0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,1,2,2] 21 | 22 | decoded :: Either String Val 23 | decoded = decode encoded 24 | -------------------------------------------------------------------------------- /src/18-generics/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive biplate.hs 6 | stack exec ghc -- -e ":q" --interactive cereal.hs 7 | stack exec ghc -- -e ":q" --interactive data.hs 8 | stack exec ghc -- -e ":q" --interactive derive_aeson.hs 9 | stack exec ghc -- -e ":q" --interactive dynamic.hs 10 | stack exec ghc -- -e ":q" --interactive generic_impl.hs 11 | stack exec ghc -- -e ":q" --interactive generics.hs 12 | stack exec ghc -- -e ":q" --interactive hashable.hs 13 | stack exec ghc -- -e ":q" --interactive typeable.hs 14 | stack exec ghc -- -e ":q" --interactive uniplate.hs 15 | -------------------------------------------------------------------------------- /src/18-generics/data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Data.Data 4 | import Control.Monad.Identity 5 | import Control.Applicative 6 | 7 | data Animal = Cat | Dog deriving (Data, Typeable) 8 | 9 | newtype Val = Val Int deriving (Show, Data, Typeable) 10 | 11 | incr :: Typeable a => a -> a 12 | incr = maybe id id (cast f) 13 | where f (Val x) = Val (x * 100) 14 | 15 | over :: Data a => a -> a 16 | over x = runIdentity $ gfoldl cont base (incr x) 17 | where 18 | cont k d = k <*> (pure $ over d) 19 | base = pure 20 | 21 | 22 | example1 :: Constr 23 | example1 = toConstr Dog 24 | -- Dog 25 | 26 | example2 :: DataType 27 | example2 = dataTypeOf Cat 28 | -- DataType {tycon = "Main.Animal", datarep = AlgRep [Cat,Dog]} 29 | 30 | example3 :: [Val] 31 | example3 = over [Val 1, Val 2, Val 3] 32 | -- [Val 100,Val 200,Val 300] 33 | 34 | example4 :: (Val, Val, Val) 35 | example4 = over (Val 1, Val 2, Val 3) 36 | -- (Val 100,Val 200,Val 300) 37 | -------------------------------------------------------------------------------- /src/18-generics/derive_aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Aeson 5 | import GHC.Generics 6 | 7 | data Point = Point { _x :: Double, _y :: Double } 8 | deriving (Show, Generic) 9 | 10 | instance FromJSON Point 11 | instance ToJSON Point 12 | 13 | example1 :: Maybe Point 14 | example1 = decode "{\"x\":3.0,\"y\":-1.0}" 15 | 16 | example2 = encode $ Point 123.4 20 17 | -------------------------------------------------------------------------------- /src/18-generics/dynamic.hs: -------------------------------------------------------------------------------- 1 | import Data.Dynamic 2 | import Data.Maybe 3 | 4 | dynamicBox :: Dynamic 5 | dynamicBox = toDyn (6.62 :: Double) 6 | 7 | example1 :: Maybe Int 8 | example1 = fromDynamic dynamicBox 9 | -- Nothing 10 | 11 | example2 :: Maybe Double 12 | example2 = fromDynamic dynamicBox 13 | -- Just 6.62 14 | 15 | example3 :: Int 16 | example3 = fromDyn dynamicBox 0 17 | -- 0 18 | 19 | example4 :: Double 20 | example4 = fromDyn dynamicBox 0.0 21 | -- 6.62 22 | -------------------------------------------------------------------------------- /src/18-generics/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | aeson 14 | , base >=4.6 && <4.14 15 | , cereal >=0.5.8.1 && <0.6 16 | , uniplate >=1.6.12 && <1.7 17 | -------------------------------------------------------------------------------- /src/18-generics/generics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import GHC.Generics 6 | 7 | data Animal 8 | = Dog 9 | | Cat 10 | 11 | instance Generic Animal where 12 | type 13 | Rep Animal = 14 | D1 ( 'MetaData "Animal" "Main" "main" 'False ) 15 | ( C1 ( 'MetaCons "Dog" 'PrefixI 'False) 16 | U1 :+: C1 ( 'MetaCons "Cat" 'PrefixI 'False) U1 17 | ) 18 | 19 | from Dog = M1 (L1 (M1 U1)) 20 | from Cat = M1 (R1 (M1 U1)) 21 | 22 | to (M1 (L1 (M1 U1))) = Dog 23 | to (M1 (R1 (M1 U1))) = Cat 24 | 25 | data T_Animal -- Animal type 26 | data C_Dog -- Dog Constructor 27 | data C_Cat -- Cat Constructor 28 | 29 | instance Datatype T_Animal where 30 | datatypeName _ = "Animal" 31 | moduleName _ = "Main" 32 | packageName _ = "main" 33 | 34 | instance Constructor C_Dog where 35 | conName _ = "Dog" 36 | 37 | instance Constructor C_Cat where 38 | conName _ = "Cat" 39 | -------------------------------------------------------------------------------- /src/18-generics/hashable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | import GHC.Generics (Generic) 4 | import Data.Hashable 5 | 6 | data Color = Red | Green | Blue deriving (Generic, Show) 7 | 8 | instance Hashable Color where 9 | 10 | example1 :: Int 11 | example1 = hash Red 12 | -- 839657738087498284 13 | 14 | example2 :: Int 15 | example2 = hashWithSalt 0xDEADBEEF Red 16 | -- 62679985974121021 17 | -------------------------------------------------------------------------------- /src/18-generics/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/18-generics/typeable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Data.Typeable 4 | 5 | data Animal = Cat | Dog deriving Typeable 6 | data Zoo a = Zoo [a] deriving Typeable 7 | 8 | equal :: (Typeable a, Typeable b) => a -> b -> Bool 9 | equal a b = typeOf a == typeOf b 10 | 11 | example1 :: TypeRep 12 | example1 = typeOf Cat 13 | -- Animal 14 | 15 | example2 :: TypeRep 16 | example2 = typeOf (Zoo [Cat, Dog]) 17 | -- Zoo Animal 18 | 19 | example3 :: TypeRep 20 | example3 = typeOf ((1, 6.636e-34, "foo") :: (Int, Double, String)) 21 | -- (Int,Double,[Char]) 22 | 23 | example4 :: Bool 24 | example4 = equal False () 25 | -- False 26 | -------------------------------------------------------------------------------- /src/19-numbers/arithmoi.hs: -------------------------------------------------------------------------------- 1 | import Data.Maybe 2 | import Math.NumberTheory.ArithmeticFunctions 3 | import Math.NumberTheory.Moduli.Sqrt 4 | import Math.NumberTheory.Primes 5 | import Math.NumberTheory.Zeta 6 | 7 | -- Riemann zeta function 8 | exampleZeta :: Double 9 | exampleZeta = zetas 1e-10 !! 10 10 | 11 | -- Euler totient function 12 | exampleEuler :: Integer 13 | exampleEuler = totient 25 14 | 15 | -- Ramanujan tau function 16 | exampleRamanujan :: Integer 17 | exampleRamanujan = ramanujan 16 18 | 19 | -- Primality testing 20 | examplePrimality :: Maybe (Prime Integer) 21 | examplePrimality = isPrime 2147483647 22 | 23 | -- Square roots moduluo prime 24 | exampleSqrt :: [Integer] 25 | exampleSqrt = sqrtsModPrime 42 (fromJust examplePrimality) 26 | -------------------------------------------------------------------------------- /src/19-numbers/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive arithmoi.hs 6 | stack exec ghc -- -e ":q" --interactive creal.hs 7 | stack exec ghc -- -e ":q" --interactive polynomial.hs 8 | stack exec ghc -- -e ":q" --interactive puzzle.hs 9 | stack exec ghc -- -e ":q" --interactive scientific.hs 10 | stack exec ghc -- -e ":q" --interactive stats.hs 11 | -------------------------------------------------------------------------------- /src/19-numbers/creal.hs: -------------------------------------------------------------------------------- 1 | import Data.Number.CReal 2 | 3 | -- algebraic 4 | phi :: CReal 5 | phi = (1 + sqrt 5) / 2 6 | 7 | -- transcendental 8 | ramanujan :: CReal 9 | ramanujan = exp (pi * sqrt 163) 10 | 11 | main :: IO () 12 | main = do 13 | putStrLn $ showCReal 30 pi 14 | -- 3.141592653589793238462643383279 15 | putStrLn $ showCReal 30 phi 16 | -- 1.618033988749894848204586834366 17 | putStrLn $ showCReal 15 ramanujan 18 | -- 262537412640768743.99999999999925 19 | -------------------------------------------------------------------------------- /src/19-numbers/diffeq/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Main where 4 | 5 | import Numeric.GSL.ODE 6 | import Numeric.LinearAlgebra 7 | 8 | -- Differential equation 9 | f :: Double -> [Double] -> [Double] 10 | f t [x, v] = [v, - x + mu * v * (1 - x ^ 2)] 11 | 12 | -- Mu scalar, dampening strenth 13 | mu :: Double 14 | mu = 0.1 15 | 16 | -- Boundary conditions 17 | ts :: Vector Double 18 | ts = linspace 1000 (0, 50) 19 | 20 | -- Use default solver: Embedded Runge-Kutta-Fehlberg (4, 5) method. 21 | vanderpol1 :: [Vector Double] 22 | vanderpol1 = toColumns $ odeSolve f [1, 0] ts 23 | 24 | -- Use Runge-Kutta (2,3) solver 25 | vanderpol2 :: [Vector Double] 26 | vanderpol2 = toColumns $ odeSolveV RK2 hi epsAbs epsRel (l2v f) [1, 0] ts 27 | where 28 | epsAbs = 1.49012e-08 29 | epsRel = epsAbs 30 | hi = (ts ! 1 - ts ! 0) / 100 31 | l2v f = \t -> fromList . f t . toList 32 | 33 | main :: IO () 34 | main = do 35 | print vanderpol1 36 | print vanderpol2 37 | -------------------------------------------------------------------------------- /src/19-numbers/diffeq/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | build-type: Simple 5 | 6 | executable example 7 | main-is: Main.hs 8 | default-language: Haskell2010 9 | build-depends: 10 | base >=4.6 && <4.14 11 | , hmatrix 12 | , hmatrix-gsl >=0.19.0.1 && <0.20 13 | -------------------------------------------------------------------------------- /src/19-numbers/diffeq/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - fused-effects-1.0.0.0 4 | -------------------------------------------------------------------------------- /src/19-numbers/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.0 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >= 4.10 && <4.14, 14 | poly >= 0.3 && <0.4, 15 | scientific >= 0.3 && <0.4, 16 | sbv >= 8.5 && <8.6, 17 | statistics >= 0.15 && <0.16, 18 | arithmoi >= 0.9 && <0.11, 19 | numbers -any 20 | -------------------------------------------------------------------------------- /src/19-numbers/polynomial.hs: -------------------------------------------------------------------------------- 1 | import Data.Poly 2 | 3 | abel :: VPoly Integer 4 | abel = X ^ 5 - X + 1 5 | 6 | fibPoly :: Integer -> VPoly Integer 7 | fibPoly 0 = 0 8 | fibPoly 1 = 1 9 | fibPoly n = X * fibPoly (n - 1) + fibPoly (n - 2) 10 | 11 | division :: (VPoly Double, VPoly Double) 12 | division = gcdExt (X ^ 3 - 2 * X ^ 2 - 4) (X - 3) 13 | -------------------------------------------------------------------------------- /src/19-numbers/puzzle.hs: -------------------------------------------------------------------------------- 1 | import Data.Foldable 2 | import Data.SBV 3 | 4 | -- | val [4,2] == 42 5 | val :: [SInteger] -> SInteger 6 | val = foldr1 (\d r -> d + 10*r) . reverse 7 | 8 | puzzle :: Symbolic SBool 9 | puzzle = do 10 | ds@[b,u,r,i,t,o,m,n,a,d] <- sequenceA [ sInteger [v] | v <- "buritomnad" ] 11 | constrain $ distinct ds 12 | for_ ds $ \d -> constrain $ inRange d (0,9) 13 | pure $ val [b,u,r,r,i,t,o] 14 | + val [m,o,n,a,d] 15 | .== val [b,a,n,d,a,i,d] 16 | -------------------------------------------------------------------------------- /src/19-numbers/scientific.hs: -------------------------------------------------------------------------------- 1 | import Data.Scientific 2 | 3 | c , h, g, a, k :: Scientific 4 | c = scientific 299792458 (0) -- Speed of light 5 | h = scientific 662606957 (-42) -- Planck's constant 6 | g = scientific 667384 (-16) -- Gravitational constant 7 | a = scientific 729735257 (-11) -- Fine structure constant 8 | k = scientific 268545200 (-9) -- Khinchin-Levy Constant 9 | 10 | tau :: Scientific 11 | tau = fromFloatDigits (2 * pi) 12 | 13 | maxDouble64 :: Double 14 | maxDouble64 = read "1.7976931348623159e308" 15 | 16 | -- Infinity 17 | 18 | maxScientific :: Scientific 19 | maxScientific = read "1.7976931348623159e308" 20 | -- 1.7976931348623159e308 21 | -------------------------------------------------------------------------------- /src/19-numbers/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - poly-0.3.3.0 4 | - exact-real-0.12.2 5 | - sbv-8.5 6 | -------------------------------------------------------------------------------- /src/20-data-structures/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive dlist.hs 6 | stack exec ghc -- -e ":q" --interactive graph.hs 7 | stack exec ghc -- -e ":q" --interactive hashtables.hs 8 | #stack exec ghc -- -e ":q" --interactive hblas.hs 9 | stack exec ghc -- -e ":q" --interactive map.hs 10 | stack exec ghc -- -e ":q" --interactive sequence.hs 11 | stack exec ghc -- -e ":q" --interactive set.hs 12 | stack exec ghc -- -e ":q" --interactive tree.hs 13 | stack exec ghc -- -e ":q" --interactive unordered.hs 14 | stack exec ghc -- -e ":q" --interactive vector.hs 15 | stack exec ghc -- -e ":q" --interactive vector_mutable.hs 16 | -------------------------------------------------------------------------------- /src/20-data-structures/dlist.hs: -------------------------------------------------------------------------------- 1 | import Data.DList 2 | import Control.Monad 3 | import Control.Monad.Writer 4 | 5 | logger :: Writer (DList Int) () 6 | logger = replicateM_ 100000 $ tell (singleton 0) 7 | -------------------------------------------------------------------------------- /src/20-data-structures/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2016 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.10 && <4.14 14 | , containers >=0.6.0.1 && <0.7 15 | , dlist >=0.8.0.7 && <0.9 16 | , hashtables >= 1.2 && <1.3 17 | , hblas >= 0.4 && <0.5 18 | , hmatrix >= 0.20 && <0.21 19 | , unordered-containers >=0.2.10.0 && <0.3 20 | -------------------------------------------------------------------------------- /src/20-data-structures/graph.hs: -------------------------------------------------------------------------------- 1 | import Data.Tree 2 | import Data.Graph 3 | 4 | data Grph node key = Grph 5 | { _graph :: Graph 6 | , _vertices :: Vertex -> (node, key, [key]) 7 | } 8 | 9 | fromList :: Ord key => [(node, key, [key])] -> Grph node key 10 | fromList = uncurry Grph . graphFromEdges' 11 | 12 | vertexLabels :: Functor f => Grph b t -> (f Vertex) -> f b 13 | vertexLabels g = fmap (vertexLabel g) 14 | 15 | vertexLabel :: Grph b t -> Vertex -> b 16 | vertexLabel g = (\(vi, _, _) -> vi) . (_vertices g) 17 | 18 | -- Topologically sort graph 19 | topo' :: Grph node key -> [node] 20 | topo' g = vertexLabels g $ topSort (_graph g) 21 | 22 | -- Strongly connected components of graph 23 | scc' :: Grph node key -> [[node]] 24 | scc' g = fmap (vertexLabels g . flatten) $ scc (_graph g) 25 | -------------------------------------------------------------------------------- /src/20-data-structures/hashtables.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (lookup) 2 | 3 | import Control.Monad.ST 4 | import Data.HashTable.ST.Basic 5 | 6 | -- Hashtable parameterized by ST "thread" 7 | type HT s = HashTable s String String 8 | 9 | set :: ST s (HT s) 10 | set = do 11 | ht <- new 12 | insert ht "key" "value1" 13 | return ht 14 | 15 | get :: HT s -> ST s (Maybe String) 16 | get ht = do 17 | val <- lookup ht "key" 18 | return val 19 | 20 | example :: Maybe String 21 | example = runST (set >>= get) 22 | -------------------------------------------------------------------------------- /src/20-data-structures/hblas.hs: -------------------------------------------------------------------------------- 1 | import Foreign.Storable 2 | import Numerical.HBLAS.BLAS 3 | import Numerical.HBLAS.MatrixTypes 4 | 5 | -- Generate the constant mutable square matrix of the given type and dimensions. 6 | constMatrix :: Storable a => Int -> a -> IO (IODenseMatrix Row a) 7 | constMatrix n k = generateMutableDenseMatrix SRow (n, n) (const k) 8 | 9 | example_dgemm :: IO () 10 | example_dgemm = do 11 | left <- constMatrix 2 (2 :: Double) 12 | right <- constMatrix 2 (3 :: Double) 13 | out <- constMatrix 2 (0 :: Double) 14 | dgemm NoTranspose NoTranspose 1.0 1.0 left right out 15 | resulting <- mutableVectorToList $ _bufferDenMutMat out 16 | print resulting 17 | -------------------------------------------------------------------------------- /src/20-data-structures/map.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as Map 2 | 3 | kv :: Map.Map Integer String 4 | kv = Map.fromList [(1, "a"), (2, "b")] 5 | 6 | lkup :: Integer -> String -> String 7 | lkup key def = 8 | case Map.lookup key kv of 9 | Just val -> val 10 | Nothing -> def 11 | -------------------------------------------------------------------------------- /src/20-data-structures/sequence.hs: -------------------------------------------------------------------------------- 1 | import Data.Sequence 2 | 3 | a :: Seq Int 4 | a = fromList [1,2,3] 5 | 6 | a0 :: Seq Int 7 | a0 = a |> 4 8 | -- [1,2,3,4] 9 | 10 | a1 :: Seq Int 11 | a1 = 0 <| a 12 | -- [0,1,2,3] 13 | -------------------------------------------------------------------------------- /src/20-data-structures/set.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Set as Set 2 | 3 | set :: Set.Set Integer 4 | set = Set.fromList [1..1000] 5 | 6 | memtest :: Integer -> Bool 7 | memtest elt = Set.member elt set 8 | -------------------------------------------------------------------------------- /src/20-data-structures/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - hblas-0.4.0.1 4 | -------------------------------------------------------------------------------- /src/20-data-structures/tree.hs: -------------------------------------------------------------------------------- 1 | import Data.Tree 2 | 3 | {- 4 | 5 | A 6 | / \ 7 | B C 8 | / \ 9 | D E 10 | 11 | -} 12 | 13 | tree :: Tree String 14 | tree = Node "A" [Node "B" [], Node "C" [Node "D" [], Node "E" []]] 15 | 16 | postorder :: Tree a -> [a] 17 | postorder (Node a ts) = elts ++ [a] 18 | where elts = concat (map postorder ts) 19 | 20 | preorder :: Tree a -> [a] 21 | preorder (Node a ts) = a : elts 22 | where elts = concat (map preorder ts) 23 | 24 | ex1 = drawTree tree 25 | ex2 = drawForest (subForest tree) 26 | ex3 = flatten tree 27 | ex4 = levels tree 28 | ex5 = preorder tree 29 | ex6 = postorder tree 30 | -------------------------------------------------------------------------------- /src/20-data-structures/unordered.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.HashSet as S 2 | import qualified Data.HashMap.Lazy as M 3 | 4 | example1 :: M.HashMap Int Char 5 | example1 = M.fromList $ zip [1..10] ['a'..] 6 | 7 | example2 :: S.HashSet Int 8 | example2 = S.fromList [1..10] 9 | -------------------------------------------------------------------------------- /src/20-data-structures/vector.hs: -------------------------------------------------------------------------------- 1 | import Data.Vector.Unboxed as V 2 | 3 | norm :: Vector Double -> Double 4 | norm = sqrt . V.sum . V.map (\x -> x*x) 5 | 6 | example1 :: Double 7 | example1 = norm $ V.iterateN 100000000 (+1) 0.0 8 | -------------------------------------------------------------------------------- /src/20-data-structures/vector_mutable.hs: -------------------------------------------------------------------------------- 1 | import GHC.Prim 2 | import Control.Monad 3 | import Control.Monad.ST 4 | import Control.Monad.Primitive 5 | 6 | import Data.Vector.Unboxed (freeze) 7 | import Data.Vector.Unboxed.Mutable 8 | import qualified Data.Vector.Unboxed as V 9 | 10 | example :: PrimMonad m => m (V.Vector Int) 11 | example = do 12 | v <- new 10 13 | forM_ [0..9] $ \i -> 14 | write v i (2*i) 15 | freeze v 16 | 17 | -- vector computation in IO 18 | vecIO :: IO (V.Vector Int) 19 | vecIO = example 20 | 21 | -- vector computation in ST 22 | vecST :: ST s (V.Vector Int) 23 | vecST = example 24 | 25 | 26 | main :: IO () 27 | main = do 28 | vecIO >>= print 29 | print $ runST vecST 30 | -------------------------------------------------------------------------------- /src/21-ffi/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive ffi.hs 6 | stack exec ghc -- -e ":q" --interactive simple_ffi.hs 7 | -------------------------------------------------------------------------------- /src/21-ffi/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.10 && <4.14 14 | -------------------------------------------------------------------------------- /src/21-ffi/ffi.hs: -------------------------------------------------------------------------------- 1 | -- ghc qsort.o ffi.hs -o ffi 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | 4 | import Foreign.Ptr 5 | import Foreign.C.Types 6 | 7 | import qualified Data.Vector.Storable as V 8 | import qualified Data.Vector.Storable.Mutable as VM 9 | 10 | foreign import ccall safe "sort" qsort 11 | :: Ptr a -> CInt -> CInt -> IO () 12 | 13 | main :: IO () 14 | main = do 15 | let vs = V.fromList ([1,3,5,2,1,2,5,9,6] :: [CInt]) 16 | v <- V.thaw vs 17 | VM.unsafeWith v $ \ptr -> do 18 | qsort ptr 0 9 19 | out <- V.freeze v 20 | print out 21 | -------------------------------------------------------------------------------- /src/21-ffi/mini-hsc/msghdr.c: -------------------------------------------------------------------------------- 1 | struct msghdr { 2 | void *msg_name; /* protocol address */ 3 | socklen_t msg_namelen; /* size of protocol address */ 4 | struct iovec *msg_iov; /* scatter/gather array */ 5 | int msg_iovlen; /* # elements in msg_iov */ 6 | void *msg_control; /* ancillary data (cmsghdr struct) */ 7 | socklen_t msg_controllen; /* length of ancillary data */ 8 | int msg_flags; /* flags returned by recvmsg() */ 9 | }; 10 | -------------------------------------------------------------------------------- /src/21-ffi/pointer.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void invoke(void (*fn)(int)) 4 | { 5 | int n = 42; 6 | printf("Inside of C, now we'll call Haskell.\n"); 7 | fn(n); 8 | printf("Back inside of C again.\n"); 9 | } 10 | -------------------------------------------------------------------------------- /src/21-ffi/pointer_use.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | 3 | import Foreign 4 | import System.IO 5 | import Foreign.C.Types(CInt(..)) 6 | 7 | foreign import ccall "wrapper" 8 | makeFunPtr :: (CInt -> IO ()) -> IO (FunPtr (CInt -> IO ())) 9 | 10 | foreign import ccall "pointer.c invoke" 11 | invoke :: FunPtr (CInt -> IO ()) -> IO () 12 | 13 | fn :: CInt -> IO () 14 | fn n = do 15 | putStrLn "Hello from Haskell, here's a number passed between runtimes:" 16 | print n 17 | hFlush stdout 18 | 19 | main :: IO () 20 | main = do 21 | fptr <- makeFunPtr fn 22 | invoke fptr 23 | -------------------------------------------------------------------------------- /src/21-ffi/qsort.c: -------------------------------------------------------------------------------- 1 | /* $(CC) -c qsort.c -o qsort.o */ 2 | void swap(int *a, int *b) 3 | { 4 | int t = *a; 5 | *a = *b; 6 | *b = t; 7 | } 8 | 9 | void sort(int *xs, int beg, int end) 10 | { 11 | if (end > beg + 1) { 12 | int piv = xs[beg], l = beg + 1, r = end; 13 | 14 | while (l < r) { 15 | if (xs[l] <= piv) { 16 | l++; 17 | } else { 18 | swap(&xs[l], &xs[--r]); 19 | } 20 | } 21 | 22 | swap(&xs[--l], &xs[beg]); 23 | sort(xs, beg, l); 24 | sort(xs, r, end); 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /src/21-ffi/simple.c: -------------------------------------------------------------------------------- 1 | /* $(CC) -c simple.c -o simple.o */ 2 | 3 | int example(int a, int b) 4 | { 5 | return a + b; 6 | } 7 | -------------------------------------------------------------------------------- /src/21-ffi/simple_ffi.hs: -------------------------------------------------------------------------------- 1 | -- ghc simple.o simple_ffi.hs -o simple_ffi 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | 4 | import Foreign.C.Types 5 | 6 | foreign import ccall safe "example" example 7 | :: CInt -> CInt -> CInt 8 | 9 | main = print (example 42 27) 10 | -------------------------------------------------------------------------------- /src/21-ffi/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/22-concurrency/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive async.hs 6 | stack exec ghc -- -e ":q" --interactive par.hs 7 | stack exec ghc -- -e ":q" --interactive spark.hs 8 | stack exec ghc -- -e ":q" --interactive sparks.hs 9 | stack exec ghc -- -e ":q" --interactive stm.hs 10 | stack exec ghc -- -e ":q" --interactive strategies.hs 11 | stack exec ghc -- -e ":q" --interactive strategies_param.hs 12 | -------------------------------------------------------------------------------- /src/22-concurrency/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | async >=2.2.2 && <2.3 14 | , base >=4.10 && <4.14 15 | , monad-par >=0.3 && <0.4 16 | -------------------------------------------------------------------------------- /src/22-concurrency/spark.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel.Strategies 2 | 3 | parMap' :: (a -> b) -> [a] -> Eval [b] 4 | parMap' f [] = return [] 5 | parMap' f (a:as) = do 6 | b <- rpar (f a) 7 | bs <- parMap' f as 8 | return (b:bs) 9 | 10 | result :: [Int] 11 | result = runEval $ parMap' (+1) [1..1000] 12 | -------------------------------------------------------------------------------- /src/22-concurrency/sparks.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel.Strategies hiding (parPair) 2 | 3 | f :: Integer -> Integer 4 | f x = x + 1 5 | 6 | example :: Integer -> Integer -> Eval (Integer, Integer) 7 | example x y = do 8 | a <- rpar $ f x 9 | b <- rpar $ f y 10 | rseq a 11 | rseq b 12 | return (a, b) 13 | 14 | result :: (Integer, Integer) 15 | result = runEval $ example 10 20 16 | -------------------------------------------------------------------------------- /src/22-concurrency/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/22-concurrency/strategies.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel.Strategies 2 | 3 | parPair' :: Strategy (a, b) 4 | parPair' (a, b) = do 5 | a' <- rpar a 6 | b' <- rpar b 7 | return (a', b') 8 | 9 | fib :: Int -> Int 10 | fib 0 = 0 11 | fib 1 = 1 12 | fib n = fib (n-1) + fib (n-2) 13 | 14 | serial :: (Int, Int) 15 | serial = (fib 30, fib 31) 16 | 17 | parallel :: (Int, Int) 18 | parallel = runEval . parPair' $ (fib 30, fib 31) 19 | -------------------------------------------------------------------------------- /src/22-concurrency/strategies_param.hs: -------------------------------------------------------------------------------- 1 | import Control.DeepSeq 2 | import Control.Parallel.Strategies 3 | 4 | evalPair :: Strategy a -> Strategy b -> Strategy (a, b) 5 | evalPair sa sb (a, b) = do 6 | a' <- sa a 7 | b' <- sb b 8 | return (a', b') 9 | 10 | parPair :: Strategy a -> Strategy b -> Strategy (a, b) 11 | parPair sa sb = evalPair (rparWith sa) (rparWith sb) 12 | 13 | fib :: Int -> Int 14 | fib 0 = 0 15 | fib 1 = 1 16 | fib n = fib (n-1) + fib (n-2) 17 | 18 | serial :: ([Int], [Int]) 19 | serial = (a, b) 20 | where 21 | a = fmap fib [0..30] 22 | b = fmap fib [1..30] 23 | 24 | parallel :: ([Int], [Int]) 25 | parallel = (a, b) `using` evalPair rdeepseq rdeepseq 26 | where 27 | a = fmap fib [0..30] 28 | b = fmap fib [1..30] 29 | -------------------------------------------------------------------------------- /src/23-graphics/diagrams.hs: -------------------------------------------------------------------------------- 1 | import Diagrams.Prelude 2 | import Diagrams.Backend.SVG.CmdLine 3 | 4 | sierpinski :: Int -> Diagram SVG 5 | sierpinski 1 = eqTriangle 1 6 | sierpinski n = 7 | s 8 | === 9 | (s ||| s) # centerX 10 | where 11 | s = sierpinski (n - 1) 12 | 13 | example :: Diagram SVG 14 | example = sierpinski 5 # fc black 15 | 16 | main :: IO () 17 | main = defaultMain example 18 | -------------------------------------------------------------------------------- /src/24-parsing/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive attoparsec.hs 6 | stack exec ghc -- -e ":q" --interactive attoparsec_lang.hs 7 | stack exec ghc -- -e ":q" --interactive configurator.hs 8 | stack exec ghc -- -e ":q" --interactive generics.hs 9 | stack exec ghc -- -e ":q" --interactive lexer_text.hs 10 | stack exec ghc -- -e ":q" --interactive megaparsec.hs 11 | -------------------------------------------------------------------------------- /src/24-parsing/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.6 && <4.14, 15 | attoparsec >= 0.13 && <0.14, 16 | megaparsec >= 7.0 && <9.0, 17 | parsec >= 3.1 && <3.2, 18 | optparse-applicative >= 0.12 && <0.15, 19 | optparse-generic >= 1.3 && <1.4, 20 | configurator >= 0.3 && <0.4, 21 | bytestring >= 0.10 && <0.11, 22 | parser-combinators -any, 23 | text >= 1.2 && <1.3 24 | 25 | default-language: Haskell2010 26 | -------------------------------------------------------------------------------- /src/24-parsing/example.config: -------------------------------------------------------------------------------- 1 | logging 2 | { 3 | verbose = true 4 | logfile = "/tmp/app.log" 5 | loggingLevel = 3 6 | } 7 | 8 | database 9 | { 10 | hostname = "us-east-1.rds.amazonaws.com" 11 | username = "app" 12 | database = "booktown" 13 | password = "hunter2" 14 | } 15 | -------------------------------------------------------------------------------- /src/24-parsing/happy/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval (eval) where 2 | 3 | import Syntax 4 | import Control.Monad.State 5 | import qualified Data.Map as Map 6 | 7 | data Value 8 | = VInt Int 9 | | VUnit 10 | 11 | instance Show Value where 12 | show (VInt x) = show x 13 | 14 | type Eval = StateT Env IO 15 | type Env = [(String, Value)] 16 | 17 | eval1 :: Expr -> Eval Value 18 | eval1 expr = case expr of 19 | Num a -> return (VInt a) 20 | Var a -> do 21 | env <- get 22 | case lookup a env of 23 | Just val -> return val 24 | Nothing -> error "Not in scope" 25 | Print a -> do 26 | a' <- eval1 a 27 | liftIO $ print a' 28 | return VUnit 29 | Assign ref val -> do 30 | modify $ \s -> (ref, VInt val) : s 31 | return VUnit 32 | 33 | eval :: [Expr] -> IO () 34 | eval xs = evalStateT (mapM_ eval1 xs) [] 35 | -------------------------------------------------------------------------------- /src/24-parsing/happy/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Lexer ( 3 | Token(..), 4 | scanTokens 5 | ) where 6 | 7 | import Syntax 8 | } 9 | 10 | %wrapper "basic" 11 | 12 | $digit = 0-9 13 | $alpha = [a-zA-Z] 14 | $eol = [\n] 15 | 16 | tokens :- 17 | 18 | -- Whitespace insensitive 19 | $eol ; 20 | $white+ ; 21 | print { \s -> TokenPrint } 22 | $digit+ { \s -> TokenNum (read s) } 23 | \= { \s -> TokenEq } 24 | $alpha [$alpha $digit \_ \']* { \s -> TokenSym s } 25 | 26 | { 27 | 28 | data Token 29 | = TokenNum Int 30 | | TokenSym String 31 | | TokenPrint 32 | | TokenEq 33 | | TokenEOF 34 | deriving (Eq,Show) 35 | 36 | scanTokens :: String -> [Token] 37 | scanTokens = alexScanTokens 38 | 39 | } 40 | -------------------------------------------------------------------------------- /src/24-parsing/happy/Main.hs: -------------------------------------------------------------------------------- 1 | import Eval (eval) 2 | import Parser (parseExpr) 3 | import System.Environment 4 | 5 | process :: String -> IO () 6 | process input = do 7 | let ast = parseExpr input 8 | case ast of 9 | Right ast -> eval ast 10 | Left err -> do 11 | putStrLn "Parser Error:" 12 | print err 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | case args of 18 | [] -> putStrLn "Usage: assign " 19 | [fname] -> do 20 | contents <- readFile fname 21 | process contents 22 | -------------------------------------------------------------------------------- /src/24-parsing/happy/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | data Expr 4 | = Var String 5 | | Num Int 6 | | Print Expr 7 | | Assign String Int 8 | deriving (Eq,Show) 9 | -------------------------------------------------------------------------------- /src/24-parsing/happy/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.0 3 | build-type: Simple 4 | extra-source-files: README.md 5 | cabal-version: >=1.10 6 | 7 | executable assign 8 | build-depends: 9 | base >= 4.6 && <4.14 10 | , array >= 0.5 && <0.6 11 | , containers >= 0.5 && <0.7 12 | , mtl >= 2.2 13 | default-language: Haskell2010 14 | main-is: Main.hs 15 | build-tools: alex, happy 16 | other-modules: 17 | Parser 18 | Lexer 19 | Syntax 20 | Eval 21 | -------------------------------------------------------------------------------- /src/24-parsing/happy/input.test: -------------------------------------------------------------------------------- 1 | x = 4 2 | print x 3 | y = 5 4 | print y 5 | y = 6 6 | print y 7 | -------------------------------------------------------------------------------- /src/24-parsing/happy/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/24-parsing/optparse_generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | import Options.Generic 8 | 9 | data Options = Options 10 | { verbose :: Bool "Enable verbose mode" 11 | , input :: FilePath "Input file" 12 | , output :: FilePath "Output file" 13 | } 14 | deriving (Generic, Show, ParseRecord) 15 | 16 | main :: IO () 17 | main = do 18 | opts <- getRecord "My CLI" 19 | print (opts :: Options) 20 | -------------------------------------------------------------------------------- /src/24-parsing/parsec_applicative.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | 3 | import Text.Parsec 4 | import Text.Parsec.String (Parser) 5 | import Text.Parsec.Language (haskellStyle) 6 | 7 | import qualified Text.Parsec.Token as Tok 8 | 9 | data Expr = Add String String deriving Show 10 | 11 | lexer :: Tok.TokenParser () 12 | lexer = Tok.makeTokenParser style 13 | where ops = ["->","\\","+","*","-","="] 14 | style = haskellStyle {Tok.reservedOpNames = ops } 15 | 16 | identifier :: Parser String 17 | identifier = Tok.identifier lexer 18 | 19 | parseM :: Parser Expr 20 | parseM = do 21 | a <- identifier 22 | char '+' 23 | b <- identifier 24 | return $ Add a b 25 | 26 | parseA :: Parser Expr 27 | parseA = Add <$> identifier <* char '+' <*> identifier 28 | 29 | main :: IO () 30 | main = do 31 | s0 <- getLine 32 | print $ parse parseM "" s0 33 | s1 <- getLine 34 | print $ parse parseA "" s1 35 | -------------------------------------------------------------------------------- /src/24-parsing/simple.ml: -------------------------------------------------------------------------------- 1 | f = g (x - 1); 2 | g = f (x + 1); 3 | h = \x y -> (f x) + (g y); 4 | -------------------------------------------------------------------------------- /src/24-parsing/simple_parser.hs: -------------------------------------------------------------------------------- 1 | import Text.Parsec 2 | import Text.Parsec.String 3 | 4 | data Expr 5 | = Var Char 6 | | Lam Char Expr 7 | | App Expr Expr 8 | deriving Show 9 | 10 | lam :: Parser Expr 11 | lam = do 12 | char '\\' 13 | n <- letter 14 | string "->" 15 | e <- expr 16 | return $ Lam n e 17 | 18 | app :: Parser Expr 19 | app = do 20 | apps <- many1 term 21 | return $ foldl1 App apps 22 | 23 | var :: Parser Expr 24 | var = do 25 | n <- letter 26 | return $ Var n 27 | 28 | parens :: Parser Expr -> Parser Expr 29 | parens p = do 30 | char '(' 31 | e <- p 32 | char ')' 33 | return e 34 | 35 | term :: Parser Expr 36 | term = var <|> parens expr 37 | 38 | expr :: Parser Expr 39 | expr = lam <|> app 40 | 41 | decl :: Parser Expr 42 | decl = do 43 | e <- expr 44 | eof 45 | return e 46 | 47 | test :: IO () 48 | test = parseTest decl "\\y->y(\\x->x)y" 49 | 50 | main :: IO () 51 | main = test >>= print 52 | -------------------------------------------------------------------------------- /src/24-parsing/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/25-streaming/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive conduit.hs 6 | stack exec ghc -- -e ":q" --interactive lazyio.hs 7 | stack exec ghc -- -e ":q" --interactive pipes.hs 8 | stack exec ghc -- -e ":q" --interactive pipes_file.hs 9 | stack exec ghc -- -e ":q" --interactive pipes_io.hs 10 | #stack exec ghc -- -e ":q" --interactive pipes_safe.hs 11 | -------------------------------------------------------------------------------- /src/25-streaming/conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | import Control.Monad.Trans 4 | import Data.Conduit 5 | import qualified Data.Conduit.List as CL 6 | 7 | source :: ConduitT () Int IO () 8 | source = CL.sourceList [1 .. 100] 9 | 10 | conduit :: ConduitT Int String IO () 11 | conduit = do 12 | val <- await 13 | case val of 14 | Nothing -> return () 15 | Just n -> do 16 | if | n `mod` 15 == 0 -> yield "FizzBuzz" 17 | | n `mod` 5 == 0 -> yield "Fizz" 18 | | n `mod` 3 == 0 -> yield "Buzz" 19 | | otherwise -> return () 20 | conduit 21 | 22 | sink :: ConduitT String o IO () 23 | sink = CL.mapM_ putStrLn 24 | 25 | main :: IO () 26 | main = runConduit $ source .| conduit .| sink 27 | -------------------------------------------------------------------------------- /src/25-streaming/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >=4.6 && <4.14 14 | , conduit >=1.3.1.2 && <1.4 15 | , mtl >=2.2.2 && <2.3 16 | , pipes >=4.3.13 && <4.4 17 | , pipes-safe >2.3 && <2.4 18 | --, zeromq-haskell 19 | -------------------------------------------------------------------------------- /src/25-streaming/foo.txt: -------------------------------------------------------------------------------- 1 | foo 2 | -------------------------------------------------------------------------------- /src/25-streaming/lazyio.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | 3 | main :: IO () 4 | main = do 5 | withFile "foo.txt" ReadMode $ \fd -> do 6 | contents <- hGetContents fd 7 | print contents 8 | -- "foo\n" 9 | 10 | contents <- withFile "foo.txt" ReadMode hGetContents 11 | print contents 12 | -- "" 13 | -------------------------------------------------------------------------------- /src/25-streaming/pipes.hs: -------------------------------------------------------------------------------- 1 | import Pipes 2 | import Pipes.Prelude as P 3 | import Control.Monad 4 | import Control.Monad.Identity 5 | 6 | a :: Producer Int Identity () 7 | a = forM_ [1..10] yield 8 | 9 | b :: Pipe Int Int Identity () 10 | b = forever $ do 11 | x <- await 12 | yield (x*2) 13 | yield (x*3) 14 | yield (x*4) 15 | 16 | c :: Pipe Int Int Identity () 17 | c = forever $ do 18 | x <- await 19 | if (x `mod` 2) == 0 20 | then yield x 21 | else return () 22 | 23 | result :: [Int] 24 | result = P.toList $ a >-> b >-> c 25 | -------------------------------------------------------------------------------- /src/25-streaming/pipes_file.hs: -------------------------------------------------------------------------------- 1 | import Pipes 2 | import Pipes.Prelude as P 3 | import System.IO 4 | 5 | readF :: FilePath -> Producer String IO () 6 | readF file = do 7 | lift $ putStrLn $ "Opened" ++ file 8 | h <- lift $ openFile file ReadMode 9 | fromHandle h 10 | lift $ putStrLn $ "Closed" ++ file 11 | lift $ hClose h 12 | 13 | main :: IO () 14 | main = runEffect $ readF "foo.txt" >-> P.take 3 >-> stdoutLn 15 | -------------------------------------------------------------------------------- /src/25-streaming/pipes_io.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | import Pipes 4 | import qualified Pipes.Prelude as P 5 | 6 | count :: Producer Integer IO () 7 | count = each [1..100] 8 | 9 | fizzbuzz :: Pipe Integer String IO () 10 | fizzbuzz = do 11 | n <- await 12 | if | n `mod` 15 == 0 -> yield "FizzBuzz" 13 | | n `mod` 5 == 0 -> yield "Fizz" 14 | | n `mod` 3 == 0 -> yield "Buzz" 15 | | otherwise -> return () 16 | fizzbuzz 17 | 18 | main :: IO () 19 | main = runEffect $ count >-> fizzbuzz >-> P.stdoutLn 20 | -------------------------------------------------------------------------------- /src/25-streaming/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - zeromq-haskell-0.8.4 4 | -------------------------------------------------------------------------------- /src/26-data-formats/aeson_derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | import Data.Aeson 5 | import Data.ByteString.Lazy.Char8 as BL 6 | import Data.Text 7 | import GHC.Generics 8 | 9 | data Refs 10 | = Refs 11 | { a :: Text, 12 | b :: Text 13 | } 14 | deriving (Show, Generic, FromJSON, ToJSON) 15 | 16 | data Data 17 | = Data 18 | { id :: Int, 19 | name :: Text, 20 | price :: Int, 21 | tags :: [Text], 22 | refs :: Refs 23 | } 24 | deriving (Show, Generic, FromJSON, ToJSON) 25 | 26 | main :: IO () 27 | main = do 28 | contents <- BL.readFile "example.json" 29 | let Just dat = decode contents 30 | print $ name dat 31 | print $ a (refs dat) 32 | BL.putStrLn $ encode dat 33 | -------------------------------------------------------------------------------- /src/26-data-formats/aeson_structured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | import Data.Text 4 | import Data.Aeson 5 | import GHC.Generics 6 | import qualified Data.ByteString.Lazy as BL 7 | 8 | import Control.Applicative 9 | 10 | data Refs = Refs 11 | { a :: Text 12 | , b :: Text 13 | } deriving (Show,Generic) 14 | 15 | data Data = Data 16 | { id :: Int 17 | , name :: Text 18 | , price :: Float 19 | , tags :: [Text] 20 | , refs :: Refs 21 | } deriving (Show,Generic) 22 | 23 | instance FromJSON Data 24 | instance FromJSON Refs 25 | instance ToJSON Data 26 | instance ToJSON Refs 27 | 28 | main :: IO () 29 | main = do 30 | contents <- BL.readFile "example.json" 31 | let Just dat = decode contents 32 | print $ name dat 33 | print $ a (refs dat) 34 | -------------------------------------------------------------------------------- /src/26-data-formats/aeson_unstructured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Text 4 | import Data.Aeson 5 | import Data.Vector 6 | import qualified Data.HashMap.Strict as M 7 | import qualified Data.ByteString.Lazy as BL 8 | 9 | -- Pull a key out of an JSON object. 10 | (^?) :: Value -> Text -> Maybe Value 11 | (^?) (Object obj) k = M.lookup k obj 12 | (^?) _ _ = Nothing 13 | 14 | -- Pull the ith value out of a JSON list. 15 | ix :: Value -> Int -> Maybe Value 16 | ix (Array arr) i = arr !? i 17 | ix _ _ = Nothing 18 | 19 | readJSON str = do 20 | obj <- decode str 21 | price <- obj ^? "price" 22 | refs <- obj ^? "refs" 23 | tags <- obj ^? "tags" 24 | aref <- refs ^? "a" 25 | tag1 <- tags `ix` 0 26 | return (price, aref, tag1) 27 | 28 | main :: IO () 29 | main = do 30 | contents <- BL.readFile "example.json" 31 | print $ readJSON contents 32 | -------------------------------------------------------------------------------- /src/26-data-formats/cassava_structured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | import Data.Csv 5 | import GHC.Generics 6 | import qualified Data.Vector as V 7 | import qualified Data.ByteString.Lazy as BL 8 | 9 | data Plant = Plant 10 | { sepal_length :: Double 11 | , sepal_width :: Double 12 | , petal_length :: Double 13 | , petal_width :: Double 14 | , plant_class :: String 15 | } deriving (Generic, Show) 16 | 17 | instance FromNamedRecord Plant 18 | instance ToNamedRecord Plant 19 | 20 | type ErrorMsg = String 21 | type CsvData = (Header, V.Vector Plant) 22 | 23 | parseCSV :: FilePath -> IO (Either ErrorMsg CsvData) 24 | parseCSV fname = do 25 | contents <- BL.readFile fname 26 | return $ decodeByName contents 27 | 28 | main = parseCSV "iris.csv" >>= print 29 | -------------------------------------------------------------------------------- /src/26-data-formats/cassava_unstructured.hs: -------------------------------------------------------------------------------- 1 | import Data.Csv 2 | 3 | import Text.Show.Pretty 4 | 5 | import qualified Data.Vector as V 6 | import qualified Data.ByteString.Lazy as BL 7 | 8 | type ErrorMsg = String 9 | type CsvData = V.Vector (V.Vector BL.ByteString) 10 | 11 | example :: FilePath -> IO (Either ErrorMsg CsvData) 12 | example fname = do 13 | contents <- BL.readFile fname 14 | return $ decode NoHeader contents 15 | -------------------------------------------------------------------------------- /src/26-data-formats/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive aeson_custom.hs 6 | stack exec ghc -- -e ":q" --interactive aeson_derive.hs 7 | stack exec ghc -- -e ":q" --interactive aeson_structured.hs 8 | stack exec ghc -- -e ":q" --interactive aeson_unstructured.hs 9 | stack exec ghc -- -e ":q" --interactive cassava_structured.hs 10 | stack exec ghc -- -e ":q" --interactive cassava_unstructured.hs 11 | stack exec ghc -- -e ":q" --interactive yaml.hs 12 | -------------------------------------------------------------------------------- /src/26-data-formats/crew.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Jean-Luc Picard", 3 | "rank": "Captain" 4 | } 5 | -------------------------------------------------------------------------------- /src/26-data-formats/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | aeson >=1.4.6.0 && <1.5 14 | , base >=4.6 && <4.14 15 | , cassava >=0.5.2.0 && <0.6 16 | , pretty-show >=1.10 && <1.11 17 | , yaml >=0.11.2.0 && <0.12 18 | -------------------------------------------------------------------------------- /src/26-data-formats/example.json: -------------------------------------------------------------------------------- 1 | { 2 | "id": 1, 3 | "name": "A green door", 4 | "price": 12.50, 5 | "tags": ["home", "green"], 6 | "refs": { 7 | "a": "red", 8 | "b": "blue" 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /src/26-data-formats/example.yaml: -------------------------------------------------------------------------------- 1 | invoice: 34843 2 | date : 2001-01-23 3 | bill: 4 | given : Chris 5 | family : Dumars 6 | address: 7 | lines: | 8 | 458 Walkman Dr. 9 | Suite #292 10 | city : Royal Oak 11 | state : MI 12 | postal : 48046 13 | -------------------------------------------------------------------------------- /src/26-data-formats/iris.csv: -------------------------------------------------------------------------------- 1 | sepal_length,sepal_width,petal_length,petal_width,plant_class 2 | 5.1,3.5,1.4,0.2,Iris-setosa 3 | 5.0,2.0,3.5,1.0,Iris-versicolor 4 | 6.3,3.3,6.0,2.5,Iris-virginica 5 | -------------------------------------------------------------------------------- /src/26-data-formats/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - pretty-show-1.10 4 | - haskell-lexer-1.1 5 | -------------------------------------------------------------------------------- /src/27-web/blaze.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Html where 4 | 5 | import Text.Blaze.Html5 6 | import Text.Blaze.Html.Renderer.Text 7 | 8 | import qualified Data.Text.Lazy.IO as T 9 | 10 | example :: Html 11 | example = do 12 | h1 "First header" 13 | p $ ul $ mconcat [li "First", li "Second"] 14 | 15 | main :: IO () 16 | main = do 17 | T.putStrLn $ renderHtml example 18 | -------------------------------------------------------------------------------- /src/27-web/blaze_instance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Html where 5 | 6 | import Text.Blaze.Html5 7 | import Text.Blaze.Html.Renderer.Text 8 | 9 | import qualified Data.Text.Lazy as T 10 | import qualified Data.Text.Lazy.IO as T 11 | 12 | data Employee = Employee 13 | { name :: T.Text 14 | , age :: Int 15 | } 16 | 17 | instance ToMarkup Employee where 18 | toMarkup Employee {..} = ul $ mconcat 19 | [ li (toHtml name) 20 | , li (toHtml age) 21 | ] 22 | 23 | fred :: Employee 24 | fred = Employee { name = "Fred", age = 35 } 25 | 26 | main :: IO () 27 | main = do 28 | T.putStrLn $ renderHtml (toHtml fred) 29 | -------------------------------------------------------------------------------- /src/27-web/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive blaze.hs 6 | stack exec ghc -- -e ":q" --interactive blaze_instance.hs 7 | #stack exec ghc -- -e ":q" --interactive hastache.hs 8 | #stack exec ghc -- -e ":q" --interactive hastache_generic.hs 9 | stack exec ghc -- -e ":q" --interactive http.hs 10 | stack exec ghc -- -e ":q" --interactive lucid.hs 11 | stack exec ghc -- -e ":q" --interactive req.hs 12 | stack exec ghc -- -e ":q" --interactive scotty.hs 13 | stack exec ghc -- -e ":q" --interactive warp.hs 14 | -------------------------------------------------------------------------------- /src/27-web/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | aeson >=1.4 && <1.5 14 | , async >=2.2.2 && <2.3 15 | , base >=4.6 && <4.14 16 | , http-client >=0.6 && <0.7 17 | , http-types >=0.12.3 && <0.13 18 | , lucid >=2.9.12 && <2.10 19 | , mtl >=2.2 && <2.3 20 | , req >=3.0 && <3.1 21 | , scotty >=0.11 && <0.12 22 | , servant >=0.16 && <0.17 23 | , servant-server >=0.16 && <0.17 24 | , Spock >=0.13 && <0.14 25 | , text >=1.2 && <1.3 26 | , wai >=3.2.2.1 && <3.3 27 | , warp >=3.3.0 && <3.4 28 | -------------------------------------------------------------------------------- /src/27-web/hastache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Text.Hastache 4 | import Text.Hastache.Context 5 | 6 | import qualified Data.Text as T 7 | import qualified Data.Text.Lazy as TL 8 | import qualified Data.Text.Lazy.IO as TL 9 | 10 | import Data.Data 11 | 12 | template :: FilePath -> MuContext IO -> IO TL.Text 13 | template = hastacheFile defaultConfig 14 | 15 | -- Function strContext 16 | context :: String -> MuType IO 17 | context "body" = MuVariable ("Hello World" :: TL.Text) 18 | context "title" = MuVariable ("Haskell is lovely" :: TL.Text) 19 | context _ = MuVariable () 20 | 21 | main :: IO () 22 | main = do 23 | output <- template "templates/home.html" (mkStrContext context) 24 | TL.putStrLn output 25 | -------------------------------------------------------------------------------- /src/27-web/hastache_generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | 4 | import Text.Hastache 5 | import Text.Hastache.Context 6 | 7 | import qualified Data.Text.Lazy as TL 8 | import qualified Data.Text.Lazy.IO as TL 9 | 10 | import Data.Data 11 | 12 | template :: FilePath -> MuContext IO -> IO TL.Text 13 | template = hastacheFile defaultConfig 14 | 15 | -- Record context 16 | data TemplateCtx = TemplateCtx 17 | { body :: TL.Text 18 | , title :: TL.Text 19 | } deriving (Data, Typeable) 20 | 21 | main :: IO () 22 | main = do 23 | let ctx = TemplateCtx { body = "Hello", title = "Haskell" } 24 | output <- template "templates/home.html" (mkGenericContext ctx) 25 | TL.putStrLn output 26 | -------------------------------------------------------------------------------- /src/27-web/http.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Applicative 4 | import Control.Concurrent.Async 5 | import Network.HTTP.Client 6 | import Network.HTTP.Types 7 | 8 | type URL = String 9 | 10 | get :: Manager -> URL -> IO Int 11 | get m url = do 12 | req <- parseUrlThrow url 13 | statusCode . responseStatus <$> httpNoBody req m 14 | 15 | single :: IO Int 16 | single = do 17 | manager <- newManager defaultManagerSettings 18 | get manager "http://haskell.org" 19 | 20 | parallel :: IO [Int] 21 | parallel = do 22 | manager <- newManager defaultManagerSettings 23 | -- Fetch w3.org 10 times concurrently 24 | let urls = replicate 10 "http://www.w3.org" 25 | mapConcurrently (get manager) urls 26 | 27 | main :: IO () 28 | main = do 29 | print =<< single 30 | print =<< parallel 31 | -------------------------------------------------------------------------------- /src/27-web/lucid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Lucid 7 | import Lucid.Base 8 | import Lucid.Html5 9 | 10 | example1 :: Html () 11 | example1 = table_ (tr_ (td_ (p_ "My table."))) 12 | 13 | example2 :: Html () 14 | example2 = html_ do 15 | head_ do 16 | title_ "HTML from Haskell" 17 | link_ [rel_ "stylesheet", type_ "text/css", href_ "bootstrap.css"] 18 | body_ do 19 | p_ "Generating HTMl form Haskell datatypes:" 20 | ul_ $ mapM_ (li_ . toHtml . show) [1 .. 100] 21 | 22 | main :: IO () 23 | main = do 24 | print (renderText example1) 25 | print (renderBS example2) 26 | -------------------------------------------------------------------------------- /src/27-web/mini-servant/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | build-type: Simple 5 | 6 | executable example-server 7 | main-is: Main.hs 8 | build-tools: alex -any, happy -any 9 | default-language: Haskell2010 10 | ghc-options: -Wall 11 | build-depends: 12 | array >=0.5 && <0.6 13 | , base >=4.6 && <4.14 14 | , blaze-html >=0.9.1.2 && <0.10 15 | , blaze-markup >=0.8.2.3 && <0.9 16 | , bytestring >=0.10.8.2 && <0.11 17 | , containers >=0.5 && <0.7 18 | , exceptions >=0.10.4 && <0.11 19 | , http-api-data >=0.4.1.1 && <0.5 20 | , mtl >=2.2 && <2.3 21 | , servant >=0.16.2 && <0.17 22 | , servant-blaze >=0.9 && <0.10 23 | , servant-server >=0.16.2 && <0.17 24 | , text >=1.2.3.1 && <1.3 25 | , transformers >=0.5.6.2 && <0.6 26 | , warp >=3.3.5 && <3.4 27 | -------------------------------------------------------------------------------- /src/27-web/mini-servant/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/27-web/req.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import Control.Monad.Trans 6 | import Data.Aeson 7 | import GHC.Generics 8 | import Network.HTTP.Req 9 | 10 | data Point = Point {x :: Int, y :: Int} 11 | deriving (Generic, ToJSON, FromJSON) 12 | 13 | example :: IO () 14 | example = runReq defaultHttpConfig $ do 15 | -- GET request http response 16 | r <- req GET (https "w3.org") NoReqBody bsResponse mempty 17 | liftIO $ print (responseBody r) 18 | -- GET request json response 19 | r <- req GET (https "api.github.com" /: "users" /: "sdiehl") NoReqBody jsonResponse mempty 20 | liftIO $ print (responseBody r :: Value) 21 | -- POST request json payload 22 | r <- req POST (https "example.com") (ReqBodyJson (Point 1 2)) jsonResponse mempty 23 | liftIO $ print (responseBody r :: Value) 24 | -------------------------------------------------------------------------------- /src/27-web/scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Web.Scotty 4 | 5 | import qualified Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5 (toHtml, Html) 7 | import Text.Blaze.Html.Renderer.Text (renderHtml) 8 | 9 | greet :: String -> Html 10 | greet user = H.html $ do 11 | H.head $ 12 | H.title "Welcome!" 13 | H.body $ do 14 | H.h1 "Greetings!" 15 | H.p ("Hello " >> toHtml user >> "!") 16 | 17 | app = do 18 | get "/" $ 19 | text "Home Page" 20 | 21 | get "/greet/:name" $ do 22 | name <- param "name" 23 | html $ renderHtml (greet name) 24 | 25 | main :: IO () 26 | main = scotty 8000 app 27 | -------------------------------------------------------------------------------- /src/27-web/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - hastache-0.6.1 6 | - Spock-0.13.0.0 7 | - Spock-core-0.13.0.0 8 | - reroute-0.5.0.0 9 | - stm-containers-0.2.16 10 | - focus-0.1.5.2 11 | - req-3.0.0 12 | flags: {} 13 | extra-package-dbs: [] 14 | -------------------------------------------------------------------------------- /src/27-web/warp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Network.HTTP.Types 4 | import Network.Wai 5 | import Network.Wai.Handler.Warp (run) 6 | 7 | app :: Application 8 | app req respond = respond $ responseLBS status200 [] "Make it so." 9 | 10 | main :: IO () 11 | main = run 8000 app 12 | -------------------------------------------------------------------------------- /src/28-databases/books.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/src/28-databases/books.db -------------------------------------------------------------------------------- /src/28-databases/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive acid.hs 6 | stack exec ghc -- -e ":q" --interactive hedis.hs 7 | stack exec ghc -- -e ":q" --interactive hedis_pubsub.hs 8 | stack exec ghc -- -e ":q" --interactive postgres.hs 9 | stack exec ghc -- -e ":q" --interactive postgres_custom.hs 10 | stack exec ghc -- -e ":q" --interactive postgres_qq.hs 11 | stack exec ghc -- -e ":q" --interactive selda.hs 12 | stack exec ghc -- -e ":q" --interactive sqlite.hs 13 | -------------------------------------------------------------------------------- /src/28-databases/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | acid-state 14 | , base >=4.6 && <4.14 15 | , hedis >=0.12 && <0.13 16 | , postgresql-simple >=0.6 && <0.7 17 | , selda >=0.5.1.0 && <0.6 18 | , sqlite-simple >=0.4 && <0.5 19 | -------------------------------------------------------------------------------- /src/28-databases/hedis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Database.Redis 4 | import Data.ByteString.Char8 5 | 6 | session :: Redis (Either Reply (Maybe ByteString)) 7 | session = do 8 | set "hello" "haskell" 9 | get "hello" 10 | 11 | main :: IO () 12 | main = do 13 | conn <- connect defaultConnectInfo 14 | res <- runRedis conn session 15 | print res 16 | -------------------------------------------------------------------------------- /src/28-databases/hedis_pubsub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Database.Redis 4 | 5 | import Control.Monad 6 | import Control.Monad.Trans 7 | import Data.ByteString.Char8 8 | 9 | import Control.Concurrent 10 | 11 | subscriber :: Redis () 12 | subscriber = 13 | pubSub (subscribe ["news"]) $ \msg -> do 14 | print msg 15 | return mempty 16 | 17 | publisher :: Redis () 18 | publisher = forM_ [1..100] $ \n -> publish "news" (pack (show n)) 19 | 20 | -- connects to localhost:6379 21 | main :: IO () 22 | main = do 23 | conn1 <- connect defaultConnectInfo 24 | conn2 <- connect defaultConnectInfo 25 | 26 | -- Fork off a publisher 27 | forkIO $ runRedis conn1 publisher 28 | 29 | -- Subscribe for messages 30 | runRedis conn2 subscriber 31 | -------------------------------------------------------------------------------- /src/28-databases/mini-selda/company.sqlite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/src/28-databases/mini-selda/company.sqlite -------------------------------------------------------------------------------- /src/28-databases/mini-selda/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | build-type: Simple 5 | 6 | executable example 7 | main-is: Main.hs 8 | default-language: Haskell2010 9 | ghc-options: -Wall 10 | build-depends: 11 | array >=0.5 && <0.6 12 | , base >=4.6 && <4.14 13 | , mtl >=2.2 && <2.3 14 | , text >=1.2.3.1 && <1.3 15 | , transformers >=0.5.6.2 && <0.6 16 | , selda >=0.5.0 && <0.6 17 | , selda-sqlite >=0.1.0 && <0.2 18 | -------------------------------------------------------------------------------- /src/28-databases/mini-selda/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - selda-0.5.1.0 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /src/28-databases/postgres.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | import qualified Data.Text as T 5 | import qualified Database.PostgreSQL.Simple as SQL 6 | 7 | creds :: SQL.ConnectInfo 8 | creds = 9 | SQL.defaultConnectInfo 10 | { SQL.connectUser = "example", 11 | SQL.connectPassword = "example", 12 | SQL.connectDatabase = "booktown" 13 | } 14 | 15 | selectBooks :: SQL.Connection -> IO [(Int, T.Text, Int)] 16 | selectBooks conn = SQL.query_ conn "select id, title, author_id from books" 17 | 18 | main :: IO () 19 | main = do 20 | conn <- SQL.connect creds 21 | books <- selectBooks conn 22 | print books 23 | -------------------------------------------------------------------------------- /src/28-databases/postgres_custom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.Text as T 4 | 5 | import qualified Database.PostgreSQL.Simple as SQL 6 | import Database.PostgreSQL.Simple.FromRow (FromRow(..), field) 7 | 8 | data Book = Book 9 | { id_ :: Int 10 | , title :: T.Text 11 | , author_id :: Int 12 | } deriving (Show) 13 | 14 | instance FromRow Book where 15 | fromRow = Book <$> field <*> field <*> field 16 | 17 | creds :: SQL.ConnectInfo 18 | creds = SQL.defaultConnectInfo 19 | { SQL.connectUser = "example" 20 | , SQL.connectPassword = "example" 21 | , SQL.connectDatabase = "booktown" 22 | } 23 | 24 | selectBooks :: SQL.Connection -> IO [Book] 25 | selectBooks conn = SQL.query_ conn "select id, title, author_id from books limit 4" 26 | 27 | main :: IO () 28 | main = do 29 | conn <- SQL.connect creds 30 | books <- selectBooks conn 31 | print books 32 | -------------------------------------------------------------------------------- /src/28-databases/selda.hs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/wiwinwlh/59ccf63de431074bd202805d888b56de2d0c8ebb/src/28-databases/selda.hs -------------------------------------------------------------------------------- /src/28-databases/sqlite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | import Data.Text as T 5 | import Database.SQLite.Simple as SQL 6 | 7 | selectBooks :: SQL.Connection -> IO [(Int, T.Text, Int)] 8 | selectBooks conn = SQL.query_ conn "select id, title, author_id from books" 9 | 10 | main :: IO () 11 | main = do 12 | conn <- open "books.db" 13 | books <- selectBooks conn 14 | pure () 15 | -------------------------------------------------------------------------------- /src/28-databases/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - acid-state-0.14.3 6 | - selda-0.5.1.0 7 | flags: {} 8 | extra-package-dbs: [] 9 | -------------------------------------------------------------------------------- /src/29-ghc/artifacts/example.dump-parsed: -------------------------------------------------------------------------------- 1 | f :: Int -> Int 2 | f x = x + 1 3 | main :: IO () 4 | main = do { print (f 10) } 5 | 6 | -------------------------------------------------------------------------------- /src/29-ghc/artifacts/example.dump-simpl: -------------------------------------------------------------------------------- 1 | Result size of Tidy Core = {terms: 12, types: 7, coercions: 0} 2 | 3 | Main.main :: GHC.Types.IO () 4 | [GblId] 5 | Main.main = 6 | System.IO.print 7 | @ GHC.Types.Int 8 | GHC.Show.$fShowInt 9 | (GHC.Num.+ 10 | @ GHC.Types.Int 11 | GHC.Num.$fNumInt 12 | (GHC.Types.I# 10) 13 | (GHC.Types.I# 1)) 14 | 15 | :Main.main :: GHC.Types.IO () 16 | [GblId] 17 | :Main.main = GHC.TopHandler.runMainIO @ () Main.main 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/29-ghc/artifacts/example.dump-stg: -------------------------------------------------------------------------------- 1 | sat_sn2 :: GHC.Types.Int 2 | [LclId] = 3 | \u srt:(0,*bitmap*) [] 4 | let { 5 | sat_smZ :: GHC.Types.Int 6 | [LclId] = 7 | NO_CCS GHC.Types.I#! [1]; } in 8 | let { 9 | sat_sn0 :: GHC.Types.Int 10 | [LclId] = 11 | NO_CCS GHC.Types.I#! [10]; 12 | } in GHC.Num.+ GHC.Num.$fNumInt sat_sn0 sat_smZ; 13 | SRT(sat_sn2): [GHC.Num.$fNumInt] 14 | Main.main :: GHC.Types.IO () 15 | [GblId] = 16 | \u srt:(0,*bitmap*) [] System.IO.print GHC.Show.$fShowInt sat_sn2; 17 | SRT(Main.main): [System.IO.print, GHC.Show.$fShowInt, sat_sn2] 18 | :Main.main :: GHC.Types.IO () 19 | [GblId] = 20 | \u srt:(0,*bitmap*) [] GHC.TopHandler.runMainIO Main.main; 21 | SRT(:Main.main): [GHC.TopHandler.runMainIO, Main.main] 22 | 23 | -------------------------------------------------------------------------------- /src/29-ghc/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | #stack exec ghc -- -e ":q" --interactive closure_size.hs 6 | #stack exec ghc -- -e ":q" --interactive cmm_include.hs 7 | stack exec ghc -- -e ":q" --interactive dictionaries.hs 8 | stack exec ghc -- -e ":q" --interactive ekg.hs 9 | stack exec ghc -- -e ":q" --interactive example.hs 10 | stack exec ghc -- -e ":q" --interactive heapview.hs 11 | #stack exec ghc -- -e ":q" --interactive hie.hs 12 | #stack exec ghc -- -e ":q" --interactive io_impl.hs 13 | stack exec ghc -- -e ":q" --interactive monad_prim.hs 14 | stack exec ghc -- -e ":q" --interactive prim.hs 15 | stack exec ghc -- -e ":q" --interactive profile.hs 16 | stack exec ghc -- -e ":q" --interactive specialize.hs 17 | -------------------------------------------------------------------------------- /src/29-ghc/closure_size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | 4 | --{-# OPTIONS_GHC -O1 #-} 5 | 6 | module Main where 7 | 8 | import Foreign 9 | import GHC.Base 10 | import GHC.Exts 11 | 12 | data Size 13 | = Size 14 | { ptrs :: Int, 15 | nptrs :: Int, 16 | size :: Int 17 | } 18 | deriving (Show) 19 | 20 | unsafeSizeof :: a -> Size 21 | unsafeSizeof a = 22 | case unpackClosure# a of 23 | (# x, ptrs, nptrs #) -> 24 | let header = sizeOf (undefined :: Int) 25 | ptr_c = I# (sizeofArray# ptrs) 26 | nptr_c = I# (sizeofByteArray# nptrs) `div` sizeOf (undefined :: Word) 27 | payload = I# (sizeofArray# ptrs +# sizeofByteArray# nptrs) 28 | size = header + payload 29 | in Size ptr_c nptr_c size 30 | 31 | data A = A {-# UNPACK #-} !Int 32 | 33 | data B = B Int 34 | 35 | main :: IO () 36 | main = do 37 | print (unsafeSizeof (A 42)) 38 | print (unsafeSizeof (B 42)) 39 | -------------------------------------------------------------------------------- /src/29-ghc/cmm/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE GHCForeignImportPrim #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnliftedFFITypes #-} 5 | 6 | module Main where 7 | 8 | import GHC.Prim 9 | import GHC.Word 10 | 11 | foreign import prim "example" example_cmm :: Word# -> Word# 12 | 13 | example :: Word64 -> Word64 14 | example (W64# n) = W64# (example_cmm n) 15 | 16 | main :: IO () 17 | main = print (example 2) 18 | -------------------------------------------------------------------------------- /src/29-ghc/cmm/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: example 3 | build-type: Simple 4 | version: 1.0.0 5 | 6 | executable example 7 | main-is: Main.hs 8 | build-depends: base, ghc-prim 9 | default-language: Haskell2010 10 | ghc-options: -ddump-cmm 11 | c-sources: example.cmm 12 | -------------------------------------------------------------------------------- /src/29-ghc/cmm/example.cmm: -------------------------------------------------------------------------------- 1 | #include "Cmm.h" 2 | 3 | example (W_ n) { 4 | entry: 5 | return (n+1); 6 | } 7 | -------------------------------------------------------------------------------- /src/29-ghc/cmm/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/29-ghc/cmm_include.hs: -------------------------------------------------------------------------------- 1 | -- ghc -c factorial.cmm -o factorial.o 2 | -- ghc factorial.o Example.hs -o Example 3 | 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE UnliftedFFITypes #-} 6 | {-# LANGUAGE GHCForeignImportPrim #-} 7 | {-# LANGUAGE ForeignFunctionInterface #-} 8 | 9 | module Main where 10 | 11 | import GHC.Prim 12 | import GHC.Word 13 | 14 | foreign import prim "factorial" factorial_cmm :: Word# -> Word# 15 | 16 | factorial :: Word64 -> Word64 17 | factorial (W64# n) = W64# (factorial_cmm n) 18 | 19 | main :: IO () 20 | main = print (factorial 5) 21 | -------------------------------------------------------------------------------- /src/29-ghc/dictionaries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Typeclasses where 4 | 5 | import Prelude (not, Bool(..)) 6 | 7 | data Animal = Dog | Cat 8 | 9 | class EqClass t where 10 | equal :: t -> t -> Bool 11 | neq :: t -> t -> Bool 12 | 13 | neq a b = not (equal a b) 14 | 15 | instance EqClass Animal where 16 | equal Dog Dog = True 17 | equal Cat Cat = True 18 | equal _ _ = False 19 | 20 | 21 | data EqDict t = EqDict { equal' :: t -> t -> Bool } 22 | 23 | equalAnimal Dog Dog = True 24 | equalAnimal Cat Cat = True 25 | equalAnimal _ _ = False 26 | 27 | animalEq :: EqDict Animal 28 | animalEq = EqDict equalAnimal 29 | 30 | neqAnimal :: EqClass t => t -> t -> Bool 31 | neqAnimal a b = neq a b 32 | 33 | neqAnimal' :: EqDict t -> t -> t -> Bool 34 | neqAnimal' dict a b = not (equal' dict a b) 35 | -------------------------------------------------------------------------------- /src/29-ghc/ekg.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | 3 | import Control.Monad 4 | import System.Remote.Monitoring 5 | 6 | main :: IO () 7 | main = do 8 | ekg <- forkServer "localhost" 8000 9 | putStrLn "Started server on http://localhost:8000" 10 | forever $ getLine >>= putStrLn 11 | -------------------------------------------------------------------------------- /src/29-ghc/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1.0.0 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | category: Documentation 8 | build-type: Simple 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >= 4.10 && <4.14 14 | , ghc == 8.6.5 15 | , ekg >= 0.4.0 && < 0.5 16 | , transformers >= 0.5.6 && < 0.6 17 | , ghc-boot-th >= 8.6.5 && < 8.7 18 | , mtl >= 2.2.2 && < 2.3 19 | , ghc-heap-view >= 0.6.1 && < 0.7 20 | , ghc-paths >= 0.1.0 && < 0.2 21 | , hie-bios >= 0.4.0 && < 0.5 22 | -------------------------------------------------------------------------------- /src/29-ghc/example.hs: -------------------------------------------------------------------------------- 1 | f :: Int -> Int 2 | f x = x + 1 3 | 4 | main :: IO () 5 | main = do 6 | print (f 10) 7 | -------------------------------------------------------------------------------- /src/29-ghc/factorial.cmm: -------------------------------------------------------------------------------- 1 | #include "Cmm.h" 2 | 3 | factorial { 4 | entry: 5 | W_ n ; 6 | W_ acc; 7 | n = R1 ; 8 | acc = n ; 9 | n = n - 1 ; 10 | 11 | for: 12 | if (n <= 0 ) { 13 | return(acc); 14 | } else { 15 | acc = acc * n ; 16 | n = n - 1 ; 17 | goto for ; 18 | } 19 | return(0); 20 | } 21 | -------------------------------------------------------------------------------- /src/29-ghc/heapview.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | import GHC.Exts 4 | import GHC.HeapView 5 | 6 | import System.Mem 7 | 8 | main :: IO () 9 | main = do 10 | -- Constr 11 | clo <- getClosureData $! ([1,2,3] :: [Int]) 12 | print clo 13 | 14 | -- Thunk 15 | let thunk = id (1+1) 16 | clo <- getClosureData thunk 17 | print clo 18 | 19 | -- evaluate to WHNF 20 | thunk `seq` return () 21 | 22 | -- Indirection 23 | clo <- getClosureData thunk 24 | print clo 25 | 26 | -- force garbage collection 27 | performGC 28 | 29 | -- Value 30 | clo <- getClosureData thunk 31 | print clo 32 | -------------------------------------------------------------------------------- /src/29-ghc/io_impl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | 4 | import GHC.IO ( IO(..) ) 5 | import GHC.Prim ( State#, RealWorld ) 6 | import GHC.Base ( realWorld# ) 7 | 8 | instance Monad IO where 9 | m >> k = m >>= \ _ -> k 10 | return = returnIO 11 | (>>=) = bindIO 12 | fail s = failIO s 13 | 14 | returnIO :: a -> IO a 15 | returnIO x = IO $ \ s -> (# s, x #) 16 | 17 | bindIO :: IO a -> (a -> IO b) -> IO b 18 | bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s 19 | 20 | thenIO :: IO a -> IO b -> IO b 21 | thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s 22 | 23 | unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) 24 | unIO (IO a) = a 25 | -------------------------------------------------------------------------------- /src/29-ghc/monad_prim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import GHC.IO ( IO(..) ) 6 | import GHC.ST ( ST(..) ) 7 | import GHC.Prim ( State#, RealWorld ) 8 | import GHC.Base ( realWorld# ) 9 | 10 | class Monad m => PrimMonad m where 11 | type PrimState m 12 | primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a 13 | internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) 14 | 15 | instance PrimMonad IO where 16 | type PrimState IO = RealWorld 17 | primitive = IO 18 | internal (IO p) = p 19 | 20 | instance PrimMonad (ST s) where 21 | type PrimState (ST s) = s 22 | primitive = ST 23 | internal (ST p) = p 24 | -------------------------------------------------------------------------------- /src/29-ghc/prim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | 5 | import GHC.Exts 6 | import GHC.Prim 7 | 8 | ex1 :: Bool 9 | ex1 = isTrue# (gtChar# a# b#) 10 | where 11 | !(C# a#) = 'a' 12 | !(C# b#) = 'b' 13 | 14 | ex2 :: Int 15 | ex2 = I# (a# +# b#) 16 | where 17 | !(I# a#) = 1 18 | !(I# b#) = 2 19 | 20 | ex3 :: Int 21 | ex3 = (I# (1# +# 2# *# 3# +# 4#)) 22 | 23 | ex4 :: (Int, Int) 24 | ex4 = (I# (dataToTag# False), I# (dataToTag# True)) 25 | -------------------------------------------------------------------------------- /src/29-ghc/profile.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Vector.Unboxed as U 2 | 3 | data Pair = Pair {-# UNPACK #-}!Int {-# UNPACK #-}!Double 4 | 5 | mean :: U.Vector Double -> Double 6 | mean xs = s / fromIntegral n 7 | where 8 | Pair n s = U.foldl' k (Pair 0 0) xs 9 | k (Pair n s) x = Pair (n+1) (s+x) 10 | 11 | main :: IO () 12 | main = print (mean $ U.enumFromN 1 (10^7)) 13 | -------------------------------------------------------------------------------- /src/29-ghc/simd/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable simd-example 7 | build-depends: 8 | base >= 4.6 && <4.14, 9 | ghc-prim -any 10 | default-language: Haskell2010 11 | main-is: simd.hs 12 | ghc-options: 13 | -fllvm 14 | -ddump-to-file 15 | -ddump-llvm 16 | -ddump-asm 17 | -------------------------------------------------------------------------------- /src/29-ghc/simd/simd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | {-# OPTIONS_GHC -mavx #-} 5 | {-# OPTIONS_GHC -msse #-} 6 | {-# OPTIONS_GHC -msse2 #-} 7 | {-# OPTIONS_GHC -msse4 #-} 8 | 9 | import GHC.Exts 10 | import GHC.Prim 11 | 12 | data FloatX4 = FX4# FloatX4# 13 | 14 | instance Show FloatX4 where 15 | show (FX4# f) = case unpackFloatX4# f of 16 | (# a, b, c, d #) -> show (F# a, F# b, F# c, F# d) 17 | 18 | main :: IO () 19 | main = do 20 | let a = packFloatX4# (# 4.5#, 7.8#, 2.3#, 6.5# #) 21 | let b = packFloatX4# (# 8.2#, 6.3#, 4.7#, 9.2# #) 22 | let c = FX4# (broadcastFloatX4# 1.5#) 23 | print (FX4# a) 24 | print (FX4# (plusFloatX4# a b)) 25 | print c 26 | -------------------------------------------------------------------------------- /src/29-ghc/simd/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /src/29-ghc/specialize.hs: -------------------------------------------------------------------------------- 1 | module Specialize (spec, nonspec, f) where 2 | 3 | {-# SPECIALIZE INLINE f :: Double -> Double -> Double #-} 4 | 5 | f :: Floating a => a -> a -> a 6 | f x y = exp (x + y) * exp (x + y) 7 | 8 | nonspec :: Float 9 | nonspec = f (10 :: Float) (20 :: Float) 10 | 11 | spec :: Double 12 | spec = f (10 :: Double) (20 :: Double) 13 | -------------------------------------------------------------------------------- /src/29-ghc/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: 3 | - ghc-8.6.5 4 | - ghc-heap-view-0.6.1 5 | - hie-bios-0.4.0 6 | -------------------------------------------------------------------------------- /src/30-languages/README.md: -------------------------------------------------------------------------------- 1 | Languages 2 | ========= 3 | 4 | ```bash 5 | $ stack exec ghci haskelline.hs 6 | $ stack exec ghci llvm-general.hs 7 | $ stack exec ghci pretty.hs 8 | $ stack exec ghci repline.hs 9 | $ stack exec ghci unbound-generics.hs 10 | $ stack exec ghci unbound.hs 11 | ``` 12 | -------------------------------------------------------------------------------- /src/30-languages/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive haskelline.hs 6 | #stack exec ghc -- -e ":q" --interactive llvm-hs.hs 7 | stack exec ghc -- -e ":q" --interactive llvm-irbuilder.hs 8 | stack exec ghc -- -e ":q" --interactive pretty.hs 9 | stack exec ghc -- -e ":q" --interactive prettysimple.hs 10 | stack exec ghc -- -e ":q" --interactive repline.hs 11 | #stack exec ghc -- -e ":q" --interactive unbound-generics.hs 12 | #stack exec ghc -- -e ":q" --interactive unbound.hs 13 | -------------------------------------------------------------------------------- /src/30-languages/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2020 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | default-language: Haskell2010 12 | build-depends: 13 | base >= 4.6 && <4.14, 14 | text >= 1.2 && <1.3, 15 | mtl >= 2.2 && <2.3, 16 | process >= 1.6 && <1.7, 17 | unbound-generics >= 0.4 && <0.5, 18 | unbound >= 0.5 && <0.6, 19 | repline >= 0.2 && <0.3, 20 | llvm-hs-pure >= 9.0 && <10.0, 21 | pretty-simple >= 2.0 && <3.3, 22 | prettyprinter >= 1.1 && <1.7, 23 | prettyprinter-ansi-terminal >= 1.1 && <1.6 24 | -------------------------------------------------------------------------------- /src/30-languages/haskelline.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans 2 | import System.Console.Haskeline 3 | 4 | type Repl a = InputT IO a 5 | 6 | process :: String -> IO () 7 | process = putStrLn 8 | 9 | repl :: Repl () 10 | repl = do 11 | minput <- getInputLine "Repl> " 12 | case minput of 13 | Nothing -> outputStrLn "Goodbye." 14 | Just input -> (liftIO $ process input) >> repl 15 | 16 | main :: IO () 17 | main = runInputT defaultSettings repl 18 | -------------------------------------------------------------------------------- /src/30-languages/prettysimple.hs: -------------------------------------------------------------------------------- 1 | import Text.Pretty.Simple 2 | 3 | main :: IO () 4 | main = do 5 | pPrint [1 .. 25] 6 | pPrint [Just (1, "hello")] 7 | -------------------------------------------------------------------------------- /src/30-languages/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - llvm-hs-pure-9.0.0 6 | - unbound-0.5.1.1 7 | - RepLib-0.5.4.1 8 | - containers-0.5.11.0 9 | - binary-0.8.8.0 10 | - text-1.2.4.0 11 | flags: {} 12 | extra-package-dbs: [] 13 | -------------------------------------------------------------------------------- /src/31-template-haskell/EnumFamily.hs: -------------------------------------------------------------------------------- 1 | module EnumFamily where 2 | import Language.Haskell.TH 3 | 4 | enumFamily :: (Integer -> Integer -> Integer) 5 | -> Name 6 | -> Integer 7 | -> Q [Dec] 8 | enumFamily f bop upper = return decls 9 | where 10 | decls = do 11 | i <- [1..upper] 12 | j <- [2..upper] 13 | return $ TySynInstD bop (rhs i j) 14 | 15 | rhs i j = TySynEqn 16 | [LitT (NumTyLit i), LitT (NumTyLit j)] 17 | (LitT (NumTyLit (i `f` j))) 18 | -------------------------------------------------------------------------------- /src/31-template-haskell/Insert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | import Splice 4 | 5 | spliceF 6 | spliceG "argument" 7 | 8 | main = do 9 | print $ f 1 2 10 | print $ g () 11 | -------------------------------------------------------------------------------- /src/31-template-haskell/Multiline.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Multiline (s) where 4 | 5 | import Data.String 6 | import Language.Haskell.TH.Quote 7 | 8 | s :: QuasiQuoter 9 | s = QuasiQuoter 10 | { quoteExp = (\a -> [|fromString a|]) . trim 11 | , quotePat = \_ -> fail "illegal raw string QuasiQuote" 12 | , quoteType = \_ -> fail "illegal raw string QuasiQuote" 13 | , quoteDec = \_ -> fail "illegal raw string QuasiQuote" 14 | } 15 | 16 | trim :: String -> String 17 | trim ('\n':xs) = xs 18 | trim xs = xs 19 | -------------------------------------------------------------------------------- /src/31-template-haskell/README.md: -------------------------------------------------------------------------------- 1 | Template Haskell 2 | ================ 3 | 4 | ```bash 5 | $ stack exec ghci Antiquote.hs 6 | $ stack exec ghci Class.hs 7 | $ stack exec ghci cquote.hs 8 | $ stack exec ghci derive.hs 9 | $ stack exec ghci enum_family_splice.hs 10 | $ stack exec ghci EnumFamily.hs 11 | $ stack exec ghci Insert.hs 12 | $ stack exec ghci multiline_example.hs 13 | $ stack exec ghci Multiline.hs 14 | $ stack exec ghci Quasiquote.hs 15 | $ stack exec ghci quasiquote_use.hs 16 | $ stack exec ghci Singleton.hs 17 | $ stack exec ghci singleton_lib.hs 18 | $ stack exec ghci singleton_promote.hs 19 | $ stack exec ghci Splice.hs 20 | $ stack exec ghci splice_class.hs 21 | $ stack exec ghci splice_singleton.hs 22 | $ stack exec ghci template_info.hs 23 | $ stack exec ghci use_antiquote.hs 24 | ``` 25 | -------------------------------------------------------------------------------- /src/31-template-haskell/Splice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Splice where 5 | 6 | import Language.Haskell.TH 7 | import Language.Haskell.TH.Syntax 8 | 9 | spliceF :: Q [Dec] 10 | spliceF = do 11 | let f = mkName "f" 12 | a <- newName "a" 13 | b <- newName "b" 14 | return [ FunD f [ Clause [VarP a, VarP b] (NormalB (VarE a)) [] ] ] 15 | 16 | spliceG :: Lift a => a -> Q [Dec] 17 | spliceG n = runQ [d| g a = n |] 18 | -------------------------------------------------------------------------------- /src/31-template-haskell/derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | import Data.Derive.Arbitrary 4 | import Data.DeriveTH 5 | import Test.QuickCheck 6 | 7 | data Color = Red | Green | Blue deriving (Show) 8 | 9 | $(derive makeArbitrary ''Color) 10 | 11 | example1 :: IO [Color] 12 | example1 = sample' arbitrary 13 | -- [Red,Green,Blue,Red,Blue,Green,Blue,Red,Blue,Blue,Red] 14 | -------------------------------------------------------------------------------- /src/31-template-haskell/enum_family_splice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import Data.Proxy 6 | import EnumFamily 7 | import GHC.TypeLits hiding (Mod) 8 | 9 | type family Mod (m :: Nat) (n :: Nat) :: Nat 10 | 11 | type family Add (m :: Nat) (n :: Nat) :: Nat 12 | 13 | type family Pow (m :: Nat) (n :: Nat) :: Nat 14 | 15 | enumFamily mod ''Mod 10 16 | 17 | enumFamily (+) ''Add 10 18 | 19 | enumFamily (^) ''Pow 10 20 | 21 | a :: Integer 22 | a = natVal (Proxy :: Proxy (Mod 6 4)) 23 | 24 | -- 2 25 | 26 | b :: Integer 27 | b = natVal (Proxy :: Proxy (Pow 3 (Mod 6 4))) 28 | -- 9 29 | 30 | -- enumFamily mod ''Mod 3 31 | -- ======> 32 | -- template_typelevel_splice.hs:7:1-14 33 | -- type instance Mod 2 1 = 0 34 | -- type instance Mod 2 2 = 0 35 | -- type instance Mod 2 3 = 2 36 | -- type instance Mod 3 1 = 0 37 | -- type instance Mod 3 2 = 1 38 | -- type instance Mod 3 3 = 0 39 | -- ... 40 | -------------------------------------------------------------------------------- /src/31-template-haskell/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2016 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | tested-with: GHC ==7.6.3 8 | category: Documentation 9 | build-type: Simple 10 | 11 | library 12 | default-language: Haskell2010 13 | build-depends: 14 | base >=4.6 && <4.14 15 | , derive >=2.6.5 && <2.7 16 | , language-c-quote >=0.12.2.1 && <0.13 17 | , mainland-pretty >=0.7.0.1 && <0.8 18 | , pretty-show >=1.10 && <1.11 19 | , QuickCheck >=2.13.2 && <2.14 20 | , singletons >=2.5.1 && <2.6 21 | -------------------------------------------------------------------------------- /src/31-template-haskell/multiline_example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Multiline (s) 4 | import qualified Data.Text as T 5 | 6 | foo :: T.Text 7 | foo = [s| 8 | This 9 | is 10 | my 11 | multiline 12 | string 13 | |] 14 | -------------------------------------------------------------------------------- /src/31-template-haskell/quasiquote_use.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Quasiquote 4 | 5 | a :: Expr 6 | a = [calc|true|] 7 | -- Tr 8 | 9 | b :: Expr 10 | b = [calc|succ (succ 0)|] 11 | -- Succ (Succ Zero) 12 | 13 | c :: Expr 14 | c = [calc|pred (succ 0)|] 15 | -- Pred (Succ Zero) 16 | -------------------------------------------------------------------------------- /src/31-template-haskell/splice_class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Class 5 | 6 | data PlatonicSolid 7 | = Tetrahedron 8 | | Cube 9 | | Octahedron 10 | | Dodecahedron 11 | | Icosahedron 12 | 13 | pretty ''PlatonicSolid 14 | 15 | main :: IO () 16 | main = do 17 | putStrLn (ppr Octahedron) 18 | putStrLn (ppr Dodecahedron) 19 | -------------------------------------------------------------------------------- /src/31-template-haskell/splice_singleton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | import Singleton 7 | 8 | zero :: [snat|0|] 9 | zero = [snat|0|] 10 | 11 | one :: [snat|1|] 12 | one = [snat|1|] 13 | 14 | two :: [snat|2|] 15 | two = [snat|2|] 16 | 17 | three :: [snat|3|] 18 | three = [snat|3|] 19 | 20 | test :: SNat a -> Int 21 | test x = case x of 22 | [snat|0|] -> 0 23 | [snat|1|] -> 1 24 | [snat|2|] -> 2 25 | [snat|3|] -> 3 26 | 27 | isZero :: SNat a -> Bool 28 | isZero [snat|0|] = True 29 | isZero _ = False 30 | -------------------------------------------------------------------------------- /src/31-template-haskell/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - derive-2.6.5 6 | - haskell-src-exts-1.20.3 7 | - pretty-show-1.10 8 | - haskell-lexer-1.1 9 | flags: {} 10 | extra-package-dbs: [] 11 | -------------------------------------------------------------------------------- /src/31-template-haskell/template_info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Language.Haskell.TH 5 | import Text.Show.Pretty (ppShow) 6 | 7 | introspect :: Name -> Q Exp 8 | introspect n = do 9 | t <- reify n 10 | runIO $ putStrLn $ ppShow t 11 | [|return ()|] 12 | -------------------------------------------------------------------------------- /src/31-template-haskell/use_antiquote.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Antiquote 4 | 5 | -- extract 6 | a :: Expr -> Expr 7 | a [mini|succ $x|] = x 8 | 9 | b :: Expr -> Expr 10 | b [mini|succ $x|] = [mini|pred $x|] 11 | 12 | c :: Expressible a => a -> Expr 13 | c x = [mini|succ $x|] 14 | 15 | d :: Expr 16 | d = c (8 :: Integer) 17 | -- Succ (Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))) 18 | 19 | e :: Expr 20 | e = c True 21 | -- Succ Tr 22 | -------------------------------------------------------------------------------- /src/32-cryptography/Argon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Argon where 4 | 5 | import Crypto.Error 6 | import Crypto.KDF.Argon2 7 | import Crypto.Random (getRandomBytes) 8 | import Data.ByteString 9 | 10 | passHash :: IO () 11 | passHash = do 12 | salt <- getRandomBytes 16 :: IO ByteString 13 | out <- throwCryptoErrorIO (hash defaultOptions ("hunter2" :: ByteString) salt 256) 14 | print (out :: ByteString) 15 | -------------------------------------------------------------------------------- /src/32-cryptography/Blake2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Blake2 where 4 | 5 | import Crypto.Hash 6 | import Data.ByteString 7 | 8 | passHash :: Digest Blake2b_256 9 | passHash = hash ("hunter2" :: ByteString) 10 | -------------------------------------------------------------------------------- /src/32-cryptography/Curve25519.hs: -------------------------------------------------------------------------------- 1 | import Crypto.Error 2 | import qualified Crypto.PubKey.Curve25519 as Curve25519 3 | 4 | -- Diffie-Hellman Key Exchange for Curve25519 5 | dh :: IO () 6 | dh = do 7 | alicePriv <- Curve25519.generateSecretKey 8 | bobPriv <- Curve25519.generateSecretKey 9 | let secret1 = Curve25519.dh (Curve25519.toPublic alicePriv) bobPriv 10 | let secret2 = Curve25519.dh (Curve25519.toPublic bobPriv) alicePriv 11 | print (secret1 == secret2) 12 | -------------------------------------------------------------------------------- /src/32-cryptography/Ed25519.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Ed25519 where 4 | 5 | import Crypto.PubKey.Ed25519 as Ed25519 6 | import Data.ByteString 7 | 8 | msg :: ByteString 9 | msg = "My example message" 10 | 11 | example :: IO () 12 | example = do 13 | privKey <- Ed25519.generateSecretKey 14 | let pubKey = Ed25519.toPublic privKey 15 | let sig = sign privKey pubKey msg 16 | print sig 17 | print (Ed25519.verify pubKey msg sig) 18 | -------------------------------------------------------------------------------- /src/32-cryptography/Galois.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedLists #-} 6 | 7 | module Galois where 8 | 9 | import Data.Field.Galois 10 | import Prelude hiding ((/)) 11 | 12 | -- Prime field 13 | type Fq = Prime 2147483647 14 | 15 | exampleFq :: IO () 16 | exampleFq = do 17 | print ((1 + 0x7FFFFFFF16) :: Fq) 18 | print ((10000 * 10000) :: Fq) 19 | print ((1 / 524287) :: Fq) 20 | 21 | -- Polynomial term 22 | data P2 23 | 24 | -- Extension field 25 | type Fq2 = Extension P2 Fq 26 | 27 | -- Irreducublie monic polynomial extension 28 | instance IrreducibleMonic P2 Fq where 29 | poly _ = X2 + 1 30 | 31 | -- Polynomial 2*x^2 + 1 over Fq2 32 | p1 :: Fq2 33 | p1 = [1, 2] 34 | 35 | p2 :: Fq2 36 | p2 = (p1 + p1) * 2 37 | 38 | p3 :: Bool 39 | p3 = p2 / p1 == 4 40 | -------------------------------------------------------------------------------- /src/32-cryptography/Keccak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Crypto.Hash (Keccak_256, Digest, hash) 4 | import Data.ByteArray (convert) 5 | import Data.ByteString.Char8 (ByteString) 6 | 7 | v1 :: ByteString 8 | v1 = "The quick brown fox jumps over the lazy dog" 9 | 10 | h1 :: Digest Keccak_256 11 | h1 = hash v1 12 | 13 | s1 :: ByteString 14 | s1 = convert h1 15 | 16 | main :: IO () 17 | main = do 18 | print v1 19 | print h1 20 | print s1 21 | -------------------------------------------------------------------------------- /src/32-cryptography/SHA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Crypto.Hash (SHA256, Digest, hash) 4 | import Data.ByteArray (convert) 5 | import Data.ByteString.Char8 (ByteString) 6 | 7 | v1 :: ByteString 8 | v1 = "The quick brown fox jumps over the lazy dog" 9 | 10 | h1 :: Digest SHA256 11 | h1 = hash v1 12 | 13 | s1 :: ByteString 14 | s1 = convert h1 15 | 16 | main :: IO () 17 | main = do 18 | print v1 19 | print h1 20 | print s1 21 | -------------------------------------------------------------------------------- /src/32-cryptography/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive AES.hs 6 | stack exec ghc -- -e ":q" --interactive Argon.hs 7 | stack exec ghc -- -e ":q" --interactive Blake2.hs 8 | stack exec ghc -- -e ":q" --interactive Curve25519.hs 9 | stack exec ghc -- -e ":q" --interactive ECC.hs 10 | stack exec ghc -- -e ":q" --interactive Ed25519.hs 11 | stack exec ghc -- -e ":q" --interactive Galois.hs 12 | stack exec ghc -- -e ":q" --interactive Keccak.hs 13 | stack exec ghc -- -e ":q" --interactive Merkle.hs 14 | stack exec ghc -- -e ":q" --interactive Pairing.hs 15 | stack exec ghc -- -e ":q" --interactive Secp256k1.hs 16 | stack exec ghc -- -e ":q" --interactive SHA.hs 17 | -------------------------------------------------------------------------------- /src/32-cryptography/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: example 3 | version: 0.1 4 | copyright: 2020 Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | author: Stephen Diehl 7 | tested-with: GHC ==7.6.3 8 | category: Documentation 9 | build-type: Simple 10 | 11 | library 12 | default-language: Haskell2010 13 | build-depends: 14 | base >=4.10 && <4.14 15 | , bytestring >=0.10.8.2 && <0.11 16 | , cryptonite >=0.20 && <0.30 17 | , elliptic-curve >=0.3 && <0.4 18 | , galois-field >=1.0 && <1.1 19 | , memory >=0.14.0 && <0.16 20 | , pairing >=1.0 && <2.0 21 | -------------------------------------------------------------------------------- /src/32-cryptography/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | extra-deps: 3 | - elliptic-curve-0.3.0 4 | - pairing-1.0.0 5 | - galois-field-1.0.1 6 | - bitvec-1.0.2.0 7 | - poly-0.3.3.0 8 | - semirings-0.5.2 9 | - vector-algorithms-0.8.0.3 10 | -------------------------------------------------------------------------------- /src/33-categories/README.md: -------------------------------------------------------------------------------- 1 | Category Theory 2 | =============== 3 | 4 | ```bash 5 | $ stack exec ghci categories.hs 6 | $ stack exec ghci dual.hs 7 | $ stack exec ghci functors.hs 8 | $ stack exec ghci iso.hs 9 | $ stack exec ghci kleisli.hs 10 | $ stack exec ghci natural.hs 11 | ``` 12 | -------------------------------------------------------------------------------- /src/33-categories/categories.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | import Prelude hiding ((.), id) 6 | 7 | -- Morphisms 8 | type (a ~> b) c = c a b 9 | 10 | class Category (c :: k -> k -> *) where 11 | id :: (a ~> a) c 12 | (.) :: (y ~> z) c -> (x ~> y) c -> (x ~> z) c 13 | 14 | type Hask = (->) 15 | 16 | instance Category Hask where 17 | id x = x 18 | (f . g) x = f (g x) 19 | -------------------------------------------------------------------------------- /src/33-categories/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive categories.hs 6 | stack exec ghc -- -e ":q" --interactive dual.hs 7 | stack exec ghc -- -e ":q" --interactive functors.hs 8 | stack exec ghc -- -e ":q" --interactive iso.hs 9 | stack exec ghc -- -e ":q" --interactive kleisli.hs 10 | stack exec ghc -- -e ":q" --interactive monoidal.hs 11 | stack exec ghc -- -e ":q" --interactive natural.hs 12 | -------------------------------------------------------------------------------- /src/33-categories/dual.hs: -------------------------------------------------------------------------------- 1 | import Control.Category 2 | import Prelude hiding ((.), id) 3 | 4 | newtype Op a b = Op (b -> a) 5 | 6 | instance Category Op where 7 | id = Op id 8 | (Op f) . (Op g) = Op (g . f) 9 | -------------------------------------------------------------------------------- /src/33-categories/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2020 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | build-depends: 12 | base >= 4.6 && <4.14 13 | default-language: Haskell2010 14 | -------------------------------------------------------------------------------- /src/33-categories/functors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | import Control.Category 5 | import Prelude hiding (Functor, fmap, id) 6 | 7 | class (Category c, Category d) => Functor c d t where 8 | fmap :: c a b -> d (t a) (t b) 9 | 10 | type Hask = (->) 11 | 12 | instance Functor Hask Hask [] where 13 | fmap f [] = [] 14 | fmap f (x : xs) = f x : (fmap f xs) 15 | -------------------------------------------------------------------------------- /src/33-categories/iso.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | 3 | data Iso a b = Iso { to :: a -> b, from :: b -> a } 4 | 5 | f :: forall a. Maybe a -> Either () a 6 | f (Just a) = Right a 7 | f Nothing = Left () 8 | 9 | f' :: forall a. Either () a -> Maybe a 10 | f' (Left _) = Nothing 11 | f' (Right a) = Just a 12 | 13 | iso :: Iso (Maybe a) (Either () a) 14 | iso = Iso f f' 15 | 16 | data V = V deriving Eq 17 | 18 | ex1 = f (f' (Right V)) == Right V 19 | ex2 = f' (f (Just V)) == Just V 20 | -------------------------------------------------------------------------------- /src/33-categories/kleisli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | 4 | import Control.Monad 5 | import Control.Category 6 | import Prelude hiding ((.)) 7 | 8 | -- Kleisli category 9 | newtype Kleisli m a b = K (a -> m b) 10 | 11 | -- Kleisli morphisms ( a -> m b ) 12 | type (a :~> b) m = Kleisli m a b 13 | 14 | instance Monad m => Category (Kleisli m) where 15 | id = K return 16 | (K f) . (K g) = K (f <=< g) 17 | 18 | 19 | just :: (a :~> a) Maybe 20 | just = K Just 21 | 22 | left :: forall a b. (a :~> b) Maybe -> (a :~> b) Maybe 23 | left f = just . f 24 | 25 | right :: forall a b. (a :~> b) Maybe -> (a :~> b) Maybe 26 | right f = f . just 27 | -------------------------------------------------------------------------------- /src/33-categories/natural.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | type (⇒) f g = forall a. f a -> g a 5 | 6 | headMay :: [] ⇒ Maybe 7 | headMay [] = Nothing 8 | headMay (x:_) = Just x 9 | -------------------------------------------------------------------------------- /src/33-categories/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: [] 3 | -------------------------------------------------------------------------------- /src/34-time/Strings.hs: -------------------------------------------------------------------------------- 1 | module Time where 2 | 3 | import Data.Maybe 4 | import Data.Time 5 | import Data.Time.Format.ISO8601 6 | 7 | -- April 5, 2063 8 | day :: Day 9 | day = fromJust (fromGregorianValid year month day) 10 | where 11 | year = 2063 12 | month = 4 13 | day = 5 14 | 15 | printing :: IO () 16 | printing = do 17 | t <- getCurrentTime 18 | zt <- getZonedTime 19 | print (iso8601Show day) 20 | print (iso8601Show t) 21 | print (iso8601Show zt) 22 | 23 | parsing :: IO () 24 | parsing = do 25 | d <- iso8601ParseM "2063-04-05" :: IO Day 26 | t <- iso8601ParseM "2020-01-29T15:03:43.013033515Z" :: IO UTCTime 27 | zt <- iso8601ParseM "2020-01-29T15:03:43.013040029+00:00" :: IO ZonedTime 28 | print d 29 | print t 30 | print zt 31 | -------------------------------------------------------------------------------- /src/34-time/ci: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | stack build 5 | stack exec ghc -- -e ":q" --interactive Strings.hs 6 | stack exec ghc -- -e ":q" --interactive Time.hs 7 | -------------------------------------------------------------------------------- /src/34-time/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1 3 | author: Stephen Diehl 4 | maintainer: stephen.m.diehl@gmail.com 5 | copyright: 2016 Stephen Diehl 6 | category: Documentation 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | tested-with: GHC == 7.6.3 10 | 11 | library 12 | 13 | build-depends: 14 | base >= 4.10 && <4.14, 15 | time >= 1.9 && <2.0 16 | 17 | default-language: Haskell2010 18 | -------------------------------------------------------------------------------- /src/34-time/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | extra-deps: 3 | - time-1.9.3 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | allow-newer: true 3 | pvp-bounds: both 4 | packages: 5 | - '.' 6 | extra-deps: 7 | - pandoc-2.9.1.1 8 | - HsYAML-0.2.1.0 9 | - doclayout-0.2.0.1 10 | - doctemplates-0.8.1 11 | - emojis-0.1 12 | - haddock-library-1.8.0 13 | - jira-wiki-markup-1.0.0 14 | - pandoc-types-1.20 15 | - skylighting-0.8.3.2 16 | - skylighting-core-0.8.3.2 17 | - texmath-0.12 18 | flags: {} 19 | extra-package-dbs: [] 20 | -------------------------------------------------------------------------------- /wiwinwlh.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: wiwinwlh 3 | version: 0.1.0.0 4 | license: MIT 5 | license-file: LICENSE 6 | maintainer: stephen.m.diehl@gmail.com 7 | author: Stephen Diehl 8 | build-type: Simple 9 | extra-source-files: README.md 10 | 11 | executable includes 12 | main-is: includes.hs 13 | default-language: Haskell2010 14 | build-depends: 15 | base >=4.12.0.0 && <4.13 16 | , containers >=0.6.0.1 && <0.7 17 | , pandoc >=2.9.1 && <2.10 18 | , text >=1.2.3.1 && <1.3 19 | --------------------------------------------------------------------------------