├── .github └── CONTRIBUTING.md ├── .gitignore ├── .travis.yml ├── 000_introduction.md ├── 001_basics.md ├── 002_parsers.md ├── 003_lambda_calculus.md ├── 004_type_systems.md ├── 005_evaluation.md ├── 006_hindley_milner.md ├── 007_path.md ├── 008_extended_parser.md ├── 009_datatypes.md ├── 010_renamer.md ├── 011_pattern_matching.md ├── 012_systemf.md ├── 026_llvm.md ├── CONTRIBUTORS.md ├── LICENSE ├── Makefile ├── README.md ├── atom.xml ├── chapter1 └── .gitkeep ├── chapter10 ├── .gitignore ├── .gitkeep ├── adt.c ├── adt.hs ├── adt2.c ├── eval.c ├── eval.hs └── generics.hs ├── chapter11 └── .gitkeep ├── chapter12 ├── .gitkeep └── systemf │ └── Syntax.hs ├── chapter2 └── .gitkeep ├── chapter27 ├── cfg │ ├── branch.dot │ ├── branch.ll │ ├── branch.png │ ├── cbranch.dot │ ├── cbranch.ll │ ├── cbranch.png │ ├── for.dot │ ├── for.ll │ ├── for.png │ ├── phi.dot │ ├── phi.ll │ ├── phi.png │ ├── ret.dot │ ├── ret.ll │ ├── ret.png │ ├── switch.dot │ ├── switch.ll │ └── switch.png ├── dsl │ ├── Codegen.hs │ ├── JIT.hs │ ├── Main.hs │ └── dsl.cabal ├── example.cpp └── example.ll ├── chapter3 ├── calc │ ├── Eval.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── README.md │ ├── Syntax.hs │ └── calc.cabal └── parsec.hs ├── chapter4 ├── lambda.hs └── untyped │ ├── Eval.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── README.md │ ├── Setup.hs │ ├── Syntax.hs │ ├── stack.yaml │ └── untyped.cabal ├── chapter5 ├── calc_typed │ ├── Check.hs │ ├── Eval.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── README.md │ ├── Syntax.hs │ ├── Type.hs │ └── arith.cabal └── stlc │ ├── Check.hs │ ├── Eval.hs │ ├── Lexer.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── README.md │ ├── Setup.hs │ ├── Syntax.hs │ └── stlc.cabal ├── chapter6 ├── hoas.hs ├── interp.hs ├── io.hs ├── lazy.hs └── phoas.hs ├── chapter7 ├── poly │ ├── LICENSE │ ├── README.md │ ├── poly.cabal │ ├── src │ │ ├── Eval.hs │ │ ├── Infer.hs │ │ ├── Lexer.hs │ │ ├── Main.hs │ │ ├── Parser.hs │ │ ├── Pretty.hs │ │ ├── Syntax.hs │ │ └── Type.hs │ ├── stack.yaml │ ├── test.ml │ └── tests │ │ └── should_fail │ │ ├── test_if.ml │ │ └── test_if.out └── poly_constraints │ ├── LICENSE │ ├── README.md │ ├── poly.cabal │ ├── src │ ├── Env.hs │ ├── Eval.hs │ ├── Infer.hs │ ├── Lexer.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── Syntax.hs │ └── Type.hs │ ├── stack.yaml │ └── test.ml ├── chapter8 ├── .gitignore └── protohaskell │ ├── Compiler.hs │ ├── Flags.hs │ ├── Frontend.hs │ ├── Monad.hs │ ├── Name.hs │ ├── Pretty.hs │ ├── README.md │ └── Type.hs ├── chapter9 ├── .gitkeep ├── assign │ ├── .gitignore │ ├── Eval.hs │ ├── Lexer.x │ ├── Main.hs │ ├── Makefile │ ├── Parser.y │ ├── README.md │ ├── Syntax.hs │ ├── assign.cabal │ ├── input.test │ └── stack.yaml ├── attoparsec │ ├── Main.hs │ └── simple.ml ├── happy │ ├── .gitignore │ ├── Eval.hs │ ├── Lexer.x │ ├── Main.hs │ ├── Makefile │ ├── Parser.y │ ├── README.md │ ├── Syntax.hs │ ├── happyParser.cabal │ └── stack.yaml ├── layout │ └── Layout.hs ├── operators │ ├── Parser.hs │ └── test.fun └── provenance │ ├── Infer.hs │ ├── Lexer.hs │ ├── Main.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── Syntax.hs │ └── Type.hs ├── css ├── bootstrap-responsive.min.css ├── bootstrap.min.css ├── colors.css └── style.css ├── deploy.sh ├── img ├── .gitignore ├── Haskell-Logo.png ├── Haskell-Logo.ps ├── ModRM.png ├── ModRM_example.png ├── Prefix.png ├── Scale.png ├── bits.png ├── coffee.png ├── cover-kindle.jpg ├── cover.png ├── kinds.dot ├── lambda.png ├── memory_layout.png ├── opcode.png ├── pipeline1.dot ├── pipeline1.png ├── pipeline2.dot ├── pipeline2.png ├── proto.dot ├── proto_pass.dot ├── proto_pass.png ├── protohaskell.dot ├── protohaskell.png ├── registers.png ├── stack.dot ├── stack.png └── titles │ ├── .gitignore │ ├── basics.png │ ├── evaluation.png │ ├── extended_parser.png │ ├── hindley_milner.png │ ├── introduction.png │ ├── kinds.png │ ├── lambda_calculus.png │ ├── llvm.png │ ├── ml.png │ ├── parsing.png │ ├── protohaskell.png │ ├── stg.png │ ├── systemf.png │ └── type_systems.png ├── includes.hs ├── index.md ├── js └── nav.js ├── latex_macros ├── misc └── rssgen.py ├── run-tests.sh ├── stack.yaml ├── template.html ├── template.latex ├── title.md └── write-you-a-haskell.cabal /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing 2 | ============ 3 | 4 | As always, I rely on the perpetual kindness and goodwill of Haskellers (like 5 | you!) to help correct grammar, clarify, and fix errors. 6 | 7 | Git Repo 8 | -------- 9 | 10 | *Simple Fixes* 11 | 12 | For most fixes you can simply edit the Markdown files at the toplevel of the Git 13 | repo and then submit a pull request on Github. There should be no need to 14 | compile the text locally. I will try to merge the changes quickly and rebuild 15 | the text daily. 16 | 17 | If you would like to add your name to 18 | [CONTRIBUTORS.md](https://github.com/sdiehl/write-you-a-haskell/blob/master/CONTRIBUTORS.md) 19 | submit this along with your pull request. 20 | 21 | *Complex Fixes* 22 | 23 | If you'd like to submit a change to the publishing software around the text, 24 | then clone the repo. You will need a local copy of Pandoc library to use the 25 | build system. 26 | 27 | ```bash 28 | $ git clone https://github.com/sdiehl/write-you-a-haskell.git 29 | $ make # Makes all html files 30 | $ make pdf # Makes a pdf containing all the chapters 31 | ``` 32 | 33 | Pandoc 34 | ------ 35 | 36 | The text is written in the Markdown language and handled with the Pandoc 37 | processing library, which is itself written in Haskell! 38 | 39 | The tutorial uses a custom pandoc preprocessor contained in *includes.hs*. This 40 | allows us to include and slice fragments of code from files in the src 41 | directory. 42 | 43 | *LaTeX Macros* 44 | 45 | ```perl 46 | ~~~~ {literal="latex_macros"} 47 | ~~~~ 48 | ``` 49 | 50 | *Including Whole Source Files* 51 | 52 | ```perl 53 | ~~~~ {.haskell include="includes.hs"} 54 | ~~~~ 55 | ``` 56 | 57 | *Including Partial Source Files* 58 | 59 | Will slice the lines 5-15 inclusively from the file *parsec.hs* with the Haskell 60 | syntax highlighting. 61 | 62 | ```perl 63 | ~~~~ {.haskell slice="src/parsers/parsec.hs" lower=5 upper=15} 64 | ~~~~ 65 | ``` 66 | 67 | *Math Typesetting* 68 | 69 | Equations can be included in display form: 70 | 71 | ```latex 72 | $$ 73 | \int_\Omega \mathrm{d}\omega = \oint_{\partial \Omega} \omega 74 | $$ 75 | ``` 76 | 77 | $$ 78 | \int_\Omega \mathrm{d}\omega = \oint_{\partial \Omega} \omega 79 | $$ 80 | 81 | Or in inline form (like $a^2 + b^2 = c^2$) with single dollar signs. Specially 82 | there must be no spaces around the dollar signs otherwise Pandoc will not parse 83 | it properly. 84 | 85 | ```latex 86 | $a^2 + b^2 = c^2$ 87 | ``` 88 | 89 | For most definitions, the ``aligned`` block is used: 90 | 91 | ```latex 92 | $$ 93 | \begin{aligned} 94 | e :=\ & x & \text{Var} \\ 95 | & \lambda x. e & \text{Lam} \\ 96 | & e\ e & \text{App} \\ 97 | \end{aligned} 98 | $$ 99 | ``` 100 | 101 | Will generate: 102 | 103 | $$ 104 | \begin{aligned} 105 | e :=\ & x & \text{Var} \\ 106 | & \lambda x. e & \text{Lam} \\ 107 | & e\ e & \text{App} \\ 108 | \end{aligned} 109 | $$ 110 | 111 | Several type theory macros are also included on many pages: 112 | 113 | ```latex 114 | $$ 115 | \infrule{ 0 : \t{nat}}{\infrule{\t{succ}(0) : \t{nat}}{ \t{succ}(\t{succ}(0)) : \t{nat} }} 116 | $$ 117 | ``` 118 | 119 | Will generate: 120 | 121 | $$ 122 | \infrule{ 0 : \t{nat}}{\infrule{\t{succ}(0) : \t{nat}}{ \t{succ}(\t{succ}(0)) : \t{nat} }} 123 | $$ 124 | 125 | Typography 126 | ---------- 127 | 128 | * Body is the system sans serif default preferring *Helvetica Neue Regular* or 129 | *Arial* if available. 130 | * Subtitles are in *Signika*. 131 | * Titles are in *Helvetica Neue Light*. 132 | * Code is typeset in *Inconsolata* or *Monaco*. 133 | 134 | LaTeX 135 | ----- 136 | 137 | The LaTeX styling is sourced from the ``template.latex`` file, which is an 138 | extension of Pandoc's default template with some custom modifications. 139 | 140 | Images 141 | ------ 142 | 143 | The images are drawn in SVG using Inkscape. 144 | 145 | Graphs and blocks diagrams are generated using graphviz. 146 | 147 | Preprocessor 148 | ------------ 149 | 150 | The source for the preprocessor is a simple bottom-up traversal replacement of 151 | these custom markdown extensions: 152 | 153 | ~~~~ {.haskell include="includes.hs"} 154 | ~~~~ 155 | 156 | Reference Code 157 | -------------- 158 | 159 | The subject of this text is largely build around the mini Haskell compiler. 160 | Several other files are included for earlier chapters. 161 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[po] 2 | *.o 3 | *.so 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | dist/ 7 | *.hi 8 | *.o 9 | includes 10 | *.html 11 | *.agdai 12 | *.history 13 | Setup.hs 14 | .stack-work 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.8 5 | #- "7.10" 6 | 7 | install: 8 | #- sudo apt-get install texlive-xetex texlive-latex-extra 9 | - cabal install pandoc 10 | 11 | script: 12 | - "./run-tests.sh" 13 | -------------------------------------------------------------------------------- /010_renamer.md: -------------------------------------------------------------------------------- 1 |

2 |

3 | 4 | Renamer 5 | ======= 6 | 7 | Renaming Pass 8 | ------------- 9 | 10 | 11 | 12 | Full Source 13 | ----------- 14 | 15 | \clearpage 16 | -------------------------------------------------------------------------------- /011_pattern_matching.md: -------------------------------------------------------------------------------- 1 |

2 |

3 | 4 | Pattern Matching 5 | ================ 6 | 7 | Full Source 8 | ----------- 9 | 10 | \clearpage 11 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | Contributors 2 | ============ 3 | 4 | * Matthew Pickering 5 | * Nick Sinopoli 6 | * Nicolas Trangez 7 | * Ingo Blechschmidt 8 | * Rein Henrichs 9 | * Ian Connolly 10 | * Ben James 11 | * Abe Voelker 12 | * Paulo Tanimoto 13 | * Brandon Williams 14 | * Dmitry Ivanov 15 | * Christian Sievers 16 | * Franklin Chen 17 | * Jake Taylor 18 | * Vitor Coimbra 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2016, Stephen Diehl 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PANDOC = pandoc 2 | IFORMAT = markdown 3 | MATHJAX = "http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" 4 | FLAGS = --standalone --toc --toc-depth=2 --mathjax=$(MATHJAX) --highlight-style pygments 5 | STYLE = css/style.css 6 | FILTER = includes.hs 7 | TEMPLATE_HTML = template.html 8 | TEMPLATE_TEX = template.latex 9 | PNG_IMAGES = $(patsubst %.pdf,%.png,$(wildcard img/*.pdf)) 10 | 11 | #SRC = $(wildcard *.md) 12 | SRC = 000_introduction.md \ 13 | 001_basics.md \ 14 | 002_parsers.md \ 15 | 003_lambda_calculus.md \ 16 | 004_type_systems.md \ 17 | 005_evaluation.md \ 18 | 006_hindley_milner.md \ 19 | 007_path.md \ 20 | 008_extended_parser.md \ 21 | 009_datatypes.md \ 22 | 010_renamer.md \ 23 | 026_llvm.md 24 | #011_pattern_matching.md \ 25 | #012_systemf.md 26 | OBJ = $(SRC:.md=.html) 27 | 28 | all: $(OBJ) top 29 | 30 | index: index.html 31 | 32 | img/%.png: img/%.pdf 33 | convert -density 150 $< $@ 34 | 35 | %.html: %.md $(FILTER) 36 | $(PANDOC) -c $(STYLE) --filter ${FILTER} --template $(TEMPLATE_HTML) -s -f $(IFORMAT) -t html $(FLAGS) -o $@ $< 37 | 38 | %.pdf: %.md $(FILTER) 39 | $(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o $@ $< 40 | 41 | %.epub: %.md $(FILTER) 42 | $(PANDOC) --filter ${FILTER} -f $(IFORMAT) $(FLAGS) -o $@ $< 43 | 44 | pdf: $(FILTER) 45 | # $(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o WYAH.pdf title.md 0*.md contributing.md 46 | $(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o WYAH.pdf title.md $(SRC) 47 | 48 | epub: $(FILTER) 49 | $(PANDOC) --filter ${FILTER} -f $(IFORMAT) $(FLAGS) --epub-cover-image=img/cover-kindle.jpg -o WYAH.epub title.md 0*.md 50 | 51 | top: $(FILTER) 52 | $(PANDOC) -c $(STYLE) --filter ${FILTER} --template $(TEMPLATE_HTML) -s -f $(IFORMAT) -t html $(FLAGS) -o tutorial.html index.md 53 | 54 | clean: 55 | -rm *.html *.pdf 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | 3 | 4 | 5 |

6 | 7 |

8 | 9 | 10 | 11 |
12 | Building a modern functional compiler from first principles. 13 |

14 | 15 |

16 | Stephen Diehl 17 |

18 | 19 | [![Build Status](https://travis-ci.org/sdiehl/write-you-a-haskell.svg)](https://travis-ci.org/sdiehl/write-you-a-haskell) 20 | [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/sdiehl/write-you-a-haskell?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=body_badge) 21 | [![MIT License](http://img.shields.io/badge/license-mit-blue.svg)](https://github.com/sdiehl/write-you-a-haskell/blob/master/LICENSE) 22 | 23 | Read Online: 24 | 25 | * [**HTML**](http://dev.stephendiehl.com/fun/) 26 | * [**PDF**](http://dev.stephendiehl.com/fun/WYAH.pdf) 27 | 28 | Releases 29 | -------- 30 | 31 | This is a work in progress. 32 | 33 | * [Chapter 1: Introduction](http://dev.stephendiehl.com/fun/000_introduction.html) 34 | * [Chapter 2: Haskell Basics](http://dev.stephendiehl.com/fun/001_basics.html) 35 | * [Chapter 3: Parsing](http://dev.stephendiehl.com/fun/002_parsers.html) 36 | * [Chapter 4: Lambda Calculus](http://dev.stephendiehl.com/fun/003_lambda_calculus.html) 37 | * [Chapter 5: Type Systems](http://dev.stephendiehl.com/fun/004_type_systems.html) 38 | * [Chapter 6: Evaluation](http://dev.stephendiehl.com/fun/005_evaluation.html) 39 | * [Chapter 7: Hindley-Milner Inference](http://dev.stephendiehl.com/fun/006_hindley_milner.html) 40 | * [Chapter 8: Design of ProtoHaskell](http://dev.stephendiehl.com/fun/007_path.html) 41 | * [Chapter 9: Extended Parser](http://dev.stephendiehl.com/fun/008_extended_parser.html) 42 | * [Chapter 10: Custom Datatypes](http://dev.stephendiehl.com/fun/009_datatypes.html) 43 | * [Chapter 11: Renamer] (http://dev.stephendiehl.com/fun/010_renamer.html) 44 | * Chapter 12: Pattern Matching & Desugaring 45 | * Chapter 13: System-F 46 | * Chapter 14: Type Classes 47 | * Chapter 15: Core Language 48 | * Chapter 16: Kinds 49 | * Chapter 17: Haskell Type Checker 50 | * Chapter 18: Core Interpreter 51 | * Chapter 19: Prelude 52 | * Chapter 20: Design of Lazy Evaluation 53 | * Chapter 21: STG 54 | * Chapter 22: Compilation 55 | * Chapter 23: Design of the Runtime 56 | * Chapter 24: Imp 57 | * Chapter 25: Code Generation ( C ) 58 | * Chapter 26: Code Generation ( LLVM ) 59 | * Chapter 27: Row Polymorphism & Effect Typing 60 | * Chapter 28: Future Work 61 | 62 | Building 63 | -------- 64 | 65 | To generate the build scripts provision a cabal sandbox with pandoc in it. This 66 | is done by the ``write-you-a-haskell.cabal`` and ``stack.yaml`` files. 67 | 68 | **Stack** 69 | 70 | ```bash 71 | $ stack exec make 72 | ``` 73 | 74 | To generate the pdf, the LaTeX packages must be installed on the 75 | system. 76 | 77 | ```bash 78 | $ sudo apt-get install texlive-xetex texlive-latex-extra 79 | $ sudo apt-get install xzdec 80 | $ sudo tlmgr install zapfding 81 | $ stack exec make pdf 82 | ``` 83 | 84 | Generation of the epub is also supported. 85 | 86 | ```bash 87 | $ stack exec make epub 88 | ``` 89 | 90 | 91 | **Cabal** 92 | 93 | ```bash 94 | $ cabal sandbox init 95 | $ cabal install --only-dependencies 96 | $ cabal exec bash 97 | $ make 98 | ``` 99 | 100 | Contributing 101 | ------------ 102 | 103 | Any and all contributions are always welcome. As always, I rely on the 104 | perpetual kindness and goodwill of Haskellers (like you!) to help correct 105 | grammar, clarify, and fix errors. 106 | 107 | * [Contributing](http://dev.stephendiehl.com/fun/contributing.html) 108 | 109 | License 110 | ------- 111 | 112 | Artwork CC BY NC SA 113 | 114 | This written work is licensed under a Creative Commons 116 | Attribution-NonCommercial-ShareAlike 4.0 International License. You may 117 | reproduce and edit this work with attribution for all non-commercial purposes. 118 | 119 | The included source is released under the terms of the [MIT License](http://opensource.org/licenses/MIT). 120 | -------------------------------------------------------------------------------- /atom.xml: -------------------------------------------------------------------------------- 1 | 2 | Write You A Haskellhttp://dev.stephendiehl.com/Building a modern functional compiler from first principles.Sat, 24 Jan 2015 14:36:50 GMTPyRSS2Gen-1.1.0http://blogs.law.harvard.edu/tech/rssIntroductionhttp://dev.stephendiehl.com/fun/000_introduction.htmlhttp://dev.stephendiehl.com/fun/000_introduction.htmlFri, 02 Jan 2015 00:00:00 GMTHaskell Basicshttp://dev.stephendiehl.com/fun/001_basics.htmlhttp://dev.stephendiehl.com/fun/001_basics.htmlSat, 03 Jan 2015 00:00:00 GMTParsinghttp://dev.stephendiehl.com/fun/002_parsers.htmlhttp://dev.stephendiehl.com/fun/002_parsers.htmlSun, 04 Jan 2015 00:00:00 GMTLambda Calculushttp://dev.stephendiehl.com/fun/003_lambda_calculus.htmlhttp://dev.stephendiehl.com/fun/003_lambda_calculus.htmlMon, 05 Jan 2015 00:00:00 GMTType Systemshttp://dev.stephendiehl.com/fun/004_type_systems.htmlhttp://dev.stephendiehl.com/fun/004_type_systems.htmlTue, 06 Jan 2015 00:00:00 GMTEvaluationhttp://dev.stephendiehl.com/fun/005_evaluation.htmlhttp://dev.stephendiehl.com/fun/005_evaluation.htmlWed, 07 Jan 2015 00:00:00 GMTHindley-Milner Inferencehttp://dev.stephendiehl.com/fun/006_hindley_milner.htmlhttp://dev.stephendiehl.com/fun/006_hindley_milner.htmlThu, 08 Jan 2015 00:00:00 GMTDesign of ProtoHaskellhttp://dev.stephendiehl.com/fun/007_path.htmlhttp://dev.stephendiehl.com/fun/007_path.htmlFri, 09 Jan 2015 00:00:00 GMTExtended Parserhttp://dev.stephendiehl.com/fun/008_extended_parser.htmlhttp://dev.stephendiehl.com/fun/008_extended_parser.htmlSat, 24 Jan 2015 14:30:28 GMT -------------------------------------------------------------------------------- /chapter1/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter1/.gitkeep -------------------------------------------------------------------------------- /chapter10/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | -------------------------------------------------------------------------------- /chapter10/.gitkeep: -------------------------------------------------------------------------------- 1 | *.o 2 | -------------------------------------------------------------------------------- /chapter10/adt.c: -------------------------------------------------------------------------------- 1 | typedef union { 2 | int a; 3 | float b; 4 | } Sum; 5 | 6 | typedef struct { 7 | int a; 8 | float b; 9 | } Prod; 10 | 11 | int main() 12 | { 13 | Prod x = { .a = 1, .b = 2.0 }; 14 | Sum sum1 = { .a = 1 }; 15 | Sum sum2 = { .b = 2.0 }; 16 | } 17 | -------------------------------------------------------------------------------- /chapter10/adt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | data Unit = Unit -- 1 4 | data Empty -- 0 5 | data (a * b) = Product a b -- a * b 6 | data (a + b) = Inl a | Inr b -- a + b 7 | data Exp a b = Exp (a -> b) -- a^b 8 | data Rec f = Mu (f (Rec f)) -- \mu 9 | 10 | -- Products 11 | 12 | type Prod3 a b c = a*(b*c) 13 | 14 | data Prod3' a b c 15 | = Prod3 a b c 16 | 17 | prod3 :: Prod3 Int Int Int 18 | prod3 = Product 1 (Product 2 3) 19 | 20 | -- Sums 21 | 22 | type Sum3 a b c = (a+b)+c 23 | 24 | data Sum3' a b c 25 | = Opt1 a 26 | | Opt2 b 27 | | Opt3 c 28 | 29 | sum3 :: Sum3 Int Int Int 30 | sum3 = Inl (Inl 2) 31 | 32 | data Option a = None | Some a 33 | 34 | type Option' a = Unit + a 35 | 36 | some :: Unit + a 37 | some = Inl Unit 38 | 39 | none :: a -> Unit + a 40 | none a = Inr a 41 | 42 | -- Recursion 43 | 44 | type Nat = Rec NatF 45 | data NatF s = Zero | Succ s 46 | 47 | zero :: Nat 48 | zero = Mu Zero 49 | 50 | succ :: Nat -> Nat 51 | succ x = Mu (Succ x) 52 | 53 | data ListF a b = Nil | Cons a b 54 | type List a = Rec (ListF a) 55 | 56 | -- syntactic sugar 57 | nil :: List a 58 | nil = Mu Nil 59 | 60 | cons :: a -> List a -> List a 61 | cons x y = Mu (Cons x y) 62 | 63 | roll :: Rec f -> f (Rec f) 64 | roll (Mu f) = f 65 | 66 | unroll :: f (Rec f) -> Rec f 67 | unroll f = Mu f 68 | 69 | main = return () 70 | -------------------------------------------------------------------------------- /chapter10/adt2.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef struct T 4 | { 5 | enum { NONE, SOME } tag; 6 | union 7 | { 8 | void *none; 9 | int some; 10 | } value; 11 | } Option; 12 | 13 | int main() 14 | { 15 | Option a = { .tag = NONE, .value = { .none = NULL } }; 16 | Option b = { .tag = SOME, .value = { .some = 3 } }; 17 | } 18 | -------------------------------------------------------------------------------- /chapter10/eval.c: -------------------------------------------------------------------------------- 1 | typedef struct T { 2 | enum { ADD, MUL, DIV, SUB, NUM } tag; 3 | union { 4 | struct { 5 | struct T *left, *right; 6 | } node; 7 | int value; 8 | }; 9 | } Expr; 10 | 11 | int eval(Expr t) 12 | { 13 | switch (t.tag) { 14 | case ADD: 15 | return eval(*t.node.left) + eval(*t.node.right); 16 | break; 17 | case MUL: 18 | return eval(*t.node.left) * eval(*t.node.right); 19 | break; 20 | case DIV: 21 | return eval(*t.node.left) / eval(*t.node.right); 22 | break; 23 | case SUB: 24 | return eval(*t.node.left) - eval(*t.node.right); 25 | break; 26 | case NUM: 27 | return t.value; 28 | break; 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /chapter10/eval.hs: -------------------------------------------------------------------------------- 1 | data T 2 | = Add T T 3 | | Mul T T 4 | | Div T T 5 | | Sub T T 6 | | Num Int 7 | 8 | eval :: T -> Int 9 | eval x = case x of 10 | Add a b -> eval a + eval b 11 | Mul a b -> eval a + eval b 12 | Div a b -> eval a + eval b 13 | Sub a b -> eval a + eval b 14 | Num a -> a 15 | -------------------------------------------------------------------------------- /chapter10/generics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | 5 | import GHC.Generics 6 | 7 | -- Auxiliary class 8 | class GEq' f where 9 | geq' :: f a -> f a -> Bool 10 | 11 | instance GEq' U1 where 12 | geq' _ _ = True 13 | 14 | instance (GEq c) => GEq' (K1 i c) where 15 | geq' (K1 a) (K1 b) = geq a b 16 | 17 | instance (GEq' a) => GEq' (M1 i c a) where 18 | geq' (M1 a) (M1 b) = geq' a b 19 | 20 | instance (GEq' a, GEq' b) => GEq' (a :+: b) where 21 | geq' (L1 a) (L1 b) = geq' a b 22 | geq' (R1 a) (R1 b) = geq' a b 23 | geq' _ _ = False 24 | 25 | instance (GEq' a, GEq' b) => GEq' (a :*: b) where 26 | geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 27 | 28 | -- 29 | class GEq a where 30 | geq :: a -> a -> Bool 31 | default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool 32 | geq x y = geq' (from x) (from y) 33 | 34 | -- Base equalities 35 | instance GEq Char where geq = (==) 36 | instance GEq Int where geq = (==) 37 | instance GEq Float where geq = (==) 38 | 39 | -- Equalities derived from structure of (:+:) and (:*:) 40 | instance GEq a => GEq (Maybe a) 41 | instance (GEq a, GEq b) => GEq (a,b) 42 | 43 | main :: IO () 44 | main = do 45 | print $ geq 2 (3 :: Int) 46 | print $ geq 'a' 'b' 47 | print $ geq (Just 'a') (Just 'a') 48 | print $ geq ('a','b') ('a', 'b') 49 | -------------------------------------------------------------------------------- /chapter11/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter11/.gitkeep -------------------------------------------------------------------------------- /chapter12/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter12/.gitkeep -------------------------------------------------------------------------------- /chapter12/systemf/Syntax.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | type TypeVar = String 3 | type TypeCon = String 4 | 5 | data Expr 6 | = Lam Type Name Expr -- \x -> a 7 | | Var Name -- x 8 | | App Expr Expr -- a b 9 | | TLam Name Expr -- /\ a . b 10 | | TApp Expr Type -- a [ b ] 11 | | Lit Literal -- 1 12 | | Let Name Expr Expr -- let x = v in a 13 | 14 | data Type 15 | = TForall [Name] Type 16 | | TArr Type Type 17 | | TCon TypeCon 18 | | TVar TypeVar 19 | deriving (Show) 20 | 21 | data Literal 22 | = LitInt Integer 23 | | LitChar Char 24 | deriving (Eq, Ord, Show) 25 | -------------------------------------------------------------------------------- /chapter2/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter2/.gitkeep -------------------------------------------------------------------------------- /chapter27/cfg/branch.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'foo' function" { 2 | graph [ dpi = 72 ]; 3 | label="Unconditional Branch"; 4 | Node0x103c3c0 [shape=record,label="{start:\l br label %next\l}"]; 5 | Node0x103c3c0 -> Node0x1038a90; 6 | Node0x1038a90 [shape=record,label="{next: \l br label %return\l}"]; 7 | Node0x1038a90 -> Node0x1038b90; 8 | Node0x1038b90 [shape=record,label="{return: \l ret i1 false\l}"]; 9 | } 10 | -------------------------------------------------------------------------------- /chapter27/cfg/branch.ll: -------------------------------------------------------------------------------- 1 | define i1 @foo() { 2 | start: 3 | br label %next 4 | next: 5 | br label %return 6 | return: 7 | ret i1 0 8 | } 9 | 10 | -------------------------------------------------------------------------------- /chapter27/cfg/branch.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/branch.png -------------------------------------------------------------------------------- /chapter27/cfg/cbranch.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'foo' function" { 2 | graph [ dpi = 72 ]; 3 | label="Conditional Branch"; 4 | 5 | Node0x1f793c0 [shape=record,label="{start:\l br i1 true, label %left, label %right\l|{T|F}}"]; 6 | Node0x1f793c0:s0 -> Node0x1f75a20; 7 | Node0x1f793c0:s1 -> Node0x1f75b40; 8 | Node0x1f75a20 [shape=record,label="{left: \l ret i32 10\l}"]; 9 | Node0x1f75b40 [shape=record,label="{right: \l ret i32 20\l}"]; 10 | } 11 | -------------------------------------------------------------------------------- /chapter27/cfg/cbranch.ll: -------------------------------------------------------------------------------- 1 | define i32 @foo() { 2 | start: 3 | br i1 true, label %left, label %right 4 | left: 5 | ret i32 10 6 | right: 7 | ret i32 20 8 | } 9 | -------------------------------------------------------------------------------- /chapter27/cfg/cbranch.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/cbranch.png -------------------------------------------------------------------------------- /chapter27/cfg/for.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'printstar' function" { 2 | graph [ dpi = 72 ]; 3 | label="For loop"; 4 | 5 | Node0x11ea390 [shape=record,label="{entry:\l br label %loop\l}"]; 6 | Node0x11ea390 -> Node0x11e72d0; 7 | Node0x11e72d0 [shape=record,label="{loop: \l %i = phi i32 [ 1, %entry ], [ %nextvar, %loop ]\l %nextvar = add i32 %i, 1\l %cmptmp = icmp ult i32 %i, %n\l %booltmp = zext i1 %cmptmp to i32\l %loopcond = icmp ne i32 %booltmp, 0\l br i1 %loopcond, label %loop, label %afterloop\l|{T|F}}"]; 8 | Node0x11e72d0:s0 -> Node0x11e72d0; 9 | Node0x11e72d0:s1 -> Node0x11e7540; 10 | Node0x11e7540 [shape=record,label="{afterloop: \l ret i32 %i\l}"]; 11 | } 12 | -------------------------------------------------------------------------------- /chapter27/cfg/for.ll: -------------------------------------------------------------------------------- 1 | define i32 @printstar(i32 %n) { 2 | entry: 3 | br label %loop 4 | 5 | loop: 6 | %i = phi i32 [ 1, %entry ], [ %nextvar, %loop ] 7 | %nextvar = add i32 %i, 1 8 | 9 | %cmptmp = icmp ult i32 %i, %n 10 | %booltmp = zext i1 %cmptmp to i32 11 | %loopcond = icmp ne i32 %booltmp, 0 12 | 13 | br i1 %loopcond, label %loop, label %afterloop 14 | 15 | afterloop: 16 | ret i32 %i 17 | } 18 | -------------------------------------------------------------------------------- /chapter27/cfg/for.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/for.png -------------------------------------------------------------------------------- /chapter27/cfg/phi.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'foo' function" { 2 | graph [ dpi = 72 ]; 3 | 4 | label="Phi node"; 5 | 6 | Node0x175c3c0 [shape=record,label="{start:\l br i1 true, label %left, label %right\l|{T|F}}"]; 7 | Node0x175c3c0:s0 -> Node0x1758a20; 8 | Node0x175c3c0:s1 -> Node0x1758b40; 9 | Node0x1758a20 [shape=record,label="{left: \l %plusOne = add i32 0, 1\l br label %merge\l}"]; 10 | Node0x1758a20 -> Node0x17593e0; 11 | Node0x1758b40 [shape=record,label="{right: \l br label %merge\l}"]; 12 | Node0x1758b40 -> Node0x17593e0; 13 | Node0x17593e0 [shape=record,label="{merge: \l %join = phi i32 [ %plusOne, %left ], [ -1, %right ]\l ret i32 %join\l}"]; 14 | } 15 | -------------------------------------------------------------------------------- /chapter27/cfg/phi.ll: -------------------------------------------------------------------------------- 1 | define i32 @foo() { 2 | start: 3 | br i1 true, label %left, label %right 4 | left: 5 | %plusOne = add i32 0, 1 6 | br label %merge 7 | right: 8 | br label %merge 9 | merge: 10 | %join = phi i32 [ %plusOne, %left], [ -1, %right] 11 | ret i32 %join 12 | } 13 | -------------------------------------------------------------------------------- /chapter27/cfg/phi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/phi.png -------------------------------------------------------------------------------- /chapter27/cfg/ret.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'foo' function" { 2 | graph [ dpi = 72 ]; 3 | 4 | label="Return"; 5 | Node0x259a2b0 [shape=record,label="{%0:\l ret i1 false\l}"]; 6 | } 7 | -------------------------------------------------------------------------------- /chapter27/cfg/ret.ll: -------------------------------------------------------------------------------- 1 | define i1 @foo() { 2 | ret i1 0 3 | } 4 | 5 | -------------------------------------------------------------------------------- /chapter27/cfg/ret.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/ret.png -------------------------------------------------------------------------------- /chapter27/cfg/switch.dot: -------------------------------------------------------------------------------- 1 | digraph "CFG for 'foo' function" { 2 | graph [ dpi = 72 ]; 3 | label="Switch"; 4 | 5 | Node0x1027390 [shape=record,label="{entry:\l switch i32 %a, label %default [\l i32 0, label %f\l i32 1, label %g\l i32 2, label %h\l ]\l|{def|0|1|2}}"]; 6 | Node0x1027390:s0 -> Node0x1024700; 7 | Node0x1027390:s1 -> Node0x1024300; 8 | Node0x1027390:s2 -> Node0x1024440; 9 | Node0x1027390:s3 -> Node0x1023920; 10 | Node0x1024300 [shape=record,label="{f: \l ret i32 1\l}"]; 11 | Node0x1024440 [shape=record,label="{g: \l ret i32 2\l}"]; 12 | Node0x1023920 [shape=record,label="{h: \l ret i32 3\l}"]; 13 | Node0x1024700 [shape=record,label="{default: \l ret i32 0\l}"]; 14 | } 15 | -------------------------------------------------------------------------------- /chapter27/cfg/switch.ll: -------------------------------------------------------------------------------- 1 | define i32 @foo(i32 %a) { 2 | entry: 3 | switch i32 %a, label %default [ i32 0, label %f 4 | i32 1, label %g 5 | i32 2, label %h ] 6 | f: 7 | ret i32 1 8 | g: 9 | ret i32 2 10 | h: 11 | ret i32 3 12 | default: 13 | ret i32 0 14 | } 15 | -------------------------------------------------------------------------------- /chapter27/cfg/switch.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter27/cfg/switch.png -------------------------------------------------------------------------------- /chapter27/dsl/JIT.hs: -------------------------------------------------------------------------------- 1 | module JIT where 2 | 3 | import Data.Int 4 | import Data.Word 5 | import Foreign.Ptr ( FunPtr, castFunPtr ) 6 | 7 | import Control.Monad.Error 8 | 9 | import LLVM.General.Target 10 | import LLVM.General.Context 11 | import LLVM.General.CodeModel 12 | import LLVM.General.Module as Mod 13 | import qualified LLVM.General.AST as AST 14 | 15 | import LLVM.General.PassManager 16 | import LLVM.General.Transforms 17 | import LLVM.General.Analysis 18 | 19 | import qualified LLVM.General.ExecutionEngine as EE 20 | 21 | foreign import ccall "dynamic" haskFun :: FunPtr (IO Double) -> (IO Double) 22 | 23 | run :: FunPtr a -> IO Double 24 | run fn = haskFun (castFunPtr fn :: FunPtr (IO Double)) 25 | 26 | jit :: Context -> (EE.MCJIT -> IO a) -> IO a 27 | jit c = EE.withMCJIT c optlevel model ptrelim fastins 28 | where 29 | optlevel = Just 0 -- optimization level 30 | model = Nothing -- code model ( Default ) 31 | ptrelim = Nothing -- frame pointer elimination 32 | fastins = Nothing -- fast instruction selection 33 | 34 | passes :: PassSetSpec 35 | passes = defaultCuratedPassSetSpec { optLevel = Just 3 } 36 | 37 | runJIT :: AST.Module -> IO (Either String AST.Module) 38 | runJIT mod = do 39 | withContext $ \context -> 40 | jit context $ \executionEngine -> 41 | runErrorT $ withModuleFromAST context mod $ \m -> 42 | withPassManager passes $ \pm -> do 43 | -- Optimization Pass 44 | {-runPassManager pm m-} 45 | optmod <- moduleAST m 46 | s <- moduleLLVMAssembly m 47 | putStrLn s 48 | 49 | EE.withModuleInEngine executionEngine m $ \ee -> do 50 | mainfn <- EE.getFunction ee (AST.Name "main") 51 | case mainfn of 52 | Just fn -> do 53 | res <- run fn 54 | putStrLn $ "Evaluated to: " ++ show res 55 | Nothing -> return () 56 | 57 | -- Return the optimized module 58 | return optmod 59 | -------------------------------------------------------------------------------- /chapter27/dsl/Main.hs: -------------------------------------------------------------------------------- 1 | import JIT 2 | import Codegen 3 | import qualified LLVM.General.AST as AST 4 | import qualified LLVM.General.AST.Float as F 5 | import qualified LLVM.General.AST.Constant as C 6 | 7 | {- 8 | 9 | ; ModuleID = 'my cool jit' 10 | 11 | define double @main() { 12 | entry: 13 | %1 = fadd double 1.000000e+01, 2.000000e+01 14 | ret double %1 15 | } 16 | 17 | -} 18 | 19 | initModule :: AST.Module 20 | initModule = emptyModule "my cool jit" 21 | 22 | logic = do 23 | define double "main" [] $ do 24 | let a = cons $ C.Float (F.Double 10) 25 | let b = cons $ C.Float (F.Double 20) 26 | res <- fadd a b 27 | ret res 28 | 29 | main = do 30 | let ast = runLLVM initModule logic 31 | runJIT ast 32 | return ast 33 | -------------------------------------------------------------------------------- /chapter27/dsl/dsl.cabal: -------------------------------------------------------------------------------- 1 | name: dsl 2 | version: 0.1.0.0 3 | --synopsis: 4 | --description: 5 | license: MIT 6 | license-file: LICENSE-MIT 7 | author: Stephen Diehl 8 | maintainer: stephen.m.diehl@gmail.com 9 | copyright: 2015 Stephen Diehl 10 | Category: Compilers 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | library 15 | default-language: Haskell2010 16 | build-depends: 17 | base >= 4.6 18 | , haskeline >= 0.7.1.2 19 | , llvm-general == 3.4.4.* 20 | , llvm-general-pure == 3.4.4.* 21 | , mtl >= 2.2 22 | , transformers 23 | -------------------------------------------------------------------------------- /chapter27/example.cpp: -------------------------------------------------------------------------------- 1 | // Generated by llvm2cpp - DO NOT MODIFY! 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | using namespace llvm; 22 | 23 | Module* makeLLVMModule(); 24 | 25 | int main(int argc, char**argv) { 26 | Module* Mod = makeLLVMModule(); 27 | verifyModule(*Mod, PrintMessageAction); 28 | PassManager PM; 29 | PM.add(createPrintModulePass(&outs())); 30 | PM.run(*Mod); 31 | return 0; 32 | } 33 | 34 | 35 | Module* makeLLVMModule() { 36 | // Module Construction 37 | Module* mod = new Module("example.ll", getGlobalContext()); 38 | 39 | // Type Definitions 40 | std::vectorFuncTy_0_args; 41 | FuncTy_0_args.push_back(IntegerType::get(mod->getContext(), 32)); 42 | FuncTy_0_args.push_back(IntegerType::get(mod->getContext(), 32)); 43 | FuncTy_0_args.push_back(IntegerType::get(mod->getContext(), 32)); 44 | FunctionType* FuncTy_0 = FunctionType::get( 45 | /*Result=*/IntegerType::get(mod->getContext(), 32), 46 | /*Params=*/FuncTy_0_args, 47 | /*isVarArg=*/false); 48 | 49 | 50 | // Function Declarations 51 | 52 | Function* func_test1 = mod->getFunction("test1"); 53 | if (!func_test1) { 54 | func_test1 = Function::Create( 55 | /*Type=*/FuncTy_0, 56 | /*Linkage=*/GlobalValue::ExternalLinkage, 57 | /*Name=*/"test1", mod); 58 | func_test1->setCallingConv(CallingConv::C); 59 | } 60 | AttrListPtr func_test1_PAL; 61 | func_test1->setAttributes(func_test1_PAL); 62 | 63 | // Global Variable Declarations 64 | 65 | 66 | // Constant Definitions 67 | 68 | // Global Variable Definitions 69 | 70 | // Function Definitions 71 | 72 | // Function: test1 (func_test1) 73 | { 74 | Function::arg_iterator args = func_test1->arg_begin(); 75 | Value* int32_x = args++; 76 | int32_x->setName("x"); 77 | Value* int32_y = args++; 78 | int32_y->setName("y"); 79 | Value* int32_z = args++; 80 | int32_z->setName("z"); 81 | 82 | BasicBlock* label_1 = BasicBlock::Create(mod->getContext(), "",func_test1,0); 83 | 84 | // Block (label_1) 85 | BinaryOperator* int32_a = BinaryOperator::Create(Instruction::And, int32_z, int32_x, "a", label_1); 86 | BinaryOperator* int32_b = BinaryOperator::Create(Instruction::And, int32_z, int32_y, "b", label_1); 87 | BinaryOperator* int32_c = BinaryOperator::Create(Instruction::Xor, int32_a, int32_b, "c", label_1); 88 | ReturnInst::Create(mod->getContext(), int32_c, label_1); 89 | 90 | } 91 | 92 | return mod; 93 | } 94 | -------------------------------------------------------------------------------- /chapter27/example.ll: -------------------------------------------------------------------------------- 1 | define i32 @test1(i32 %x, i32 %y, i32 %z) { 2 | %a = and i32 %z, %x 3 | %b = and i32 %z, %y 4 | %c = xor i32 %a, %b 5 | ret i32 %c 6 | } 7 | -------------------------------------------------------------------------------- /chapter3/calc/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval where 2 | 3 | import Syntax 4 | 5 | import Data.Maybe 6 | import Data.Functor 7 | 8 | isNum :: Expr -> Bool 9 | isNum Zero = True 10 | isNum (Succ t) = isNum t 11 | isNum _ = False 12 | 13 | isVal :: Expr -> Bool 14 | isVal Tr = True 15 | isVal Fl = True 16 | isVal t | isNum t = True 17 | isVal _ = False 18 | 19 | eval' :: Expr -> Maybe Expr 20 | eval' x = case x of 21 | IsZero Zero -> Just Tr 22 | IsZero (Succ t) | isNum t -> Just Fl 23 | IsZero t -> IsZero <$> (eval' t) 24 | Succ t -> Succ <$> (eval' t) 25 | Pred Zero -> Just Zero 26 | Pred (Succ t) | isNum t -> Just t 27 | Pred t -> Pred <$> (eval' t) 28 | If Tr c _ -> Just c 29 | If Fl _ a -> Just a 30 | If t c a -> (\t' -> If t' c a) <$> eval' t 31 | _ -> Nothing 32 | 33 | nf :: Expr -> Expr 34 | nf x = fromMaybe x (nf <$> eval' x) 35 | 36 | eval :: Expr -> Maybe Expr 37 | eval t = case nf t of 38 | nft | isVal nft -> Just nft 39 | | otherwise -> Nothing -- term is "stuck" 40 | -------------------------------------------------------------------------------- /chapter3/calc/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Eval 4 | import Parser 5 | import Pretty 6 | 7 | import Control.Monad.Trans 8 | import System.Console.Haskeline 9 | 10 | process :: String -> IO () 11 | process line = do 12 | let res = parseExpr line 13 | case res of 14 | Left err -> print err 15 | Right ex -> case eval ex of 16 | Nothing -> putStrLn "Cannot evaluate" 17 | Just result -> putStrLn $ ppexpr result 18 | 19 | main :: IO () 20 | main = runInputT defaultSettings loop 21 | where 22 | loop = do 23 | minput <- getInputLine "Arith> " 24 | case minput of 25 | Nothing -> outputStrLn "Goodbye." 26 | Just input -> (liftIO $ process input) >> loop 27 | -------------------------------------------------------------------------------- /chapter3/calc/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( 2 | parseExpr 3 | ) where 4 | 5 | import Syntax 6 | 7 | import Text.Parsec 8 | import Text.Parsec.String (Parser) 9 | import Text.Parsec.Language (emptyDef) 10 | 11 | import qualified Text.Parsec.Expr as Ex 12 | import qualified Text.Parsec.Token as Tok 13 | 14 | import Data.Functor.Identity 15 | 16 | langDef :: Tok.LanguageDef () 17 | langDef = Tok.LanguageDef 18 | { Tok.commentStart = "{-" 19 | , Tok.commentEnd = "-}" 20 | , Tok.commentLine = "--" 21 | , Tok.nestedComments = True 22 | , Tok.identStart = letter 23 | , Tok.identLetter = alphaNum <|> oneOf "_'" 24 | , Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 25 | , Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 26 | , Tok.reservedNames = [] 27 | , Tok.reservedOpNames = [] 28 | , Tok.caseSensitive = True 29 | } 30 | 31 | lexer :: Tok.TokenParser () 32 | lexer = Tok.makeTokenParser langDef 33 | 34 | parens :: Parser a -> Parser a 35 | parens = Tok.parens lexer 36 | 37 | reserved :: String -> Parser () 38 | reserved = Tok.reserved lexer 39 | 40 | semiSep :: Parser a -> Parser [a] 41 | semiSep = Tok.semiSep lexer 42 | 43 | reservedOp :: String -> Parser () 44 | reservedOp = Tok.reservedOp lexer 45 | 46 | prefixOp :: String -> (a -> a) -> Ex.Operator String () Identity a 47 | prefixOp s f = Ex.Prefix (reservedOp s >> return f) 48 | 49 | 50 | -- Prefix operators 51 | table :: Ex.OperatorTable String () Identity Expr 52 | table = [ 53 | [ 54 | prefixOp "succ" Succ 55 | , prefixOp "pred" Pred 56 | , prefixOp "iszero" IsZero 57 | ] 58 | ] 59 | 60 | 61 | -- if/then/else 62 | ifthen :: Parser Expr 63 | ifthen = do 64 | reserved "if" 65 | cond <- expr 66 | reservedOp "then" 67 | tr <- expr 68 | reserved "else" 69 | fl <- expr 70 | return (If cond tr fl) 71 | 72 | -- Constants 73 | true, false, zero :: Parser Expr 74 | true = reserved "true" >> return Tr 75 | false = reserved "false" >> return Fl 76 | zero = reservedOp "0" >> return Zero 77 | 78 | expr :: Parser Expr 79 | expr = Ex.buildExpressionParser table factor 80 | 81 | factor :: Parser Expr 82 | factor = 83 | true 84 | <|> false 85 | <|> zero 86 | <|> ifthen 87 | <|> parens expr 88 | 89 | contents :: Parser a -> Parser a 90 | contents p = do 91 | Tok.whiteSpace lexer 92 | r <- p 93 | eof 94 | return r 95 | 96 | toplevel :: Parser [Expr] 97 | toplevel = semiSep expr 98 | 99 | parseExpr :: String -> Either ParseError Expr 100 | parseExpr s = parse (contents expr) "" s 101 | -------------------------------------------------------------------------------- /chapter3/calc/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Pretty ( 2 | ppexpr 3 | ) where 4 | 5 | import Syntax 6 | 7 | import Text.PrettyPrint (Doc, (<>), (<+>)) 8 | import qualified Text.PrettyPrint as PP 9 | 10 | parensIf :: Bool -> Doc -> Doc 11 | parensIf True = PP.parens 12 | parensIf False = id 13 | 14 | class Pretty p where 15 | ppr :: Int -> p -> Doc 16 | 17 | instance Pretty Expr where 18 | ppr _ Zero = PP.text "0" 19 | ppr _ Tr = PP.text "true" 20 | ppr _ Fl = PP.text "false" 21 | ppr p (Succ a) = (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a) 22 | ppr p (Pred a) = (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a) 23 | ppr p (IsZero a) = (parensIf (p > 0) $ PP.text "iszero" <+> ppr (p+1) a) 24 | ppr p (If a b c) = 25 | PP.text "if" <+> ppr p a 26 | <+> PP.text "then" <+> ppr p b 27 | <+> PP.text "else" <+> ppr p c 28 | 29 | ppexpr :: Expr -> String 30 | ppexpr = PP.render . ppr 0 31 | -------------------------------------------------------------------------------- /chapter3/calc/README.md: -------------------------------------------------------------------------------- 1 | Arith 2 | ====== 3 | 4 | A untyped arithmetic. 5 | 6 | To compile and run: 7 | 8 | ```shell 9 | $ cabal run 10 | ``` 11 | 12 | Usage: 13 | 14 | ```ocaml 15 | Arith> succ 0 16 | succ 0 17 | 18 | Arith> succ (succ 0) 19 | succ (succ 0) 20 | 21 | Arith> if false then true else false 22 | false 23 | 24 | Arith> iszero (pred (succ (succ 0))) 25 | false 26 | 27 | Arith> pred (succ 0) 28 | 0 29 | 30 | Arith> iszero false 31 | Cannot evaluate 32 | 33 | Arith> if 0 then true else false 34 | Cannot evaluate 35 | ``` 36 | 37 | License 38 | ======= 39 | 40 | Released under MIT license. 41 | -------------------------------------------------------------------------------- /chapter3/calc/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | data Expr 4 | = Tr 5 | | Fl 6 | | Zero 7 | | IsZero Expr 8 | | Succ Expr 9 | | Pred Expr 10 | | If Expr Expr Expr 11 | deriving (Eq, Show) 12 | -------------------------------------------------------------------------------- /chapter3/calc/calc.cabal: -------------------------------------------------------------------------------- 1 | name: calc 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable calc 12 | build-depends: 13 | base >= 4.6 && <4.7, 14 | mtl >= 2.2 && <3.0, 15 | filepath >= 1.3 && <1.4, 16 | text >= 1.1 && <1.2, 17 | pretty >= 1.1 && <1.2, 18 | process >= 1.1 && <1.2, 19 | directory >= 1.2 && <1.3, 20 | haskeline >= 0.7 && <0.8, 21 | containers >= 0.5 && <0.6, 22 | parsec >= 3.1 && <3.2, 23 | transformers >= 0.4 && <0.5 24 | default-language: Haskell2010 25 | main-is: Main.hs 26 | -------------------------------------------------------------------------------- /chapter3/parsec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} 2 | 3 | module NanoParsec where 4 | 5 | import Data.Char 6 | import Control.Monad 7 | import Control.Applicative 8 | 9 | newtype Parser a = Parser { parse :: String -> [(a,String)] } 10 | 11 | runParser :: Parser a -> String -> a 12 | runParser m s = 13 | case parse m s of 14 | [(res, [])] -> res 15 | [(_, _)] -> error "Parser did not consume entire stream." 16 | _ -> error "Parser error." 17 | 18 | item :: Parser Char 19 | item = Parser $ \s -> 20 | case s of 21 | [] -> [] 22 | (c:cs) -> [(c,cs)] 23 | 24 | bind :: Parser a -> (a -> Parser b) -> Parser b 25 | bind p f = Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s 26 | 27 | unit :: a -> Parser a 28 | unit a = Parser (\s -> [(a,s)]) 29 | 30 | instance Functor Parser where 31 | fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s]) 32 | 33 | instance Applicative Parser where 34 | pure = return 35 | (Parser cs1) <*> (Parser cs2) = Parser (\s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1]) 36 | 37 | instance Monad Parser where 38 | return = unit 39 | (>>=) = bind 40 | 41 | instance MonadPlus Parser where 42 | mzero = failure 43 | mplus = combine 44 | 45 | instance Alternative Parser where 46 | empty = mzero 47 | (<|>) = option 48 | 49 | combine :: Parser a -> Parser a -> Parser a 50 | combine p q = Parser (\s -> parse p s ++ parse q s) 51 | 52 | failure :: Parser a 53 | failure = Parser (\cs -> []) 54 | 55 | option :: Parser a -> Parser a -> Parser a 56 | option p q = Parser $ \s -> 57 | case parse p s of 58 | [] -> parse q s 59 | res -> res 60 | 61 | satisfy :: (Char -> Bool) -> Parser Char 62 | satisfy p = item `bind` \c -> 63 | if p c 64 | then unit c 65 | else failure 66 | 67 | ------------------------------------------------------------------------------- 68 | -- Combinators 69 | ------------------------------------------------------------------------------- 70 | 71 | oneOf :: [Char] -> Parser Char 72 | oneOf s = satisfy (flip elem s) 73 | 74 | chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a 75 | chainl p op a = (p `chainl1` op) <|> return a 76 | 77 | chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a 78 | p `chainl1` op = do {a <- p; rest a} 79 | where rest a = (do f <- op 80 | b <- p 81 | rest (f a b)) 82 | <|> return a 83 | 84 | char :: Char -> Parser Char 85 | char c = satisfy (c ==) 86 | 87 | natural :: Parser Integer 88 | natural = read <$> some (satisfy isDigit) 89 | 90 | string :: String -> Parser String 91 | string [] = return [] 92 | string (c:cs) = do { char c; string cs; return (c:cs)} 93 | 94 | token :: Parser a -> Parser a 95 | token p = do { a <- p; spaces ; return a} 96 | 97 | reserved :: String -> Parser String 98 | reserved s = token (string s) 99 | 100 | spaces :: Parser String 101 | spaces = many $ oneOf " \n\r" 102 | 103 | digit :: Parser Char 104 | digit = satisfy isDigit 105 | 106 | number :: Parser Int 107 | number = do 108 | s <- string "-" <|> return [] 109 | cs <- some digit 110 | return $ read (s ++ cs) 111 | 112 | parens :: Parser a -> Parser a 113 | parens m = do 114 | reserved "(" 115 | n <- m 116 | reserved ")" 117 | return n 118 | 119 | ------------------------------------------------------------------------------- 120 | -- Calulator parser 121 | ------------------------------------------------------------------------------- 122 | 123 | -- number = [ "-" ] digit { digit }. 124 | -- digit = "0" | "1" | ... | "8" | "9". 125 | -- expr = term { addop term }. 126 | -- term = factor { mulop factor }. 127 | -- factor = "(" expr ")" | number. 128 | -- addop = "+" | "-". 129 | -- mulop = "*". 130 | 131 | data Expr 132 | = Add Expr Expr 133 | | Mul Expr Expr 134 | | Sub Expr Expr 135 | | Lit Int 136 | deriving Show 137 | 138 | eval :: Expr -> Int 139 | eval ex = case ex of 140 | Add a b -> eval a + eval b 141 | Mul a b -> eval a * eval b 142 | Sub a b -> eval a - eval b 143 | Lit n -> n 144 | 145 | int :: Parser Expr 146 | int = do 147 | n <- number 148 | return (Lit n) 149 | 150 | expr :: Parser Expr 151 | expr = term `chainl1` addop 152 | 153 | term :: Parser Expr 154 | term = factor `chainl1` mulop 155 | 156 | factor :: Parser Expr 157 | factor = 158 | int 159 | <|> parens expr 160 | 161 | infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a) 162 | infixOp x f = reserved x >> return f 163 | 164 | addop :: Parser (Expr -> Expr -> Expr) 165 | addop = (infixOp "+" Add) <|> (infixOp "-" Sub) 166 | 167 | mulop :: Parser (Expr -> Expr -> Expr) 168 | mulop = infixOp "*" Mul 169 | 170 | run :: String -> Expr 171 | run = runParser expr 172 | 173 | main :: IO () 174 | main = forever $ do 175 | putStr "> " 176 | a <- getLine 177 | print $ eval $ run a 178 | -------------------------------------------------------------------------------- /chapter4/lambda.hs: -------------------------------------------------------------------------------- 1 | type Name = String 2 | 3 | data Expr 4 | = Var Name 5 | | App Expr Expr 6 | | Lam Name Expr 7 | 8 | s, k, i :: Expr 9 | i = Lam "x" (Var "x") 10 | k = Lam "x" (Lam "y" (Var "x")) 11 | s = Lam "x" (Lam "y" (Lam "z" (App (App (Var "x") (Var "z")) (App (Var "y") (Var "z"))))) 12 | -------------------------------------------------------------------------------- /chapter4/untyped/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval ( 2 | runEval 3 | ) where 4 | 5 | import Syntax 6 | import qualified Data.Map as Map 7 | 8 | import Control.Monad.State 9 | import Control.Monad.Writer 10 | 11 | 12 | data Value 13 | = VInt Integer 14 | | VBool Bool 15 | | VClosure String Expr (Eval.Scope) 16 | 17 | instance Show Value where 18 | show (VInt x) = show x 19 | show (VBool x) = show x 20 | show VClosure{} = "<>" 21 | 22 | data EvalState = EvalState 23 | { depth :: Int 24 | } deriving (Show) 25 | 26 | inc :: Eval a -> Eval a 27 | inc m = do 28 | modify $ \s -> s { depth = (depth s) + 1 } 29 | out <- m 30 | modify $ \s -> s { depth = (depth s) - 1 } 31 | return out 32 | 33 | red :: Expr -> Eval () 34 | red x = do 35 | d <- gets depth 36 | tell [(d, x)] 37 | return () 38 | 39 | type Step = (Int, Expr) 40 | type Eval a = WriterT [Step] (State EvalState) a 41 | 42 | type Scope = Map.Map String Value 43 | 44 | eval :: Eval.Scope -> Expr -> Eval Value 45 | eval env expr = case expr of 46 | 47 | Lit (LInt x) -> do 48 | return $ VInt (fromIntegral x) 49 | 50 | Lit (LBool x) -> do 51 | return $ VBool x 52 | 53 | Var x -> do 54 | red expr 55 | return $ env Map.! x 56 | 57 | Lam x body -> inc $ do 58 | return (VClosure x body env) 59 | 60 | App a b -> inc $ do 61 | x <- eval env a 62 | red a 63 | y <- eval env b 64 | red b 65 | apply x y 66 | 67 | extend :: Scope -> String -> Value -> Scope 68 | extend env v t = Map.insert v t env 69 | 70 | apply :: Value -> Value -> Eval Value 71 | apply (VClosure n e clo) ex = do 72 | eval (extend clo n ex) e 73 | apply _ _ = error "Tried to apply non-closure" 74 | 75 | emptyScope :: Scope 76 | emptyScope = Map.empty 77 | 78 | runEval :: Expr -> (Value, [Step]) 79 | runEval x = evalState (runWriterT (eval emptyScope x)) (EvalState 0) 80 | -------------------------------------------------------------------------------- /chapter4/untyped/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Syntax 4 | import Parser 5 | import Eval 6 | import Pretty 7 | 8 | import Control.Monad 9 | import Control.Monad.Trans 10 | import System.Console.Haskeline 11 | 12 | showStep :: (Int, Expr) -> IO () 13 | showStep (d, x) = putStrLn ((replicate d ' ') ++ "=> " ++ ppexpr x) 14 | 15 | process :: String -> IO () 16 | process line = do 17 | let res = parseExpr line 18 | case res of 19 | Left err -> print err 20 | Right ex -> do 21 | let (out, ~steps) = runEval ex 22 | mapM_ showStep steps 23 | print out 24 | 25 | main :: IO () 26 | main = runInputT defaultSettings loop 27 | where 28 | loop = do 29 | minput <- getInputLine "Untyped> " 30 | case minput of 31 | Nothing -> outputStrLn "Goodbye." 32 | Just input -> (liftIO $ process input) >> loop 33 | -------------------------------------------------------------------------------- /chapter4/untyped/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser (parseExpr) where 2 | 3 | import Data.Char 4 | import Text.Parsec 5 | import Text.Parsec.String (Parser) 6 | import Text.Parsec.Language (haskellStyle) 7 | 8 | import qualified Text.Parsec.Expr as Ex 9 | import qualified Text.Parsec.Token as Tok 10 | 11 | import Syntax 12 | 13 | lexer :: Tok.TokenParser () 14 | lexer = Tok.makeTokenParser style 15 | where ops = ["->","\\","+","*","-","="] 16 | names = [] 17 | style = haskellStyle {Tok.reservedOpNames = ops, 18 | Tok.reservedNames = names, 19 | Tok.commentLine = "#"} 20 | 21 | reserved :: String -> Parser () 22 | reserved = Tok.reserved lexer 23 | 24 | reservedOp :: String -> Parser () 25 | reservedOp = Tok.reservedOp lexer 26 | 27 | identifier :: Parser String 28 | identifier = Tok.identifier lexer 29 | 30 | parens :: Parser a -> Parser a 31 | parens = Tok.parens lexer 32 | 33 | contents :: Parser a -> Parser a 34 | contents p = do 35 | Tok.whiteSpace lexer 36 | r <- p 37 | eof 38 | return r 39 | 40 | natural :: Parser Integer 41 | natural = Tok.natural lexer 42 | 43 | variable :: Parser Expr 44 | variable = do 45 | x <- identifier 46 | return (Var x) 47 | 48 | number :: Parser Expr 49 | number = do 50 | n <- natural 51 | return (Lit (LInt (fromIntegral n))) 52 | 53 | lambda :: Parser Expr 54 | lambda = do 55 | reservedOp "\\" 56 | args <- many1 identifier 57 | reservedOp "." 58 | body <- expr 59 | return $ foldr Lam body args 60 | 61 | term :: Parser Expr 62 | term = parens expr 63 | <|> variable 64 | <|> number 65 | <|> lambda 66 | 67 | expr :: Parser Expr 68 | expr = do 69 | es <- many1 term 70 | return (foldl1 App es) 71 | 72 | parseExpr :: String -> Either ParseError Expr 73 | parseExpr input = parse (contents expr) "" input 74 | -------------------------------------------------------------------------------- /chapter4/untyped/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Pretty ( 5 | ppexpr 6 | ) where 7 | 8 | import Syntax 9 | 10 | import Text.PrettyPrint 11 | 12 | class Pretty p where 13 | ppr :: Int -> p -> Doc 14 | 15 | parensIf :: Bool -> Doc -> Doc 16 | parensIf True = parens 17 | parensIf False = id 18 | 19 | instance Pretty Name where 20 | ppr _ x = text x 21 | 22 | instance Pretty Expr where 23 | ppr _ (Var x) = text x 24 | ppr _ (Lit (LInt a)) = text (show a) 25 | ppr _ (Lit (LBool b)) = text (show b) 26 | ppr p e@(App _ _) = parensIf (p>0) (ppr p f <+> sep (map (ppr (p+1)) xs)) 27 | where (f, xs) = viewApp e 28 | ppr p e@(Lam _ _) = parensIf (p>0) $ char '\\' <> hsep vars <+> text "." <+> body 29 | where 30 | vars = map (ppr 0) (viewVars e) 31 | body = ppr (p+1) (viewBody e) 32 | 33 | viewVars :: Expr -> [Name] 34 | viewVars (Lam n a) = n : viewVars a 35 | viewVars _ = [] 36 | 37 | viewBody :: Expr -> Expr 38 | viewBody (Lam _ a) = viewBody a 39 | viewBody x = x 40 | 41 | viewApp :: Expr -> (Expr, [Expr]) 42 | viewApp (App e1 e2) = go e1 [e2] 43 | where 44 | go (App a b) xs = go a (b : xs) 45 | go f xs = (f, xs) 46 | viewApp _ = error "not application" 47 | 48 | ppexpr :: Expr -> String 49 | ppexpr = render . ppr 0 50 | -------------------------------------------------------------------------------- /chapter4/untyped/README.md: -------------------------------------------------------------------------------- 1 | Untyped Lambda Calculus 2 | ======================= 3 | 4 | Untyped lambda calculus. 5 | 6 | To compile and run: 7 | 8 | ```shell 9 | $ cabal run 10 | ``` 11 | 12 | Example 13 | ------- 14 | 15 | ```bash 16 | Untyped> (\x. x) 1 17 | => \x . x 18 | => 1 19 | => x 20 | 1 21 | ``` 22 | 23 | License 24 | ======= 25 | 26 | Released under MIT license. 27 | -------------------------------------------------------------------------------- /chapter4/untyped/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter4/untyped/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | type Name = String 4 | 5 | data Expr 6 | = Var Name 7 | | Lit Lit 8 | | App Expr Expr 9 | | Lam Name Expr 10 | deriving (Eq, Show) 11 | 12 | data Lit 13 | = LInt Int 14 | | LBool Bool 15 | deriving (Show, Eq, Ord) 16 | -------------------------------------------------------------------------------- /chapter4/untyped/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: ghc-7.8.4 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | - mtl-2.1.3.1 13 | - parsec-3.1.9 14 | - text-1.2.1.3 15 | 16 | # Override default flag values for local packages and extra-deps 17 | flags: 18 | text: 19 | integer-simple: false 20 | 21 | # Extra package databases containing global packages 22 | extra-package-dbs: [] 23 | 24 | # Control whether we use the GHC we find on the path 25 | # system-ghc: true 26 | 27 | # Require a specific version of stack, using version ranges 28 | # require-stack-version: -any # Default 29 | # require-stack-version: >= 0.1.4.0 30 | 31 | # Override the architecture used by stack, especially useful on Windows 32 | # arch: i386 33 | # arch: x86_64 34 | 35 | # Extra directories used by stack for building 36 | # extra-include-dirs: [/path/to/dir] 37 | # extra-lib-dirs: [/path/to/dir] 38 | -------------------------------------------------------------------------------- /chapter4/untyped/untyped.cabal: -------------------------------------------------------------------------------- 1 | name: untyped 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable untyped 12 | build-depends: 13 | base >= 4.6 && <4.8 14 | , pretty >= 1.1 && <1.2 15 | , parsec >= 3.1 && <3.2 16 | , containers >= 0.5 && <0.6 17 | , haskeline >= 0.7 18 | , mtl 19 | , transformers 20 | default-language: Haskell2010 21 | main-is: Main.hs 22 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Check.hs: -------------------------------------------------------------------------------- 1 | module Check ( 2 | check 3 | ) where 4 | 5 | import Type 6 | import Syntax 7 | import Pretty 8 | 9 | import Control.Monad.Except 10 | 11 | data TypeError 12 | = TypeMismatch Type Type 13 | 14 | instance Show TypeError where 15 | show (TypeMismatch a b) = "Type Mismatch: " ++ pptype a ++ " is not " ++ pptype b 16 | 17 | type Check a = Except TypeError a 18 | 19 | typeof :: Expr -> Check Type 20 | typeof expr = case expr of 21 | Tr -> return TBool 22 | Fl -> return TBool 23 | Zero -> return TNat 24 | 25 | Succ a -> do 26 | ta <- typeof a 27 | case ta of 28 | TNat -> return TNat 29 | _ -> throwError $ TypeMismatch ta TNat 30 | 31 | Pred a -> do 32 | ta <- typeof a 33 | case ta of 34 | TNat -> return TNat 35 | _ -> throwError $ TypeMismatch ta TNat 36 | 37 | IsZero a -> do 38 | ta <- typeof a 39 | case ta of 40 | TNat -> return TBool 41 | _ -> throwError $ TypeMismatch ta TNat 42 | 43 | If a b c -> do 44 | ta <- typeof a 45 | tb <- typeof b 46 | tc <- typeof c 47 | if ta /= TBool 48 | then throwError $ TypeMismatch ta TBool 49 | else 50 | if tb /= tc 51 | then throwError $ TypeMismatch tb tc 52 | else return tc 53 | 54 | check :: Expr -> Either TypeError Type 55 | check = runExcept . typeof 56 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval ( 2 | eval 3 | ) where 4 | 5 | import Syntax 6 | 7 | import Data.Maybe 8 | import Data.Functor 9 | 10 | -- Evaluate a single step. 11 | eval1 :: Expr -> Maybe Expr 12 | eval1 expr = case expr of 13 | IsZero Zero -> Just Tr 14 | IsZero (Succ t) | isNum t -> Just Fl 15 | IsZero t -> IsZero <$> (eval1 t) 16 | Succ t -> Succ <$> (eval1 t) 17 | Pred Zero -> Just Zero 18 | Pred (Succ t) | isNum t -> Just t 19 | Pred t -> Pred <$> (eval1 t) 20 | If Tr c _ -> Just c 21 | If Fl _ a -> Just a 22 | If t c a -> (\t' -> If t' c a) <$> eval1 t 23 | _ -> Nothing 24 | 25 | isNum :: Expr -> Bool 26 | isNum Zero = True 27 | isNum (Succ t) = isNum t 28 | isNum _ = False 29 | 30 | isVal :: Expr -> Bool 31 | isVal Tr = True 32 | isVal Fl = True 33 | isVal t | isNum t = True 34 | isVal _ = False 35 | 36 | nf :: Expr -> Expr 37 | nf t = fromMaybe t (nf <$> eval1 t) 38 | 39 | eval :: Expr -> Maybe Expr 40 | eval t = case isVal (nf t) of 41 | True -> Just (nf t) 42 | False -> Nothing -- term is "stuck" 43 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Eval 4 | import Type 5 | import Check 6 | import Parser 7 | import Pretty 8 | import Syntax 9 | 10 | import Data.Maybe 11 | 12 | import Control.Monad.Trans 13 | import System.Console.Haskeline 14 | 15 | eval' :: Expr -> Expr 16 | eval' = fromJust . eval 17 | 18 | process :: String -> IO () 19 | process line = do 20 | let res = parseExpr line 21 | case res of 22 | Left err -> print err 23 | Right ex -> do 24 | let chk = check ex 25 | case chk of 26 | Left err -> print err 27 | Right ty -> putStrLn $ (ppexpr $ eval' ex) ++ " : " ++ (pptype ty) 28 | 29 | main :: IO () 30 | main = runInputT defaultSettings loop 31 | where 32 | loop = do 33 | minput <- getInputLine "Arith> " 34 | case minput of 35 | Nothing -> outputStrLn "Goodbye." 36 | Just input -> (liftIO $ process input) >> loop 37 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( 2 | parseExpr 3 | ) where 4 | 5 | import Syntax 6 | 7 | import Text.Parsec 8 | import Text.Parsec.String (Parser) 9 | import Text.Parsec.Language (emptyDef) 10 | 11 | import qualified Text.Parsec.Expr as Ex 12 | import qualified Text.Parsec.Token as Tok 13 | 14 | import Data.Functor.Identity 15 | 16 | lexer :: Tok.TokenParser () 17 | lexer = Tok.makeTokenParser emptyDef 18 | 19 | parens :: Parser a -> Parser a 20 | parens = Tok.parens lexer 21 | 22 | reserved :: String -> Parser () 23 | reserved = Tok.reserved lexer 24 | 25 | semiSep :: Parser a -> Parser [a] 26 | semiSep = Tok.semiSep lexer 27 | 28 | reservedOp :: String -> Parser () 29 | reservedOp = Tok.reservedOp lexer 30 | 31 | infixOp :: String -> (a -> a) -> Ex.Operator String () Identity a 32 | infixOp s f = Ex.Prefix (reservedOp s >> return f) 33 | 34 | table :: Ex.OperatorTable String () Identity Expr 35 | table = [ 36 | [ 37 | infixOp "succ" Succ 38 | , infixOp "pred" Pred 39 | , infixOp "iszero" IsZero 40 | ] 41 | ] 42 | 43 | expr :: Parser Expr 44 | expr = Ex.buildExpressionParser table factor 45 | 46 | ifthen :: Parser Expr 47 | ifthen = do 48 | reserved "if" 49 | cond <- expr 50 | reservedOp "then" 51 | tr <- expr 52 | reserved "else" 53 | fl <- expr 54 | return (If cond tr fl) 55 | 56 | true, false, zero :: Parser Expr 57 | true = reserved "true" >> return Tr 58 | false = reserved "false" >> return Fl 59 | zero = reservedOp "0" >> return Zero 60 | 61 | factor :: Parser Expr 62 | factor = 63 | true 64 | <|> false 65 | <|> zero 66 | <|> ifthen 67 | <|> parens expr 68 | 69 | contents :: Parser a -> Parser a 70 | contents p = do 71 | Tok.whiteSpace lexer 72 | r <- p 73 | eof 74 | return r 75 | 76 | toplevel :: Parser [Expr] 77 | toplevel = semiSep expr 78 | 79 | parseExpr :: String -> Either ParseError Expr 80 | parseExpr s = parse (contents expr) "" s 81 | 82 | parseToplevel :: String -> Either ParseError [Expr] 83 | parseToplevel s = parse (contents toplevel) "" s 84 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Pretty ( 2 | ppexpr, 3 | pptype 4 | ) where 5 | 6 | import Syntax 7 | import Type 8 | 9 | import Text.PrettyPrint (Doc, (<>), (<+>)) 10 | import qualified Text.PrettyPrint as PP 11 | 12 | parensIf :: Bool -> Doc -> Doc 13 | parensIf True = PP.parens 14 | parensIf False = id 15 | 16 | class Pretty p where 17 | ppr :: Int -> p -> Doc 18 | 19 | instance Pretty Expr where 20 | ppr p expr = case expr of 21 | Zero -> PP.text "0" 22 | Tr -> PP.text "true" 23 | Fl -> PP.text "false" 24 | Succ a -> (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a) 25 | Pred a -> (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a) 26 | IsZero a -> (parensIf (p > 0) $ PP.text "iszero" <+> ppr (p+1) a) 27 | If a b c -> 28 | PP.text "if" <+> ppr p a 29 | <+> PP.text "then" <+> ppr p b 30 | <+> PP.text "else" <+> ppr p c 31 | 32 | instance Pretty Type where 33 | ppr _ TNat = PP.text "Nat" 34 | ppr _ TBool = PP.text "Bool" 35 | 36 | ppexpr :: Expr -> String 37 | ppexpr = PP.render . ppr 0 38 | 39 | pptype :: Type -> String 40 | pptype = PP.render . ppr 0 41 | -------------------------------------------------------------------------------- /chapter5/calc_typed/README.md: -------------------------------------------------------------------------------- 1 | Arith 2 | ====== 3 | 4 | A typed arithmetic. 5 | 6 | To compile and run: 7 | 8 | ```shell 9 | $ cabal run 10 | ``` 11 | 12 | Usage: 13 | 14 | ```ocaml 15 | Arith> succ 0 16 | succ 0 : Nat 17 | 18 | Arith> succ (succ 0) 19 | succ (succ 0) : Nat 20 | 21 | Arith> if false then true else false 22 | false : Bool 23 | 24 | Arith> iszero (pred (succ (succ 0))) 25 | false : Bool 26 | 27 | Arith> pred (succ 0) 28 | 0 : Nat 29 | 30 | Arith> iszero false 31 | Type Mismatch: Bool is not Nat 32 | 33 | Arith> if 0 then true else false 34 | Type Mismatch: Nat is not Bool 35 | ``` 36 | 37 | License 38 | ======= 39 | 40 | Released under MIT license. 41 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | data Expr 4 | = Tr 5 | | Fl 6 | | Zero 7 | | IsZero Expr 8 | | Succ Expr 9 | | Pred Expr 10 | | If Expr Expr Expr 11 | deriving (Eq, Show) 12 | -------------------------------------------------------------------------------- /chapter5/calc_typed/Type.hs: -------------------------------------------------------------------------------- 1 | module Type where 2 | 3 | data Type 4 | = TBool 5 | | TNat 6 | deriving (Eq, Show) 7 | -------------------------------------------------------------------------------- /chapter5/calc_typed/arith.cabal: -------------------------------------------------------------------------------- 1 | name: arith 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable calc 12 | other-extensions: GADTs 13 | build-depends: base >=4.6 && <4.7, pretty >=1.1 && <1.2, parsec >=3.1 && <3.2 14 | default-language: Haskell2010 15 | main-is: Main.hs 16 | -------------------------------------------------------------------------------- /chapter5/stlc/Check.hs: -------------------------------------------------------------------------------- 1 | module Check ( 2 | check, 3 | checkTop, 4 | TypeError(..) 5 | ) where 6 | 7 | import Syntax 8 | import Control.Monad.Except 9 | import Control.Monad.Reader 10 | 11 | type Env = [(Name, Type)] 12 | 13 | extend :: (Name, Type) -> Env -> Env 14 | extend xt env = xt : env 15 | 16 | data TypeError 17 | = Mismatch Type Type 18 | | NotFunction Type 19 | | NotInScope Name 20 | 21 | type Check = ExceptT TypeError (Reader Env) 22 | 23 | inEnv :: (Name, Type) -> Check a -> Check a 24 | inEnv (x,t) = local (extend (x,t)) 25 | 26 | lookupVar :: Name -> Check Type 27 | lookupVar x = do 28 | env <- ask 29 | case lookup x env of 30 | Just e -> return e 31 | Nothing -> throwError $ NotInScope x 32 | 33 | check :: Expr -> Check Type 34 | check expr = case expr of 35 | 36 | Lit LInt{} -> return TInt 37 | 38 | Lit LBool{} -> return TBool 39 | 40 | Lam x t e -> do 41 | rhs <- inEnv (x,t) (check e) 42 | return (TArr t rhs) 43 | 44 | App e1 e2 -> do 45 | t1 <- check e1 46 | t2 <- check e2 47 | case t1 of 48 | (TArr a b) | a == t2 -> return b 49 | | otherwise -> throwError $ Mismatch t2 a 50 | ty -> throwError $ NotFunction ty 51 | 52 | Var x -> lookupVar x 53 | 54 | runCheck :: Env -> Check a -> Either TypeError a 55 | runCheck env = flip runReader env . runExceptT 56 | 57 | checkTop :: Env -> Expr -> Either TypeError Type 58 | checkTop env x = runCheck env $ (check x) 59 | -------------------------------------------------------------------------------- /chapter5/stlc/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval where 2 | 3 | import Syntax 4 | 5 | import Control.Monad.Identity 6 | import qualified Data.Map as Map 7 | 8 | data Value 9 | = VInt Integer 10 | | VBool Bool 11 | | VClosure String Expr (Eval.Scope) 12 | 13 | instance Show Value where 14 | show (VInt x) = show x 15 | show (VBool x) = show x 16 | show VClosure{} = "<>" 17 | 18 | type Evaluate t = Identity t 19 | type Scope = Map.Map String Value 20 | 21 | eval :: Eval.Scope -> Expr -> Identity Value 22 | eval env expr = case expr of 23 | 24 | Lit (LInt x) -> return $ VInt (fromIntegral x) 25 | 26 | Lit (LBool x) -> return $ VBool x 27 | 28 | Var x -> return $ env Map.! x 29 | 30 | Lam x _ body -> return (VClosure x body env) 31 | 32 | App a b -> do 33 | x <- eval env a 34 | y <- eval env b 35 | apply x y 36 | 37 | extend :: Scope -> String -> Value -> Scope 38 | extend env v t = Map.insert v t env 39 | 40 | apply :: Value -> Value -> Evaluate Value 41 | apply (VClosure v t0 e) t1 = eval (extend e v t1) t0 42 | apply _ _ = error "Tried to apply closure" 43 | 44 | emptyScope :: Scope 45 | emptyScope = Map.empty 46 | 47 | runEval :: Expr -> Value 48 | runEval x = runIdentity (eval emptyScope x) 49 | -------------------------------------------------------------------------------- /chapter5/stlc/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer where 2 | 3 | import Text.Parsec 4 | import Text.Parsec.String 5 | import qualified Text.Parsec.Token as Tok 6 | import Text.Parsec.Language (haskellStyle) 7 | 8 | lexer :: Tok.TokenParser () 9 | lexer = Tok.makeTokenParser style 10 | where ops = ["->","\\","+","*","-","="] 11 | names = ["True", "False"] 12 | style = haskellStyle {Tok.reservedOpNames = ops, 13 | Tok.reservedNames = names, 14 | Tok.commentLine = "#"} 15 | 16 | reserved :: String -> Parser () 17 | reserved = Tok.reserved lexer 18 | 19 | reservedOp :: String -> Parser () 20 | reservedOp = Tok.reservedOp lexer 21 | 22 | identifier :: Parser String 23 | identifier = Tok.identifier lexer 24 | 25 | parens :: Parser a -> Parser a 26 | parens = Tok.parens lexer 27 | 28 | contents :: Parser a -> Parser a 29 | contents p = do 30 | Tok.whiteSpace lexer 31 | r <- p 32 | eof 33 | return r 34 | 35 | natural :: Parser Integer 36 | natural = Tok.natural lexer 37 | -------------------------------------------------------------------------------- /chapter5/stlc/Main.hs: -------------------------------------------------------------------------------- 1 | import Syntax 2 | import Parser 3 | import Check 4 | import Eval 5 | import Pretty 6 | 7 | import Control.Monad.Trans 8 | import System.Console.Haskeline 9 | 10 | process :: String -> IO () 11 | process line = do 12 | let res = parseExpr line 13 | case res of 14 | Left err -> print err 15 | Right ex -> do 16 | let chk = checkTop [] ex 17 | case chk of 18 | Left tyerr -> print tyerr 19 | Right _ -> print $ runEval ex 20 | 21 | main :: IO () 22 | main = runInputT defaultSettings loop 23 | where 24 | loop = do 25 | minput <- getInputLine "Happy> " 26 | case minput of 27 | Nothing -> outputStrLn "Goodbye." 28 | Just input -> (liftIO $ process input) >> loop 29 | -------------------------------------------------------------------------------- /chapter5/stlc/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( 2 | parseExpr 3 | ) where 4 | 5 | import Text.Parsec 6 | import Text.Parsec.String (Parser) 7 | 8 | import qualified Text.Parsec.Expr as Ex 9 | 10 | import Lexer 11 | import Syntax 12 | 13 | ------------------------------------------------------------------------------- 14 | -- Expression 15 | ------------------------------------------------------------------------------- 16 | 17 | variable :: Parser Expr 18 | variable = do 19 | x <- identifier 20 | return (Var x) 21 | 22 | number :: Parser Expr 23 | number = do 24 | n <- natural 25 | return (Lit (LInt (fromIntegral n))) 26 | 27 | lambda :: Parser Expr 28 | lambda = do 29 | reservedOp "\\" 30 | x <- identifier 31 | reservedOp ":" 32 | t <- type' 33 | reservedOp "." 34 | e <- expr 35 | return (Lam x t e) 36 | 37 | bool :: Parser Expr 38 | bool = (reserved "True" >> return (Lit (LBool True))) 39 | <|> (reserved "False" >> return (Lit (LBool False))) 40 | 41 | term :: Parser Expr 42 | term = parens expr 43 | <|> bool 44 | <|> number 45 | <|> variable 46 | <|> lambda 47 | 48 | expr :: Parser Expr 49 | expr = do 50 | es <- many1 term 51 | return (foldl1 App es) 52 | 53 | ------------------------------------------------------------------------------- 54 | -- Types 55 | ------------------------------------------------------------------------------- 56 | 57 | tyatom :: Parser Type 58 | tyatom = tylit <|> (parens type') 59 | 60 | tylit :: Parser Type 61 | tylit = (reservedOp "Bool" >> return TBool) <|> (reservedOp "Int" >> return TInt) 62 | 63 | type' :: Parser Type 64 | type' = Ex.buildExpressionParser tyops tyatom 65 | where 66 | infixOp x f = Ex.Infix (reservedOp x >> return f) 67 | tyops = [ 68 | [infixOp "->" TArr Ex.AssocRight] 69 | ] 70 | 71 | ------------------------------------------------------------------------------- 72 | -- Toplevel 73 | ------------------------------------------------------------------------------- 74 | 75 | parseExpr :: String -> Either ParseError Expr 76 | parseExpr input = parse (contents expr) "" input 77 | -------------------------------------------------------------------------------- /chapter5/stlc/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Pretty ( 2 | ppexpr, 3 | pptype 4 | ) where 5 | 6 | import Syntax 7 | import Check 8 | 9 | import Text.PrettyPrint 10 | 11 | class Pretty p where 12 | ppr :: Int -> p -> Doc 13 | 14 | pp :: p -> Doc 15 | pp = ppr 0 16 | 17 | parensIf :: Bool -> Doc -> Doc 18 | parensIf True = parens 19 | parensIf False = id 20 | 21 | instance Pretty Expr where 22 | ppr p ex = case ex of 23 | Var x -> text x 24 | Lit (LInt a) -> text (show a) 25 | Lit (LBool b) -> text (show b) 26 | App a b -> (parensIf (p>0) (ppr (p+1) a)) <+> (ppr p b) 27 | Lam x t a -> parensIf (p > 0) $ 28 | char '\\' 29 | <+> parens (text x <+> char ':' <+> ppr p t) 30 | <+> text "->" 31 | <+> ppr (p+1) a 32 | 33 | instance Pretty Type where 34 | ppr _ TInt = text "Int" 35 | ppr _ TBool = text "Bool" 36 | ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b 37 | where 38 | isArrow TArr{} = True 39 | isArrow _ = False 40 | 41 | instance Show TypeError where 42 | show (Mismatch a b) = 43 | "Expecting " ++ (pptype b) ++ " but got " ++ (pptype a) 44 | show (NotFunction a) = 45 | "Tried to apply to non-function type: " ++ (pptype a) 46 | show (NotInScope a) = 47 | "Variable " ++ a ++ " is not in scope" 48 | 49 | ppexpr :: Expr -> String 50 | ppexpr = render . ppr 0 51 | 52 | pptype :: Type -> String 53 | pptype = render . ppr 0 54 | -------------------------------------------------------------------------------- /chapter5/stlc/README.md: -------------------------------------------------------------------------------- 1 | Simply Typed Lambda Calculus 2 | ============================ 3 | 4 | Simply typed lambda calculus. 5 | 6 | To compile and run: 7 | 8 | ```shell 9 | $ cabal run 10 | ``` 11 | 12 | Usage: 13 | 14 | ```haskell 15 | ./stlc 16 | Stlc> (\x : Int . \y : Int . y) 1 2 17 | 2 18 | 19 | Stlc> (\x : (Int -> Int). x) (\x : Int . 1) 2 20 | 1 21 | 22 | Stlc> (\x : Int . x) False 23 | Couldn't match expected type 'Int' with actual type: 'Bool' 24 | 25 | Stlc> (\x : Int . (\y : Int . x)) 26 | <> 27 | ``` 28 | 29 | License 30 | ======= 31 | 32 | Released under MIT license. 33 | -------------------------------------------------------------------------------- /chapter5/stlc/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /chapter5/stlc/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | type Name = String 4 | 5 | data Expr 6 | = Var Name 7 | | Lit Ground 8 | | App Expr Expr 9 | | Lam Name Type Expr 10 | deriving (Eq, Show) 11 | 12 | data Ground 13 | = LInt Int 14 | | LBool Bool 15 | deriving (Show, Eq, Ord) 16 | 17 | data Type 18 | = TInt 19 | | TBool 20 | | TArr Type Type 21 | deriving (Eq, Read, Show) 22 | -------------------------------------------------------------------------------- /chapter5/stlc/stlc.cabal: -------------------------------------------------------------------------------- 1 | name: stlc 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable stlc 12 | build-depends: 13 | base >= 4.6 && <4.7 14 | , pretty >= 1.1 && <1.2 15 | , parsec >= 3.1 && <3.2 16 | , containers >= 0.5 && <0.6 17 | , haskeline >= 0.7 18 | , mtl 19 | , transformers 20 | default-language: Haskell2010 21 | main-is: Main.hs 22 | -------------------------------------------------------------------------------- /chapter6/hoas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | data Expr a where 4 | Lift :: a -> Expr a 5 | Tup :: Expr a -> Expr b -> Expr (a, b) 6 | Lam :: (Expr a -> Expr b) -> Expr (a -> b) 7 | App :: Expr (a -> b) -> Expr a -> Expr b 8 | Fix :: Expr (a -> a) -> Expr a 9 | 10 | eval :: Expr a -> a 11 | eval (Lift v) = v 12 | eval (Tup e1 e2) = (eval e1, eval e2) 13 | eval (Lam f) = \x -> eval (f (Lift x)) 14 | eval (App e1 e2) = (eval e1) (eval e2) 15 | eval (Fix f) = (eval f) (eval (Fix f)) 16 | 17 | fact :: Expr (Integer -> Integer) 18 | fact = 19 | Fix ( 20 | Lam (\f -> 21 | Lam (\y -> 22 | Lift ( 23 | if eval y == 0 24 | then 1 25 | else eval y * (eval f) (eval y - 1))))) 26 | 27 | test :: Integer 28 | test = eval fact 10 29 | 30 | main :: IO () 31 | main = print test 32 | -------------------------------------------------------------------------------- /chapter6/interp.hs: -------------------------------------------------------------------------------- 1 | -- Traditional call-by-value interpreter. 2 | 3 | data Expr 4 | = Var Int 5 | | Lam Expr 6 | | App Expr Expr 7 | | Lit Int 8 | | Prim PrimOp Expr Expr 9 | deriving Show 10 | 11 | data Value 12 | = VInt Int 13 | | VClosure Expr Env 14 | deriving Show 15 | 16 | data PrimOp = Add | Mul 17 | deriving Show 18 | 19 | type Env = [Value] 20 | 21 | eval :: Env -> Expr -> Value 22 | eval env term = case term of 23 | Var n -> env !! n 24 | Lam a -> VClosure a env 25 | App a b -> 26 | let VClosure c env' = eval env a in 27 | let v = eval env b in 28 | eval (v : env') c 29 | 30 | Lit n -> VInt n 31 | Prim p a b -> (evalPrim p) (eval env a) (eval env b) 32 | 33 | evalPrim :: PrimOp -> Value -> Value -> Value 34 | evalPrim Add (VInt a) (VInt b) = VInt (a + b) 35 | evalPrim Mul (VInt a) (VInt b) = VInt (a + b) 36 | 37 | emptyEnv :: Env 38 | emptyEnv = [] 39 | 40 | -- (\x y -> x + y) 10 20 41 | test :: Value 42 | test = eval emptyEnv $ App (App (Lam (Lam (Prim Add (Var 0) (Var 1)))) (Lit 10)) (Lit 20) 43 | -------------------------------------------------------------------------------- /chapter6/io.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | import Control.Monad 4 | 5 | type Name = String 6 | 7 | data ExprP a 8 | = VarP a 9 | | GlobalP Name 10 | | AppP (ExprP a) (ExprP a) 11 | | LamP (a -> ExprP a) 12 | | LitP Char 13 | | EffectP a 14 | 15 | data Value 16 | = VChar Char 17 | | VFun (Value -> Value) 18 | | VEffect (IO Value) 19 | | VUnit 20 | 21 | instance Show Value where 22 | show (VChar x) = show x 23 | show (VUnit) = "()" 24 | show (VFun _) = "<>" 25 | show (VEffect {}) = "<>" 26 | 27 | newtype Expr = Expr { unExpr :: forall a . ExprP a } 28 | 29 | fromVFun :: Value -> (Value -> Value) 30 | fromVFun val = case val of 31 | VFun f -> f 32 | _ -> error "not a function" 33 | 34 | fromVChar :: Value -> Char 35 | fromVChar val = case val of 36 | VChar n -> n 37 | _ -> error "not a char" 38 | 39 | fromVEff :: Value -> (IO Value) 40 | fromVEff val = case val of 41 | VEffect f -> f 42 | _ -> error "not an effect" 43 | 44 | lam :: (Value -> Value) -> Value 45 | lam = VFun 46 | 47 | unary :: (Value -> Value) -> Value 48 | unary f = lam $ \a -> f a 49 | 50 | binary :: (Value -> Value -> Value) -> Value 51 | binary f = lam $ \a -> 52 | lam $ \b -> f a b 53 | 54 | prim :: Name -> Value 55 | prim op = case op of 56 | "putChar#" -> unary $ \x -> 57 | VEffect $ do 58 | putChar (fromVChar x) 59 | return VUnit 60 | 61 | "getChar#" -> VEffect $ do 62 | val <- getChar 63 | return (VChar val) 64 | 65 | "bindIO#" -> binary $ \x y -> bindIO x y 66 | "returnIO#" -> unary $ \x -> returnIO x 67 | "thenIO#" -> binary $ \x y -> thenIO x y 68 | 69 | bindIO :: Value -> Value -> Value 70 | bindIO (VEffect f) (VFun g) = VEffect (f >>= fromVEff . g) 71 | 72 | thenIO :: Value -> Value -> Value 73 | thenIO (VEffect f) (VEffect g) = VEffect (f >> g) 74 | 75 | returnIO :: Value -> Value 76 | returnIO a = VEffect $ return a 77 | 78 | eval :: Expr -> Value 79 | eval e = ev (unExpr e) where 80 | ev (LamP f) = VFun(ev . f) 81 | ev (AppP e1 e2) = fromVFun (ev e1) (ev e2) 82 | ev (LitP n) = VChar n 83 | ev (EffectP v) = v 84 | ev (VarP v) = v 85 | ev (GlobalP op) = prim op 86 | 87 | gets, puts, bind, seqn :: ExprP a 88 | gets = GlobalP "getChar#" 89 | puts = GlobalP "putChar#" 90 | bind = GlobalP "bindIO#" 91 | seqn = GlobalP "thenIO#" 92 | 93 | run :: Expr -> IO () 94 | run f = void (fromVEff (eval f)) 95 | 96 | 97 | example1 :: IO () 98 | example1 = run $ Expr (AppP (AppP bind gets) puts) 99 | 100 | example2 :: IO () 101 | example2 = run $ Expr $ foldr1 seq (str "Hello Haskell!\n") 102 | where 103 | seq a b = AppP (AppP seqn a) b 104 | str xs = fmap (\c -> AppP puts (LitP c)) xs 105 | -------------------------------------------------------------------------------- /chapter6/lazy.hs: -------------------------------------------------------------------------------- 1 | import Data.IORef 2 | 3 | data Expr 4 | = EVar String 5 | | ELam String Expr 6 | | EApp Expr Expr 7 | | EBool Bool 8 | | EInt Integer 9 | | EFix Expr 10 | deriving (Show) 11 | 12 | data Value 13 | = VBool Bool 14 | | VInt Integer 15 | | VClosure (Thunk -> IO Value) 16 | 17 | instance Show Value where 18 | show (VBool b) = show b 19 | show (VInt n) = show n 20 | show (VClosure _) = "<>" 21 | 22 | type Env = [(String, IORef Thunk)] 23 | 24 | type Thunk = () -> IO Value 25 | 26 | lookupEnv :: Env -> String -> IO (IORef Thunk) 27 | lookupEnv [] y = error $ "Unbound Variable" ++ y 28 | lookupEnv ((x, v) : xs) n = 29 | if x == n 30 | then return v 31 | else lookupEnv xs n 32 | 33 | force :: IORef Thunk -> IO Value 34 | force ref = do 35 | th <- readIORef ref 36 | v <- th () 37 | update ref v 38 | return v 39 | 40 | mkThunk :: Env -> String -> Expr -> (Thunk -> IO Value) 41 | mkThunk env x body = \a -> do 42 | a' <- newIORef a 43 | eval ((x, a') : env) body 44 | 45 | update :: IORef Thunk -> Value -> IO () 46 | update ref v = do 47 | writeIORef ref (\() -> return v) 48 | return () 49 | 50 | eval :: Env -> Expr -> IO Value 51 | eval env ex = case ex of 52 | EVar n -> do 53 | th <- lookupEnv env n 54 | v <- force th 55 | return v 56 | 57 | ELam x e -> return $ VClosure (mkThunk env x e) 58 | 59 | EApp a b -> do 60 | VClosure c <- eval env a 61 | c (\() -> eval env b) 62 | 63 | EBool b -> return $ VBool b 64 | EInt n -> return $ VInt n 65 | EFix e -> eval env (EApp e (EFix e)) 66 | 67 | -- Tests 68 | -- ----- 69 | 70 | -- diverge = fix (\x -> x x) 71 | diverge :: Expr 72 | diverge = EFix (ELam "x" (EApp (EVar "x") (EVar "x"))) 73 | 74 | -- ignore = \x -> 0 75 | ignore :: Expr 76 | ignore = ELam "x" (EInt 0) 77 | 78 | -- omega = (\x -> x x) (\x -> x x) 79 | omega :: Expr 80 | omega = EApp (ELam "x" (EApp (EVar "x") (EVar "x"))) 81 | (ELam "x" (EApp (EVar "x") (EVar "x"))) 82 | 83 | -- test1 = (\y -> 42) omega 84 | test1 :: IO Value 85 | test1 = eval [] $ EApp (ELam "y" (EInt 42)) omega 86 | 87 | -- test2 = (\y -> 0) diverge 88 | test2 :: IO Value 89 | test2 = eval [] $ EApp ignore diverge 90 | 91 | main = return () 92 | -------------------------------------------------------------------------------- /chapter6/phoas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | data ExprP a 4 | = VarP a 5 | | AppP (ExprP a) (ExprP a) 6 | | LamP (a -> ExprP a) 7 | | LitP Integer 8 | 9 | data Value 10 | = VLit Integer 11 | | VFun (Value -> Value) 12 | 13 | fromVFun :: Value -> (Value -> Value) 14 | fromVFun val = case val of 15 | VFun f -> f 16 | _ -> error "not a function" 17 | 18 | fromVLit :: Value -> Integer 19 | fromVLit val = case val of 20 | VLit n -> n 21 | _ -> error "not an integer" 22 | 23 | eval :: Expr -> Value 24 | eval e = ev (unExpr e) where 25 | ev (LamP f) = VFun(ev . f) 26 | ev (VarP v) = v 27 | ev (AppP e1 e2) = fromVFun (ev e1) (ev e2) 28 | ev (LitP n) = VLit n 29 | 30 | newtype Expr = Expr { unExpr :: forall a . ExprP a } 31 | 32 | i :: ExprP a 33 | i = LamP (\a -> VarP a) 34 | 35 | k :: ExprP a 36 | k = LamP (\x -> LamP (\y -> VarP x)) 37 | 38 | s :: ExprP a 39 | s = LamP (\x -> LamP (\y -> LamP (\z -> AppP (AppP (VarP x) (VarP z)) (AppP (VarP y) (VarP z))))) 40 | 41 | skk :: ExprP a 42 | skk = AppP (AppP s k) k 43 | 44 | example :: Integer 45 | example = fromVLit $ eval $ Expr (AppP skk (LitP 3)) 46 | -------------------------------------------------------------------------------- /chapter7/poly/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015, Stephen Diehl 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /chapter7/poly/README.md: -------------------------------------------------------------------------------- 1 | Poly 2 | ==== 3 | 4 | A simple ML dialect with definitions, let polymorphism and a fixpoint operator. 5 | Uses syntax directed HM type inference. 6 | 7 | To compile and run: 8 | 9 | ```shell 10 | $ cabal run 11 | ``` 12 | 13 | Usage: 14 | 15 | ```ocaml 16 | Poly> let i x = x; 17 | i : forall a. a -> a 18 | 19 | Poly> i 3 20 | 3 21 | 22 | Poly> :type i 23 | i : forall a. a -> a 24 | 25 | Poly> :type let k x y = x; 26 | k : forall a b. a -> b -> a 27 | 28 | Poly> :type let s f g x = f x (g x) 29 | s : forall a b c. ((a -> b) -> c -> a) -> (a -> b) -> c -> b 30 | 31 | Poly> :type let on g f = \x y -> g (f x) (f y) 32 | on : forall a b c. (a -> a -> b) -> (c -> a) -> c -> c -> b 33 | 34 | Poly> :type let let_bound = i (i i) (i 3) 35 | let_bound : Int 36 | 37 | Poly> :type let compose f g = \x -> f (g x) 38 | compose : forall a b c. (a -> b) -> (c -> a) -> c -> b 39 | 40 | Poly> let rec factorial n = 41 | if (n == 0) 42 | then 1 43 | else (n * (factorial (n-1))); 44 | ``` 45 | 46 | Notes 47 | ===== 48 | 49 | Top level let declarations are syntactic sugar for nested lambda. For example: 50 | 51 | ```ocaml 52 | let add x y = x + y; 53 | ``` 54 | 55 | Is semantically equivalent to: 56 | 57 | ```ocaml 58 | let add = \x -> \y -> x + y; 59 | ``` 60 | 61 | Top level Let-rec declarations are syntactic sugar for use of the ``fix`` 62 | operator. For example: 63 | 64 | ```ocaml 65 | let rec factorial n = if (n == 0) then 1 else (n * (factorial (n-1))); 66 | ``` 67 | Is semantically equivalent to: 68 | 69 | ```ocaml 70 | let factorial = fix (\factorial n -> if (n == 0) then 1 else (n * (factorial (n-1)))); 71 | ``` 72 | 73 | License 74 | ======= 75 | 76 | Released under MIT license. 77 | -------------------------------------------------------------------------------- /chapter7/poly/poly.cabal: -------------------------------------------------------------------------------- 1 | name: poly 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable poly 12 | build-depends: 13 | base >= 4.6 && <4.9 14 | , pretty >= 1.1 && <1.2 15 | , parsec >= 3.1 && <3.2 16 | , text >= 1.2 && <1.3 17 | , containers >= 0.5 && <0.6 18 | , mtl >= 2.2 && <2.3 19 | , transformers >= 0.4.2 && <0.5 20 | , repline >= 0.1.2.0 21 | 22 | other-modules: 23 | Eval 24 | Infer 25 | Lexer 26 | Parser 27 | Pretty 28 | Syntax 29 | Type 30 | 31 | default-language: Haskell2010 32 | hs-source-dirs: src 33 | main-is: Main.hs 34 | -------------------------------------------------------------------------------- /chapter7/poly/src/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval ( 2 | runEval, 3 | 4 | TermEnv, 5 | emptyTmenv 6 | ) where 7 | 8 | import Syntax 9 | 10 | import Control.Monad.Identity 11 | import qualified Data.Map as Map 12 | 13 | data Value 14 | = VInt Integer 15 | | VBool Bool 16 | | VClosure String Expr TermEnv 17 | 18 | type TermEnv = Map.Map String Value 19 | type Interpreter t = Identity t 20 | 21 | emptyTmenv :: TermEnv 22 | emptyTmenv = Map.empty 23 | 24 | instance Show Value where 25 | show (VInt n) = show n 26 | show (VBool n) = show n 27 | show VClosure{} = "<>" 28 | 29 | eval :: TermEnv -> Expr -> Interpreter Value 30 | eval env expr = case expr of 31 | Lit (LInt k) -> return $ VInt k 32 | Lit (LBool k) -> return $ VBool k 33 | 34 | Var x -> do 35 | let Just v = Map.lookup x env 36 | return v 37 | 38 | Op op a b -> do 39 | VInt a' <- eval env a 40 | VInt b' <- eval env b 41 | return $ (binop op) a' b' 42 | 43 | Lam x body -> 44 | return (VClosure x body env) 45 | 46 | App fun arg -> do 47 | VClosure x body clo <- eval env fun 48 | argv <- eval env arg 49 | let nenv = Map.insert x argv clo 50 | eval nenv body 51 | 52 | Let x e body -> do 53 | e' <- eval env e 54 | let nenv = Map.insert x e' env 55 | eval nenv body 56 | 57 | If cond tr fl -> do 58 | VBool br <- eval env cond 59 | if br == True 60 | then eval env tr 61 | else eval env fl 62 | 63 | Fix e -> do 64 | eval env (App e (Fix e)) 65 | 66 | binop :: Binop -> Integer -> Integer -> Value 67 | binop Add a b = VInt $ a + b 68 | binop Mul a b = VInt $ a * b 69 | binop Sub a b = VInt $ a - b 70 | binop Eql a b = VBool $ a == b 71 | 72 | runEval :: TermEnv -> String -> Expr -> (Value, TermEnv) 73 | runEval env nm ex = 74 | let res = runIdentity (eval env ex) in 75 | (res, Map.insert nm res env) 76 | -------------------------------------------------------------------------------- /chapter7/poly/src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer where 2 | 3 | import Text.Parsec 4 | import Text.Parsec.Text.Lazy 5 | import qualified Data.Text.Lazy as L 6 | import qualified Text.Parsec.Token as Tok 7 | import qualified Text.Parsec.Expr as Ex 8 | 9 | import Data.Functor.Identity 10 | 11 | type Op a = Ex.Operator L.Text () Identity a 12 | type Operators a = Ex.OperatorTable L.Text () Identity a 13 | 14 | reservedNames :: [String] 15 | reservedNames = [ 16 | "let", 17 | "in", 18 | "fix", 19 | "rec", 20 | "if", 21 | "then", 22 | "else" 23 | ] 24 | 25 | reservedOps :: [String] 26 | reservedOps = [ 27 | "->", 28 | "\\", 29 | "+", 30 | "*", 31 | "-", 32 | "=" 33 | ] 34 | 35 | lexer :: Tok.GenTokenParser L.Text () Identity 36 | lexer = Tok.makeTokenParser $ Tok.LanguageDef 37 | { Tok.commentStart = "{-" 38 | , Tok.commentEnd = "-}" 39 | , Tok.commentLine = "--" 40 | , Tok.nestedComments = True 41 | , Tok.identStart = letter 42 | , Tok.identLetter = alphaNum <|> oneOf "_'" 43 | , Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 44 | , Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 45 | , Tok.reservedNames = reservedNames 46 | , Tok.reservedOpNames = reservedOps 47 | , Tok.caseSensitive = True 48 | } 49 | 50 | reserved :: String -> Parser () 51 | reserved = Tok.reserved lexer 52 | 53 | reservedOp :: String -> Parser () 54 | reservedOp = Tok.reservedOp lexer 55 | 56 | identifier :: Parser String 57 | identifier = Tok.identifier lexer 58 | 59 | parens :: Parser a -> Parser a 60 | parens = Tok.parens lexer 61 | 62 | semiSep :: Parser a -> Parser [a] 63 | semiSep = Tok.semiSep lexer 64 | 65 | semi :: Parser String 66 | semi = Tok.semi lexer 67 | 68 | contents :: Parser a -> Parser a 69 | contents p = do 70 | Tok.whiteSpace lexer 71 | r <- p 72 | eof 73 | return r 74 | -------------------------------------------------------------------------------- /chapter7/poly/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | 8 | import Syntax 9 | import Infer 10 | import Parser 11 | import Pretty 12 | import Eval 13 | 14 | import Data.Monoid 15 | import qualified Data.Set as Set 16 | import qualified Data.Map as Map 17 | import qualified Data.Text.Lazy as L 18 | import qualified Data.Text.Lazy.IO as L 19 | import Data.List (isPrefixOf, foldl') 20 | 21 | import Control.Monad.State.Strict 22 | 23 | import System.Exit 24 | import System.Environment 25 | import System.Console.Repline 26 | 27 | ------------------------------------------------------------------------------- 28 | -- Types 29 | ------------------------------------------------------------------------------- 30 | 31 | data IState = IState 32 | { tyctx :: TypeEnv -- Type environment 33 | , tmctx :: TermEnv -- Value environment 34 | } 35 | 36 | initState :: IState 37 | initState = IState emptyTyenv emptyTmenv 38 | 39 | type Repl a = HaskelineT (StateT IState IO) a 40 | 41 | hoistErr :: Show e => Either e a -> Repl a 42 | hoistErr (Right val) = return val 43 | hoistErr (Left err) = do 44 | liftIO $ print err 45 | abort 46 | 47 | ------------------------------------------------------------------------------- 48 | -- Execution 49 | ------------------------------------------------------------------------------- 50 | 51 | evalDef :: TermEnv -> (String, Expr) -> TermEnv 52 | evalDef env (nm, ex) = tmctx' 53 | where (val, tmctx') = runEval env nm ex 54 | 55 | 56 | exec :: Bool -> L.Text -> Repl () 57 | exec update source = do 58 | -- Get the current interpreter state 59 | st <- get 60 | 61 | -- Parser ( returns AST ) 62 | mod <- hoistErr $ parseModule "" source 63 | 64 | -- Type Inference ( returns Typing Environment ) 65 | tyctx' <- hoistErr $ inferTop (tyctx st) mod 66 | 67 | -- Create the new environment 68 | let st' = st { tmctx = foldl' evalDef (tmctx st) mod 69 | , tyctx = tyctx' <> (tyctx st) 70 | } 71 | 72 | -- Update the interpreter state 73 | when update (put st') 74 | 75 | -- If a value is entered, print it. 76 | case lookup "it" mod of 77 | Nothing -> return () 78 | Just ex -> do 79 | let (val, _) = runEval (tmctx st') "it" ex 80 | showOutput (show val) st' 81 | 82 | showOutput :: String -> IState -> Repl () 83 | showOutput arg st = do 84 | case Infer.typeof (tyctx st) "it" of 85 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 86 | Nothing -> return () 87 | 88 | cmd :: String -> Repl () 89 | cmd source = exec True (L.pack source) 90 | 91 | ------------------------------------------------------------------------------- 92 | -- Commands 93 | ------------------------------------------------------------------------------- 94 | 95 | -- :browse command 96 | browse :: [String] -> Repl () 97 | browse _ = do 98 | st <- get 99 | liftIO $ mapM_ putStrLn $ filter (not . ('#' `elem`)) $ ppenv (tyctx st) 100 | 101 | -- :load command 102 | load :: [String] -> Repl () 103 | load args = do 104 | contents <- liftIO $ L.readFile (unwords args) 105 | exec True contents 106 | 107 | -- :type command 108 | typeof :: [String] -> Repl () 109 | typeof args = do 110 | st <- get 111 | let arg = unwords args 112 | case Infer.typeof (tyctx st) arg of 113 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 114 | Nothing -> exec False (L.pack arg) 115 | 116 | -- :quit command 117 | quit :: a -> Repl () 118 | quit _ = liftIO $ exitSuccess 119 | 120 | ------------------------------------------------------------------------------- 121 | -- Tab completion 122 | ------------------------------------------------------------------------------- 123 | 124 | -- Prefix tab completer 125 | defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] 126 | defaultMatcher = [ 127 | (":load" , fileCompleter) 128 | ] 129 | 130 | -- Default tab completer 131 | comp :: (Monad m, MonadState IState m) => WordCompleter m 132 | comp n = do 133 | let cmds = [":load", ":browse", ":quit", ":type"] 134 | TypeEnv ctx <- gets tyctx 135 | let defs = Map.keys ctx 136 | return $ filter (isPrefixOf n) (cmds ++ defs) 137 | 138 | options :: [(String, [String] -> Repl ())] 139 | options = [ 140 | ("load" , load) 141 | , ("browse" , browse) 142 | , ("quit" , quit) 143 | , ("type" , Main.typeof) 144 | ] 145 | 146 | completer :: CompleterStyle (StateT IState IO) 147 | completer = Prefix (wordCompleter comp) defaultMatcher 148 | 149 | ------------------------------------------------------------------------------- 150 | -- Shell 151 | ------------------------------------------------------------------------------- 152 | 153 | shell :: Repl a -> IO () 154 | shell pre 155 | = flip evalStateT initState 156 | $ evalRepl "Poly> " cmd options completer pre 157 | 158 | ------------------------------------------------------------------------------- 159 | -- Toplevel 160 | ------------------------------------------------------------------------------- 161 | 162 | main :: IO () 163 | main = do 164 | args <- getArgs 165 | case args of 166 | [] -> shell (return ()) 167 | [fname] -> shell (load [fname]) 168 | ["test", fname] -> shell (load [fname] >> browse [] >> quit ()) 169 | _ -> putStrLn "invalid arguments" 170 | -------------------------------------------------------------------------------- /chapter7/poly/src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Parser ( 4 | parseExpr, 5 | parseModule 6 | ) where 7 | 8 | import Text.Parsec 9 | import Text.Parsec.Text.Lazy (Parser) 10 | 11 | import qualified Text.Parsec.Expr as Ex 12 | import qualified Text.Parsec.Token as Tok 13 | 14 | import qualified Data.Text.Lazy as L 15 | 16 | import Lexer 17 | import Syntax 18 | 19 | integer :: Parser Integer 20 | integer = Tok.integer lexer 21 | 22 | variable :: Parser Expr 23 | variable = do 24 | x <- identifier 25 | return (Var x) 26 | 27 | number :: Parser Expr 28 | number = do 29 | n <- integer 30 | return (Lit (LInt (fromIntegral n))) 31 | 32 | bool :: Parser Expr 33 | bool = (reserved "True" >> return (Lit (LBool True))) 34 | <|> (reserved "False" >> return (Lit (LBool False))) 35 | 36 | fix :: Parser Expr 37 | fix = do 38 | reservedOp "fix" 39 | x <- expr 40 | return (Fix x) 41 | 42 | lambda :: Parser Expr 43 | lambda = do 44 | reservedOp "\\" 45 | args <- many identifier 46 | reservedOp "->" 47 | body <- expr 48 | return $ foldr Lam body args 49 | 50 | letin :: Parser Expr 51 | letin = do 52 | reserved "let" 53 | x <- identifier 54 | reservedOp "=" 55 | e1 <- expr 56 | reserved "in" 57 | e2 <- expr 58 | return (Let x e1 e2) 59 | 60 | letrecin :: Parser Expr 61 | letrecin = do 62 | reserved "let" 63 | reserved "rec" 64 | x <- identifier 65 | reservedOp "=" 66 | e1 <- expr 67 | reserved "in" 68 | e2 <- expr 69 | return (Let x e1 e2) 70 | 71 | ifthen :: Parser Expr 72 | ifthen = do 73 | reserved "if" 74 | cond <- expr 75 | reservedOp "then" 76 | tr <- expr 77 | reserved "else" 78 | fl <- expr 79 | return (If cond tr fl) 80 | 81 | aexp :: Parser Expr 82 | aexp = 83 | parens expr 84 | <|> bool 85 | <|> number 86 | <|> ifthen 87 | <|> fix 88 | <|> try letrecin 89 | <|> letin 90 | <|> lambda 91 | <|> variable 92 | 93 | term :: Parser Expr 94 | term = aexp >>= \x -> 95 | (many1 aexp >>= \xs -> return (foldl App x xs)) 96 | <|> return x 97 | 98 | infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a 99 | infixOp x f = Ex.Infix (reservedOp x >> return f) 100 | 101 | table :: Operators Expr 102 | table = [ 103 | [ 104 | infixOp "*" (Op Mul) Ex.AssocLeft 105 | ], 106 | [ 107 | infixOp "+" (Op Add) Ex.AssocLeft 108 | , infixOp "-" (Op Sub) Ex.AssocLeft 109 | ], 110 | [ 111 | infixOp "==" (Op Eql) Ex.AssocLeft 112 | ] 113 | ] 114 | 115 | expr :: Parser Expr 116 | expr = Ex.buildExpressionParser table term 117 | 118 | type Binding = (String, Expr) 119 | 120 | letdecl :: Parser Binding 121 | letdecl = do 122 | reserved "let" 123 | name <- identifier 124 | args <- many identifier 125 | reservedOp "=" 126 | body <- expr 127 | return $ (name, foldr Lam body args) 128 | 129 | letrecdecl :: Parser (String, Expr) 130 | letrecdecl = do 131 | reserved "let" 132 | reserved "rec" 133 | name <- identifier 134 | args <- many identifier 135 | reservedOp "=" 136 | body <- expr 137 | return $ (name, Fix $ foldr Lam body (name:args)) 138 | 139 | val :: Parser Binding 140 | val = do 141 | ex <- expr 142 | return ("it", ex) 143 | 144 | decl :: Parser Binding 145 | decl = try letrecdecl <|> letdecl <|> val 146 | 147 | top :: Parser Binding 148 | top = do 149 | x <- decl 150 | optional semi 151 | return x 152 | 153 | modl :: Parser [Binding] 154 | modl = many top 155 | 156 | parseExpr :: L.Text -> Either ParseError Expr 157 | parseExpr input = parse (contents expr) "" input 158 | 159 | parseModule :: FilePath -> L.Text -> Either ParseError [(String, Expr)] 160 | parseModule fname input = parse (contents modl) fname input 161 | -------------------------------------------------------------------------------- /chapter7/poly/src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language TypeSynonymInstances #-} 2 | {-# Language FlexibleInstances #-} 3 | 4 | module Pretty ( 5 | ppscheme, 6 | pptype, 7 | ppexpr, 8 | ppsignature, 9 | ppenv, 10 | ppdecl 11 | ) where 12 | 13 | import Type 14 | import Syntax 15 | import Infer 16 | 17 | import Text.PrettyPrint 18 | import qualified Data.Map as Map 19 | 20 | parensIf :: Bool -> Doc -> Doc 21 | parensIf True = parens 22 | parensIf False = id 23 | 24 | 25 | class Pretty p where 26 | ppr :: Int -> p -> Doc 27 | 28 | instance Pretty Var where 29 | ppr _ x = text x 30 | 31 | instance Pretty TVar where 32 | ppr _ (TV x) = text x 33 | 34 | instance Pretty Type where 35 | ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b 36 | where 37 | isArrow TArr{} = True 38 | isArrow _ = False 39 | ppr p (TVar a) = ppr p a 40 | ppr _ (TCon a) = text a 41 | 42 | instance Pretty Scheme where 43 | ppr p (Forall [] t) = ppr p t 44 | ppr p (Forall ts t) = text "forall" <+> hcat (punctuate space (fmap (ppr p) ts)) <> text "." <+> ppr p t 45 | 46 | instance Pretty Binop where 47 | ppr _ Add = text "+" 48 | ppr _ Sub = text "-" 49 | ppr _ Mul = text "-" 50 | ppr _ Eql = text "==" 51 | 52 | instance Pretty Expr where 53 | ppr p (Var a) = ppr p a 54 | ppr p (App a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b 55 | ppr p (Lam a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b 56 | ppr p (Let a b c) = text "let" <> ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c 57 | ppr p (Lit a) = ppr p a 58 | ppr p (Op o a b) = parensIf (p>0) $ ppr p a <+> ppr p o <+> ppr p b 59 | ppr p (Fix a) = parensIf (p>0) $ text "fix" <> ppr p a 60 | ppr p (If a b c) = 61 | text "if" <> ppr p a <+> 62 | text "then" <+> ppr p b <+> 63 | text "else" <+> ppr p c 64 | 65 | instance Pretty Lit where 66 | ppr _ (LInt i) = integer i 67 | ppr _ (LBool True) = text "True" 68 | ppr _ (LBool False) = text "False" 69 | 70 | instance Show TypeError where 71 | show (UnificationFail a b) = 72 | concat ["Cannot unify types: \n\t", pptype a, "\nwith \n\t", pptype b] 73 | show (InfiniteType (TV a) b) = 74 | concat ["Cannot construct the infinite type: ", a, " = ", pptype b] 75 | show (UnboundVariable a) = "Not in scope: " ++ a 76 | 77 | ppscheme :: Scheme -> String 78 | ppscheme = render . ppr 0 79 | 80 | pptype :: Type -> String 81 | pptype = render . ppr 0 82 | 83 | ppexpr :: Expr -> String 84 | ppexpr = render . ppr 0 85 | 86 | ppsignature :: (String, Scheme) -> String 87 | ppsignature (a, b) = a ++ " : " ++ ppscheme b 88 | 89 | ppdecl :: (String, Expr) -> String 90 | ppdecl (a, b) = "let " ++ a ++ " = " ++ ppexpr b 91 | 92 | ppenv :: TypeEnv -> [String] 93 | ppenv (TypeEnv env) = fmap ppsignature $ Map.toList env 94 | -------------------------------------------------------------------------------- /chapter7/poly/src/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | type Var = String 4 | 5 | data Expr 6 | = Var Var 7 | | App Expr Expr 8 | | Lam Var Expr 9 | | Let Var Expr Expr 10 | | Lit Lit 11 | | If Expr Expr Expr 12 | | Fix Expr 13 | | Op Binop Expr Expr 14 | deriving (Show, Eq, Ord) 15 | 16 | data Lit 17 | = LInt Integer 18 | | LBool Bool 19 | deriving (Show, Eq, Ord) 20 | 21 | data Binop = Add | Sub | Mul | Eql 22 | deriving (Eq, Ord, Show) 23 | 24 | type Decl = (String, Expr) 25 | 26 | data Program = Program [Decl] Expr deriving (Show, Eq) 27 | -------------------------------------------------------------------------------- /chapter7/poly/src/Type.hs: -------------------------------------------------------------------------------- 1 | module Type where 2 | 3 | newtype TVar = TV String 4 | deriving (Show, Eq, Ord) 5 | 6 | data Type 7 | = TVar TVar 8 | | TCon String 9 | | TArr Type Type 10 | deriving (Show, Eq, Ord) 11 | 12 | infixr `TArr` 13 | 14 | data Scheme = Forall [TVar] Type 15 | deriving (Show, Eq, Ord) 16 | 17 | typeInt :: Type 18 | typeInt = TCon "Int" 19 | 20 | typeBool :: Type 21 | typeBool = TCon "Bool" 22 | -------------------------------------------------------------------------------- /chapter7/poly/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-3.15 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - repline-0.1.4.0 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /chapter7/poly/test.ml: -------------------------------------------------------------------------------- 1 | -- Booleans 2 | let T x y = x; 3 | let F x y = y; 4 | 5 | -- SKI combinators 6 | let I x = x; 7 | let K x y = x; 8 | let S f g x = f x (g x); 9 | 10 | let skk = S K K; 11 | 12 | let Mu f = f (fix f); 13 | 14 | -- Other combinators 15 | let B x y z = x (y z); 16 | let C x y z = x z y; 17 | let W x y = x y y; 18 | 19 | -- Integer arithmetic 20 | let nsucc x = x + 1; 21 | let npred x = x - 1; 22 | 23 | -- Arithmetic 24 | let succ n f x = f (n f x); 25 | 26 | let zero f x = x ; 27 | let one f x = f x ; 28 | let two f x = f (f x) ; 29 | let three f x = f (f (f x)) ; 30 | let four f x = f (f (f (f x))) ; 31 | let five f x = f (f (f (f (f x)))) ; 32 | let six f x = f (f (f (f (f (f x))))) ; 33 | let seven f x = f (f (f (f (f (f (f x)))))) ; 34 | let eight f x = f (f (f (f (f (f (f (f x))))))) ; 35 | let nine f x = f (f (f (f (f (f (f (f (f x)))))))) ; 36 | let ten f x = f (f (f (f (f (f (f (f (f (f x))))))))) ; 37 | 38 | let iszero n = n (\x -> F) T; 39 | let plus m n f x = n f (m f x); 40 | let mult m n f = m (n f); 41 | let pow m n = n m; 42 | let pred n f x = n (\g h -> h (g f)) (\u -> x) I; 43 | let ack = \m -> m (\f n -> n f (f one)) succ; 44 | let sub m n = (n pred) m; 45 | 46 | -- Conversions 47 | 48 | let unbool n = n True False; 49 | let unchurch n = n (\i -> i + 1) 0; 50 | let rec church n = 51 | if (n == 0) 52 | then zero 53 | else \f x -> f (church (n-1) f x); 54 | 55 | -- Logic 56 | let not p = p F T; 57 | let and p q = p q F; 58 | let or p q = p T q; 59 | let cond p x y = p x y; 60 | let xor p q = p (q F T) q; 61 | let equ p q = not (xor p q); 62 | let nand x y = cond x (not y) T; 63 | let nor x y = cond x F (not y); 64 | 65 | -- Tuples 66 | let fst p = p T; 67 | let snd p = p F; 68 | let pair a b f = f a b; 69 | 70 | -- Lists 71 | let nil x = x; 72 | let cons x y = pair F (pair x y); 73 | let null z = z T; 74 | let head z = fst (snd z); 75 | let tail z = snd (snd z); 76 | let indx xs n = head (n tail xs); 77 | 78 | let fact = fix (\fact -> \n -> if (n == 0) then 1 else (n * (fact (n-1)))); 79 | 80 | let rec fib n = 81 | if (n == 0) 82 | then 0 83 | else if (n==1) 84 | then 1 85 | else ((fib (n-1)) + (fib (n-2))); 86 | 87 | let fixf = (\x -> fix (x 0)); 88 | 89 | -- Functions 90 | let const x y = x; 91 | let compose f g = \x -> f (g x); 92 | let twice f x = f (f x); 93 | let on g f = \x y -> g (f x) (f y); 94 | let ap f x = f (f x); 95 | 96 | -- Let Polymorphism 97 | let poly = I (I I) (I 3); 98 | let self = (\x -> x) (\x -> x); 99 | let innerlet = \x -> (let y = \z -> z in y); 100 | let innerletrec = \x -> (let rec y = \z -> z in y); 101 | 102 | -- Fresh variables 103 | let wtf = \a b c d e e' f g h i j k l m n o o' o'' o''' p q r r' s t u u' v w x y z -> 104 | q u i c k b r o w n f o' x j u' m p s o'' v e r' t h e' l a z y d o''' g; 105 | 106 | -- if-then-else 107 | let notbool x = if x then False else True; 108 | let eqzero x = if (x == 0) then True else False; 109 | 110 | let rec until p f x = 111 | if (p x) 112 | then x 113 | else (until p f (f x)); 114 | -------------------------------------------------------------------------------- /chapter7/poly/tests/should_fail/test_if.ml: -------------------------------------------------------------------------------- 1 | let f = (\x -> if x then x else (x+1)); 2 | let g = (\x -> if x then 1 else (x+1)); 3 | let h = (\x -> if x then (x+1) else 1); 4 | let j = (\x -> fix (x 0)); 5 | -------------------------------------------------------------------------------- /chapter7/poly/tests/should_fail/test_if.out: -------------------------------------------------------------------------------- 1 | Cannot unify types: 2 | Int 3 | with 4 | Bool 5 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015, Stephen Diehl 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/README.md: -------------------------------------------------------------------------------- 1 | Poly 2 | ==== 3 | 4 | A simple ML dialect with definitions, let polymorphism and a fixpoint operator. 5 | Uses syntax directed HM type inference. 6 | 7 | To compile and run: 8 | 9 | ```shell 10 | $ cabal run 11 | ``` 12 | 13 | Usage: 14 | 15 | ```ocaml 16 | Poly> let i x = x; 17 | i : forall a. a -> a 18 | 19 | Poly> i 3 20 | 3 21 | 22 | Poly> :type i 23 | i : forall a. a -> a 24 | 25 | Poly> :type let k x y = x; 26 | k : forall a b. a -> b -> a 27 | 28 | Poly> :type let s f g x = f x (g x) 29 | s : forall a b c. ((a -> b) -> c -> a) -> (a -> b) -> c -> b 30 | 31 | Poly> :type let on g f = \x y -> g (f x) (f y) 32 | on : forall a b c. (a -> a -> b) -> (c -> a) -> c -> c -> b 33 | 34 | Poly> :type let let_bound = i (i i) (i 3) 35 | let_bound : Int 36 | 37 | Poly> :type let compose f g = \x -> f (g x) 38 | compose : forall a b c. (a -> b) -> (c -> a) -> c -> b 39 | 40 | Poly> let rec factorial n = 41 | if (n == 0) 42 | then 1 43 | else (n * (factorial (n-1))); 44 | ``` 45 | 46 | Notes 47 | ===== 48 | 49 | Top level let declarations are syntactic sugar for nested lambda. For example: 50 | 51 | ```ocaml 52 | let add x y = x + y; 53 | ``` 54 | 55 | Is semantically equivalent to: 56 | 57 | ```ocaml 58 | let add = \x -> \y -> x + y; 59 | ``` 60 | 61 | Top level Let-rec declarations are syntactic sugar for use of the ``fix`` 62 | operator. For example: 63 | 64 | ```ocaml 65 | let rec factorial n = if (n == 0) then 1 else (n * (factorial (n-1))); 66 | ``` 67 | Is semantically equivalent to: 68 | 69 | ```ocaml 70 | let factorial = fix (\factorial n -> if (n == 0) then 1 else (n * (factorial (n-1)))); 71 | ``` 72 | 73 | License 74 | ======= 75 | 76 | Released under MIT license. 77 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/poly.cabal: -------------------------------------------------------------------------------- 1 | name: poly 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable poly 12 | build-depends: 13 | base >= 4.6 && <4.9 14 | , pretty >= 1.1 && <1.2 15 | , parsec >= 3.1 && <3.2 16 | , text >= 1.2 && <1.3 17 | , containers >= 0.5 && <0.6 18 | , mtl >= 2.2 && <2.3 19 | , transformers >= 0.4.2 && <0.5 20 | , repline >= 0.1.2.0 21 | 22 | other-modules: 23 | Env 24 | Eval 25 | Infer 26 | Lexer 27 | Parser 28 | Pretty 29 | Syntax 30 | Type 31 | 32 | default-language: Haskell2010 33 | hs-source-dirs: src 34 | main-is: Main.hs 35 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Env ( 4 | Env(..), 5 | empty, 6 | lookup, 7 | remove, 8 | extend, 9 | extends, 10 | merge, 11 | mergeEnvs, 12 | singleton, 13 | keys, 14 | fromList, 15 | toList, 16 | ) where 17 | 18 | import Prelude hiding (lookup) 19 | 20 | import Syntax 21 | import Type 22 | 23 | import Data.Monoid 24 | import Data.Foldable hiding (toList) 25 | import qualified Data.Map as Map 26 | 27 | ------------------------------------------------------------------------------- 28 | -- Typing Environment 29 | ------------------------------------------------------------------------------- 30 | 31 | data Env = TypeEnv { types :: Map.Map Name Scheme } 32 | deriving (Eq, Show) 33 | 34 | empty :: Env 35 | empty = TypeEnv Map.empty 36 | 37 | extend :: Env -> (Name, Scheme) -> Env 38 | extend env (x, s) = env { types = Map.insert x s (types env) } 39 | 40 | remove :: Env -> Name -> Env 41 | remove (TypeEnv env) var = TypeEnv (Map.delete var env) 42 | 43 | extends :: Env -> [(Name, Scheme)] -> Env 44 | extends env xs = env { types = Map.union (Map.fromList xs) (types env) } 45 | 46 | lookup :: Name -> Env -> Maybe Scheme 47 | lookup key (TypeEnv tys) = Map.lookup key tys 48 | 49 | merge :: Env -> Env -> Env 50 | merge (TypeEnv a) (TypeEnv b) = TypeEnv (Map.union a b) 51 | 52 | mergeEnvs :: [Env] -> Env 53 | mergeEnvs = foldl' merge empty 54 | 55 | singleton :: Name -> Scheme -> Env 56 | singleton x y = TypeEnv (Map.singleton x y) 57 | 58 | keys :: Env -> [Name] 59 | keys (TypeEnv env) = Map.keys env 60 | 61 | fromList :: [(Name, Scheme)] -> Env 62 | fromList xs = TypeEnv (Map.fromList xs) 63 | 64 | toList :: Env -> [(Name, Scheme)] 65 | toList (TypeEnv env) = Map.toList env 66 | 67 | instance Monoid Env where 68 | mempty = empty 69 | mappend = merge 70 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval where 2 | 3 | import Syntax 4 | 5 | import Control.Monad.Identity 6 | import qualified Data.Map as Map 7 | 8 | data Value 9 | = VInt Integer 10 | | VBool Bool 11 | | VClosure String Expr TermEnv 12 | 13 | type TermEnv = Map.Map String Value 14 | type Interpreter t = Identity t 15 | 16 | emptyTmenv :: TermEnv 17 | emptyTmenv = Map.empty 18 | 19 | instance Show Value where 20 | show (VInt n) = show n 21 | show (VBool n) = show n 22 | show VClosure{} = "<>" 23 | 24 | eval :: TermEnv -> Expr -> Interpreter Value 25 | eval env expr = case expr of 26 | Lit (LInt k) -> return $ VInt k 27 | Lit (LBool k) -> return $ VBool k 28 | 29 | Var x -> do 30 | let Just v = Map.lookup x env 31 | return v 32 | 33 | Op op a b -> do 34 | VInt a' <- eval env a 35 | VInt b' <- eval env b 36 | return $ (binop op) a' b' 37 | 38 | Lam x body -> 39 | return (VClosure x body env) 40 | 41 | App fun arg -> do 42 | VClosure x body clo <- eval env fun 43 | argv <- eval env arg 44 | let nenv = Map.insert x argv clo 45 | eval nenv body 46 | 47 | Let x e body -> do 48 | e' <- eval env e 49 | let nenv = Map.insert x e' env 50 | eval nenv body 51 | 52 | If cond tr fl -> do 53 | VBool br <- eval env cond 54 | if br == True 55 | then eval env tr 56 | else eval env fl 57 | 58 | Fix e -> do 59 | eval env (App e (Fix e)) 60 | 61 | binop :: Binop -> Integer -> Integer -> Value 62 | binop Add a b = VInt $ a + b 63 | binop Mul a b = VInt $ a * b 64 | binop Sub a b = VInt $ a - b 65 | binop Eql a b = VBool $ a == b 66 | 67 | runEval :: TermEnv -> String -> Expr -> (Value, TermEnv) 68 | runEval env nm ex = 69 | let res = runIdentity (eval env ex) in 70 | (res, Map.insert nm res env) 71 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer where 2 | 3 | import Text.Parsec 4 | import Text.Parsec.Text.Lazy 5 | import qualified Data.Text.Lazy as L 6 | import qualified Text.Parsec.Token as Tok 7 | import qualified Text.Parsec.Expr as Ex 8 | 9 | import Data.Functor.Identity 10 | 11 | type Op a = Ex.Operator L.Text () Identity a 12 | type Operators a = Ex.OperatorTable L.Text () Identity a 13 | 14 | reservedNames :: [String] 15 | reservedNames = [ 16 | "let", 17 | "in", 18 | "fix", 19 | "rec", 20 | "if", 21 | "then", 22 | "else" 23 | ] 24 | 25 | reservedOps :: [String] 26 | reservedOps = [ 27 | "->", 28 | "\\", 29 | "+", 30 | "*", 31 | "-", 32 | "=" 33 | ] 34 | 35 | lexer :: Tok.GenTokenParser L.Text () Identity 36 | lexer = Tok.makeTokenParser $ Tok.LanguageDef 37 | { Tok.commentStart = "{-" 38 | , Tok.commentEnd = "-}" 39 | , Tok.commentLine = "--" 40 | , Tok.nestedComments = True 41 | , Tok.identStart = letter 42 | , Tok.identLetter = alphaNum <|> oneOf "_'" 43 | , Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 44 | , Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 45 | , Tok.reservedNames = reservedNames 46 | , Tok.reservedOpNames = reservedOps 47 | , Tok.caseSensitive = True 48 | } 49 | 50 | reserved :: String -> Parser () 51 | reserved = Tok.reserved lexer 52 | 53 | reservedOp :: String -> Parser () 54 | reservedOp = Tok.reservedOp lexer 55 | 56 | identifier :: Parser String 57 | identifier = Tok.identifier lexer 58 | 59 | parens :: Parser a -> Parser a 60 | parens = Tok.parens lexer 61 | 62 | semiSep :: Parser a -> Parser [a] 63 | semiSep = Tok.semiSep lexer 64 | 65 | semi :: Parser String 66 | semi = Tok.semi lexer 67 | 68 | contents :: Parser a -> Parser a 69 | contents p = do 70 | Tok.whiteSpace lexer 71 | r <- p 72 | eof 73 | return r 74 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | import Syntax 7 | import Infer 8 | import Parser 9 | import Pretty 10 | import Eval 11 | import qualified Env 12 | 13 | import Data.Monoid 14 | import qualified Data.Map as Map 15 | import qualified Data.Text.Lazy as L 16 | import qualified Data.Text.Lazy.IO as L 17 | 18 | import Control.Monad.Identity 19 | import Control.Monad.State.Strict 20 | 21 | import Data.List (isPrefixOf, foldl') 22 | 23 | import System.Exit 24 | import System.Environment 25 | import System.Console.Repline 26 | 27 | ------------------------------------------------------------------------------- 28 | -- Types 29 | ------------------------------------------------------------------------------- 30 | 31 | data IState = IState 32 | { tyctx :: Env.Env -- Type environment 33 | , tmctx :: TermEnv -- Value environment 34 | } 35 | 36 | initState :: IState 37 | initState = IState Env.empty emptyTmenv 38 | 39 | type Repl a = HaskelineT (StateT IState IO) a 40 | hoistErr :: Show e => Either e a -> Repl a 41 | hoistErr (Right val) = return val 42 | hoistErr (Left err) = do 43 | liftIO $ print err 44 | abort 45 | 46 | ------------------------------------------------------------------------------- 47 | -- Execution 48 | ------------------------------------------------------------------------------- 49 | 50 | evalDef :: TermEnv -> (String, Expr) -> TermEnv 51 | evalDef env (nm, ex) = tmctx' 52 | where (val, tmctx') = runEval env nm ex 53 | 54 | exec :: Bool -> L.Text -> Repl () 55 | exec update source = do 56 | -- Get the current interpreter state 57 | st <- get 58 | 59 | -- Parser ( returns AST ) 60 | mod <- hoistErr $ parseModule "" source 61 | 62 | -- Type Inference ( returns Typing Environment ) 63 | tyctx' <- hoistErr $ inferTop (tyctx st) mod 64 | 65 | -- Create the new environment 66 | let st' = st { tmctx = foldl' evalDef (tmctx st) mod 67 | , tyctx = tyctx' <> (tyctx st) 68 | } 69 | 70 | -- Update the interpreter state 71 | when update (put st') 72 | 73 | -- If a value is entered, print it. 74 | case lookup "it" mod of 75 | Nothing -> return () 76 | Just ex -> do 77 | let (val, _) = runEval (tmctx st') "it" ex 78 | showOutput (show val) st' 79 | 80 | showOutput :: String -> IState -> Repl () 81 | showOutput arg st = do 82 | case Env.lookup "it" (tyctx st) of 83 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 84 | Nothing -> return () 85 | 86 | cmd :: String -> Repl () 87 | cmd source = exec True (L.pack source) 88 | 89 | ------------------------------------------------------------------------------- 90 | -- Commands 91 | ------------------------------------------------------------------------------- 92 | 93 | -- :browse command 94 | browse :: [String] -> Repl () 95 | browse _ = do 96 | st <- get 97 | liftIO $ mapM_ putStrLn $ ppenv (tyctx st) 98 | 99 | -- :load command 100 | load :: [String] -> Repl () 101 | load args = do 102 | contents <- liftIO $ L.readFile (unwords args) 103 | exec True contents 104 | 105 | -- :type command 106 | typeof :: [String] -> Repl () 107 | typeof args = do 108 | st <- get 109 | let arg = unwords args 110 | case Env.lookup arg (tyctx st) of 111 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 112 | Nothing -> exec False (L.pack arg) 113 | 114 | -- :quit command 115 | quit :: a -> Repl () 116 | quit _ = liftIO $ exitSuccess 117 | 118 | ------------------------------------------------------------------------------- 119 | -- Interactive Shell 120 | ------------------------------------------------------------------------------- 121 | 122 | -- Prefix tab completer 123 | defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] 124 | defaultMatcher = [ 125 | (":load" , fileCompleter) 126 | --, (":type" , values) 127 | ] 128 | 129 | -- Default tab completer 130 | comp :: (Monad m, MonadState IState m) => WordCompleter m 131 | comp n = do 132 | let cmds = [":load", ":type", ":browse", ":quit"] 133 | Env.TypeEnv ctx <- gets tyctx 134 | let defs = Map.keys ctx 135 | return $ filter (isPrefixOf n) (cmds ++ defs) 136 | 137 | options :: [(String, [String] -> Repl ())] 138 | options = [ 139 | ("load" , load) 140 | , ("browse" , browse) 141 | , ("quit" , quit) 142 | , ("type" , Main.typeof) 143 | ] 144 | 145 | ------------------------------------------------------------------------------- 146 | -- Entry Point 147 | ------------------------------------------------------------------------------- 148 | 149 | completer :: CompleterStyle (StateT IState IO) 150 | completer = Prefix (wordCompleter comp) defaultMatcher 151 | 152 | shell :: Repl a -> IO () 153 | shell pre = flip evalStateT initState 154 | $ evalRepl "Poly> " cmd options completer pre 155 | 156 | ------------------------------------------------------------------------------- 157 | -- Toplevel 158 | ------------------------------------------------------------------------------- 159 | 160 | main :: IO () 161 | main = do 162 | args <- getArgs 163 | case args of 164 | [] -> shell (return ()) 165 | [fname] -> shell (load [fname]) 166 | ["test", fname] -> shell (load [fname] >> browse [] >> quit ()) 167 | _ -> putStrLn "invalid arguments" 168 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Parser ( 4 | parseExpr, 5 | parseModule 6 | ) where 7 | 8 | import Text.Parsec 9 | import Text.Parsec.Text.Lazy (Parser) 10 | 11 | import qualified Text.Parsec.Expr as Ex 12 | import qualified Text.Parsec.Token as Tok 13 | 14 | import qualified Data.Text.Lazy as L 15 | 16 | import Lexer 17 | import Syntax 18 | 19 | integer :: Parser Integer 20 | integer = Tok.integer lexer 21 | 22 | variable :: Parser Expr 23 | variable = do 24 | x <- identifier 25 | return (Var x) 26 | 27 | number :: Parser Expr 28 | number = do 29 | n <- integer 30 | return (Lit (LInt (fromIntegral n))) 31 | 32 | bool :: Parser Expr 33 | bool = (reserved "True" >> return (Lit (LBool True))) 34 | <|> (reserved "False" >> return (Lit (LBool False))) 35 | 36 | fix :: Parser Expr 37 | fix = do 38 | reservedOp "fix" 39 | x <- expr 40 | return (Fix x) 41 | 42 | lambda :: Parser Expr 43 | lambda = do 44 | reservedOp "\\" 45 | args <- many identifier 46 | reservedOp "->" 47 | body <- expr 48 | return $ foldr Lam body args 49 | 50 | letin :: Parser Expr 51 | letin = do 52 | reserved "let" 53 | x <- identifier 54 | reservedOp "=" 55 | e1 <- expr 56 | reserved "in" 57 | e2 <- expr 58 | return (Let x e1 e2) 59 | 60 | letrecin :: Parser Expr 61 | letrecin = do 62 | reserved "let" 63 | reserved "rec" 64 | x <- identifier 65 | reservedOp "=" 66 | e1 <- expr 67 | reserved "in" 68 | e2 <- expr 69 | return (Let x e1 e2) 70 | 71 | ifthen :: Parser Expr 72 | ifthen = do 73 | reserved "if" 74 | cond <- expr 75 | reservedOp "then" 76 | tr <- expr 77 | reserved "else" 78 | fl <- expr 79 | return (If cond tr fl) 80 | 81 | aexp :: Parser Expr 82 | aexp = 83 | parens expr 84 | <|> bool 85 | <|> number 86 | <|> ifthen 87 | <|> fix 88 | <|> try letrecin 89 | <|> letin 90 | <|> lambda 91 | <|> variable 92 | 93 | term :: Parser Expr 94 | term = aexp >>= \x -> 95 | (many1 aexp >>= \xs -> return (foldl App x xs)) 96 | <|> return x 97 | 98 | infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a 99 | infixOp x f = Ex.Infix (reservedOp x >> return f) 100 | 101 | table :: Operators Expr 102 | table = [ 103 | [ 104 | infixOp "*" (Op Mul) Ex.AssocLeft 105 | ], 106 | [ 107 | infixOp "+" (Op Add) Ex.AssocLeft 108 | , infixOp "-" (Op Sub) Ex.AssocLeft 109 | ], 110 | [ 111 | infixOp "==" (Op Eql) Ex.AssocLeft 112 | ] 113 | ] 114 | 115 | expr :: Parser Expr 116 | expr = Ex.buildExpressionParser table term 117 | 118 | type Binding = (String, Expr) 119 | 120 | letdecl :: Parser Binding 121 | letdecl = do 122 | reserved "let" 123 | name <- identifier 124 | args <- many identifier 125 | reservedOp "=" 126 | body <- expr 127 | return $ (name, foldr Lam body args) 128 | 129 | letrecdecl :: Parser (String, Expr) 130 | letrecdecl = do 131 | reserved "let" 132 | reserved "rec" 133 | name <- identifier 134 | args <- many identifier 135 | reservedOp "=" 136 | body <- expr 137 | return $ (name, Fix $ foldr Lam body (name:args)) 138 | 139 | val :: Parser Binding 140 | val = do 141 | ex <- expr 142 | return ("it", ex) 143 | 144 | decl :: Parser Binding 145 | decl = try letrecdecl <|> letdecl <|> val 146 | 147 | top :: Parser Binding 148 | top = do 149 | x <- decl 150 | optional semi 151 | return x 152 | 153 | modl :: Parser [Binding] 154 | modl = many top 155 | 156 | parseExpr :: L.Text -> Either ParseError Expr 157 | parseExpr input = parse (contents expr) "" input 158 | 159 | parseModule :: FilePath -> L.Text -> Either ParseError [(String, Expr)] 160 | parseModule fname input = parse (contents modl) fname input 161 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language FlexibleInstances #-} 2 | {-# Language TypeSynonymInstances #-} 3 | 4 | module Pretty ( 5 | ppconstraint, 6 | ppconstraints, 7 | ppdecl, 8 | ppenv, 9 | ppexpr, 10 | ppscheme, 11 | ppsubst, 12 | ppsignature, 13 | pptype 14 | ) where 15 | 16 | import Env 17 | import Type 18 | import Syntax 19 | import Infer 20 | 21 | import Text.PrettyPrint 22 | import qualified Data.Map as Map 23 | 24 | parensIf :: Bool -> Doc -> Doc 25 | parensIf True = parens 26 | parensIf False = id 27 | 28 | 29 | class Pretty p where 30 | ppr :: Int -> p -> Doc 31 | 32 | instance Pretty Name where 33 | ppr _ x = text x 34 | 35 | instance Pretty TVar where 36 | ppr _ (TV x) = text x 37 | 38 | instance Pretty Type where 39 | ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b 40 | where 41 | isArrow TArr{} = True 42 | isArrow _ = False 43 | ppr p (TVar a) = ppr p a 44 | ppr _ (TCon a) = text a 45 | 46 | instance Pretty Scheme where 47 | ppr p (Forall [] t) = ppr p t 48 | ppr p (Forall ts t) = text "forall" <+> hcat (punctuate space (map (ppr p) ts)) <> text "." <+> ppr p t 49 | 50 | instance Pretty Binop where 51 | ppr _ Add = text "+" 52 | ppr _ Sub = text "-" 53 | ppr _ Mul = text "*" 54 | ppr _ Eql = text "==" 55 | 56 | instance Pretty Expr where 57 | ppr p (Var a) = ppr p a 58 | ppr p (App a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b 59 | ppr p (Lam a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b 60 | ppr p (Let a b c) = text "let" <> ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c 61 | ppr p (Lit a) = ppr p a 62 | ppr p (Op o a b) = parensIf (p>0) $ ppr p a <+> ppr p o <+> ppr p b 63 | ppr p (Fix a) = parensIf (p>0) $ text "fix" <> ppr p a 64 | ppr p (If a b c) = 65 | text "if" <> ppr p a <+> 66 | text "then" <+> ppr p b <+> 67 | text "else" <+> ppr p c 68 | 69 | instance Pretty Lit where 70 | ppr _ (LInt i) = integer i 71 | ppr _ (LBool True) = text "True" 72 | ppr _ (LBool False) = text "False" 73 | 74 | instance Pretty Constraint where 75 | ppr p (a, b) = (ppr p a) <+> text " ~ " <+> (ppr p b) 76 | 77 | instance Pretty [Constraint] where 78 | ppr p cs = vcat (punctuate space (map (ppr p) cs)) 79 | 80 | instance Pretty Subst where 81 | ppr p (Subst s) = vcat (punctuate space (map pprSub $ Map.toList s)) 82 | where pprSub (a, b) = ppr 0 a <+> text "~" <+> ppr 0 b 83 | 84 | instance Show TypeError where 85 | show (UnificationFail a b) = 86 | concat ["Cannot unify types: \n\t", pptype a, "\nwith \n\t", pptype b] 87 | show (InfiniteType (TV a) b) = 88 | concat ["Cannot construct the infinite type: ", a, " = ", pptype b] 89 | show (Ambigious cs) = 90 | concat ["Cannot not match expected type: '" ++ pptype a ++ "' with actual type: '" ++ pptype b ++ "'\n" | (a,b) <- cs] 91 | show (UnboundVariable a) = "Not in scope: " ++ a 92 | 93 | ppscheme :: Scheme -> String 94 | ppscheme = render . ppr 0 95 | 96 | pptype :: Type -> String 97 | pptype = render . ppr 0 98 | 99 | ppexpr :: Expr -> String 100 | ppexpr = render . ppr 0 101 | 102 | ppsignature :: (String, Scheme) -> String 103 | ppsignature (a, b) = a ++ " : " ++ ppscheme b 104 | 105 | ppdecl :: (String, Expr) -> String 106 | ppdecl (a, b) = "let " ++ a ++ " = " ++ ppexpr b 107 | 108 | ppenv :: Env -> [String] 109 | ppenv (TypeEnv env) = map ppsignature $ Map.toList env 110 | 111 | ppconstraint :: Constraint -> String 112 | ppconstraint = render . ppr 0 113 | 114 | ppconstraints :: [Constraint] -> String 115 | ppconstraints = render . ppr 0 116 | 117 | ppsubst :: Subst -> String 118 | ppsubst = render . ppr 0 119 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | type Name = String 4 | 5 | data Expr 6 | = Var Name 7 | | App Expr Expr 8 | | Lam Name Expr 9 | | Let Name Expr Expr 10 | | Lit Lit 11 | | If Expr Expr Expr 12 | | Fix Expr 13 | | Op Binop Expr Expr 14 | deriving (Show, Eq, Ord) 15 | 16 | data Lit 17 | = LInt Integer 18 | | LBool Bool 19 | deriving (Show, Eq, Ord) 20 | 21 | data Binop = Add | Sub | Mul | Eql 22 | deriving (Eq, Ord, Show) 23 | 24 | data Program = Program [Decl] Expr deriving Eq 25 | 26 | type Decl = (String, Expr) 27 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/src/Type.hs: -------------------------------------------------------------------------------- 1 | module Type where 2 | 3 | newtype TVar = TV String 4 | deriving (Show, Eq, Ord) 5 | 6 | data Type 7 | = TVar TVar 8 | | TCon String 9 | | TArr Type Type 10 | deriving (Show, Eq, Ord) 11 | 12 | data Scheme = Forall [TVar] Type 13 | deriving (Show, Eq, Ord) 14 | 15 | typeInt, typeBool :: Type 16 | typeInt = TCon "Int" 17 | typeBool = TCon "Bool" 18 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-3.15 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - repline-0.1.4.0 6 | flags: {} 7 | extra-package-dbs: [] 8 | -------------------------------------------------------------------------------- /chapter7/poly_constraints/test.ml: -------------------------------------------------------------------------------- 1 | -- Booleans 2 | let T x y = x; 3 | let F x y = y; 4 | 5 | -- SKI combinators 6 | let I x = x; 7 | let K x y = x; 8 | let S f g x = f x (g x); 9 | 10 | let skk = S K K; 11 | 12 | let Mu f = f (fix f); 13 | 14 | -- Other combinators 15 | let B x y z = x (y z); 16 | let C x y z = x z y; 17 | let W x y = x y y; 18 | 19 | -- Integer arithmetic 20 | let nsucc x = x + 1; 21 | let npred x = x - 1; 22 | 23 | -- Arithmetic 24 | let succ n f x = f (n f x); 25 | 26 | let zero f x = x ; 27 | let one f x = f x ; 28 | let two f x = f (f x) ; 29 | let three f x = f (f (f x)) ; 30 | let four f x = f (f (f (f x))) ; 31 | let five f x = f (f (f (f (f x)))) ; 32 | let six f x = f (f (f (f (f (f x))))) ; 33 | let seven f x = f (f (f (f (f (f (f x)))))) ; 34 | let eight f x = f (f (f (f (f (f (f (f x))))))) ; 35 | let nine f x = f (f (f (f (f (f (f (f (f x)))))))) ; 36 | let ten f x = f (f (f (f (f (f (f (f (f (f x))))))))) ; 37 | 38 | let iszero n = n (\x -> F) T; 39 | let plus m n f x = n f (m f x); 40 | let mult m n f = m (n f); 41 | let pow m n = n m; 42 | let pred n f x = n (\g h -> h (g f)) (\u -> x) I; 43 | let ack = \m -> m (\f n -> n f (f one)) succ; 44 | let sub m n = (n pred) m; 45 | 46 | -- Conversions 47 | 48 | let unbool n = n True False; 49 | let unchurch n = n (\i -> i + 1) 0; 50 | let rec church n = 51 | if (n == 0) 52 | then zero 53 | else \f x -> f (church (n-1) f x); 54 | 55 | -- Logic 56 | let not p = p F T; 57 | let and p q = p q F; 58 | let or p q = p T q; 59 | let cond p x y = p x y; 60 | let xor p q = p (q F T) q; 61 | let equ p q = not (xor p q); 62 | let nand x y = cond x (not y) T; 63 | let nor x y = cond x F (not y); 64 | 65 | -- Tuples 66 | let fst p = p T; 67 | let snd p = p F; 68 | let pair a b f = f a b; 69 | 70 | -- Lists 71 | let nil x = x; 72 | let cons x y = pair F (pair x y); 73 | let null z = z T; 74 | let head z = fst (snd z); 75 | let tail z = snd (snd z); 76 | let indx xs n = head (n tail xs); 77 | 78 | let fact = fix (\fact -> \n -> if (n == 0) then 1 else (n * (fact (n-1)))); 79 | 80 | let rec fib n = 81 | if (n == 0) 82 | then 0 83 | else if (n==1) 84 | then 1 85 | else ((fib (n-1)) + (fib (n-2))); 86 | 87 | -- Functions 88 | let const x y = x; 89 | let compose f g = \x -> f (g x); 90 | let twice f x = f (f x); 91 | let on g f = \x y -> g (f x) (f y); 92 | let ap f x = f (f x); 93 | 94 | -- Let Polymorphism 95 | let poly = I (I I) (I 3); 96 | let self = (\x -> x) (\x -> x); 97 | let innerlet = \x -> (let y = \z -> z in y); 98 | let innerletrec = \x -> (let rec y = \z -> z in y); 99 | 100 | -- Issue #72 101 | let f = let add = \a b -> a + b in add; 102 | 103 | -- Issue #82 104 | let y = \y -> (let f = \x -> if x then True else False in const (f y) y); 105 | let id x = x; 106 | let foo x = let y = id x in y + 1; 107 | 108 | -- Fresh variables 109 | let wtf = \a b c d e e' f g h i j k l m n o o' o'' o''' p q r r' s t u u' v w x y z -> 110 | q u i c k b r o w n f o' x j u' m p s o'' v e r' t h e' l a z y d o''' g; 111 | 112 | -- if-then-else 113 | let notbool x = if x then False else True; 114 | let eqzero x = if (x == 0) then True else False; 115 | 116 | let rec until p f x = 117 | if (p x) 118 | then x 119 | else (until p f (f x)); 120 | -------------------------------------------------------------------------------- /chapter8/.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[po] 2 | *.o 3 | *.so 4 | cabal.sandbox.config 5 | .cabal-sandbox 6 | dist/ 7 | *.hi 8 | *.o 9 | includes 10 | *.html 11 | *.agdai 12 | *.history 13 | -------------------------------------------------------------------------------- /chapter8/protohaskell/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Compiler ( 2 | -- * Code paths 3 | modl, 4 | expr, 5 | 6 | -- * Module driver 7 | modls, 8 | ) where 9 | 10 | -- Future chapters. 11 | modl = undefined 12 | expr = undefined 13 | modls = undefined 14 | -------------------------------------------------------------------------------- /chapter8/protohaskell/Flags.hs: -------------------------------------------------------------------------------- 1 | module Flags ( 2 | -- * Compiler flags 3 | Flag(..), 4 | Flags, 5 | 6 | -- * Setting/Unsetting 7 | isSet, 8 | set, 9 | unset, 10 | 11 | -- * Command line switches 12 | flagOpts, 13 | flagFor, 14 | ) where 15 | 16 | import qualified Data.Set as S 17 | import Control.Monad (msum) 18 | import Data.List (isPrefixOf) 19 | 20 | -- Flag set. 21 | type Flags = S.Set Flag 22 | 23 | data Flag 24 | = DumpC 25 | | DumpLLVM -- ^ \-ddump-llvm 26 | | DumpASM -- ^ \-ddump-asm 27 | | DumpParsed -- ^ \-ddump-parsed 28 | | DumpDesugar -- ^ \-ddump-desugar 29 | | DumpInfer -- ^ \-ddump-infer 30 | | DumpCore -- ^ \-ddump-core 31 | | DumpTypes -- ^ \-ddump-types 32 | | DumpKinds -- ^ \-ddump-types 33 | | DumpStg -- ^ \-ddump-stg 34 | | DumpImp -- ^ \-ddump-imp 35 | | DumpRenamer -- ^ \-ddump-rn 36 | | DumpToFile -- ^ \-ddump-to-file 37 | deriving (Eq, Ord, Show) 38 | 39 | -- | Query a flag setting. 40 | isSet :: Flags -> Flag -> Bool 41 | isSet = flip S.member 42 | 43 | -- | Insert a flag into the flag set. 44 | set :: Flags -> Flag -> Flags 45 | set = flip S.insert 46 | 47 | -- | Remove a flag into the flag set. 48 | unset :: Flags -> Flag -> Flags 49 | unset = flip S.delete 50 | 51 | flags :: [(String, Flag)] 52 | flags = [ 53 | ("ddump-parsed" , DumpParsed) 54 | , ("ddump-ds" , DumpDesugar) 55 | , ("ddump-core" , DumpCore) 56 | , ("ddump-infer" , DumpInfer) 57 | , ("ddump-types" , DumpTypes) 58 | , ("ddump-kinds" , DumpKinds) 59 | , ("ddump-stg" , DumpStg) 60 | , ("ddump-imp" , DumpImp) 61 | , ("ddump-c" , DumpC) 62 | , ("ddump-rn" , DumpRenamer) 63 | , ("ddump-to-file" , DumpToFile) 64 | ] 65 | 66 | matches :: String -> (String, Flag) -> Maybe Flag 67 | matches s (flagstr, flag) 68 | | ('-' : flagstr) `isPrefixOf` s = Just flag 69 | | otherwise = Nothing 70 | 71 | -- | Command line switches for flag options 72 | flagOpts :: [String] 73 | flagOpts = fmap fst flags 74 | 75 | -- | Lookup the flag from a command line option switch. 76 | flagFor :: String -> Maybe Flags.Flag 77 | flagFor s = msum $ fmap (matches s) flags 78 | -------------------------------------------------------------------------------- /chapter8/protohaskell/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Monad ( 4 | -- * Compiler driver 5 | CompilerM, 6 | runCompilerM, 7 | 8 | -- * Compiler state 9 | CompilerState(..), 10 | emptyCS, 11 | 12 | -- * Reporting 13 | Pos, 14 | Msg, 15 | 16 | -- * Utilities 17 | inIO, 18 | ifSet, 19 | ) where 20 | 21 | import Data.Monoid 22 | import qualified Data.Text.Lazy as L 23 | 24 | import Control.Applicative 25 | import Control.Monad.State 26 | import Control.Monad.Except 27 | 28 | import qualified Flags 29 | import qualified Frontend as Syn 30 | 31 | ------------------------------------------------------------------------------- 32 | -- Compiler Monad 33 | ------------------------------------------------------------------------------- 34 | 35 | type CompilerMonad = 36 | ExceptT Msg 37 | (StateT CompilerState IO) 38 | 39 | -- | Main compiler driver a monad. 40 | newtype CompilerM a = Compiler { runCompiler :: CompilerMonad a } 41 | deriving 42 | ( Functor 43 | , Applicative 44 | , Alternative 45 | , Monad 46 | , MonadFix 47 | , MonadPlus 48 | , MonadIO 49 | , MonadState CompilerState 50 | , MonadError Msg 51 | ) 52 | 53 | ------------------------------------------------------------------------------- 54 | -- Compiler State 55 | ------------------------------------------------------------------------------- 56 | 57 | data CompilerState = CompilerState 58 | { _fname :: Maybe FilePath -- ^ File path 59 | , _imports :: [FilePath] -- ^ Loaded modules 60 | , _src :: Maybe L.Text -- ^ File source 61 | , _ast :: Maybe Syn.Module -- ^ Frontend AST 62 | , _flags :: Flags.Flags -- ^ Compiler flags 63 | 64 | -- Future Chapters 65 | -- , _tenv :: Env.Env -- ^ Typing environment 66 | -- , _kenv :: Map.Map Name Kind -- ^ Kind environment 67 | -- , _cenv :: ClassEnv.ClassEnv -- ^ Class environment 68 | -- , _cast :: Maybe Core.Module -- ^ Core AST 69 | -- , _cprg :: Maybe String -- ^ Outputted source 70 | -- , _venv :: CoreEval.ValEnv Core.Expr -- ^ Core interpreter environment 71 | -- , _denv :: DataEnv.DataEnv -- ^ Entity dictionary 72 | -- , _clenv :: ClassEnv.ClassHier -- ^ Typeclass hierarchy 73 | -- , _stg :: Maybe STG.Module -- ^ STG module 74 | -- , _imp :: Maybe Imp.ImpModule -- ^ Imp module 75 | } deriving (Eq, Show) 76 | 77 | -- | Initial empty compiler state. 78 | emptyCS :: CompilerState 79 | emptyCS = CompilerState 80 | { _fname = Nothing 81 | , _imports = mempty 82 | , _src = Nothing 83 | , _ast = Nothing 84 | , _flags = mempty 85 | 86 | -- Future Chapters 87 | -- , _tenv = mempty 88 | -- , _cenv = mempty 89 | -- , _kenv = mempty 90 | -- , _cast = Nothing 91 | -- , _cprg = Nothing 92 | -- , _venv = mempty 93 | -- , _denv = mempty 94 | -- , _clenv = mempty 95 | -- , _stg = Nothing 96 | -- , _imp = Nothing 97 | } 98 | 99 | ------------------------------------------------------------------------------- 100 | -- Types 101 | ------------------------------------------------------------------------------- 102 | 103 | -- | Position information 104 | type Pos = String 105 | 106 | -- | Failure message. 107 | type Msg = String 108 | 109 | -- | Run the compiler pipeline. 110 | runCompilerM 111 | :: CompilerM a 112 | -> CompilerState 113 | -> IO (Either Msg a, CompilerState) 114 | runCompilerM = runStateT . runExceptT . runCompiler 115 | 116 | -- | Lift IO action into the Compiler IO layer. 117 | inIO :: IO a -> CompilerM a 118 | inIO = Compiler . liftIO 119 | 120 | -- | Conditional execute monadic action if a flag is set. 121 | ifSet :: Flags.Flag -> CompilerM a -> CompilerM () 122 | ifSet flag m = do 123 | flags <- gets _flags 124 | when (Flags.isSet flags flag) (void m) 125 | -------------------------------------------------------------------------------- /chapter8/protohaskell/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Name ( 4 | -- * Name types 5 | Name(..), 6 | Named(getName), 7 | 8 | -- * Name conversion/renaming 9 | unName, 10 | prefix, 11 | 12 | -- * Name supplies 13 | letters, 14 | genNames, 15 | ) where 16 | 17 | import Data.String 18 | import Data.Monoid 19 | import Data.Hashable 20 | import Control.Monad 21 | 22 | import GHC.Generics 23 | 24 | data Name 25 | = Gen String Integer 26 | | Name String 27 | deriving (Eq, Ord, Show, Read, Generic) 28 | 29 | instance Hashable Name where 30 | 31 | instance IsString Name where 32 | fromString = Name 33 | 34 | prefix :: String -> Name -> Name 35 | prefix p (Gen nm i) = Gen (p <> nm) i 36 | prefix p (Name nm) = Name (p <> nm) 37 | 38 | unName :: IsString a => Name -> a 39 | unName (Name s) = fromString s 40 | unName (Gen s n) = fromString (s ++ show n) 41 | 42 | letters :: [String] 43 | letters = [1..] >>= flip replicateM ['a'..'z'] 44 | 45 | genNames :: [Name] 46 | genNames = Prelude.zipWith Gen letters [0..] 47 | 48 | class Named a where 49 | getName :: a -> Name 50 | -------------------------------------------------------------------------------- /chapter8/protohaskell/README.md: -------------------------------------------------------------------------------- 1 | ProtoHaskell ( Chapter 8 ) 2 | ========================== 3 | 4 | Frontend syntax for ProtoHaskell for Chapter 8. 5 | 6 | * ``Monad`` - Compiler monad 7 | * ``Flags`` - Compiler flags 8 | * ``Frontend`` - Frontend syntax 9 | * ``Name`` - Syntax names 10 | * ``Compiler`` - Initial compiler stub 11 | * ``Pretty`` - Pretty printer 12 | * ``Type`` - Type syntax 13 | 14 | License 15 | ======= 16 | 17 | Released under MIT license. 18 | -------------------------------------------------------------------------------- /chapter8/protohaskell/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Type ( 4 | -- * Types 5 | Type(..), 6 | Kind(..), 7 | TVar(..), 8 | Pred(..), 9 | TyCon(..), 10 | 11 | -- * Alpha equivalence 12 | Alpha(aeq), 13 | 14 | -- * Type predicates 15 | predicates, 16 | predicate, 17 | 18 | -- * Constructors 19 | mkTArr, 20 | mkTApp, 21 | mkTPair, 22 | mkTList, 23 | 24 | -- * Deconstructors 25 | viewTArr, 26 | viewTApp, 27 | typeArity, 28 | 29 | -- * Wired-in types 30 | tyArrow, 31 | tyList, 32 | tyPair, 33 | tyInt, 34 | tyChar, 35 | tyBool, 36 | tyUnit, 37 | tyAddr, 38 | 39 | intTyCon, 40 | charTyCon, 41 | addrTyCon, 42 | listTyCon, 43 | pairTyCon, 44 | unitTyCon, 45 | ) where 46 | 47 | import Name 48 | import Data.Char 49 | import Data.String 50 | import Data.List (foldl') 51 | 52 | data Type 53 | = TVar TVar 54 | | TCon TyCon 55 | | TApp Type Type 56 | | TArr Type Type 57 | | TForall [Pred] [TVar] Type 58 | deriving (Show, Eq, Ord) 59 | 60 | data Kind 61 | = KStar 62 | | KArr Kind Kind 63 | | KPrim 64 | | KVar Name 65 | deriving (Show, Eq, Ord) 66 | 67 | data TyCon 68 | = AlgTyCon { tyId :: Name } 69 | | PrimTyCon { tyId :: Name } 70 | deriving (Show, Eq, Ord) 71 | 72 | data Pred 73 | = IsIn Name Type 74 | deriving (Show, Eq, Ord) 75 | 76 | ------------------------------------------------------------------------------- 77 | -- Type Variables 78 | ------------------------------------------------------------------------------- 79 | 80 | data TVar = TV 81 | { tvName :: Name 82 | } deriving (Show, Eq, Ord) 83 | 84 | instance IsString TVar where 85 | fromString x = TV (fromString x) 86 | 87 | instance IsString TyCon where 88 | fromString = AlgTyCon . fromString 89 | 90 | ------------------------------------------------------------------------------- 91 | -- Alpha Equivalence 92 | ------------------------------------------------------------------------------- 93 | 94 | class Alpha a where 95 | aeq :: a -> a -> Bool 96 | 97 | instance Alpha TVar where 98 | aeq _ _ = True 99 | 100 | instance Alpha Type where 101 | aeq (TVar _) (TVar _) = True 102 | aeq (TApp a b) (TApp c d) = aeq a c && aeq b d 103 | aeq (TArr a b) (TArr c d) = aeq a c && aeq b d 104 | aeq (TCon a) (TCon b) = a == b 105 | aeq _ _ = False 106 | 107 | instance Alpha Kind where 108 | aeq KStar KStar = True 109 | aeq KPrim KPrim = True 110 | aeq (KArr a b) (KArr c d) = aeq a c && aeq b d 111 | aeq _ _ = False 112 | 113 | ------------------------------------------------------------------------------- 114 | -- Transformations 115 | ------------------------------------------------------------------------------- 116 | 117 | predicates :: Type -> [Pred] 118 | predicates (TForall pd _ _) = pd 119 | 120 | predicate :: [Pred] -> Type -> Type 121 | predicate pd (TForall _ as ty) = TForall pd as ty 122 | 123 | ------------------------------------------------------------------------------- 124 | -- Deconstructors 125 | ------------------------------------------------------------------------------- 126 | 127 | viewTArr :: Type -> [Type] 128 | viewTArr (TArr t1 t2) = t1 : viewTArr t2 129 | viewTArr t = [t] 130 | 131 | 132 | viewTApp :: Type -> [Type] 133 | viewTApp t = go t [] 134 | where 135 | go (TApp t1 t2) acc = go t1 (t2:acc) 136 | go t1 acc = (t1 : acc) 137 | 138 | typeArity :: Type -> Int 139 | typeArity ty = length (viewTArr ty) 140 | 141 | ------------------------------------------------------------------------------- 142 | -- Constructors 143 | ------------------------------------------------------------------------------- 144 | 145 | mkTArr :: [Type] -> Type 146 | mkTArr [] = error "not defined for empty lists" 147 | mkTArr [t] = t 148 | mkTArr (t:ts) = TArr t (mkTArr ts) 149 | 150 | mkTApp :: TyCon -> [Type] -> Type 151 | mkTApp tcon args = foldl' TApp (TCon tcon) args 152 | 153 | mkTPair :: [Type] -> Type 154 | mkTPair = foldr1 pair 155 | where pair x y = mkTApp (AlgTyCon "Pair") [x,y] 156 | 157 | mkTList :: Type -> Type 158 | mkTList tp 159 | = TApp (TCon (AlgTyCon "List")) tp 160 | 161 | ------------------------------------------------------------------------------- 162 | -- Wired-in Types 163 | ------------------------------------------------------------------------------- 164 | 165 | -- | @ Int# @ 166 | tyInt :: Type 167 | tyInt = TCon intTyCon 168 | 169 | -- | @ Char# @ 170 | tyChar :: Type 171 | tyChar = TCon charTyCon 172 | 173 | -- | @ Addr# @ 174 | tyAddr :: Type 175 | tyAddr = TCon addrTyCon 176 | 177 | -- | @ Bool @ 178 | tyBool :: Type 179 | tyBool = TCon (AlgTyCon "Bool") 180 | 181 | -- | @ \[\] @ 182 | tyList :: Type 183 | tyList = TCon listTyCon 184 | 185 | -- | @ (,) @ 186 | tyPair :: Type 187 | tyPair = TCon pairTyCon 188 | 189 | -- | @ () @ 190 | tyUnit :: Type 191 | tyUnit = TCon unitTyCon 192 | 193 | 194 | -- | Int# 195 | intTyCon :: TyCon 196 | intTyCon = PrimTyCon "Int" 197 | 198 | -- | Char# 199 | charTyCon :: TyCon 200 | charTyCon = PrimTyCon "Char" 201 | 202 | -- | Addr# 203 | addrTyCon :: TyCon 204 | addrTyCon = PrimTyCon "Addr" 205 | 206 | -- | List 207 | listTyCon :: TyCon 208 | listTyCon = AlgTyCon "List" 209 | 210 | -- | Pair 211 | pairTyCon :: TyCon 212 | pairTyCon = AlgTyCon "Pair" 213 | 214 | unitTyCon :: TyCon 215 | unitTyCon = AlgTyCon "Unit" 216 | 217 | -- | (->) 218 | tyArrow :: Type 219 | tyArrow = TCon (AlgTyCon "->") 220 | -------------------------------------------------------------------------------- /chapter9/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/chapter9/.gitkeep -------------------------------------------------------------------------------- /chapter9/assign/.gitignore: -------------------------------------------------------------------------------- 1 | Lexer.hs 2 | Parser.hs 3 | Main 4 | -------------------------------------------------------------------------------- /chapter9/assign/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 | -------------------------------------------------------------------------------- /chapter9/assign/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 = alexScanTokens 37 | 38 | } 39 | -------------------------------------------------------------------------------- /chapter9/assign/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 | -------------------------------------------------------------------------------- /chapter9/assign/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | alex Lexer.x 3 | happy Parser.y 4 | ghc --make Main -o Main 5 | clean: 6 | rm -f *.o *.hi Parser.hs Lexer.hs Main 7 | -------------------------------------------------------------------------------- /chapter9/assign/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Parser ( 5 | parseExpr, 6 | ) where 7 | 8 | import Lexer 9 | import Syntax 10 | 11 | import Control.Monad.Except 12 | } 13 | 14 | %name expr 15 | %tokentype { Token } 16 | %monad { Except String } { (>>=) } { return } 17 | %error { parseError } 18 | 19 | %token 20 | int { TokenNum $$ } 21 | var { TokenSym $$ } 22 | print { TokenPrint } 23 | '=' { TokenEq } 24 | 25 | %% 26 | 27 | terms 28 | : term { [$1] } 29 | | term terms { $1 : $2 } 30 | 31 | term 32 | : var { Var $1 } 33 | | var '=' int { Assign $1 $3 } 34 | | print term { Print $2 } 35 | 36 | { 37 | 38 | parseError :: [Token] -> Except String a 39 | parseError (l:ls) = throwError (show l) 40 | parseError [] = throwError "Unexpected end of Input" 41 | 42 | parseExpr :: String -> Either String [Expr] 43 | parseExpr input = 44 | let tokenStream = scanTokens input in 45 | runExcept (expr tokenStream) 46 | } 47 | -------------------------------------------------------------------------------- /chapter9/assign/README.md: -------------------------------------------------------------------------------- 1 | Assign 2 | ------ 3 | 4 | ```bash 5 | $ stack exec assign input.test 6 | ``` 7 | -------------------------------------------------------------------------------- /chapter9/assign/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 | -------------------------------------------------------------------------------- /chapter9/assign/assign.cabal: -------------------------------------------------------------------------------- 1 | name: assign 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.9 10 | , containers >= 0.5 && <0.6 11 | , mtl >= 2.2 12 | default-language: Haskell2010 13 | main-is: Main.hs 14 | 15 | Build-depends: base, array 16 | build-tools: alex, happy 17 | other-modules: 18 | Parser, 19 | Lexer 20 | -------------------------------------------------------------------------------- /chapter9/assign/input.test: -------------------------------------------------------------------------------- 1 | x = 4 2 | print x 3 | y = 5 4 | print y 5 | y = 6 6 | print y 7 | -------------------------------------------------------------------------------- /chapter9/assign/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-3.16 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /chapter9/attoparsec/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} 3 | 4 | import Control.Applicative 5 | import Data.Attoparsec.Text 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as T 8 | import Data.List (foldl1') 9 | 10 | data Name 11 | = Gen Int 12 | | Name T.Text 13 | deriving (Eq, Show, Ord) 14 | 15 | data Expr 16 | = Var Name 17 | | App Expr Expr 18 | | Lam [Name] Expr 19 | | Lit Int 20 | | Prim PrimOp 21 | deriving (Eq, Show) 22 | 23 | data PrimOp 24 | = Add 25 | | Sub 26 | | Mul 27 | | Div 28 | deriving (Eq, Show) 29 | 30 | data Defn = Defn Name Expr 31 | deriving (Eq, Show) 32 | 33 | name :: Parser Name 34 | name = Name . T.pack <$> many1 letter 35 | 36 | num :: Parser Expr 37 | num = Lit <$> signed decimal 38 | 39 | var :: Parser Expr 40 | var = Var <$> name 41 | 42 | lam :: Parser Expr 43 | lam = do 44 | string "\\" 45 | vars <- many1 (skipSpace *> name) 46 | skipSpace *> string "->" 47 | body <- expr 48 | return (Lam vars body) 49 | 50 | eparen :: Parser Expr 51 | eparen = char '(' *> expr <* skipSpace <* char ')' 52 | 53 | prim :: Parser Expr 54 | prim = Prim <$> ( 55 | char '+' *> return Add 56 | <|> char '-' *> return Sub 57 | <|> char '*' *> return Mul 58 | <|> char '/' *> return Div) 59 | 60 | expr :: Parser Expr 61 | expr = foldl1' App <$> many1 (skipSpace *> atom) 62 | 63 | atom :: Parser Expr 64 | atom = try lam 65 | <|> eparen 66 | <|> prim 67 | <|> var 68 | <|> num 69 | 70 | def :: Parser Defn 71 | def = do 72 | skipSpace 73 | nm <- name 74 | skipSpace *> char '=' *> skipSpace 75 | ex <- expr 76 | skipSpace <* char ';' 77 | return $ Defn nm ex 78 | 79 | file :: T.Text -> Either String [Defn] 80 | file = parseOnly (many def <* skipSpace) 81 | 82 | parseFile :: FilePath -> IO (Either T.Text [Defn]) 83 | parseFile path = do 84 | contents <- T.readFile path 85 | case file contents of 86 | Left a -> return $ Left (T.pack a) 87 | Right b -> return $ Right b 88 | 89 | main :: IO (Either T.Text [Defn]) 90 | main = parseFile "simple.ml" 91 | -------------------------------------------------------------------------------- /chapter9/attoparsec/simple.ml: -------------------------------------------------------------------------------- 1 | (\x -> x) 2 | -------------------------------------------------------------------------------- /chapter9/happy/.gitignore: -------------------------------------------------------------------------------- 1 | Lexer.hs 2 | Parser.hs 3 | Main 4 | -------------------------------------------------------------------------------- /chapter9/happy/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval ( 2 | runEval, 3 | ) where 4 | 5 | import Syntax 6 | 7 | import Control.Monad.Except 8 | import qualified Data.Map as Map 9 | 10 | data Value 11 | = VInt Integer 12 | | VBool Bool 13 | | VClosure String Expr (Eval.Scope) 14 | 15 | instance Show Value where 16 | show (VInt x) = show x 17 | show (VBool x) = show x 18 | show VClosure{} = "<>" 19 | 20 | type Eval t = Except String t 21 | 22 | type Scope = Map.Map String Value 23 | 24 | eval :: Eval.Scope -> Expr -> Eval Value 25 | eval env expr = case expr of 26 | Lit (LInt x) -> return $ VInt (fromIntegral x) 27 | Lit (LBool x) -> return $ VBool x 28 | Var x -> return $ env Map.! x 29 | Lam x body -> return (VClosure x body env) 30 | App a b -> do 31 | x <- eval env a 32 | y <- eval env b 33 | apply x y 34 | Op op a b -> do 35 | x <- eval env a 36 | y <- eval env b 37 | binop op x y 38 | 39 | binop :: Binop -> Value -> Value -> Eval Value 40 | binop Add (VInt a) (VInt b) = return $ VInt (a+b) 41 | binop Sub (VInt a) (VInt b) = return $ VInt (a-b) 42 | binop Mul (VInt a) (VInt b) = return $ VInt (a*b) 43 | binop Eql (VInt a) (VInt b) = return $ VBool (a==b) 44 | binop _ _ _ = throwError "Tried to do arithmetic operation over non-number" 45 | 46 | extend :: Scope -> String -> Value -> Scope 47 | extend env v t = Map.insert v t env 48 | 49 | apply :: Value -> Value -> Eval Value 50 | apply (VClosure v t0 e) t1 = eval (extend e v t1) t0 51 | apply _ _ = throwError "Tried to apply closure" 52 | 53 | emptyScope :: Scope 54 | emptyScope = Map.empty 55 | 56 | runEval :: Expr -> Either String Value 57 | runEval x = runExcept (eval emptyScope x) 58 | -------------------------------------------------------------------------------- /chapter9/happy/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Lexer ( 3 | Token(..), 4 | scanTokens 5 | ) where 6 | 7 | import Syntax 8 | 9 | import Control.Monad.Except 10 | 11 | } 12 | 13 | %wrapper "basic" 14 | 15 | $digit = 0-9 16 | $alpha = [a-zA-Z] 17 | $eol = [\n] 18 | 19 | tokens :- 20 | 21 | -- Whitespace insensitive 22 | $eol ; 23 | $white+ ; 24 | 25 | -- Comments 26 | "#".* ; 27 | 28 | -- Syntax 29 | let { \s -> TokenLet } 30 | True { \s -> TokenTrue } 31 | False { \s -> TokenFalse } 32 | in { \s -> TokenIn } 33 | $digit+ { \s -> TokenNum (read s) } 34 | "->" { \s -> TokenArrow } 35 | \= { \s -> TokenEq } 36 | \\ { \s -> TokenLambda } 37 | [\+] { \s -> TokenAdd } 38 | [\-] { \s -> TokenSub } 39 | [\*] { \s -> TokenMul } 40 | \( { \s -> TokenLParen } 41 | \) { \s -> TokenRParen } 42 | $alpha [$alpha $digit \_ \']* { \s -> TokenSym s } 43 | 44 | { 45 | 46 | data Token 47 | = TokenLet 48 | | TokenTrue 49 | | TokenFalse 50 | | TokenIn 51 | | TokenLambda 52 | | TokenNum Int 53 | | TokenSym String 54 | | TokenArrow 55 | | TokenEq 56 | | TokenAdd 57 | | TokenSub 58 | | TokenMul 59 | | TokenLParen 60 | | TokenRParen 61 | | TokenEOF 62 | deriving (Eq,Show) 63 | 64 | scanTokens :: String -> Except String [Token] 65 | scanTokens str = go ('\n',[],str) where 66 | go inp@(_,_bs,str) = 67 | case alexScan inp 0 of 68 | AlexEOF -> return [] 69 | AlexError _ -> throwError "Invalid lexeme." 70 | AlexSkip inp' len -> go inp' 71 | AlexToken inp' len act -> do 72 | res <- go inp' 73 | let rest = act (take len str) 74 | return (rest : res) 75 | 76 | } 77 | -------------------------------------------------------------------------------- /chapter9/happy/Main.hs: -------------------------------------------------------------------------------- 1 | import Syntax (Expr) 2 | import Eval (runEval) 3 | import Parser (parseExpr, parseTokens) 4 | 5 | import Control.Monad.Trans 6 | import System.Console.Haskeline 7 | 8 | process :: String -> IO () 9 | process input = do 10 | let tokens = parseTokens input 11 | putStrLn ("Tokens: " ++ show tokens) 12 | let ast = parseExpr input 13 | putStrLn ("Syntax: " ++ show ast) 14 | case ast of 15 | Left err -> do 16 | putStrLn "Parse Error:" 17 | print err 18 | Right ast -> exec ast 19 | 20 | exec :: Expr -> IO () 21 | exec ast = do 22 | let result = runEval ast 23 | case result of 24 | Left err -> do 25 | putStrLn "Runtime Error:" 26 | putStrLn err 27 | Right res -> print res 28 | 29 | main :: IO () 30 | main = runInputT defaultSettings loop 31 | where 32 | loop = do 33 | minput <- getInputLine "Happy> " 34 | case minput of 35 | Nothing -> outputStrLn "Goodbye." 36 | Just input -> (liftIO $ process input) >> loop 37 | -------------------------------------------------------------------------------- /chapter9/happy/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | alex Lexer.x 3 | happy Parser.y 4 | ghc --make Main -o Main 5 | clean: 6 | rm -f *.o *.hi Parser.hs Lexer.hs Main 7 | -------------------------------------------------------------------------------- /chapter9/happy/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Parser ( 5 | parseExpr, 6 | parseTokens, 7 | ) where 8 | 9 | import Lexer 10 | import Syntax 11 | 12 | import Control.Monad.Except 13 | 14 | } 15 | 16 | -- Entry point 17 | %name expr 18 | 19 | -- Entry point 20 | %name expr 21 | 22 | -- Lexer structure 23 | %tokentype { Token } 24 | 25 | -- Parser monad 26 | %monad { Except String } { (>>=) } { return } 27 | %error { parseError } 28 | 29 | -- Token Names 30 | %token 31 | let { TokenLet } 32 | true { TokenTrue } 33 | false { TokenFalse } 34 | in { TokenIn } 35 | NUM { TokenNum $$ } 36 | VAR { TokenSym $$ } 37 | '\\' { TokenLambda } 38 | '->' { TokenArrow } 39 | '=' { TokenEq } 40 | '+' { TokenAdd } 41 | '-' { TokenSub } 42 | '*' { TokenMul } 43 | '(' { TokenLParen } 44 | ')' { TokenRParen } 45 | 46 | -- Operators 47 | %left '+' '-' 48 | %left '*' 49 | %% 50 | 51 | Expr : let VAR '=' Expr in Expr { App (Lam $2 $6) $4 } 52 | | '\\' VAR '->' Expr { Lam $2 $4 } 53 | | Form { $1 } 54 | 55 | Form : Form '+' Form { Op Add $1 $3 } 56 | | Form '-' Form { Op Sub $1 $3 } 57 | | Form '*' Form { Op Mul $1 $3 } 58 | | Fact { $1 } 59 | 60 | Fact : Fact Atom { App $1 $2 } 61 | | Atom { $1 } 62 | 63 | Atom : '(' Expr ')' { $2 } 64 | | NUM { Lit (LInt $1) } 65 | | VAR { Var $1 } 66 | | true { Lit (LBool True) } 67 | | false { Lit (LBool False) } 68 | 69 | { 70 | 71 | parseError :: [Token] -> Except String a 72 | parseError (l:ls) = throwError (show l) 73 | parseError [] = throwError "Unexpected end of Input" 74 | 75 | parseExpr :: String -> Either String Expr 76 | parseExpr input = runExcept $ do 77 | tokenStream <- scanTokens input 78 | expr tokenStream 79 | 80 | parseTokens :: String -> Either String [Token] 81 | parseTokens = runExcept . scanTokens 82 | 83 | } 84 | -------------------------------------------------------------------------------- /chapter9/happy/README.md: -------------------------------------------------------------------------------- 1 | Happy 2 | ===== 3 | 4 | A simple example use of the Happy/Alex toolchain to generate parsers. 5 | 6 | To compile and run: 7 | 8 | ```shell 9 | $ cabal run 10 | ``` 11 | 12 | Usage: 13 | 14 | ```ocaml 15 | Happy> 42 16 | Tokens: [TokenNum 42] 17 | Syntax: Right (Lit (LInt 42)) 18 | 42 19 | 20 | Happy> (\x -> x) 1 21 | Tokens: [TokenLParen,TokenLambda,TokenSym "x",TokenArrow,TokenSym "x",TokenRParen,TokenNum 1] 22 | Syntax: Right (App (Lam "x" (Var "x")) (Lit (LInt 1))) 23 | 1 24 | ``` 25 | 26 | License 27 | ======= 28 | 29 | Released under MIT license. 30 | -------------------------------------------------------------------------------- /chapter9/happy/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | 3 | type Name = String 4 | 5 | data Expr 6 | = Lam Name Expr 7 | | App Expr Expr 8 | | Var Name 9 | | Lit Lit 10 | | Op Binop Expr Expr 11 | deriving (Eq,Show) 12 | 13 | data Lit 14 | = LInt Int 15 | | LBool Bool 16 | deriving (Show, Eq, Ord) 17 | 18 | data Binop = Add | Sub | Mul | Eql 19 | deriving (Eq, Ord, Show) 20 | -------------------------------------------------------------------------------- /chapter9/happy/happyParser.cabal: -------------------------------------------------------------------------------- 1 | name: happyParser 2 | version: 0.1.0.0 3 | license: MIT 4 | author: Stephen Diehl 5 | maintainer: stephen.m.diehl@gmail.com 6 | build-type: Simple 7 | extra-source-files: README.md 8 | cabal-version: >=1.10 9 | 10 | executable happyParser 11 | build-depends: 12 | base >= 4.6 && <4.9 13 | , pretty >= 1.1 && <1.2 14 | , parsec >= 3.1 && <3.2 15 | , containers >= 0.5 && <0.7 16 | , haskeline >= 0.7 17 | , mtl >= 2.2 && <2.4 18 | , transformers 19 | default-language: Haskell2010 20 | main-is: Main.hs 21 | 22 | Build-depends: base, array 23 | build-tools: alex, happy 24 | other-modules: 25 | Parser, 26 | Lexer, 27 | Syntax, 28 | Eval 29 | -------------------------------------------------------------------------------- /chapter9/happy/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-3.16 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /chapter9/layout/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Layout ( 4 | -- * Layout combinators 5 | IParsec, 6 | laidout, 7 | indented, 8 | align, 9 | runIndentParser, 10 | ) where 11 | 12 | import Data.Text.Lazy 13 | 14 | import Text.Parsec (ParseError) 15 | import Text.Parsec.Pos 16 | import Text.Parsec.Prim hiding (State) 17 | 18 | import Control.Monad.Identity 19 | import Control.Applicative ((<$>)) 20 | 21 | -- Indentation sensitive Parsec monad. 22 | type IParsec a = Parsec Text ParseState a 23 | 24 | data ParseState = ParseState 25 | { indents :: Column 26 | } deriving (Show) 27 | 28 | initParseState :: ParseState 29 | initParseState = ParseState 0 30 | 31 | indentCmp 32 | :: (Column -> Column -> Bool) 33 | -> IParsec () 34 | indentCmp cmp = do 35 | col <- sourceColumn <$> getPosition 36 | current <- indents <$> getState 37 | guard (col `cmp` current) 38 | 39 | withIndent :: Monad m =>Column-> Column -> ParsecT s ParseState m b -> ParsecT s ParseState m b 40 | withIndent cur pos m = do 41 | modifyState $ \st -> st { indents = pos } 42 | res <- m 43 | modifyState $ \st -> st { indents = cur } 44 | return res 45 | 46 | laidout :: Parsec s ParseState a -> Parsec s ParseState a 47 | laidout m = do 48 | cur <- indents <$> getState 49 | pos <- sourceColumn <$> getPosition 50 | res <- withIndent cur pos m 51 | return res 52 | 53 | indented :: IParsec () 54 | indented = indentCmp (>) "Block (indented)" 55 | 56 | align :: IParsec () 57 | align = indentCmp (==) "Block (same indentation)" 58 | 59 | runIndentParser 60 | :: Stream Text Identity a 61 | => SourceName 62 | -> IParsec a 63 | -> Text 64 | -> Either ParseError a 65 | runIndentParser filePath p = runParser p initParseState filePath 66 | -------------------------------------------------------------------------------- /chapter9/operators/test.fun: -------------------------------------------------------------------------------- 1 | infixl 3 ($); 2 | infixr 4 (#); 3 | 4 | infix 4 (.); 5 | 6 | prefix 10 (-); 7 | postfix 10 (!); 8 | 9 | let a = y in a $ a $ (-a)!; 10 | let b = y in a # a # a $ b; 11 | let c = y in a # a # a # b; 12 | -------------------------------------------------------------------------------- /chapter9/provenance/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer where 2 | 3 | import Text.Parsec 4 | import Text.Parsec.Text.Lazy 5 | import qualified Data.Text.Lazy as L 6 | import qualified Text.Parsec.Token as Tok 7 | import qualified Text.Parsec.Expr as Ex 8 | 9 | import Data.Functor.Identity 10 | 11 | type Op a = Ex.Operator L.Text () Identity a 12 | type Operators a = Ex.OperatorTable L.Text () Identity a 13 | 14 | reservedNames :: [String] 15 | reservedNames = [ 16 | "let", 17 | "in", 18 | "fix", 19 | "rec", 20 | "if", 21 | "then", 22 | "else" 23 | ] 24 | 25 | reservedOps :: [String] 26 | reservedOps = [ 27 | "->", 28 | "\\", 29 | "+", 30 | "*", 31 | "-", 32 | "=" 33 | ] 34 | 35 | lexer :: Tok.GenTokenParser L.Text () Identity 36 | lexer = Tok.makeTokenParser $ Tok.LanguageDef 37 | { Tok.commentStart = "{-" 38 | , Tok.commentEnd = "-}" 39 | , Tok.commentLine = "--" 40 | , Tok.nestedComments = True 41 | , Tok.identStart = letter 42 | , Tok.identLetter = alphaNum <|> oneOf "_'" 43 | , Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" 44 | , Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 45 | , Tok.reservedNames = reservedNames 46 | , Tok.reservedOpNames = reservedOps 47 | , Tok.caseSensitive = True 48 | } 49 | 50 | reserved :: String -> Parser () 51 | reserved = Tok.reserved lexer 52 | 53 | reservedOp :: String -> Parser () 54 | reservedOp = Tok.reservedOp lexer 55 | 56 | identifier :: Parser String 57 | identifier = Tok.identifier lexer 58 | 59 | parens :: Parser a -> Parser a 60 | parens = Tok.parens lexer 61 | 62 | semiSep :: Parser a -> Parser [a] 63 | semiSep = Tok.semiSep lexer 64 | 65 | semi :: Parser String 66 | semi = Tok.semi lexer 67 | 68 | contents :: Parser a -> Parser a 69 | contents p = do 70 | Tok.whiteSpace lexer 71 | r <- p 72 | eof 73 | return r 74 | -------------------------------------------------------------------------------- /chapter9/provenance/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | import Syntax 7 | import Infer 8 | import Parser 9 | import Pretty 10 | 11 | import Data.Monoid 12 | import qualified Data.Map as Map 13 | import qualified Data.Text.Lazy as L 14 | import qualified Data.Text.Lazy.IO as L 15 | 16 | import Control.Monad.Identity 17 | import Control.Monad.State.Strict 18 | 19 | import Data.List (isPrefixOf) 20 | 21 | import System.Exit 22 | import System.Environment 23 | import System.Console.Repline 24 | 25 | ------------------------------------------------------------------------------- 26 | -- Types 27 | ------------------------------------------------------------------------------- 28 | 29 | data IState = IState 30 | { tyctx :: Env -- Type environment 31 | } 32 | 33 | initState :: IState 34 | initState = IState [] 35 | 36 | type Repl a = HaskelineT (StateT IState IO) a 37 | 38 | hoistErr :: Show e => Either e a -> Repl a 39 | hoistErr (Right val) = return val 40 | hoistErr (Left err) = do 41 | liftIO $ print err 42 | abort 43 | 44 | ------------------------------------------------------------------------------- 45 | -- Execution 46 | ------------------------------------------------------------------------------- 47 | 48 | exec :: Bool -> L.Text -> Repl () 49 | exec update source = do 50 | -- Get the current interpreter state 51 | st <- get 52 | 53 | -- Parser ( returns AST ) 54 | mod <- hoistErr $ parseExpr source 55 | 56 | -- Type Inference ( returns Typing Environment ) 57 | tyctx' <- hoistErr $ inferTop (tyctx st) mod 58 | liftIO $ putStrLn (pptype tyctx') 59 | return () 60 | 61 | showOutput :: String -> IState -> Repl () 62 | showOutput arg st = do 63 | case lookup "it" (tyctx st) of 64 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 65 | Nothing -> return () 66 | 67 | cmd :: String -> Repl () 68 | cmd source = exec True (L.pack source) 69 | 70 | ------------------------------------------------------------------------------- 71 | -- Commands 72 | ------------------------------------------------------------------------------- 73 | 74 | -- :browse command 75 | browse :: [String] -> Repl () 76 | browse _ = do 77 | st <- get 78 | undefined 79 | {-liftIO $ mapM_ putStrLn $ ppenv (tyctx st)-} 80 | 81 | -- :load command 82 | load :: [String] -> Repl () 83 | load args = do 84 | contents <- liftIO $ L.readFile (unwords args) 85 | exec True contents 86 | 87 | -- :type command 88 | typeof :: [String] -> Repl () 89 | typeof args = do 90 | st <- get 91 | let arg = unwords args 92 | case lookup arg (tyctx st) of 93 | Just val -> liftIO $ putStrLn $ ppsignature (arg, val) 94 | Nothing -> exec False (L.pack arg) 95 | 96 | -- :quit command 97 | quit :: a -> Repl () 98 | quit _ = liftIO $ exitSuccess 99 | 100 | ------------------------------------------------------------------------------- 101 | -- Interactive Shell 102 | ------------------------------------------------------------------------------- 103 | 104 | -- Prefix tab completer 105 | defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] 106 | defaultMatcher = [ 107 | (":load" , fileCompleter) 108 | --, (":type" , values) 109 | ] 110 | 111 | -- Default tab completer 112 | comp :: (Monad m, MonadState IState m) => WordCompleter m 113 | comp n = do 114 | let cmds = [":load", ":type", ":browse", ":quit"] 115 | ctx <- gets tyctx 116 | let defs = fmap fst ctx 117 | return $ filter (isPrefixOf n) (cmds ++ defs) 118 | 119 | options :: [(String, [String] -> Repl ())] 120 | options = [ 121 | ("load" , load) 122 | , ("browse" , browse) 123 | , ("quit" , quit) 124 | , ("type" , Main.typeof) 125 | ] 126 | 127 | ------------------------------------------------------------------------------- 128 | -- Entry Point 129 | ------------------------------------------------------------------------------- 130 | 131 | completer :: CompleterStyle (StateT IState IO) 132 | completer = Prefix (wordCompleter comp) defaultMatcher 133 | 134 | shell :: Repl a -> IO () 135 | shell pre = flip evalStateT initState 136 | $ evalRepl "Poly> " cmd options completer pre 137 | 138 | ------------------------------------------------------------------------------- 139 | -- Toplevel 140 | ------------------------------------------------------------------------------- 141 | 142 | main :: IO () 143 | main = do 144 | args <- getArgs 145 | case args of 146 | [] -> shell (return ()) 147 | [fname] -> shell (load [fname]) 148 | ["test", fname] -> shell (load [fname] >> browse [] >> quit ()) 149 | _ -> putStrLn "invalid arguments" 150 | -------------------------------------------------------------------------------- /chapter9/provenance/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Parser ( 4 | parseExpr, 5 | parseModule 6 | ) where 7 | 8 | import Text.Parsec 9 | import Text.Parsec.Text.Lazy (Parser) 10 | 11 | import qualified Text.Parsec.Expr as Ex 12 | import qualified Text.Parsec.Token as Tok 13 | 14 | import qualified Data.Text.Lazy as L 15 | 16 | import Lexer 17 | import Syntax 18 | 19 | import Control.Applicative ((<$>)) 20 | 21 | integer :: Parser Integer 22 | integer = Tok.integer lexer 23 | 24 | variable :: Parser Expr 25 | variable = do 26 | x <- identifier 27 | l <- sourceLine <$> getPosition 28 | return (Var (Located l) x) 29 | 30 | number :: Parser Expr 31 | number = do 32 | n <- integer 33 | l <- sourceLine <$> getPosition 34 | return (Lit (Located l) (fromIntegral n)) 35 | 36 | lambda :: Parser Expr 37 | lambda = do 38 | reservedOp "\\" 39 | args <- many identifier 40 | reservedOp "->" 41 | body <- expr 42 | l <- sourceLine <$> getPosition 43 | return $ foldr (Lam (Located l)) body args 44 | 45 | aexp :: Parser Expr 46 | aexp = parens expr 47 | <|> lambda 48 | <|> number 49 | <|> variable 50 | 51 | expr :: Parser Expr 52 | expr = do 53 | es <- many1 aexp 54 | l <- sourceLine <$> getPosition 55 | return (foldl1 (App (Located l)) es) 56 | 57 | type Binding = (String, Expr) 58 | 59 | val :: Parser Binding 60 | val = do 61 | ex <- expr 62 | return ("it", ex) 63 | 64 | top :: Parser Binding 65 | top = do 66 | x <- val 67 | optional semi 68 | return x 69 | 70 | modl :: Parser [Binding] 71 | modl = many top 72 | 73 | parseExpr :: L.Text -> Either ParseError Expr 74 | parseExpr input = parse (contents expr) "" input 75 | 76 | parseModule :: FilePath -> L.Text -> Either ParseError [(String, Expr)] 77 | parseModule fname input = parse (contents modl) fname input 78 | -------------------------------------------------------------------------------- /chapter9/provenance/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# Language FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# Language TypeSynonymInstances #-} 4 | 5 | module Pretty ( 6 | ppdecl, 7 | ppexpr, 8 | ppsignature, 9 | pptype 10 | ) where 11 | 12 | import Type 13 | import Syntax 14 | import Infer 15 | 16 | import Text.PrettyPrint 17 | 18 | parensIf :: Bool -> Doc -> Doc 19 | parensIf True = parens 20 | parensIf False = id 21 | 22 | class Pretty p where 23 | ppr :: Int -> p -> Doc 24 | pp :: p -> Doc 25 | pp = ppr 0 26 | 27 | instance Pretty Name where 28 | ppr _ x = text x 29 | 30 | instance Pretty TVar where 31 | ppr _ (TV x) = text x 32 | 33 | instance Pretty Type where 34 | ppr p (TArr _ a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b 35 | where 36 | isArrow TArr{} = True 37 | isArrow _ = False 38 | ppr p (TVar _ a) = ppr p a 39 | ppr _ (TCon _ a) = text a 40 | 41 | instance Pretty Expr where 42 | ppr p (Var _ a) = ppr p a 43 | ppr p (App _ a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b 44 | ppr p (Lam _ a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b 45 | ppr _ (Lit _ a) = int a 46 | 47 | instance Pretty Loc where 48 | ppr p (NoLoc) = "" 49 | ppr p (Located n) = int n 50 | 51 | instance Show TypeError where 52 | show (UnificationFail a la b lb) = 53 | concat [ 54 | "Cannot unify types: \n\t" 55 | , pptype a 56 | , "\n\tIntroduced at: " 57 | , (pploc la) 58 | , "\nwith \n\t" 59 | , pptype b 60 | , "\n\tIntroduced at: " 61 | , (pploc lb) 62 | ] 63 | show (InfiniteType (TV a) la b) = 64 | concat [ 65 | "Cannot construct the infinite type: " 66 | , a 67 | , " = " 68 | , pptype b 69 | , "\n\tIntroduced at: " 70 | , (pploc la) 71 | ] 72 | show (Ambigious cs) = 73 | concat ["Cannot not match expected type: '" ++ pptype a ++ "' with actual type: '" ++ pptype b ++ "'\n" | (a,b) <- cs] 74 | show (UnboundVariable a) = "Not in scope: " ++ a 75 | 76 | pploc :: Loc -> String 77 | pploc = render . ppr 0 78 | 79 | pptype :: Type -> String 80 | pptype = render . ppr 0 81 | 82 | ppexpr :: Expr -> String 83 | ppexpr = render . ppr 0 84 | 85 | ppsignature :: (String, Type) -> String 86 | ppsignature (a, b) = a ++ " : " ++ pptype b 87 | 88 | ppdecl :: (String, Expr) -> String 89 | ppdecl (a, b) = "let " ++ a ++ " = " ++ ppexpr b 90 | -------------------------------------------------------------------------------- /chapter9/provenance/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax ( 2 | Expr(..), 3 | Name, 4 | Loc(..), 5 | ) where 6 | 7 | type Name = String 8 | 9 | data Expr 10 | = Var Loc Name 11 | | App Loc Expr Expr 12 | | Lam Loc Name Expr 13 | | Lit Loc Int 14 | 15 | data Loc = NoLoc | Located Int 16 | deriving (Show, Eq, Ord) 17 | -------------------------------------------------------------------------------- /chapter9/provenance/Type.hs: -------------------------------------------------------------------------------- 1 | module Type ( 2 | Type(..), 3 | TVar(..), 4 | setLoc, 5 | getLoc, 6 | typeInt, 7 | ) where 8 | 9 | import Syntax (Loc(..), Name) 10 | 11 | data Type 12 | = TVar Loc TVar 13 | | TCon Loc Name 14 | | TArr Loc Type Type 15 | deriving (Show, Eq, Ord) 16 | 17 | newtype TVar = TV String 18 | deriving (Show, Eq, Ord) 19 | 20 | setLoc :: Loc -> Type -> Type 21 | setLoc l (TVar _ a) = TVar l a 22 | setLoc l (TCon _ a) = TCon l a 23 | setLoc l (TArr _ a b) = TArr l a b 24 | 25 | getLoc :: Type -> Loc 26 | getLoc (TVar l _) = l 27 | getLoc (TCon l _) = l 28 | getLoc (TArr l _ _) = l 29 | 30 | typeInt :: Type 31 | typeInt = TCon NoLoc "Int" 32 | -------------------------------------------------------------------------------- /deploy.sh: -------------------------------------------------------------------------------- 1 | cp tutorial.html index.html 2 | rsync -v *.html ec2:~ 3 | ssh ec2 'sudo mv *.html /srv/http/fun/' 4 | rsync -v WYAH.pdf ec2:~ 5 | ssh ec2 'sudo mv WYAH.pdf /srv/http/fun/' 6 | rm -f index.html 7 | -------------------------------------------------------------------------------- /img/.gitignore: -------------------------------------------------------------------------------- 1 | *.svg 2 | -------------------------------------------------------------------------------- /img/Haskell-Logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/Haskell-Logo.png -------------------------------------------------------------------------------- /img/Haskell-Logo.ps: -------------------------------------------------------------------------------- 1 | %!PS-Adobe-3.0 2 | %%Creator: cairo 1.10.2 (http://cairographics.org) 3 | %%CreationDate: Wed Jan 14 11:07:43 2015 4 | %%Pages: 1 5 | %%BoundingBox: 0 0 490 349 6 | %%DocumentData: Clean7Bit 7 | %%LanguageLevel: 2 8 | %%DocumentMedia: 173x123mm 490 348 0 () () 9 | %%EndComments 10 | %%BeginProlog 11 | /languagelevel where 12 | { pop languagelevel } { 1 } ifelse 13 | 2 lt { /Helvetica findfont 12 scalefont setfont 50 500 moveto 14 | (This print job requires a PostScript Language Level 2 printer.) show 15 | showpage quit } if 16 | /q { gsave } bind def 17 | /Q { grestore } bind def 18 | /cm { 6 array astore concat } bind def 19 | /w { setlinewidth } bind def 20 | /J { setlinecap } bind def 21 | /j { setlinejoin } bind def 22 | /M { setmiterlimit } bind def 23 | /d { setdash } bind def 24 | /m { moveto } bind def 25 | /l { lineto } bind def 26 | /c { curveto } bind def 27 | /h { closepath } bind def 28 | /re { exch dup neg 3 1 roll 5 3 roll moveto 0 rlineto 29 | 0 exch rlineto 0 rlineto closepath } bind def 30 | /S { stroke } bind def 31 | /f { fill } bind def 32 | /f* { eofill } bind def 33 | /n { newpath } bind def 34 | /W { clip } bind def 35 | /W* { eoclip } bind def 36 | /BT { } bind def 37 | /ET { } bind def 38 | /pdfmark where { pop globaldict /?pdfmark /exec load put } 39 | { globaldict begin /?pdfmark /pop load def /pdfmark 40 | /cleartomark load def end } ifelse 41 | /BDC { mark 3 1 roll /BDC pdfmark } bind def 42 | /EMC { mark /EMC pdfmark } bind def 43 | /cairo_store_point { /cairo_point_y exch def /cairo_point_x exch def } def 44 | /Tj { show currentpoint cairo_store_point } bind def 45 | /TJ { 46 | { 47 | dup 48 | type /stringtype eq 49 | { show } { -0.001 mul 0 cairo_font_matrix dtransform rmoveto } ifelse 50 | } forall 51 | currentpoint cairo_store_point 52 | } bind def 53 | /cairo_selectfont { cairo_font_matrix aload pop pop pop 0 0 6 array astore 54 | cairo_font exch selectfont cairo_point_x cairo_point_y moveto } bind def 55 | /Tf { pop /cairo_font exch def /cairo_font_matrix where 56 | { pop cairo_selectfont } if } bind def 57 | /Td { matrix translate cairo_font_matrix matrix concatmatrix dup 58 | /cairo_font_matrix exch def dup 4 get exch 5 get cairo_store_point 59 | /cairo_font where { pop cairo_selectfont } if } bind def 60 | /Tm { 2 copy 8 2 roll 6 array astore /cairo_font_matrix exch def 61 | cairo_store_point /cairo_font where { pop cairo_selectfont } if } bind def 62 | /g { setgray } bind def 63 | /rg { setrgbcolor } bind def 64 | /d1 { setcachedevice } bind def 65 | %%EndProlog 66 | %%Page: 1 1 67 | %%BeginPageSetup 68 | %%PageMedia: 173x123mm 69 | %%PageBoundingBox: 0 0 490 349 70 | %%EndPageSetup 71 | q 0 0 490 349 rectclip q 72 | 1 g 73 | 8 w 74 | 0 J 75 | 1 j 76 | [] 0.0 d 77 | 4 M q 1 0 0 -1 0 348.156311 cm 78 | 4.016 344.156 m 117.402 174.078 l 4.016 4 l 89.055 4 l 202.441 174.078 79 | l 89.055 344.156 l h 80 | 4.016 344.156 m S Q 81 | q 1 0 0 -1 0 348.156311 cm 82 | 117.402 344.156 m 230.789 174.078 l 117.402 4 l 202.441 4 l 429.211 83 | 344.156 l 344.172 344.156 l 273.309 237.859 l 202.441 344.156 l h 84 | 117.402 344.156 m S Q 85 | q 1 0 0 -1 0 348.156311 cm 86 | 391.418 244.945 m 353.625 188.254 l 485.906 188.25 l 485.906 244.945 l 87 | h 88 | 391.418 244.945 m S Q 89 | q 1 0 0 -1 0 348.156311 cm 90 | 334.727 159.906 m 296.93 103.215 l 485.906 103.211 l 485.906 159.906 l 91 | h 92 | 334.727 159.906 m S Q 93 | Q Q 94 | showpage 95 | %%Trailer 96 | %%EOF 97 | -------------------------------------------------------------------------------- /img/ModRM.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/ModRM.png -------------------------------------------------------------------------------- /img/ModRM_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/ModRM_example.png -------------------------------------------------------------------------------- /img/Prefix.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/Prefix.png -------------------------------------------------------------------------------- /img/Scale.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/Scale.png -------------------------------------------------------------------------------- /img/bits.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/bits.png -------------------------------------------------------------------------------- /img/coffee.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/coffee.png -------------------------------------------------------------------------------- /img/cover-kindle.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/cover-kindle.jpg -------------------------------------------------------------------------------- /img/cover.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/cover.png -------------------------------------------------------------------------------- /img/kinds.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | rankdir=BT 3 | node [shape=box] 4 | Values -> Types -> Kinds 5 | } 6 | -------------------------------------------------------------------------------- /img/lambda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/lambda.png -------------------------------------------------------------------------------- /img/memory_layout.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/memory_layout.png -------------------------------------------------------------------------------- /img/opcode.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/opcode.png -------------------------------------------------------------------------------- /img/pipeline1.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 300 ]; 3 | rankdir=LR 4 | node [shape=box] 5 | Source -> Parsing -> Desugar -> "Type Checking" -> Transformation -> Compilation 6 | } 7 | -------------------------------------------------------------------------------- /img/pipeline1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/pipeline1.png -------------------------------------------------------------------------------- /img/pipeline2.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 300 ]; 3 | rankdir=LR 4 | node [shape=box] 5 | Frontend -> "Core Language" -> "Compiler IR" -> "Machine Code" 6 | } 7 | -------------------------------------------------------------------------------- /img/pipeline2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/pipeline2.png -------------------------------------------------------------------------------- /img/proto.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 300 ]; 3 | rankdir=LR 4 | node [shape=box] 5 | Source -> Parsing -> Desugar -> Inference -> Transformation -> Compliation 6 | } 7 | -------------------------------------------------------------------------------- /img/proto_pass.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 300 ]; 3 | rankdir=LR 4 | node [shape=box] 5 | Parse -> Rename -> Typecheck -> Desugar -> ToCore -> Evaluate 6 | } 7 | -------------------------------------------------------------------------------- /img/proto_pass.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/proto_pass.png -------------------------------------------------------------------------------- /img/protohaskell.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 300 ]; 3 | rankdir=LR 4 | node [shape=box] 5 | Source -> Frontend -> Core -> PHOAS 6 | } 7 | -------------------------------------------------------------------------------- /img/protohaskell.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/protohaskell.png -------------------------------------------------------------------------------- /img/registers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/registers.png -------------------------------------------------------------------------------- /img/stack.dot: -------------------------------------------------------------------------------- 1 | digraph G { 2 | graph [ dpi = 72 ]; 3 | rankdir=TB 4 | node [shape=box] 5 | WriterT -> IO [label = " execWriterT"] 6 | StateT -> WriterT [label = " evalStateT"] 7 | Stack -> StateT [label = " unStack"] 8 | } 9 | -------------------------------------------------------------------------------- /img/stack.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/stack.png -------------------------------------------------------------------------------- /img/titles/.gitignore: -------------------------------------------------------------------------------- 1 | *.svg 2 | -------------------------------------------------------------------------------- /img/titles/basics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/basics.png -------------------------------------------------------------------------------- /img/titles/evaluation.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/evaluation.png -------------------------------------------------------------------------------- /img/titles/extended_parser.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/extended_parser.png -------------------------------------------------------------------------------- /img/titles/hindley_milner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/hindley_milner.png -------------------------------------------------------------------------------- /img/titles/introduction.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/introduction.png -------------------------------------------------------------------------------- /img/titles/kinds.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/kinds.png -------------------------------------------------------------------------------- /img/titles/lambda_calculus.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/lambda_calculus.png -------------------------------------------------------------------------------- /img/titles/llvm.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/llvm.png -------------------------------------------------------------------------------- /img/titles/ml.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/ml.png -------------------------------------------------------------------------------- /img/titles/parsing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/parsing.png -------------------------------------------------------------------------------- /img/titles/protohaskell.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/protohaskell.png -------------------------------------------------------------------------------- /img/titles/stg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/stg.png -------------------------------------------------------------------------------- /img/titles/systemf.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/systemf.png -------------------------------------------------------------------------------- /img/titles/type_systems.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdiehl/write-you-a-haskell/ae73485e045ef38f50846b62bd91777a9943d1f7/img/titles/type_systems.png -------------------------------------------------------------------------------- /includes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Text.Read 4 | import Control.Monad.State 5 | import Control.Monad 6 | import Text.Pandoc 7 | import Data.Monoid 8 | import Control.Applicative 9 | 10 | import Text.Pandoc.JSON 11 | import Text.Pandoc.Walk 12 | 13 | slice :: Int -> Int -> [a] -> [a] 14 | slice from to xs = take (to - from + 1) (drop from xs) 15 | 16 | doSlice :: Block -> IO Block 17 | doSlice cb@(CodeBlock (id, classes, namevals) contents) = do 18 | res <- return $ do 19 | upper <- readMaybe =<< lookup "upper" namevals 20 | lower <- readMaybe =<< lookup "lower" namevals 21 | file <- lookup "slice" namevals 22 | return (upper, lower, file) 23 | 24 | case res of 25 | Nothing -> return cb 26 | Just (upper, lower, f) -> do 27 | contents <- readFile f 28 | let lns = unlines $ slice lower upper (lines contents) 29 | return (CodeBlock (id, classes, namevals) lns) 30 | doSlice x = return x 31 | 32 | doInclude :: Block -> IO Block 33 | doInclude cb@(CodeBlock (id, classes, namevals) contents) = 34 | case lookup "include" namevals of 35 | Just f -> return . (CodeBlock (id, classes, namevals)) =<< readFile f 36 | Nothing -> return cb 37 | doInclude x = return x 38 | 39 | doHtml :: Block -> IO Block 40 | doHtml cb@(CodeBlock (id, classes, namevals) contents) = 41 | case lookup "literal" namevals of 42 | Just f -> return . (RawBlock "html") =<< readFile f 43 | Nothing -> return cb 44 | doHtml x = return x 45 | 46 | injectLatexMacros :: Maybe Format -> Pandoc -> IO Pandoc 47 | injectLatexMacros (Just fmt) p = do 48 | macros <- readFile "latex_macros" 49 | let block = 50 | case fmt of 51 | Format "html" -> 52 | Div ("",[],[("style","display:none")]) . (:[]) 53 | . Para . (:[]) . Math DisplayMath $ macros 54 | Format "latex" -> RawBlock "latex" macros 55 | Format "epub" -> RawBlock "latex" macros 56 | return (Pandoc nullMeta [block] <> p) 57 | injectLatexMacros _ _ = return mempty 58 | 59 | main :: IO () 60 | main = toJSONFilter 61 | ((\fmt -> injectLatexMacros fmt 62 | >=> walkM doInclude 63 | >=> walkM doSlice 64 | >=> walkM doHtml) :: Maybe Format -> Pandoc -> IO Pandoc) 65 | -------------------------------------------------------------------------------- /index.md: -------------------------------------------------------------------------------- 1 | 6 | 7 |

8 |

9 | 10 | 13 | 14 | 17 | 18 |

19 | Building a modern functional compiler from first principles. 20 |

21 | 22 |

23 | [Stephen Diehl](https://twitter.com/smdiehl) 24 |

25 | 26 |

27 |

28 | 29 |

30 |

31 | 32 | In 2014 I wrote a [short tutorial](http://www.stephendiehl.com/llvm/) about 33 | building a small imperative language in Haskell that compiled into LLVM. I was 34 | extremely happy with the effect the tutorial seemed to have, and the warm 35 | response I got from so many people was very encouraging. 36 | 37 | I've done a great bit of thinking about what the most impactful topic I could 38 | write about in 2015 could be; and decided throughout this year I will follow up 39 | with a large endeavor for another project-based tutorial on *building a simple 40 | functional programming language from first principles*. 41 | 42 | This is a nontrivial topic and is unfortunately very much underserved, the 43 | knowledge to build such a modern functional language is not widely disseminated 44 | among many programmers. The available resources most often discuss language 45 | theory in depth while completely glossing over the engineering details. I wished 46 | to write a project-based tutorial that included the engineering details and left 47 | the reader with a fully functional toy language at the end that could be 48 | extended for further projects. 49 | 50 | We will build a small functional language called *Fun* which is a partial 51 | Haskell 2010 toy language; complete with a parser, type inference, datatypes, 52 | pattern matching, desugaring, typeclasses, higher-kinded types, monadic IO, 53 | arbitrary-rank polymorphism, records, Core language, STG intermediate language, 54 | lazy evaluation, interpreter, native code generator, a runtime, and several 55 | optimization passes. 56 | 57 | As with most of my writing, this is the pre-edited rough cut version, which I 58 | will refine over time. 59 | 60 | * [Chapter 1: Introduction](000_introduction.html) 61 | * [Chapter 2: Haskell Basics](001_basics.html) 62 | * [Chapter 3: Parsing](002_parsers.html) 63 | * [Chapter 4: Lambda Calculus](003_lambda_calculus.html) 64 | * [Chapter 5: Type Systems](004_type_systems.html) 65 | * [Chapter 6: Evaluation](005_evaluation.html) 66 | * [Chapter 7: Hindley-Milner Inference](006_hindley_milner.html) 67 | * [Chapter 8: Design of ProtoHaskell](007_path.html) 68 | * [Chapter 9: Extended Parser](http://dev.stephendiehl.com/fun/008_extended_parser.html) 69 | * [Chapter 10: Custom Datatypes](http://dev.stephendiehl.com/fun/009_datatypes.html) 70 | * Chapter 11: Renamer 71 | * Chapter 12: Pattern Matching & Desugaring 72 | * Chapter 13: System-F 73 | * Chapter 14: Type Classes 74 | * Chapter 15: Core Language 75 | * Chapter 16: Kinds 76 | * Chapter 17: Haskell Type Checker 77 | * Chapter 18: Core Interpreter 78 | * Chapter 19: Prelude 79 | * Chapter 20: Design of Lazy Evaluation 80 | * Chapter 21: STG 81 | * Chapter 22: Compilation 82 | * Chapter 23: Design of the Runtime 83 | * Chapter 24: Imp 84 | * Chapter 25: Code Generation ( C ) 85 | * Chapter 26: Code Generation ( LLVM ) 86 | * Chapter 27: Row Polymorphism & Effect Typing 87 | * Chapter 28: Future Work 88 | 89 | *** 90 | 91 | Addendum 92 | -------- 93 | 94 | * [Contributing](contributing.html) 95 | 96 | License 97 | ------- 98 | 99 | This written work is licensed under a Creative Commons 101 | Attribution-NonCommercial-ShareAlike 4.0 International License. You may 102 | reproduce and edit this work with attribution for all non-commercial purposes. 103 | 104 | The included source is released under the terms of the [MIT License](http://opensource.org/licenses/MIT). 105 | -------------------------------------------------------------------------------- /js/nav.js: -------------------------------------------------------------------------------- 1 | // Adapted from Javascript Garden, a MIT project. 2 | function Sections(page) { 3 | this.page = page; 4 | this.init(); 5 | } 6 | 7 | Sections.prototype = { 8 | init: function(attribute) { 9 | this.heights = this.page.nav.find('ul').map(function(idx, ele) { 10 | return $(this).outerHeight(); 11 | }).get(); 12 | }, 13 | 14 | map: function() { 15 | this.names = $('h2').map(function(idx, ele) { 16 | return { 17 | id: this.id, 18 | offset: $(this).offset().top + 30, 19 | title: $(this).find(':header:first').html() 20 | }; 21 | }).get(); 22 | }, 23 | 24 | highlight: function() { 25 | 26 | var scroll = this.page.window.scrollTop(), 27 | articleID = this.names[this.names.length - 1].id; 28 | 29 | $('a').removeClass('active'); 30 | 31 | var $el; 32 | 33 | for(var i = 0, l = this.names.length; i < l; i++) { 34 | if (this.names[i].offset > scroll) { 35 | $el = $("[href='#" + this.names[i].id + "']"); 36 | var s = $el.parents('ul')[0]; 37 | 38 | // $el.addClass('active'); 39 | 40 | if (s !== window.section) { 41 | //$(window.section).slideUp(); 42 | $(window.section).hide(); 43 | //$(s).slideDown(); 44 | $(s).show(); 45 | window.section = s; 46 | } 47 | 48 | break; 49 | } 50 | } 51 | }, 52 | 53 | updateLinks: function(index) { 54 | if (index !== this.names.length - 1) { 55 | this.setLink(this.links.next, this.names[index + 1]); 56 | } else { 57 | //this.links.next.slideUp(100); 58 | this.links.next.hide(); 59 | } 60 | 61 | if (index !== 0) { 62 | this.setLink(this.links.prev, this.names[index - 1]); 63 | } else { 64 | //this.links.prev.slideUp(100); 65 | this.links.next.hide(); 66 | } 67 | }, 68 | 69 | setLink: function(ele, data) { 70 | ele.slideDown(100).attr('href', '#' + data.id) 71 | .find('.nav_section_name').html(data.title); 72 | } 73 | }; 74 | 75 | function Page() { 76 | $.extend(true, this, { 77 | window: $(window), 78 | nav: $('.nav > ul > li'), 79 | section: null, 80 | articule: null 81 | }); 82 | 83 | this.sections = new Sections(this); 84 | this.init(); 85 | } 86 | 87 | Page.prototype = { 88 | init: function() { 89 | var that = this, 90 | mainNav = $('.toc'); 91 | 92 | $.extend(this, { 93 | scrollLast: 0, 94 | resizeTimeout: null 95 | }); 96 | 97 | this.window.scroll(function() { 98 | that.onScroll(); 99 | }); 100 | 101 | this.window.resize(function() { 102 | that.onResize(); 103 | }); 104 | 105 | that.sections.map(); 106 | setTimeout(function() { 107 | that.sections.highlight(); 108 | }, 10); 109 | }, 110 | 111 | onScroll: function() { 112 | if ((+new Date()) - this.scrollLast > 50) { 113 | this.scrollLast = +new Date(); 114 | this.sections.highlight(); 115 | } 116 | }, 117 | 118 | onResize: function() { 119 | clearTimeout(this.resizeTimeout); 120 | } 121 | }; 122 | 123 | $(document).ready(function() { 124 | if ($(window).width() > 481) { 125 | var page = new Page(); 126 | page.scrolllast = new Date(); 127 | } 128 | 129 | //$('.side ul ul').hide(); 130 | //$('.side ul ul').first().show(); 131 | }); 132 | -------------------------------------------------------------------------------- /latex_macros: -------------------------------------------------------------------------------- 1 | \newcommand{\andalso}{\quad\quad} 2 | \newcommand{\infabbrev}[2]{\infax{#1 \quad\eqdef\quad #2}} 3 | \newcommand{\infrule}[2]{\displaystyle \dfrac{#1}{#2}} 4 | \newcommand{\ar}{\rightarrow} 5 | \newcommand{\Int}{\mathtt{Int}} 6 | \newcommand{\Bool}{\mathtt{Bool}} 7 | \newcommand{\becomes}{\Downarrow} 8 | \newcommand{\trule}[1]{(\textbf{#1})} 9 | \newcommand{\FV}[1]{\mathtt{fv}(#1)} 10 | \newcommand{\FTV}[1]{\mathtt{ftv}(#1)} 11 | \newcommand{\BV}[1]{\mathtt{bv}(#1)} 12 | \newcommand{\compiles}[1]{\text{C}\llbracket{#1}\rrbracket} 13 | \newcommand{\exec}[1]{\text{E}\llbracket{#1}\rrbracket} 14 | \renewcommand{\t}[1]{\mathtt{#1}} 15 | \newcommand{\ite}[3]{\text{if }#1\text{ then }#2\text{ else }#3} 16 | -------------------------------------------------------------------------------- /misc/rssgen.py: -------------------------------------------------------------------------------- 1 | import datetime 2 | import PyRSS2Gen 3 | 4 | jan = datetime.datetime(2015, 1, 1, 0, 0) 5 | feb = datetime.datetime(2015, 2, 1, 0, 0) 6 | mar = datetime.datetime(2015, 3, 1, 0, 0) 7 | apr = datetime.datetime(2015, 4, 1, 0, 0) 8 | may = datetime.datetime(2015, 5, 1, 0, 0) 9 | jun = datetime.datetime(2015, 6, 1, 0, 0) 10 | jul = datetime.datetime(2015, 7, 1, 0, 0) 11 | aug = datetime.datetime(2015, 8, 1, 0, 0) 12 | 13 | pages = [ 14 | PyRSS2Gen.RSSItem( 15 | title = "Introduction", 16 | link = "http://dev.stephendiehl.com/fun/000_introduction.html", 17 | description = "", 18 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/000_introduction.html"), 19 | pubDate = jan + datetime.timedelta(1) ), 20 | 21 | PyRSS2Gen.RSSItem( 22 | title = "Haskell Basics", 23 | link = "http://dev.stephendiehl.com/fun/001_basics.html", 24 | description = "", 25 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/001_basics.html"), 26 | pubDate = jan + datetime.timedelta(2) ), 27 | 28 | PyRSS2Gen.RSSItem( 29 | title = "Parsing", 30 | link = "http://dev.stephendiehl.com/fun/002_parsers.html", 31 | description = "", 32 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/002_parsers.html"), 33 | pubDate = jan + datetime.timedelta(3)), 34 | 35 | PyRSS2Gen.RSSItem( 36 | title = "Lambda Calculus", 37 | link = "http://dev.stephendiehl.com/fun/003_lambda_calculus.html", 38 | description = "", 39 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/003_lambda_calculus.html"), 40 | pubDate = jan + datetime.timedelta(4)), 41 | 42 | PyRSS2Gen.RSSItem( 43 | title = "Type Systems", 44 | link = "http://dev.stephendiehl.com/fun/004_type_systems.html", 45 | description = "", 46 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/004_type_systems.html"), 47 | pubDate = jan + datetime.timedelta(5)), 48 | 49 | PyRSS2Gen.RSSItem( 50 | title = "Evaluation", 51 | link = "http://dev.stephendiehl.com/fun/005_evaluation.html", 52 | description = "", 53 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/005_evaluation.html"), 54 | pubDate = jan + datetime.timedelta(6)), 55 | 56 | PyRSS2Gen.RSSItem( 57 | title = "Hindley-Milner Inference", 58 | link = "http://dev.stephendiehl.com/fun/006_hindley_milner.html", 59 | description = "", 60 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/006_hindley_milner.html"), 61 | pubDate = jan + datetime.timedelta(7)), 62 | 63 | PyRSS2Gen.RSSItem( 64 | title = "Design of ProtoHaskell", 65 | link = "http://dev.stephendiehl.com/fun/007_path.html", 66 | description = "", 67 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/007_path.html"), 68 | pubDate = jan + datetime.timedelta(8)), 69 | 70 | PyRSS2Gen.RSSItem( 71 | title = "Extended Parser", 72 | link = "http://dev.stephendiehl.com/fun/008_extended_parser.html", 73 | description = "", 74 | guid = PyRSS2Gen.Guid("http://dev.stephendiehl.com/fun/008_extended_parser.html"), 75 | pubDate = datetime.datetime(2015, 1, 24, 14, 30, 28, 996866)) 76 | ] 77 | 78 | rss = PyRSS2Gen.RSS2( 79 | title = "Write You A Haskell", 80 | link = "http://dev.stephendiehl.com/", 81 | description = "Building a modern functional compiler from first principles.", 82 | lastBuildDate = datetime.datetime.now(), 83 | items = pages 84 | ) 85 | 86 | 87 | if __name__ == '__main__': 88 | print "Generating RSS Feeding: atom.xml" 89 | rss.write_xml(open("atom.xml", "w")) 90 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | make 2 | #make pdf 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-4.2 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /template.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Write You a Haskell ( Stephen Diehl ) 6 | 7 | 8 | 9 | 10 | 11 | 14 | 15 | 16 | 17 | 18 | 28 | 29 | $if(highlighting-css)$ 30 | 33 | $endif$ 34 | $for(css)$ 35 | 36 | $endfor$ 37 | $if(math)$ 38 | $if(html5)$ 39 | $else$ 40 | $math$ 41 | $endif$ 42 | $endif$ 43 | $for(header-includes)$ 44 | $header-includes$ 45 | $endfor$ 46 | 47 | 48 | 49 | 50 |
51 | 52 |
53 | 54 |
55 | 61 | $toc$ 62 |
63 | 64 |
65 | 66 | $body$ 67 |
68 |
69 | 70 |
71 | 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /title.md: -------------------------------------------------------------------------------- 1 | % Write You a Haskell 2 | % Stephen Diehl 3 | % 1/2/2015 4 | 5 | 48 | -------------------------------------------------------------------------------- /write-you-a-haskell.cabal: -------------------------------------------------------------------------------- 1 | name: write-you-a-haskell 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Stephen Diehl 6 | maintainer: stephen.m.diehl@gmail.com 7 | build-type: Simple 8 | extra-source-files: README.md 9 | cabal-version: >=1.10 10 | 11 | executable write-you-a-haskell 12 | main-is: Main.hs 13 | build-depends: 14 | base >= 4.7 && <4.9, 15 | pretty >= 1.1 && <1.2, 16 | containers >= 0.5 && <0.6, 17 | transformers >= 0.3 && <0.5, 18 | haskeline >= 0.7 && <0.8, 19 | pandoc -any 20 | build-tools: alex, happy 21 | default-language: Haskell2010 22 | --------------------------------------------------------------------------------